From 29458c8c4632edc264c73e2c089753adbfe5f93f Mon Sep 17 00:00:00 2001 From: roki Date: Thu, 3 Dec 2020 03:45:34 +0900 Subject: [PATCH 01/51] Initialization to rewrite parser --- app/Main.hs | 154 ++++++++++++++------------------- htcc.cabal | 9 +- package.yaml | 2 + src/Htcc/CRules/Definition.hs | 88 +++++++++++++++++++ src/Htcc/Parser/Combinators.hs | 77 +++++++++++++++++ 5 files changed, 241 insertions(+), 89 deletions(-) create mode 100644 src/Htcc/CRules/Definition.hs create mode 100644 src/Htcc/Parser/Combinators.hs diff --git a/app/Main.hs b/app/Main.hs index 3b34fbf..2f3838d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,101 +1,79 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where -import Control.Conditional (ifM) -import Data.Bool (bool) -import Data.List.Split (splitOn) -import Data.Maybe (isJust, isNothing) -import qualified Data.Text.IO as T -import Data.Tuple.Extra (both, dupe, fst3) -import Diagrams.TwoD.Size (mkSizeSpec2D) -import Options.Applicative -import System.Directory (doesFileExist) -import System.Exit (exitFailure) -import Text.PrettyPrint.ANSI.Leijen (char, linebreak, text, - (<+>)) -import Text.Read (readMaybe) +import Control.Monad (forM_, (>=>)) +import qualified Data.Text.IO as T +import Data.Version (showVersion) +import Development.GitRev (gitHash) +import qualified Options.Applicative as OA +import qualified Paths_htcc as P -import Htcc.Asm (InputCCode, casm, - execAST) -import Htcc.Parser (ASTs) -import Htcc.Parser.ConstructionData.Scope.Var (GlobalVars, Literals) -import Htcc.Utils (errTxtDoc, locTxtDoc, - putDocLnErr, - putStrLnErr) -import Htcc.Visualizer (visualize) +data Opts = Opts + { optIsRunAsm :: !Bool + , optIsVerbose :: !Bool + , optOutput :: FilePath + , optInput :: [FilePath] + } deriving (Read, Show) -data Options = Options - { visualizeAST :: Bool - , resolution :: String - , inputFName :: FilePath - , outputFName :: FilePath - , supressWarn :: Bool - } deriving Show +output :: OA.Parser String +output = OA.strOption $ mconcat [ + OA.metavar "" + , OA.value "a.out" + , OA.long "output" + , OA.short 'o' + , OA.help "Place the output into " + ] -visualizeASTP :: Parser Bool -visualizeASTP = switch $ mconcat - [ long "visualize-ast" - , help "Visualize an AST built from source code" - ] - -resolutionP :: Parser String -resolutionP = strOption $ mconcat - [ metavar "RESOLUTION" - , long "img-resolution" - , help "Specify the resolution of the AST graph to be generated" - , value "640x480" - , showDefaultWith id - ] - -inputFNameP :: Parser FilePath -inputFNameP = strArgument $ mconcat - [ metavar "file" - , action "file" - , help "Specify the input file name" - ] +input :: OA.Parser [String] +input = OA.some $ OA.strArgument $ mconcat [ + OA.metavar "file..." + , OA.help "Input source files" + ] -outputFNameP :: Parser FilePath -outputFNameP = strOption $ mconcat - [ metavar "file" - , short 'o' - , long "out" - , help "Specify the output destination file name, supported only svg" - , value "./out.svg" - , showDefaultWith id - ] +isRunAsm :: OA.Parser Bool +isRunAsm = OA.switch $ mconcat [ + OA.long "run-asm" + , OA.short 'r' + , OA.help "Generates executable binaries using the assembler built into the GCC compiler" + ] -supressWarnP :: Parser Bool -supressWarnP = switch $ mconcat - [ short 'w' - , long "supress-warns" - , help "Disable all warning messages" - ] +isVerbose :: OA.Parser Bool +isVerbose = OA.switch $ mconcat [ + OA.long "verbose" + , OA.short 'v' + , OA.help "Show the programs invoked by the compiler" + ] -optionsP :: Parser Options -optionsP = (<*>) helper $ - Options <$> visualizeASTP <*> resolutionP <*> inputFNameP <*> outputFNameP <*> supressWarnP +programOptions :: OA.Parser Opts +programOptions = Opts + <$> isRunAsm + <*> isVerbose + <*> output + <*> input -parseResolution :: (Num a, Read a) => String -> (Maybe a, Maybe a) -parseResolution xs = let rs = splitOn "x" xs in if length rs /= 2 then dupe Nothing else - let rs' = map readMaybe rs in if any isNothing rs' then dupe Nothing else (head rs', rs' !! 1) +versionOption :: OA.Parser (a -> a) +versionOption = OA.infoOption vopt $ mconcat [ + OA.long "version" + , OA.help "Show compiler version information" + ] + where + vopt = concat [ + "The C Language Compiler htcc " + , showVersion P.version + , "\ncommit hash: " + , $(gitHash) + ] -execVisualize :: Show i => Options -> ASTs i -> IO () -execVisualize ops ast = let rlt = parseResolution $ resolution ops in do - rs <- if uncurry (&&) (both isJust rlt) then return rlt else - (Just 640, Just 480) <$ putStrLnErr "warning: the specified resolution is invalid, so using default resolution." - visualize ast (uncurry mkSizeSpec2D rs) (outputFName ops) +optsParser :: OA.ParserInfo Opts +optsParser = OA.info (OA.helper <*> versionOption <*> programOptions) $ mconcat [ + OA.fullDesc + , OA.progDesc $ concat [ + "The C Language Compiler htcc " + , showVersion P.version + ] + ] main :: IO () main = do - ops <- execParser $ info optionsP fullDesc - ifM (not <$> doesFileExist (inputFName ops)) (notFould (inputFName ops) >> exitFailure) $ - T.readFile (inputFName ops) >>= execAST' (supressWarn ops) (inputFName ops) >>= maybe (return ()) (bool casm (execVisualize ops . fst3) (visualizeAST ops)) - where - execAST' :: Bool -> FilePath -> InputCCode -> IO (Maybe (ASTs Integer, GlobalVars Integer, Literals Integer)) - execAST' = execAST - notFould fpath = putDocLnErr $ - locTxtDoc "htcc:" <+> - errTxtDoc "error:" <+> - text fpath <> char ':' <+> - text "no such file" <> linebreak <> - text "compilation terminated." + opts <- OA.execParser optsParser + forM_ (optInput opts) $ T.readFile >=> T.putStr diff --git a/htcc.cabal b/htcc.cabal index f1a5855..3f6d932 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 22bacaccc5bc8617817eb1c982386f1b7ce9a77e1928a9f47181e1dcd7a27d2a +-- hash: 9f038934ecf3af287cdb982fab4ed2163a79dec6d3dbe365c5b6c98a38a7b8bc name: htcc version: 0.0.0.1 @@ -55,6 +55,7 @@ library Htcc.Asm.Intrinsic.Structure.Section.Text.Operations Htcc.CRules Htcc.CRules.Char + Htcc.CRules.Definition Htcc.CRules.LexicalElements Htcc.CRules.Preprocessor Htcc.CRules.Preprocessor.Core @@ -70,6 +71,7 @@ library Htcc.Parser.AST.Type Htcc.Parser.AST.Var Htcc.Parser.AST.Var.Init + Htcc.Parser.Combinators Htcc.Parser.ConstructionData Htcc.Parser.ConstructionData.Core Htcc.Parser.ConstructionData.Scope @@ -124,6 +126,7 @@ library , mtl , natural-transformation , optparse-applicative + , parsec , safe , split , text @@ -149,6 +152,7 @@ executable htcc , diagrams-svg , directory , extra + , gitrev , htcc , monad-finally , monad-loops @@ -156,6 +160,7 @@ executable htcc , mtl , natural-transformation , optparse-applicative + , parsec , safe , split , text @@ -202,6 +207,7 @@ test-suite htcc-test , mtl , natural-transformation , optparse-applicative + , parsec , process , safe , split @@ -237,6 +243,7 @@ benchmark criterion , mtl , natural-transformation , optparse-applicative + , parsec , safe , split , text diff --git a/package.yaml b/package.yaml index c659094..3f8fdf6 100644 --- a/package.yaml +++ b/package.yaml @@ -46,6 +46,7 @@ dependencies: - diagrams-lib - natural-transformation - optparse-applicative +- parsec library: source-dirs: src @@ -64,6 +65,7 @@ executables: dependencies: - htcc - directory + - gitrev tests: htcc-test: diff --git a/src/Htcc/CRules/Definition.hs b/src/Htcc/CRules/Definition.hs new file mode 100644 index 0000000..510ef53 --- /dev/null +++ b/src/Htcc/CRules/Definition.hs @@ -0,0 +1,88 @@ +{-| +Module : Htcc.CRules.Definition +Description : C language definition +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language definition +-} +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} +module Htcc.CRules.Definition ( + cDef +) where + +import Text.Parsec (Stream, (<|>)) +import Text.Parsec.Char (alphaNum, char, letter, oneOf) +import qualified Text.Parsec.Token as P + +charOps :: String +charOps = "+-*/()<>=;{},&|^%!~[].?:" + +strOps2 :: [String] +strOps2 = [ + "<=" + , ">=" + , "==" + , "!=" + , "<<" + , ">>" + , "->" + , "++" + , "--" + , "+=" + , "-=" + , "*=" + , "/=" + , "&&" + , "||" + , "&=" + , "|=" + , "^=" + ] + +strOps3 :: [String] +strOps3 = [ + "<<=" + , ">>=" + ] + +keywords :: [String] +keywords = [ + "return" + , "if" + , "switch" + , "case" + , "default" + , "else" + , "while" + , "for" + , "break" + , "continue" + , "enum" + , "struct" + , "sizeof" + , "goto" + , "_Alignof" + , "typedef" + ] + +cDef :: Stream s m Char => P.GenLanguageDef s st m +cDef = P.LanguageDef + { P.commentStart = "/*" + , P.commentEnd = "*/" + , P.commentLine = "//" + , P.nestedComments = True + , P.identStart = letter <|> char '_' + , P.identLetter = alphaNum <|> char '_' + , P.opStart = P.opLetter cDef + , P.opLetter = oneOf charOps + , P.reservedOpNames = ((:[]) <$> charOps) + <> strOps2 + <> strOps3 + , P.reservedNames = keywords + , P.caseSensitive = True + } + diff --git a/src/Htcc/Parser/Combinators.hs b/src/Htcc/Parser/Combinators.hs new file mode 100644 index 0000000..be4c95e --- /dev/null +++ b/src/Htcc/Parser/Combinators.hs @@ -0,0 +1,77 @@ +{-| +Module : Htcc.Parser.Combinators +Description : C language lexer +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language lexer +-} +{-# LANGUAGE FlexibleContexts #-} +module Htcc.Parser.Combinators ( + natural + , lexer + , operator + , identifier + , reserved + , reservedOp + , integer + , whiteSpace + , float + , charLiteral + , stringLiteral + , parens + , braces + , angles + , semi + , comma + , colon + , dot + , commaSep + , commaSep1 +) where + +import Htcc.CRules.Definition +import Text.Parsec (ParsecT, Stream) +import qualified Text.Parsec.Token as P + +{-# INLINE lexer #-} +lexer :: Stream s m Char => P.GenTokenParser s u m +lexer = P.makeTokenParser cDef + +reserved, reservedOp :: Stream s m Char => String -> ParsecT s u m () +reserved = P.reserved lexer +reservedOp = P.reservedOp lexer + +natural, integer :: Stream s m Char => ParsecT s u m Integer +natural = P.natural lexer +integer = P.integer lexer + +whiteSpace :: Stream s m Char => ParsecT s u m () +whiteSpace = P.whiteSpace lexer + +float :: Stream s m Char => ParsecT s u m Double +float = P.float lexer + +parens, braces, angles :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a +parens = P.parens lexer +braces = P.braces lexer +angles = P.angles lexer + +charLiteral :: Stream s m Char => ParsecT s u m Char +charLiteral = P.charLiteral lexer + +identifier, operator, semi, comma, colon, dot, stringLiteral :: Stream s m Char => ParsecT s u m String +identifier = P.identifier lexer +operator = P.operator lexer +semi = P.semi lexer +comma = P.comma lexer +colon = P.colon lexer +dot = P.dot lexer +stringLiteral = P.stringLiteral lexer + +commaSep, commaSep1 :: Stream s m Char => ParsecT s u m a -> ParsecT s u m [a] +commaSep = P.commaSep lexer +commaSep1 = P.commaSep1 lexer From a6e3f76ac21cde4c6cf9df0c434ae55bca55650a Mon Sep 17 00:00:00 2001 From: roki Date: Tue, 8 Dec 2020 05:42:03 +0900 Subject: [PATCH 02/51] Transition to Monadic Parser: Calculation of four arithmetic operations --- app/Main.hs | 30 ++- htcc.cabal | 27 ++- package.yaml | 6 +- src/Htcc/CRules/Definition.hs | 88 -------- src/Htcc/Parser/Combinators.hs | 67 +----- src/Htcc/Parser/Combinators/Core.hs | 120 ++++++++++ src/Htcc/Parser/Combinators/Expr.hs | 48 ++++ src/Htcc/Parser/Combinators/Keywords.hs | 96 ++++++++ src/Htcc/Parser/Development.hs | 22 ++ src/Htcc/Tokenizer/Token.hs | 60 ++--- stack.yaml | 1 - test/Spec.hs | 9 +- test/Tests/ComponentsTests.hs | 13 ++ .../ComponentsTests/Parser/Combinators.hs | 209 ++++++++++++++++++ 14 files changed, 599 insertions(+), 197 deletions(-) delete mode 100644 src/Htcc/CRules/Definition.hs create mode 100644 src/Htcc/Parser/Combinators/Core.hs create mode 100644 src/Htcc/Parser/Combinators/Expr.hs create mode 100644 src/Htcc/Parser/Combinators/Keywords.hs create mode 100644 src/Htcc/Parser/Development.hs create mode 100644 test/Tests/ComponentsTests.hs create mode 100644 test/Tests/ComponentsTests/Parser/Combinators.hs diff --git a/app/Main.hs b/app/Main.hs index 2f3838d..7ebe9b3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,12 +1,23 @@ {-# LANGUAGE TemplateHaskell #-} module Main where -import Control.Monad (forM_, (>=>)) -import qualified Data.Text.IO as T -import Data.Version (showVersion) -import Development.GitRev (gitHash) -import qualified Options.Applicative as OA -import qualified Paths_htcc as P +import Control.Monad (forM_) +import qualified Data.Text.IO as T +import Data.Version (showVersion) +import Development.GitRev (gitHash) +import qualified Options.Applicative as OA +import qualified Paths_htcc as P + +import qualified Data.Text as T +import Data.Void +import Htcc.Asm.Generate (casm') +import qualified Htcc.Asm.Intrinsic.Structure.Internal as SI +import Htcc.Parser (ASTs) +import Htcc.Parser.Combinators (parser, runParser) +import Htcc.Parser.ConstructionData (Warnings) +import Htcc.Parser.ConstructionData.Scope.Var (GlobalVars, Literals) +import Htcc.Utils +import qualified Text.Megaparsec as M data Opts = Opts { optIsRunAsm :: !Bool @@ -76,4 +87,9 @@ optsParser = OA.info (OA.helper <*> versionOption <*> programOptions) $ mconcat main :: IO () main = do opts <- OA.execParser optsParser - forM_ (optInput opts) $ T.readFile >=> T.putStr + forM_ (optInput opts) $ \fname -> do + txt <- T.readFile fname + case runParser parser fname txt + :: Either (M.ParseErrorBundle T.Text Void) (Warnings Integer, ASTs Integer, GlobalVars Integer, Literals Integer) of + Left x -> print x + Right r -> SI.runAsm $ casm' (snd4 r) (thd4 r) (fou4 r) diff --git a/htcc.cabal b/htcc.cabal index 3f6d932..6c75a10 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 9f038934ecf3af287cdb982fab4ed2163a79dec6d3dbe365c5b6c98a38a7b8bc +-- hash: eafa6289395390475dd9cf3e016680d63468cafd8c86f64acb8619a5b655f0e2 name: htcc version: 0.0.0.1 @@ -55,7 +55,6 @@ library Htcc.Asm.Intrinsic.Structure.Section.Text.Operations Htcc.CRules Htcc.CRules.Char - Htcc.CRules.Definition Htcc.CRules.LexicalElements Htcc.CRules.Preprocessor Htcc.CRules.Preprocessor.Core @@ -72,6 +71,9 @@ library Htcc.Parser.AST.Var Htcc.Parser.AST.Var.Init Htcc.Parser.Combinators + Htcc.Parser.Combinators.Core + Htcc.Parser.Combinators.Expr + Htcc.Parser.Combinators.Keywords Htcc.Parser.ConstructionData Htcc.Parser.ConstructionData.Core Htcc.Parser.ConstructionData.Scope @@ -82,6 +84,7 @@ library Htcc.Parser.ConstructionData.Scope.Typedef Htcc.Parser.ConstructionData.Scope.Utils Htcc.Parser.ConstructionData.Scope.Var + Htcc.Parser.Development Htcc.Parser.Parsing Htcc.Parser.Parsing.Core Htcc.Parser.Parsing.Global @@ -120,15 +123,17 @@ library , diagrams-lib , diagrams-svg , extra + , megaparsec , monad-finally , monad-loops , mono-traversable , mtl , natural-transformation , optparse-applicative - , parsec + , parser-combinators , safe , split + , template-haskell , text , transformers default-language: Haskell2010 @@ -139,7 +144,7 @@ executable htcc Paths_htcc hs-source-dirs: app - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror -O2 + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2 build-depends: ansi-wl-pprint , base >=4.7 && <5 @@ -154,15 +159,17 @@ executable htcc , extra , gitrev , htcc + , megaparsec , monad-finally , monad-loops , mono-traversable , mtl , natural-transformation , optparse-applicative - , parsec + , parser-combinators , safe , split + , template-haskell , text , transformers default-language: Haskell2010 @@ -171,6 +178,8 @@ test-suite htcc-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Tests.ComponentsTests + Tests.ComponentsTests.Parser.Combinators Tests.SubProcTests Tests.Test1 Tests.Test2 @@ -201,16 +210,18 @@ test-suite htcc-test , hspec-contrib , hspec-core , htcc + , megaparsec , monad-finally , monad-loops , mono-traversable , mtl , natural-transformation , optparse-applicative - , parsec + , parser-combinators , process , safe , split + , template-haskell , text , time , transformers @@ -237,15 +248,17 @@ benchmark criterion , diagrams-svg , extra , htcc + , megaparsec , monad-finally , monad-loops , mono-traversable , mtl , natural-transformation , optparse-applicative - , parsec + , parser-combinators , safe , split + , template-haskell , text , transformers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 3f8fdf6..d18a67e 100644 --- a/package.yaml +++ b/package.yaml @@ -46,7 +46,9 @@ dependencies: - diagrams-lib - natural-transformation - optparse-applicative -- parsec +- megaparsec +- parser-combinators +- template-haskell library: source-dirs: src @@ -60,7 +62,7 @@ executables: - -rtsopts - -with-rtsopts=-N - -Wall - - -Werror + #- -Werror - -O2 dependencies: - htcc diff --git a/src/Htcc/CRules/Definition.hs b/src/Htcc/CRules/Definition.hs deleted file mode 100644 index 510ef53..0000000 --- a/src/Htcc/CRules/Definition.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-| -Module : Htcc.CRules.Definition -Description : C language definition -Copyright : (c) roki, 2020~ -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -C language definition --} -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} -module Htcc.CRules.Definition ( - cDef -) where - -import Text.Parsec (Stream, (<|>)) -import Text.Parsec.Char (alphaNum, char, letter, oneOf) -import qualified Text.Parsec.Token as P - -charOps :: String -charOps = "+-*/()<>=;{},&|^%!~[].?:" - -strOps2 :: [String] -strOps2 = [ - "<=" - , ">=" - , "==" - , "!=" - , "<<" - , ">>" - , "->" - , "++" - , "--" - , "+=" - , "-=" - , "*=" - , "/=" - , "&&" - , "||" - , "&=" - , "|=" - , "^=" - ] - -strOps3 :: [String] -strOps3 = [ - "<<=" - , ">>=" - ] - -keywords :: [String] -keywords = [ - "return" - , "if" - , "switch" - , "case" - , "default" - , "else" - , "while" - , "for" - , "break" - , "continue" - , "enum" - , "struct" - , "sizeof" - , "goto" - , "_Alignof" - , "typedef" - ] - -cDef :: Stream s m Char => P.GenLanguageDef s st m -cDef = P.LanguageDef - { P.commentStart = "/*" - , P.commentEnd = "*/" - , P.commentLine = "//" - , P.nestedComments = True - , P.identStart = letter <|> char '_' - , P.identLetter = alphaNum <|> char '_' - , P.opStart = P.opLetter cDef - , P.opLetter = oneOf charOps - , P.reservedOpNames = ((:[]) <$> charOps) - <> strOps2 - <> strOps3 - , P.reservedNames = keywords - , P.caseSensitive = True - } - diff --git a/src/Htcc/Parser/Combinators.hs b/src/Htcc/Parser/Combinators.hs index be4c95e..e521999 100644 --- a/src/Htcc/Parser/Combinators.hs +++ b/src/Htcc/Parser/Combinators.hs @@ -9,69 +9,10 @@ Portability : POSIX C language lexer -} -{-# LANGUAGE FlexibleContexts #-} module Htcc.Parser.Combinators ( - natural - , lexer - , operator - , identifier - , reserved - , reservedOp - , integer - , whiteSpace - , float - , charLiteral - , stringLiteral - , parens - , braces - , angles - , semi - , comma - , colon - , dot - , commaSep - , commaSep1 + module Htcc.Parser.Combinators.Core + , module Htcc.Parser.Combinators.Expr ) where -import Htcc.CRules.Definition -import Text.Parsec (ParsecT, Stream) -import qualified Text.Parsec.Token as P - -{-# INLINE lexer #-} -lexer :: Stream s m Char => P.GenTokenParser s u m -lexer = P.makeTokenParser cDef - -reserved, reservedOp :: Stream s m Char => String -> ParsecT s u m () -reserved = P.reserved lexer -reservedOp = P.reservedOp lexer - -natural, integer :: Stream s m Char => ParsecT s u m Integer -natural = P.natural lexer -integer = P.integer lexer - -whiteSpace :: Stream s m Char => ParsecT s u m () -whiteSpace = P.whiteSpace lexer - -float :: Stream s m Char => ParsecT s u m Double -float = P.float lexer - -parens, braces, angles :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a -parens = P.parens lexer -braces = P.braces lexer -angles = P.angles lexer - -charLiteral :: Stream s m Char => ParsecT s u m Char -charLiteral = P.charLiteral lexer - -identifier, operator, semi, comma, colon, dot, stringLiteral :: Stream s m Char => ParsecT s u m String -identifier = P.identifier lexer -operator = P.operator lexer -semi = P.semi lexer -comma = P.comma lexer -colon = P.colon lexer -dot = P.dot lexer -stringLiteral = P.stringLiteral lexer - -commaSep, commaSep1 :: Stream s m Char => ParsecT s u m a -> ParsecT s u m [a] -commaSep = P.commaSep lexer -commaSep1 = P.commaSep1 lexer +import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.Expr diff --git a/src/Htcc/Parser/Combinators/Core.hs b/src/Htcc/Parser/Combinators/Core.hs new file mode 100644 index 0000000..668fc09 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Core.hs @@ -0,0 +1,120 @@ +{-| +Module : Htcc.Parser.Combinators.Core +Description : C language lexer +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language lexer +-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, TupleSections #-} +module Htcc.Parser.Combinators.Core ( + runParser + , Parser + , lexme + , symbol + , charLiteral + , stringLiteral + , decimal + , hexadecimal + , octal + , natural + , integer + , angles + , parens + , braces + , brackets + , identifier + , operator + , semi + , comma + , colon + , commaSep + , commaSep1 +) where + +import Control.Applicative (Alternative (..)) +import Control.Monad.Trans.State.Lazy +import Data.Char (isAlpha) +import Data.Foldable (asum) +import Data.Functor.Identity +import Data.Maybe (isJust) +import qualified Data.Text as T +import Data.Void +import qualified Htcc.CRules as CR +import Htcc.Parser.AST.Core (ATree (..)) +import Htcc.Parser.ConstructionData (ConstructionData (..), + initConstructionData, Warnings) +import Htcc.Tokenizer.Token (Token (..), keywordsTokens, + lookupKeyword) +import Htcc.Utils (lor) +import qualified Text.Megaparsec as M +import qualified Text.Megaparsec.Char as MC +import qualified Text.Megaparsec.Char.Lexer as ML +import qualified Htcc.Parser.ConstructionData.Scope.Var as PSV +import qualified Htcc.Parser.ConstructionData.Scope as PS +import Htcc.Parser.AST.Type (ASTs) + +type ConstructionDataState i = StateT (ConstructionData i) Identity +type Parser i = M.ParsecT Void T.Text (ConstructionDataState i) + +runParser :: + Parser i (ASTs i) -> + FilePath -> + T.Text -> + Either (M.ParseErrorBundle T.Text Void) (Warnings i, ASTs i, PSV.GlobalVars i, PSV.Literals i) -- (ATree i, ConstructionData i) +runParser p fp input = + (warns (snd result),, PSV.globals $ PS.vars $ scope $ snd result, PSV.literals $ PS.vars $ scope $ snd result) + <$> fst result + where + result = runIdentity $ runStateT (M.runParserT p fp input) initConstructionData + +spaceConsumer :: Ord e => M.ParsecT e T.Text m () +spaceConsumer = ML.space MC.space1 (ML.skipLineComment "//") (ML.skipBlockComment "/*" "*/") + +lexme :: Ord e => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m a +lexme = ML.lexeme spaceConsumer + +symbol :: Ord e => T.Text -> M.ParsecT e T.Text m T.Text +symbol = ML.symbol spaceConsumer + +toSymbols :: (Ord e) => [T.Text] -> M.ParsecT e T.Text m T.Text +toSymbols = asum . map (M.try . symbol) + +charLiteral :: Ord e => M.ParsecT e T.Text m Char +charLiteral = M.between (MC.char '\'') (MC.char '\'') ML.charLiteral + +stringLiteral :: Ord e => M.ParsecT e T.Text m String +stringLiteral = MC.char '\"' *> M.manyTill ML.charLiteral (MC.char '\"') + +hexadecimal, octal, decimal, natural, integer :: (Ord e, Num i) => M.ParsecT e T.Text m i +hexadecimal = MC.char '0' >> MC.char' 'x' >> ML.hexadecimal +octal = MC.char '0' >> ML.octal +decimal = ML.decimal +natural = M.try (lexme hexadecimal) <|> M.try (lexme octal) <|> lexme decimal +integer = ML.signed spaceConsumer natural <|> natural + +parens, braces, angles, brackets :: Ord e => M.ParsecT e T.Text m T.Text -> M.ParsecT e T.Text m T.Text +parens = M.between (symbol "(") (symbol ")") +braces = M.between (symbol "{") (symbol "}") +angles = M.between (symbol "<") (symbol ">") +brackets = M.between (symbol "[") (symbol "]") + +identifier, operator, semi, comma, colon :: Ord e => M.ParsecT e T.Text m T.Text +identifier = + mappend + <$> M.takeWhile1P (Just "valid identifier") (lor [isAlpha, (=='_')]) + <*> M.takeWhileP (Just "valid identifier") CR.isValidChar +operator = + toSymbols CR.strOps3 + <|> toSymbols CR.strOps2 + <|> toSymbols (T.singleton <$> CR.charOps) +semi = symbol ";" +comma = symbol "," +colon = symbol "." + +commaSep, commaSep1 :: Ord e => M.ParsecT e T.Text m T.Text -> M.ParsecT e T.Text m [T.Text] +commaSep = flip M.sepBy comma +commaSep1 = flip M.sepBy1 comma diff --git a/src/Htcc/Parser/Combinators/Expr.hs b/src/Htcc/Parser/Combinators/Expr.hs new file mode 100644 index 0000000..f934de0 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Expr.hs @@ -0,0 +1,48 @@ +{-| +Module : Htcc.Parser.Combinators.Expr +Description : C language lexer +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language lexer +-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +module Htcc.Parser.Combinators.Expr ( + parser +) where + +import Control.Applicative hiding (many) +import Control.Monad.Combinators (between) +import Control.Monad.Fix (fix) +import Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATKind (..), ATree (..), + atNumLit) +import Htcc.Parser.AST.Type (ASTs) +import Htcc.Parser.Combinators.Core +import Htcc.Parser.Development (defMainFn) + +parser :: Num i => Parser i (ASTs i) +parser = (:[]) . defMainFn <$> expr + +expr :: Num i => Parser i (ATree i) +expr = do + m <- term + ($ m) . fix $ \f nd -> + ((ATNode ATAdd (CT.SCAuto CT.CTInt) nd <$> (symbol "+" >> term)) >>= f) + <|> ((ATNode ATSub (CT.SCAuto CT.CTInt) nd <$> (symbol "-" >> term)) >>= f) + <|> return nd + +term :: Num i => Parser i (ATree i) +term = do + fac <- factor + ($ fac) . fix $ \f nd -> + ((ATNode ATMul (CT.SCAuto CT.CTInt) nd <$> (symbol "*" >> factor)) >>= f) + <|> ((ATNode ATDiv (CT.SCAuto CT.CTInt) nd <$> (symbol "/" >> factor)) >>= f) + <|> return nd + +factor :: Num i => Parser i (ATree i) +factor = atNumLit <$> integer <|> between (symbol "(") (symbol ")") expr + diff --git a/src/Htcc/Parser/Combinators/Keywords.hs b/src/Htcc/Parser/Combinators/Keywords.hs new file mode 100644 index 0000000..a2b0526 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Keywords.hs @@ -0,0 +1,96 @@ +{-| +Module : Htcc.Parser.Combinators.Keywords +Description : C language lexer +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language lexer +-} +{-# LANGUAGE OverloadedStrings #-} +module Htcc.Parser.Combinators.Keywords ( + kAuto, kBreak, kCase, kChar, kConst, kContinue, + kDefault, kDo, kDouble, kElse, kEnum, kExtern, + kFloat, kFor, kGoto, kIf, kInline, kInt, + kLong, kRegister, kRestrict, kReturn, kShort, kSigned, + kSizeof, kStatic, kStruct, kSwitch, kTypedef, kUnion, + kUnsigned, kVoid, kVolatile, kWhile, k_Alignas, k_Alignof, + k_Atomic, k_Bool, k_Complex, k_Generic, k_Imaginary, k_Noreturn, + k_Static_assert, k_Thread_local, kBasicTypes +) where + +import qualified Data.Text as T +import Htcc.Parser.Combinators.Core +import qualified Text.Megaparsec as M + +kAuto, kBreak, kCase, kChar, kConst, kContinue, + kDefault, kDo, kDouble, kElse, kEnum, kExtern, + kFloat, kFor, kGoto, kIf, kInline, kInt, + kLong, kRegister, kRestrict, kReturn, kShort, kSigned, + kSizeof, kStatic, kStruct, kSwitch, kTypedef, kUnion, + kUnsigned, kVoid, kVolatile, kWhile, k_Alignas, k_Alignof, + k_Atomic, k_Bool, k_Complex, k_Generic, k_Imaginary, k_Noreturn, + k_Static_assert, k_Thread_local :: Ord e => M.ParsecT e T.Text m T.Text +kAuto = symbol "auto" +kBreak = symbol "break" +kCase = symbol "case" +kChar = symbol "char" +kConst = symbol "const" +kContinue = symbol "continue" +kDefault = symbol "default" +kDo = symbol "do" +kDouble = symbol "double" +kElse = symbol "else" +kEnum = symbol "enum" +kExtern = symbol "extern" +kFloat = symbol "float" +kFor = symbol "for" +kGoto = symbol "goto" +kIf = symbol "if" +kInline = symbol "inline" +kInt = symbol "int" +kLong = symbol "long" +kRegister = symbol "register" +kRestrict = "restrict" +kReturn = symbol "return" +kShort = symbol "short" +kSigned = symbol "signed" +kSizeof = symbol "sizeof" +kStatic = symbol "static" +kStruct = symbol "struct" +kSwitch = symbol "switch" +kTypedef = symbol "typedef" +kUnion = symbol "union" +kUnsigned = symbol "unsigned" +kVoid = symbol "void" +kVolatile = symbol "volatile" +kWhile = symbol "while" +k_Alignas = symbol "_Alignas" +k_Alignof = symbol "_Alignof" +k_Atomic = symbol "_Atomic" +k_Bool = symbol "_Bool" +k_Complex = symbol "_Complex" +k_Generic = symbol "_Generic" +k_Imaginary = symbol "_Imaginary" +k_Noreturn = symbol "_Noreturn" +k_Static_assert = symbol "_Static_assert" +k_Thread_local = symbol "_Thread_local" + +kBasicTypes :: Ord e => [M.ParsecT e T.Text m T.Text] +kBasicTypes = [ + kChar + , kDouble + , kFloat + , kInt + , kLong + , kShort + , kSigned + , kUnsigned + , kVoid + , k_Bool + , k_Complex + , k_Imaginary + ] + diff --git a/src/Htcc/Parser/Development.hs b/src/Htcc/Parser/Development.hs new file mode 100644 index 0000000..3c939cb --- /dev/null +++ b/src/Htcc/Parser/Development.hs @@ -0,0 +1,22 @@ +{-| +Module : Htcc.Parser.Development +Description : C language lexer +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language lexer +-} +{-# LANGUAGE OverloadedStrings #-} +module Htcc.Parser.Development ( + defMainFn +) where + +import Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATree (..), + atDefFunc) + +defMainFn :: ATree i -> ATree i +defMainFn = atDefFunc "main" Nothing (CT.SCAuto CT.CTInt) diff --git a/src/Htcc/Tokenizer/Token.hs b/src/Htcc/Tokenizer/Token.hs index 87cc1b3..b798ad4 100644 --- a/src/Htcc/Tokenizer/Token.hs +++ b/src/Htcc/Tokenizer/Token.hs @@ -17,6 +17,7 @@ module Htcc.Tokenizer.Token ( TokenLC, Token (..), -- * Utilities for accessing to token data + keywordsTokens, length, emptyToken, isTKNum, @@ -145,36 +146,39 @@ length (TKString s) = B.length s length (TKMacro m t) = CP.length m + T.length t length TKEmpty = 0 +keywordsTokens :: [Token i] +keywordsTokens = [ + TKReturn + , TKWhile + , TKIf + , TKSwitch + , TKCase + , TKDefault + , TKElse + , TKFor + , TKBreak + , TKContinue + , TKEnum + , TKStruct + , TKSizeof + , TKGoto + , TKAlignof + , TKTypedef + , TKType $ CR.SCUndef CR.CTInt + , TKType $ CR.SCUndef CR.CTChar + , TKType $ CR.SCUndef $ CR.CTSigned CR.CTUndef + , TKType $ CR.SCUndef $ CR.CTShort CR.CTUndef + , TKType $ CR.SCUndef $ CR.CTLong CR.CTUndef + , TKType $ CR.SCUndef CR.CTVoid + , TKType $ CR.SCUndef CR.CTBool + , TKType $ CR.SCAuto CR.CTUndef + , TKType $ CR.SCStatic CR.CTUndef + , TKType $ CR.SCRegister CR.CTUndef + ] + -- | Lookup keyword from `T.Text`. If the specified `T.Text` is not keyword as C language, `lookupKeyword` returns `Nothing`. lookupKeyword :: forall i. (Show i) => T.Text -> Maybe (Token i) -lookupKeyword s = find ((==) s . tshow) [ - TKReturn, - TKWhile, - TKIf, - TKSwitch, - TKCase, - TKDefault, - TKElse, - TKFor, - TKBreak, - TKContinue, - TKEnum, - TKStruct, - TKSizeof, - TKGoto, - TKAlignof, - TKTypedef, - TKType $ CR.SCUndef CR.CTInt, - TKType $ CR.SCUndef CR.CTChar, - TKType $ CR.SCUndef $ CR.CTSigned CR.CTUndef, - TKType $ CR.SCUndef $ CR.CTShort CR.CTUndef, - TKType $ CR.SCUndef $ CR.CTLong CR.CTUndef, - TKType $ CR.SCUndef CR.CTVoid, - TKType $ CR.SCUndef CR.CTBool, - TKReserved $ T.pack $ show (CR.SCAuto CR.CTUndef :: CR.StorageClass i), - TKReserved $ T.pack $ show (CR.SCStatic CR.CTUndef :: CR.StorageClass i), - TKReserved $ T.pack $ show (CR.SCRegister CR.CTUndef :: CR.StorageClass i) - ] +lookupKeyword s = find ((==) s . tshow) keywordsTokens -- | `TokenLCNums` is data structure for storing the line number and character number of each token data TokenLCNums i = TokenLCNums -- ^ The constructor of `TokenLCNums` diff --git a/stack.yaml b/stack.yaml index 874850d..2a6b166 100644 --- a/stack.yaml +++ b/stack.yaml @@ -22,7 +22,6 @@ extra-deps: - monad-abort-fd-0.7@sha256:dc917e7ee2ec0b4f20d6e1cc323bef03adf5b2067619b6e7f4f324a50ae6e870,1340 - transformers-abort-0.6.0.3@sha256:34de32cc6e852df10ad57df34e46404f841c6b0123526b7fd942c455f62a7a31,1236 - # Override default flag values for local packages and extra-deps # flags: {} diff --git a/test/Spec.hs b/test/Spec.hs index a531222..8de8afe 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -13,6 +13,7 @@ import qualified Options.Applicative as OA import System.Directory (createDirectoryIfMissing) import System.FilePath (()) import System.Process (readCreateProcess, shell) +import qualified Tests.ComponentsTests as ComponentsTests import qualified Tests.SubProcTests as SubProcTests import Tests.Utils @@ -25,7 +26,7 @@ specPath = workDir "spec.s" dockerComposePath :: FilePath dockerComposePath = "./docker" "test.dhall" -data Command = WithSubProc | WithDocker | WithSelf +data Command = WithSubProc | WithDocker | WithSelf | WithComponents data Opts = Opts { optClean :: !Bool @@ -44,6 +45,10 @@ selfCmd :: OA.Mod OA.CommandFields Command selfCmd = OA.command "self" $ OA.info (pure WithSelf) $ OA.progDesc "run the test using htcc's processing power" +componentsCmd :: OA.Mod OA.CommandFields Command +componentsCmd = OA.command "components" $ + OA.info (pure WithComponents) $ OA.progDesc "run unit tests of components" + cleanOpt :: OA.Parser Bool cleanOpt = OA.switch $ mconcat [ OA.long "clean" @@ -57,6 +62,7 @@ programOptions = Opts subProcCmd , dockerCmd , selfCmd + , componentsCmd ]) optsParser :: OA.ParserInfo Opts @@ -93,3 +99,4 @@ main = do genTestAsm execErrFin $ "gcc -no-pie -o spec " <> T.pack specPath execErrFin "./spec" + WithComponents -> ComponentsTests.exec diff --git a/test/Tests/ComponentsTests.hs b/test/Tests/ComponentsTests.hs new file mode 100644 index 0000000..5e46003 --- /dev/null +++ b/test/Tests/ComponentsTests.hs @@ -0,0 +1,13 @@ +module Tests.ComponentsTests ( + exec +) where + +import Tests.Utils hiding (exec) +-- import Test.HUnit (Test (..)) +import Tests.ComponentsTests.Parser.Combinators as PC + +exec :: IO () +exec = runTests $ + TestList [ + PC.test + ] diff --git a/test/Tests/ComponentsTests/Parser/Combinators.hs b/test/Tests/ComponentsTests/Parser/Combinators.hs new file mode 100644 index 0000000..506099b --- /dev/null +++ b/test/Tests/ComponentsTests/Parser/Combinators.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes #-} +module Tests.ComponentsTests.Parser.Combinators ( + test +) where +import Data.Char (chr) +import Data.Either (isLeft) +import qualified Data.Text as T +import Data.Void (Void) +import qualified Htcc.CRules as CR +import Htcc.Parser.Combinators.Core +import qualified Htcc.Tokenizer.Token as HTT +import Htcc.Utils (tshow) +import Test.HUnit (Test (..), (~:), (~?=)) +import Text.Megaparsec + +type TestParser = Parsec Void T.Text + +charLiteralTest, stringLiteralTest, hexadecimalTest, octalTest, naturalTest, integerTest, identifierTest, operatorTest :: Test + +charLiteralTest = TestLabel "Parser.Combinators.Core.charLiteral" $ + TestList [ + TestLabel "Parser.Combinators.Core.charLiteral success patterns" $ + TestList [ + TestLabel "valid characters" $ TestList [ + (show x <> " == " <> show x) ~: + runParser charLiteral' "" (T.singleton '\'' <> T.singleton x <> T.singleton '\'') ~?= Right x + | x <- charSets + ] + , TestLabel "partial characters" $ TestList [ + "\'a\'b == a" ~: + runParser charLiteral' "" "\'a\'b" ~?= Right 'a' + , "\'!\'b == !" ~: + runParser charLiteral' "" "\'!\'b" ~?= Right '!' + ] + ] + , TestLabel "Parser.Combinators.Core.charLiteral fail patterns" $ + TestList [ + "ab" ~: isLeft (runParser charLiteral' "" "ab") ~?= True + , "123" ~: isLeft (runParser charLiteral' "" "123") ~?= True + , "\'a" ~: isLeft (runParser charLiteral' "" "\'a") ~?= True + ] + ] + where + charLiteral' = charLiteral :: TestParser Char + charSets = + ['A'..'Z'] + <> ['a'..'z'] + <> ['0'..'9'] + <> "!\"#%&\'()*+,-./:;<=>?[]^_{|}~\a\b\n\r\f\t\v\0" + <> [chr 27] + +stringLiteralTest = TestLabel "Parser.Combinators.Core.stringLiteral" $ + TestList [ + TestLabel "Parser.Combinators.Core.stringLiteral success patterns" $ + TestList [ + "\"abc\" == abc" ~: runParser stringLiteral' "" "\"abc\"" ~?= Right "abc" + , "\"012\" == 012" ~: runParser stringLiteral' "" "\"012\"" ~?= Right "012" + , "\"012\"3 == 012" ~: runParser stringLiteral' "" "\"012\"3" ~?= Right "012" + ] + , TestLabel "Parser.Combinators.Core.stringLiteral fail patterns" $ + TestList [ + "abc" ~: isLeft (runParser stringLiteral' "" "abc") ~?= True + , "\"abc" ~: isLeft (runParser stringLiteral' "" "\"abc") ~?= True + ] + ] + where + stringLiteral' = stringLiteral :: TestParser String + +hexadecimalTest = TestLabel "Parser.Combinators.Core.hexadecimal" $ + TestList [ + TestLabel "Parser.Combinators.Core.hexadecimal success patterns" $ + TestList [ + "0x01 == 0x01" ~: runParser hexadecimal' "" "0x01" ~?= Right 0x01 + , "0xf == 0xf" ~: runParser hexadecimal' "" "0xf" ~?= Right 0xf + , "0X0 == 0x0" ~: runParser hexadecimal' "" "0X0" ~?= Right 0x0 + , "0Xf == 0xf" ~: runParser hexadecimal' "" "0Xf" ~?= Right 0xf + , "0xfz == 0xf" ~: runParser hexadecimal' "" "0xfz" ~?= Right 0xf + ] + , TestLabel "Parser.Combinators.Core.hexadecimal fail patterns" $ + TestList [ + "0x" ~: isLeft (runParser hexadecimal' "" "0x") ~?= True + , "0xz" ~: isLeft (runParser hexadecimal' "" "0xz") ~?= True + , "01" ~: isLeft (runParser hexadecimal' "" "01") ~?= True + , "0" ~: isLeft (runParser hexadecimal' "" "0") ~?= True + ] + ] + where + hexadecimal' = hexadecimal :: TestParser Int + +octalTest = TestLabel "Parser.Combinators.Core.octal" $ + TestList [ + TestLabel "Parser.Combinators.Core.octal success patterns" $ + TestList [ + "01 == 0o1" ~: runParser octal' "" "01" ~?= Right 0o1 + , "0010 == 0o10" ~: runParser octal' "" "0010" ~?= Right 0o10 + , "0010a == 0o10" ~: runParser octal' "" "0010a" ~?= Right 0o10 + ] + , TestLabel "Parser.Combinators.Core.octal fail patterns" $ + TestList [ + "0x0" ~: isLeft (runParser octal' "" "0x0") ~?= True + , "0" ~: isLeft (runParser octal' "" "0") ~?= True + ] + ] + where + octal' = octal :: TestParser Int + +naturalTest = TestLabel "Parser.Combinators.Core.natural" $ + TestList [ + TestLabel "Parser.Combinators.Core.natural success patterns" $ + TestList [ + "10 == 10" ~: runParser natural' "" "10" ~?= Right 10 + , "0010 == 0o10" ~: runParser natural' "" "0010" ~?= Right 0o10 + , "0x1 == 0x1" ~: runParser natural' "" "0x1" ~?= Right 0x1 + , "0x == 0" ~: runParser natural' "" "0x" ~?= Right 0 + , "0xz == 0" ~: runParser natural' "" "0xz" ~?= Right 0 + , "00x0 == 0" ~: runParser natural' "" "00x0" ~?= Right 0 + ] + , TestLabel "Parser.Combinators.Core.natural fail patterns" $ + TestList [ + "hoge" ~: isLeft (runParser natural' "" "hoge") ~?= True + ] + ] + where + natural' = natural :: TestParser Int + +integerTest = TestLabel "Parser.Combinators.Core.integer" $ + TestList [ + TestLabel "Parser.Combinators.Core.integer success patterns" $ + TestList [ + "10 == 10" ~: runParser integer' "" "10" ~?= Right 10 + , "0010 == 0o10" ~: runParser integer' "" "0010" ~?= Right 0o10 + , "0x1 == 0x1" ~: runParser integer' "" "0x1" ~?= Right 0x1 + , "0x == 0" ~: runParser integer' "" "0x" ~?= Right 0 + , "0xz == 0" ~: runParser integer' "" "0xz" ~?= Right 0 + , "00x0 == 0" ~: runParser integer' "" "00x0" ~?= Right 0 + , "+10 == 10" ~: runParser integer' "" "+10" ~?= Right 10 + , "+0010 == 0o10" ~: runParser integer' "" "+0010" ~?= Right 0o10 + , "+0x1 == 0x1" ~: runParser integer' "" "+0x1" ~?= Right 0x1 + , "+0x == 0" ~: runParser integer' "" "+0x" ~?= Right 0 + , "+0xz == 0" ~: runParser integer' "" "+0xz" ~?= Right 0 + , "+00x0 == 0" ~: runParser integer' "" "+00x0" ~?= Right 0 + , "-10 == -10" ~: runParser integer' "" "-10" ~?= Right (-10) + , "-0010 == -0o10" ~: runParser integer' "" "-0010" ~?= Right (-0o10) + , "-0x1 == -0x1" ~: runParser integer' "" "-0x1" ~?= Right (-0x1) + , "-0x == 0" ~: runParser integer' "" "-0x" ~?= Right 0 + , "-0xz == 0" ~: runParser integer' "" "-0xz" ~?= Right 0 + , "-00x0 == 0" ~: runParser integer' "" "-00x0" ~?= Right 0 + ] + ] + where + integer' = integer :: TestParser Int + +identifierTest = TestLabel "Parser.Combinators.Core.identifier" $ + TestList [ + TestLabel "Parser.Combinators.Core.identifier success patterns" $ + TestList [ + "abcde" ~: runParser identifier' "" "abcde" ~?= Right "abcde" + , "_" ~: runParser identifier' "" "_" ~?= Right "_" + , "a@" ~: runParser identifier' "" "a@" ~?= Right "a" + , "a1a" ~: runParser identifier' "" "a1" ~?= Right "a1" + ] + , TestLabel "Parser.Combinators.Core.identifier fail patterns" $ + TestList [ + TestLabel "invalid characters eg" $ TestList [ + "@" ~: isLeft (runParser identifier' "" "@") ~?= True + , "@a" ~: isLeft (runParser identifier' "" "@a") ~?= True + , "1a" ~: isLeft (runParser identifier' "" "1a") ~?= True + ] + , TestLabel "3 characters op" $ + TestList [T.unpack op ~: isLeft (runParser identifier' "" op) ~?= True | op <- CR.strOps3] + , TestLabel "2 characters op" $ + TestList [T.unpack op ~: isLeft (runParser identifier' "" op) ~?= True | op <- CR.strOps2] + , TestLabel "1 characters op" $ + TestList [[op] ~: isLeft (runParser identifier' "" $ T.singleton op) ~?= True | op <- CR.charOps] + ] + ] + where + identifier' = identifier :: TestParser T.Text + +operatorTest = TestLabel "Parser.Combinators.Core.operator" $ + TestList [ + TestLabel "Parser.Combinators.Core.operator success patterns" $ + TestList [ + TestLabel "3 characters" $ TestList [T.unpack op ~: runParser operator' "" op ~?= Right op | op <- CR.strOps3] + , TestLabel "2 characters" $ TestList [T.unpack op ~: runParser operator' "" op ~?= Right op | op <- CR.strOps2] + , TestLabel "1 character" $ + TestList [[op] ~: runParser operator' "" (T.singleton op) ~?= Right (T.singleton op) | op <- CR.charOps] + ] + , TestLabel "Parser.Combinators.Core.operator fail patterns" $ + TestList [ + [c] ~: isLeft (runParser operator' "" (T.singleton c)) ~?= True + | c <- ['a'..'z'] <> ['A'..'Z'] + ] + ] + where + operator' = operator :: TestParser T.Text + +test :: Test +test = TestLabel "Parser.Combinators.Core" $ + TestList [ + charLiteralTest + , stringLiteralTest + , hexadecimalTest + , octalTest + , naturalTest + , integerTest + , identifierTest + , operatorTest + ] From a64a2cad2fc0e03923f415e9133f2303585c9b60 Mon Sep 17 00:00:00 2001 From: roki Date: Thu, 10 Dec 2020 05:55:49 +0900 Subject: [PATCH 03/51] Changed to use makeExprParser --- htcc.cabal | 4 +- src/Htcc/Parser/Combinators.hs | 4 +- src/Htcc/Parser/Combinators/Core.hs | 14 +- src/Htcc/Parser/Combinators/Expr.hs | 48 ------- src/Htcc/Parser/Combinators/Program.hs | 83 +++++++++++ .../ComponentsTests/Parser/Combinators.hs | 134 +++++++++--------- test/Tests/SubProcTests.hs | 26 +++- 7 files changed, 186 insertions(+), 127 deletions(-) delete mode 100644 src/Htcc/Parser/Combinators/Expr.hs create mode 100644 src/Htcc/Parser/Combinators/Program.hs diff --git a/htcc.cabal b/htcc.cabal index 6c75a10..a07ce8f 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: eafa6289395390475dd9cf3e016680d63468cafd8c86f64acb8619a5b655f0e2 +-- hash: 53af2f1cf00739fb56c3b6d2d73e9672335a38d5af516dc7675f6adb67caa046 name: htcc version: 0.0.0.1 @@ -72,8 +72,8 @@ library Htcc.Parser.AST.Var.Init Htcc.Parser.Combinators Htcc.Parser.Combinators.Core - Htcc.Parser.Combinators.Expr Htcc.Parser.Combinators.Keywords + Htcc.Parser.Combinators.Program Htcc.Parser.ConstructionData Htcc.Parser.ConstructionData.Core Htcc.Parser.ConstructionData.Scope diff --git a/src/Htcc/Parser/Combinators.hs b/src/Htcc/Parser/Combinators.hs index e521999..ea60113 100644 --- a/src/Htcc/Parser/Combinators.hs +++ b/src/Htcc/Parser/Combinators.hs @@ -11,8 +11,8 @@ C language lexer -} module Htcc.Parser.Combinators ( module Htcc.Parser.Combinators.Core - , module Htcc.Parser.Combinators.Expr + , module Htcc.Parser.Combinators.Program ) where import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Expr +import Htcc.Parser.Combinators.Program diff --git a/src/Htcc/Parser/Combinators/Core.hs b/src/Htcc/Parser/Combinators/Core.hs index 668fc09..e38c17b 100644 --- a/src/Htcc/Parser/Combinators/Core.hs +++ b/src/Htcc/Parser/Combinators/Core.hs @@ -13,6 +13,7 @@ C language lexer module Htcc.Parser.Combinators.Core ( runParser , Parser + , spaceConsumer , lexme , symbol , charLiteral @@ -56,6 +57,7 @@ import qualified Text.Megaparsec.Char.Lexer as ML import qualified Htcc.Parser.ConstructionData.Scope.Var as PSV import qualified Htcc.Parser.ConstructionData.Scope as PS import Htcc.Parser.AST.Type (ASTs) +import Control.Monad.Combinators (between) type ConstructionDataState i = StateT (ConstructionData i) Identity type Parser i = M.ParsecT Void T.Text (ConstructionDataState i) @@ -64,7 +66,7 @@ runParser :: Parser i (ASTs i) -> FilePath -> T.Text -> - Either (M.ParseErrorBundle T.Text Void) (Warnings i, ASTs i, PSV.GlobalVars i, PSV.Literals i) -- (ATree i, ConstructionData i) + Either (M.ParseErrorBundle T.Text Void) (Warnings i, ASTs i, PSV.GlobalVars i, PSV.Literals i) runParser p fp input = (warns (snd result),, PSV.globals $ PS.vars $ scope $ snd result, PSV.literals $ PS.vars $ scope $ snd result) <$> fst result @@ -96,11 +98,11 @@ decimal = ML.decimal natural = M.try (lexme hexadecimal) <|> M.try (lexme octal) <|> lexme decimal integer = ML.signed spaceConsumer natural <|> natural -parens, braces, angles, brackets :: Ord e => M.ParsecT e T.Text m T.Text -> M.ParsecT e T.Text m T.Text -parens = M.between (symbol "(") (symbol ")") -braces = M.between (symbol "{") (symbol "}") -angles = M.between (symbol "<") (symbol ">") -brackets = M.between (symbol "[") (symbol "]") +parens, braces, angles, brackets :: Ord e => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m a +parens = between (symbol "(") (symbol ")") +braces = between (symbol "{") (symbol "}") +angles = between (symbol "<") (symbol ">") +brackets = between (symbol "[") (symbol "]") identifier, operator, semi, comma, colon :: Ord e => M.ParsecT e T.Text m T.Text identifier = diff --git a/src/Htcc/Parser/Combinators/Expr.hs b/src/Htcc/Parser/Combinators/Expr.hs deleted file mode 100644 index f934de0..0000000 --- a/src/Htcc/Parser/Combinators/Expr.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-| -Module : Htcc.Parser.Combinators.Expr -Description : C language lexer -Copyright : (c) roki, 2020~ -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -C language lexer --} -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} -module Htcc.Parser.Combinators.Expr ( - parser -) where - -import Control.Applicative hiding (many) -import Control.Monad.Combinators (between) -import Control.Monad.Fix (fix) -import Htcc.CRules.Types as CT -import Htcc.Parser.AST.Core (ATKind (..), ATree (..), - atNumLit) -import Htcc.Parser.AST.Type (ASTs) -import Htcc.Parser.Combinators.Core -import Htcc.Parser.Development (defMainFn) - -parser :: Num i => Parser i (ASTs i) -parser = (:[]) . defMainFn <$> expr - -expr :: Num i => Parser i (ATree i) -expr = do - m <- term - ($ m) . fix $ \f nd -> - ((ATNode ATAdd (CT.SCAuto CT.CTInt) nd <$> (symbol "+" >> term)) >>= f) - <|> ((ATNode ATSub (CT.SCAuto CT.CTInt) nd <$> (symbol "-" >> term)) >>= f) - <|> return nd - -term :: Num i => Parser i (ATree i) -term = do - fac <- factor - ($ fac) . fix $ \f nd -> - ((ATNode ATMul (CT.SCAuto CT.CTInt) nd <$> (symbol "*" >> factor)) >>= f) - <|> ((ATNode ATDiv (CT.SCAuto CT.CTInt) nd <$> (symbol "/" >> factor)) >>= f) - <|> return nd - -factor :: Num i => Parser i (ATree i) -factor = atNumLit <$> integer <|> between (symbol "(") (symbol ")") expr - diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs new file mode 100644 index 0000000..64ef4a3 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -0,0 +1,83 @@ +{-| +Module : Htcc.Parser.Combinators.Program +Description : C language lexer +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language lexer +-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +module Htcc.Parser.Combinators.Program ( + parser +) where + +import Control.Applicative hiding (many) +import Control.Monad.Combinators (between, choice) +import Control.Monad.Combinators.Expr +import Control.Monad.Fix (fix) +import qualified Data.Text as T +import Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATKind (..), ATree (..), + atNumLit) +import Htcc.Parser.AST.Type (ASTs) +import Htcc.Parser.Combinators.Core +import Htcc.Parser.Development (defMainFn) +import qualified Text.Megaparsec as M +import qualified Text.Megaparsec.Char as MC + +parser :: Num i => Parser i (ASTs i) +parser = (:[]) . defMainFn <$> (spaceConsumer >> expr) + +expr :: Num i => Parser i (ATree i) +expr = makeExprParser term operatorTable M. "expression" + +term :: Num i => Parser i (ATree i) +term = choice [parens expr, atNumLit <$> natural] M. "term" + +operatorTable :: Num i => [[Operator (Parser i) (ATree i)]] +operatorTable = + [ [ binary "==" (ATNode ATEQ (CT.SCAuto CT.CTInt)) + , binary "!=" (ATNode ATNEQ (CT.SCAuto CT.CTInt)) + ] + , [ binary "<=" (ATNode ATLEQ (CT.SCAuto CT.CTInt)) + , binary "<" (ATNode ATLT (CT.SCAuto CT.CTInt)) + , binary ">=" (ATNode ATGEQ (CT.SCAuto CT.CTInt)) + , binary ">" (ATNode ATGT (CT.SCAuto CT.CTInt)) + ] + , [ prefix "-" (ATNode ATSub (CT.SCAuto CT.CTInt) (atNumLit 0)) + , prefix "+" id + ] + , [ binary "*" (ATNode ATMul (CT.SCAuto CT.CTInt)) + , binary "/" (ATNode ATDiv (CT.SCAuto CT.CTInt)) + ] + , [ binary "+" (ATNode ATAdd (CT.SCAuto CT.CTInt)) + , binary "-" (ATNode ATSub (CT.SCAuto CT.CTInt)) + ] + ] + where + prefix name f = Prefix (f <$ symbol name) + binary name f = InfixL (f <$ symbol name) + +{- +expr :: Num i => Parser i (ATree i) +expr = do + m <- term + ($ m) . fix $ \f nd -> + ((ATNode ATAdd (CT.SCAuto CT.CTInt) nd <$> (symbol "+" >> term)) >>= f) + <|> ((ATNode ATSub (CT.SCAuto CT.CTInt) nd <$> (symbol "-" >> term)) >>= f) + <|> return nd + +term :: Num i => Parser i (ATree i) +term = do + fac <- factor + ($ fac) . fix $ \f nd -> + ((ATNode ATMul (CT.SCAuto CT.CTInt) nd <$> (symbol "*" >> factor)) >>= f) + <|> ((ATNode ATDiv (CT.SCAuto CT.CTInt) nd <$> (symbol "/" >> factor)) >>= f) + <|> return nd + +factor :: Num i => Parser i (ATree i) +factor = atNumLit <$> integer <|> between (symbol "(") (symbol ")") expr +-} diff --git a/test/Tests/ComponentsTests/Parser/Combinators.hs b/test/Tests/ComponentsTests/Parser/Combinators.hs index 506099b..55662e2 100644 --- a/test/Tests/ComponentsTests/Parser/Combinators.hs +++ b/test/Tests/ComponentsTests/Parser/Combinators.hs @@ -8,12 +8,12 @@ import qualified Data.Text as T import Data.Void (Void) import qualified Htcc.CRules as CR import Htcc.Parser.Combinators.Core -import qualified Htcc.Tokenizer.Token as HTT +import qualified Htcc.Tokenizer.Token as HTT import Htcc.Utils (tshow) import Test.HUnit (Test (..), (~:), (~?=)) -import Text.Megaparsec +import qualified Text.Megaparsec as M -type TestParser = Parsec Void T.Text +type TestParser = M.Parsec Void T.Text charLiteralTest, stringLiteralTest, hexadecimalTest, octalTest, naturalTest, integerTest, identifierTest, operatorTest :: Test @@ -23,21 +23,21 @@ charLiteralTest = TestLabel "Parser.Combinators.Core.charLiteral" $ TestList [ TestLabel "valid characters" $ TestList [ (show x <> " == " <> show x) ~: - runParser charLiteral' "" (T.singleton '\'' <> T.singleton x <> T.singleton '\'') ~?= Right x + M.runParser charLiteral' "" (T.singleton '\'' <> T.singleton x <> T.singleton '\'') ~?= Right x | x <- charSets ] , TestLabel "partial characters" $ TestList [ "\'a\'b == a" ~: - runParser charLiteral' "" "\'a\'b" ~?= Right 'a' + M.runParser charLiteral' "" "\'a\'b" ~?= Right 'a' , "\'!\'b == !" ~: - runParser charLiteral' "" "\'!\'b" ~?= Right '!' + M.runParser charLiteral' "" "\'!\'b" ~?= Right '!' ] ] , TestLabel "Parser.Combinators.Core.charLiteral fail patterns" $ TestList [ - "ab" ~: isLeft (runParser charLiteral' "" "ab") ~?= True - , "123" ~: isLeft (runParser charLiteral' "" "123") ~?= True - , "\'a" ~: isLeft (runParser charLiteral' "" "\'a") ~?= True + "ab" ~: isLeft (M.runParser charLiteral' "" "ab") ~?= True + , "123" ~: isLeft (M.runParser charLiteral' "" "123") ~?= True + , "\'a" ~: isLeft (M.runParser charLiteral' "" "\'a") ~?= True ] ] where @@ -53,14 +53,14 @@ stringLiteralTest = TestLabel "Parser.Combinators.Core.stringLiteral" $ TestList [ TestLabel "Parser.Combinators.Core.stringLiteral success patterns" $ TestList [ - "\"abc\" == abc" ~: runParser stringLiteral' "" "\"abc\"" ~?= Right "abc" - , "\"012\" == 012" ~: runParser stringLiteral' "" "\"012\"" ~?= Right "012" - , "\"012\"3 == 012" ~: runParser stringLiteral' "" "\"012\"3" ~?= Right "012" + "\"abc\" == abc" ~: M.runParser stringLiteral' "" "\"abc\"" ~?= Right "abc" + , "\"012\" == 012" ~: M.runParser stringLiteral' "" "\"012\"" ~?= Right "012" + , "\"012\"3 == 012" ~: M.runParser stringLiteral' "" "\"012\"3" ~?= Right "012" ] , TestLabel "Parser.Combinators.Core.stringLiteral fail patterns" $ TestList [ - "abc" ~: isLeft (runParser stringLiteral' "" "abc") ~?= True - , "\"abc" ~: isLeft (runParser stringLiteral' "" "\"abc") ~?= True + "abc" ~: isLeft (M.runParser stringLiteral' "" "abc") ~?= True + , "\"abc" ~: isLeft (M.runParser stringLiteral' "" "\"abc") ~?= True ] ] where @@ -70,18 +70,18 @@ hexadecimalTest = TestLabel "Parser.Combinators.Core.hexadecimal" $ TestList [ TestLabel "Parser.Combinators.Core.hexadecimal success patterns" $ TestList [ - "0x01 == 0x01" ~: runParser hexadecimal' "" "0x01" ~?= Right 0x01 - , "0xf == 0xf" ~: runParser hexadecimal' "" "0xf" ~?= Right 0xf - , "0X0 == 0x0" ~: runParser hexadecimal' "" "0X0" ~?= Right 0x0 - , "0Xf == 0xf" ~: runParser hexadecimal' "" "0Xf" ~?= Right 0xf - , "0xfz == 0xf" ~: runParser hexadecimal' "" "0xfz" ~?= Right 0xf + "0x01 == 0x01" ~: M.runParser hexadecimal' "" "0x01" ~?= Right 0x01 + , "0xf == 0xf" ~: M.runParser hexadecimal' "" "0xf" ~?= Right 0xf + , "0X0 == 0x0" ~: M.runParser hexadecimal' "" "0X0" ~?= Right 0x0 + , "0Xf == 0xf" ~: M.runParser hexadecimal' "" "0Xf" ~?= Right 0xf + , "0xfz == 0xf" ~: M.runParser hexadecimal' "" "0xfz" ~?= Right 0xf ] , TestLabel "Parser.Combinators.Core.hexadecimal fail patterns" $ TestList [ - "0x" ~: isLeft (runParser hexadecimal' "" "0x") ~?= True - , "0xz" ~: isLeft (runParser hexadecimal' "" "0xz") ~?= True - , "01" ~: isLeft (runParser hexadecimal' "" "01") ~?= True - , "0" ~: isLeft (runParser hexadecimal' "" "0") ~?= True + "0x" ~: isLeft (M.runParser hexadecimal' "" "0x") ~?= True + , "0xz" ~: isLeft (M.runParser hexadecimal' "" "0xz") ~?= True + , "01" ~: isLeft (M.runParser hexadecimal' "" "01") ~?= True + , "0" ~: isLeft (M.runParser hexadecimal' "" "0") ~?= True ] ] where @@ -91,14 +91,14 @@ octalTest = TestLabel "Parser.Combinators.Core.octal" $ TestList [ TestLabel "Parser.Combinators.Core.octal success patterns" $ TestList [ - "01 == 0o1" ~: runParser octal' "" "01" ~?= Right 0o1 - , "0010 == 0o10" ~: runParser octal' "" "0010" ~?= Right 0o10 - , "0010a == 0o10" ~: runParser octal' "" "0010a" ~?= Right 0o10 + "01 == 0o1" ~: M.runParser octal' "" "01" ~?= Right 0o1 + , "0010 == 0o10" ~: M.runParser octal' "" "0010" ~?= Right 0o10 + , "0010a == 0o10" ~: M.runParser octal' "" "0010a" ~?= Right 0o10 ] , TestLabel "Parser.Combinators.Core.octal fail patterns" $ TestList [ - "0x0" ~: isLeft (runParser octal' "" "0x0") ~?= True - , "0" ~: isLeft (runParser octal' "" "0") ~?= True + "0x0" ~: isLeft (M.runParser octal' "" "0x0") ~?= True + , "0" ~: isLeft (M.runParser octal' "" "0") ~?= True ] ] where @@ -108,16 +108,16 @@ naturalTest = TestLabel "Parser.Combinators.Core.natural" $ TestList [ TestLabel "Parser.Combinators.Core.natural success patterns" $ TestList [ - "10 == 10" ~: runParser natural' "" "10" ~?= Right 10 - , "0010 == 0o10" ~: runParser natural' "" "0010" ~?= Right 0o10 - , "0x1 == 0x1" ~: runParser natural' "" "0x1" ~?= Right 0x1 - , "0x == 0" ~: runParser natural' "" "0x" ~?= Right 0 - , "0xz == 0" ~: runParser natural' "" "0xz" ~?= Right 0 - , "00x0 == 0" ~: runParser natural' "" "00x0" ~?= Right 0 + "10 == 10" ~: M.runParser natural' "" "10" ~?= Right 10 + , "0010 == 0o10" ~: M.runParser natural' "" "0010" ~?= Right 0o10 + , "0x1 == 0x1" ~: M.runParser natural' "" "0x1" ~?= Right 0x1 + , "0x == 0" ~: M.runParser natural' "" "0x" ~?= Right 0 + , "0xz == 0" ~: M.runParser natural' "" "0xz" ~?= Right 0 + , "00x0 == 0" ~: M.runParser natural' "" "00x0" ~?= Right 0 ] , TestLabel "Parser.Combinators.Core.natural fail patterns" $ TestList [ - "hoge" ~: isLeft (runParser natural' "" "hoge") ~?= True + "hoge" ~: isLeft (M.runParser natural' "" "hoge") ~?= True ] ] where @@ -127,24 +127,24 @@ integerTest = TestLabel "Parser.Combinators.Core.integer" $ TestList [ TestLabel "Parser.Combinators.Core.integer success patterns" $ TestList [ - "10 == 10" ~: runParser integer' "" "10" ~?= Right 10 - , "0010 == 0o10" ~: runParser integer' "" "0010" ~?= Right 0o10 - , "0x1 == 0x1" ~: runParser integer' "" "0x1" ~?= Right 0x1 - , "0x == 0" ~: runParser integer' "" "0x" ~?= Right 0 - , "0xz == 0" ~: runParser integer' "" "0xz" ~?= Right 0 - , "00x0 == 0" ~: runParser integer' "" "00x0" ~?= Right 0 - , "+10 == 10" ~: runParser integer' "" "+10" ~?= Right 10 - , "+0010 == 0o10" ~: runParser integer' "" "+0010" ~?= Right 0o10 - , "+0x1 == 0x1" ~: runParser integer' "" "+0x1" ~?= Right 0x1 - , "+0x == 0" ~: runParser integer' "" "+0x" ~?= Right 0 - , "+0xz == 0" ~: runParser integer' "" "+0xz" ~?= Right 0 - , "+00x0 == 0" ~: runParser integer' "" "+00x0" ~?= Right 0 - , "-10 == -10" ~: runParser integer' "" "-10" ~?= Right (-10) - , "-0010 == -0o10" ~: runParser integer' "" "-0010" ~?= Right (-0o10) - , "-0x1 == -0x1" ~: runParser integer' "" "-0x1" ~?= Right (-0x1) - , "-0x == 0" ~: runParser integer' "" "-0x" ~?= Right 0 - , "-0xz == 0" ~: runParser integer' "" "-0xz" ~?= Right 0 - , "-00x0 == 0" ~: runParser integer' "" "-00x0" ~?= Right 0 + "10 == 10" ~: M.runParser integer' "" "10" ~?= Right 10 + , "0010 == 0o10" ~: M.runParser integer' "" "0010" ~?= Right 0o10 + , "0x1 == 0x1" ~: M.runParser integer' "" "0x1" ~?= Right 0x1 + , "0x == 0" ~: M.runParser integer' "" "0x" ~?= Right 0 + , "0xz == 0" ~: M.runParser integer' "" "0xz" ~?= Right 0 + , "00x0 == 0" ~: M.runParser integer' "" "00x0" ~?= Right 0 + , "+10 == 10" ~: M.runParser integer' "" "+10" ~?= Right 10 + , "+0010 == 0o10" ~: M.runParser integer' "" "+0010" ~?= Right 0o10 + , "+0x1 == 0x1" ~: M.runParser integer' "" "+0x1" ~?= Right 0x1 + , "+0x == 0" ~: M.runParser integer' "" "+0x" ~?= Right 0 + , "+0xz == 0" ~: M.runParser integer' "" "+0xz" ~?= Right 0 + , "+00x0 == 0" ~: M.runParser integer' "" "+00x0" ~?= Right 0 + , "-10 == -10" ~: M.runParser integer' "" "-10" ~?= Right (-10) + , "-0010 == -0o10" ~: M.runParser integer' "" "-0010" ~?= Right (-0o10) + , "-0x1 == -0x1" ~: M.runParser integer' "" "-0x1" ~?= Right (-0x1) + , "-0x == 0" ~: M.runParser integer' "" "-0x" ~?= Right 0 + , "-0xz == 0" ~: M.runParser integer' "" "-0xz" ~?= Right 0 + , "-00x0 == 0" ~: M.runParser integer' "" "-00x0" ~?= Right 0 ] ] where @@ -154,24 +154,24 @@ identifierTest = TestLabel "Parser.Combinators.Core.identifier" $ TestList [ TestLabel "Parser.Combinators.Core.identifier success patterns" $ TestList [ - "abcde" ~: runParser identifier' "" "abcde" ~?= Right "abcde" - , "_" ~: runParser identifier' "" "_" ~?= Right "_" - , "a@" ~: runParser identifier' "" "a@" ~?= Right "a" - , "a1a" ~: runParser identifier' "" "a1" ~?= Right "a1" + "abcde" ~: M.runParser identifier' "" "abcde" ~?= Right "abcde" + , "_" ~: M.runParser identifier' "" "_" ~?= Right "_" + , "a@" ~: M.runParser identifier' "" "a@" ~?= Right "a" + , "a1a" ~: M.runParser identifier' "" "a1" ~?= Right "a1" ] , TestLabel "Parser.Combinators.Core.identifier fail patterns" $ TestList [ TestLabel "invalid characters eg" $ TestList [ - "@" ~: isLeft (runParser identifier' "" "@") ~?= True - , "@a" ~: isLeft (runParser identifier' "" "@a") ~?= True - , "1a" ~: isLeft (runParser identifier' "" "1a") ~?= True + "@" ~: isLeft (M.runParser identifier' "" "@") ~?= True + , "@a" ~: isLeft (M.runParser identifier' "" "@a") ~?= True + , "1a" ~: isLeft (M.runParser identifier' "" "1a") ~?= True ] , TestLabel "3 characters op" $ - TestList [T.unpack op ~: isLeft (runParser identifier' "" op) ~?= True | op <- CR.strOps3] + TestList [T.unpack op ~: isLeft (M.runParser identifier' "" op) ~?= True | op <- CR.strOps3] , TestLabel "2 characters op" $ - TestList [T.unpack op ~: isLeft (runParser identifier' "" op) ~?= True | op <- CR.strOps2] + TestList [T.unpack op ~: isLeft (M.runParser identifier' "" op) ~?= True | op <- CR.strOps2] , TestLabel "1 characters op" $ - TestList [[op] ~: isLeft (runParser identifier' "" $ T.singleton op) ~?= True | op <- CR.charOps] + TestList [[op] ~: isLeft (M.runParser identifier' "" $ T.singleton op) ~?= True | op <- CR.charOps] ] ] where @@ -181,14 +181,14 @@ operatorTest = TestLabel "Parser.Combinators.Core.operator" $ TestList [ TestLabel "Parser.Combinators.Core.operator success patterns" $ TestList [ - TestLabel "3 characters" $ TestList [T.unpack op ~: runParser operator' "" op ~?= Right op | op <- CR.strOps3] - , TestLabel "2 characters" $ TestList [T.unpack op ~: runParser operator' "" op ~?= Right op | op <- CR.strOps2] + TestLabel "3 characters" $ TestList [T.unpack op ~: M.runParser operator' "" op ~?= Right op | op <- CR.strOps3] + , TestLabel "2 characters" $ TestList [T.unpack op ~: M.runParser operator' "" op ~?= Right op | op <- CR.strOps2] , TestLabel "1 character" $ - TestList [[op] ~: runParser operator' "" (T.singleton op) ~?= Right (T.singleton op) | op <- CR.charOps] + TestList [[op] ~: M.runParser operator' "" (T.singleton op) ~?= Right (T.singleton op) | op <- CR.charOps] ] , TestLabel "Parser.Combinators.Core.operator fail patterns" $ TestList [ - [c] ~: isLeft (runParser operator' "" (T.singleton c)) ~?= True + [c] ~: isLeft (M.runParser operator' "" (T.singleton c)) ~?= True | c <- ['a'..'z'] <> ['A'..'Z'] ] ] diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 37eed81..db3b17e 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -14,6 +14,28 @@ import Tests.Utils hiding (exec) import qualified Htcc.CRules.Types as CT exec :: IO () +exec = runTestsEx + [ (StatementEqual.test "1+2", 3) + , (StatementEqual.test "1+2+4", 7) + , (StatementEqual.test "10-7+3", 6) + , (StatementEqual.test "42+23-30", 35) + , (StatementEqual.test "42/2+2-5", 18) + , (StatementEqual.test "(3+5)/2", 4) + , (StatementEqual.test "(4-2)*8+20/4",21) + , (StatementEqual.test "-(-3*+5)", 15) + , (StatementEqual.test "-25+30", 5) + , (StatementEqual.test "42 == 42", 1) + , (StatementEqual.test "42 != 53", 1) + , (StatementEqual.test "42 < 53", 1) + , (StatementEqual.test "53 > 42", 1) + , (StatementEqual.test "42 <= 42", 1) + , (StatementEqual.test "32 <= 42", 1) + , (StatementEqual.test "42 >= 42", 1) + , (StatementEqual.test "53 >= 42", 1) + , (StatementEqual.test "(1 + 1) == 2", 1) + , (StatementEqual.test "(2 * 3) != 2", 1) + ] +{- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ (StatementEqual.test "int main() { return 42; }", 42), (StatementEqual.test "int main() { return 1+2; }", 3), @@ -178,6 +200,6 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ (StatementEqual.test "int main() { int* ar[3]; int x; ar[0] = &x; x = 42; ar[0][0]; }", 42) ] >> runTestsEx [ (LinkFuncStdOut.test "int test_func1(); int main() { return test_func1(); }" ["test_func1"], Right "test/Tests/csrc/test_func1.c::test_func1(): [OK]"), - (LinkFuncStdOut.test "int test_func2(); int main() { return test_func2(40); }" ["test_func2"], Right "test/Tests/csrc/test_func2.c::test_func2(40) outputs: \"2 3 5 7 11 13 17 19 23 29 31 37 \": [OK]") --, - -- (LinkFuncStdOut.test "int main() { return test_func2(sum7(1, 2, 3, 4, 5, 6, 7)); }" ["test_func2", "test_func3"], Right "test/Tests/csrc/test_func2.c::test_func2(28) outputs: \"2 3 5 7 11 13 17 19 23 \": [OK]") + (LinkFuncStdOut.test "int test_func2(); int main() { return test_func2(40); }" ["test_func2"], Right "test/Tests/csrc/test_func2.c::test_func2(40) outputs: \"2 3 5 7 11 13 17 19 23 29 31 37 \": [OK]"), ] +-} From 2956d8eee70a2c4900d4524d308b97d0c36188ac Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 13 Dec 2020 04:37:01 +0900 Subject: [PATCH 04/51] Implemented some binary operators, untyped (all int) variables and return statements --- app/Main.hs | 4 +- htcc.cabal | 3 +- src/Htcc/CRules/Types/StorageClass.hs | 3 + src/Htcc/CRules/Types/TypeKind.hs | 9 + src/Htcc/Parser/Combinators/BasicOperator.hs | 34 +++ src/Htcc/Parser/Combinators/Core.hs | 48 ++--- src/Htcc/Parser/Combinators/Program.hs | 193 ++++++++++++------ .../ComponentsTests/Parser/Combinators.hs | 24 +-- test/Tests/SubProcTests.hs | 50 +++-- 9 files changed, 232 insertions(+), 136 deletions(-) create mode 100644 src/Htcc/Parser/Combinators/BasicOperator.hs diff --git a/app/Main.hs b/app/Main.hs index 7ebe9b3..60297ff 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -92,4 +92,6 @@ main = do case runParser parser fname txt :: Either (M.ParseErrorBundle T.Text Void) (Warnings Integer, ASTs Integer, GlobalVars Integer, Literals Integer) of Left x -> print x - Right r -> SI.runAsm $ casm' (snd4 r) (thd4 r) (fou4 r) + Right r -> runAsm' $ casm' (snd4 r) (thd4 r) (fou4 r) + where + runAsm' = SI.runAsm :: SI.Asm SI.AsmCodeCtx Integer a -> IO a diff --git a/htcc.cabal b/htcc.cabal index a07ce8f..ad0c3db 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 53af2f1cf00739fb56c3b6d2d73e9672335a38d5af516dc7675f6adb67caa046 +-- hash: 7820f03d55b3883d2f23b4561ae836c295ade3fa98f3eab9e4e44d9636218d0b name: htcc version: 0.0.0.1 @@ -71,6 +71,7 @@ library Htcc.Parser.AST.Var Htcc.Parser.AST.Var.Init Htcc.Parser.Combinators + Htcc.Parser.Combinators.BasicOperator Htcc.Parser.Combinators.Core Htcc.Parser.Combinators.Keywords Htcc.Parser.Combinators.Program diff --git a/src/Htcc/CRules/Types/StorageClass.hs b/src/Htcc/CRules/Types/StorageClass.hs index cb4f787..c8052d1 100644 --- a/src/Htcc/CRules/Types/StorageClass.hs +++ b/src/Htcc/CRules/Types/StorageClass.hs @@ -94,6 +94,9 @@ instance TypeKindBase StorageClass where {-# INLINE isArray #-} isArray = isArray . toTypeKind + {-# INLINE isIntegral #-} + isIntegral = isIntegral . toTypeKind + {-# INLINE isCTStruct #-} isCTStruct = isCTStruct . toTypeKind diff --git a/src/Htcc/CRules/Types/TypeKind.hs b/src/Htcc/CRules/Types/TypeKind.hs index 2263f95..5c18519 100644 --- a/src/Htcc/CRules/Types/TypeKind.hs +++ b/src/Htcc/CRules/Types/TypeKind.hs @@ -53,6 +53,8 @@ class TypeKindBase a where -- | `isArray` return `True` when the given argument is `Htcc.CRules.Types.Core.CTArray` or `IncompleteArray` -- Otherwise, returns `False` isArray :: a i -> Bool + -- | `isIntegral` return `True` when the given argument is `Htcc.CRules.Types.Core.CTInt`, `Htcc.CRules.Types.Core.CTShort` or `Htcc.CRules.Types.Core.CTLong` + isIntegral :: a i -> Bool -- | `isCTStruct` returns `True` when the given argument is `Htcc.CRules.Types.Core.CTStruct`. -- Otherwise, returns `False` isCTStruct :: a i -> Bool @@ -388,6 +390,13 @@ instance TypeKindBase TypeKind where {-# INLINE isArray #-} isArray = lor [isCTArray, isIncompleteArray] + {-# INLINE isIntegral #-} + isIntegral CTInt = True + isIntegral (CTSigned x) = isIntegral x + isIntegral (CTLong x) = isIntegral x + isIntegral (CTShort x) = isIntegral x + isIntegral _ = False + {-# INLINE isCTStruct #-} isCTStruct (CTStruct _) = True isCTStruct _ = False diff --git a/src/Htcc/Parser/Combinators/BasicOperator.hs b/src/Htcc/Parser/Combinators/BasicOperator.hs new file mode 100644 index 0000000..e7f22e5 --- /dev/null +++ b/src/Htcc/Parser/Combinators/BasicOperator.hs @@ -0,0 +1,34 @@ +{-| +Module : Htcc.Parser.Combinators.BasicOperator +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +module Htcc.Parser.Combinators.BasicOperator ( + binaryOperator +) where + +import Control.Applicative ((<|>)) +import Control.Monad.Combinators (choice) +import Control.Monad.Fix (fix) +import Htcc.Parser.AST.Core (ATree (..)) +import Htcc.Parser.Combinators.Core +import qualified Text.Megaparsec as M + +-- | A parser combinator that builds a parser for basic binary operators. +-- This is useful for syntax such as: +-- \\[X::=X'\left("\text{op}_1"\ X'\ \mid\ "\text{op}_2"\ X'\ \mid\cdots\right)\ast\\] +binaryOperator :: + Parser i (ATree i) + -> [(Parser i a, ATree i -> ATree i -> Parser i (ATree i))] + -> Parser i (ATree i) +binaryOperator p opndMs = do + m <- p + ($ m) . fix $ \f nd -> + choice [M.try (opM >> p) >>= ndM nd >>= f | (opM, ndM) <- opndMs] + <|> return nd diff --git a/src/Htcc/Parser/Combinators/Core.hs b/src/Htcc/Parser/Combinators/Core.hs index e38c17b..f2593b1 100644 --- a/src/Htcc/Parser/Combinators/Core.hs +++ b/src/Htcc/Parser/Combinators/Core.hs @@ -28,7 +28,6 @@ module Htcc.Parser.Combinators.Core ( , braces , brackets , identifier - , operator , semi , comma , colon @@ -36,28 +35,24 @@ module Htcc.Parser.Combinators.Core ( , commaSep1 ) where -import Control.Applicative (Alternative (..)) +import Control.Applicative (Alternative (..)) +import Control.Monad.Combinators (between) import Control.Monad.Trans.State.Lazy -import Data.Char (isAlpha) -import Data.Foldable (asum) +import Data.Char (isAlpha) import Data.Functor.Identity -import Data.Maybe (isJust) -import qualified Data.Text as T +import qualified Data.Text as T import Data.Void -import qualified Htcc.CRules as CR -import Htcc.Parser.AST.Core (ATree (..)) -import Htcc.Parser.ConstructionData (ConstructionData (..), - initConstructionData, Warnings) -import Htcc.Tokenizer.Token (Token (..), keywordsTokens, - lookupKeyword) -import Htcc.Utils (lor) -import qualified Text.Megaparsec as M -import qualified Text.Megaparsec.Char as MC -import qualified Text.Megaparsec.Char.Lexer as ML +import qualified Htcc.CRules as CR +import Htcc.Parser.AST.Type (ASTs) +import Htcc.Parser.ConstructionData (ConstructionData (..), + Warnings, + initConstructionData) +import qualified Htcc.Parser.ConstructionData.Scope as PS import qualified Htcc.Parser.ConstructionData.Scope.Var as PSV -import qualified Htcc.Parser.ConstructionData.Scope as PS -import Htcc.Parser.AST.Type (ASTs) -import Control.Monad.Combinators (between) +import Htcc.Utils (lor) +import qualified Text.Megaparsec as M +import qualified Text.Megaparsec.Char as MC +import qualified Text.Megaparsec.Char.Lexer as ML type ConstructionDataState i = StateT (ConstructionData i) Identity type Parser i = M.ParsecT Void T.Text (ConstructionDataState i) @@ -67,8 +62,8 @@ runParser :: FilePath -> T.Text -> Either (M.ParseErrorBundle T.Text Void) (Warnings i, ASTs i, PSV.GlobalVars i, PSV.Literals i) -runParser p fp input = - (warns (snd result),, PSV.globals $ PS.vars $ scope $ snd result, PSV.literals $ PS.vars $ scope $ snd result) +runParser p fp input = + (warns (snd result),, PSV.globals $ PS.vars $ scope $ snd result, PSV.literals $ PS.vars $ scope $ snd result) <$> fst result where result = runIdentity $ runStateT (M.runParserT p fp input) initConstructionData @@ -82,9 +77,6 @@ lexme = ML.lexeme spaceConsumer symbol :: Ord e => T.Text -> M.ParsecT e T.Text m T.Text symbol = ML.symbol spaceConsumer -toSymbols :: (Ord e) => [T.Text] -> M.ParsecT e T.Text m T.Text -toSymbols = asum . map (M.try . symbol) - charLiteral :: Ord e => M.ParsecT e T.Text m Char charLiteral = M.between (MC.char '\'') (MC.char '\'') ML.charLiteral @@ -104,15 +96,13 @@ braces = between (symbol "{") (symbol "}") angles = between (symbol "<") (symbol ">") brackets = between (symbol "[") (symbol "]") -identifier, operator, semi, comma, colon :: Ord e => M.ParsecT e T.Text m T.Text +identifier, semi, comma, colon :: Ord e => M.ParsecT e T.Text m T.Text identifier = mappend <$> M.takeWhile1P (Just "valid identifier") (lor [isAlpha, (=='_')]) <*> M.takeWhileP (Just "valid identifier") CR.isValidChar -operator = - toSymbols CR.strOps3 - <|> toSymbols CR.strOps2 - <|> toSymbols (T.singleton <$> CR.charOps) + <* spaceConsumer + semi = symbol ";" comma = symbol "," colon = symbol "." diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 64ef4a3..edfe3e7 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -14,70 +14,133 @@ module Htcc.Parser.Combinators.Program ( parser ) where -import Control.Applicative hiding (many) -import Control.Monad.Combinators (between, choice) -import Control.Monad.Combinators.Expr -import Control.Monad.Fix (fix) -import qualified Data.Text as T -import Htcc.CRules.Types as CT -import Htcc.Parser.AST.Core (ATKind (..), ATree (..), - atNumLit) -import Htcc.Parser.AST.Type (ASTs) +import Control.Applicative hiding (many, some) +import Control.Monad.Combinators (choice, some) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.State (get, put) +import Data.Bits (Bits (..)) +import Htcc.CRules.Types as CT +import Htcc.Parser.AST (Treealizable (..)) +import Htcc.Parser.AST.Core (ATKind (..), + ATree (..), atBlock, + atGVar, atNumLit, + atReturn) +import Htcc.Parser.AST.Type (ASTs) +import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core -import Htcc.Parser.Development (defMainFn) -import qualified Text.Megaparsec as M -import qualified Text.Megaparsec.Char as MC - -parser :: Num i => Parser i (ASTs i) -parser = (:[]) . defMainFn <$> (spaceConsumer >> expr) - -expr :: Num i => Parser i (ATree i) -expr = makeExprParser term operatorTable M. "expression" - -term :: Num i => Parser i (ATree i) -term = choice [parens expr, atNumLit <$> natural] M. "term" - -operatorTable :: Num i => [[Operator (Parser i) (ATree i)]] -operatorTable = - [ [ binary "==" (ATNode ATEQ (CT.SCAuto CT.CTInt)) - , binary "!=" (ATNode ATNEQ (CT.SCAuto CT.CTInt)) - ] - , [ binary "<=" (ATNode ATLEQ (CT.SCAuto CT.CTInt)) - , binary "<" (ATNode ATLT (CT.SCAuto CT.CTInt)) - , binary ">=" (ATNode ATGEQ (CT.SCAuto CT.CTInt)) - , binary ">" (ATNode ATGT (CT.SCAuto CT.CTInt)) - ] - , [ prefix "-" (ATNode ATSub (CT.SCAuto CT.CTInt) (atNumLit 0)) - , prefix "+" id - ] - , [ binary "*" (ATNode ATMul (CT.SCAuto CT.CTInt)) - , binary "/" (ATNode ATDiv (CT.SCAuto CT.CTInt)) - ] - , [ binary "+" (ATNode ATAdd (CT.SCAuto CT.CTInt)) - , binary "-" (ATNode ATSub (CT.SCAuto CT.CTInt)) - ] +import Htcc.Parser.Combinators.Keywords +import Htcc.Parser.ConstructionData (addLVar, lookupVar) +import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) +import qualified Htcc.Parser.ConstructionData.Scope.Var as PV +import Htcc.Parser.Development (defMainFn) +import qualified Htcc.Tokenizer.Token as HT +import Htcc.Utils (lor) +import qualified Text.Megaparsec as M + +binOpBool, binOpCon :: (Monad m, Ord i, Bits i, Show i) + => ATKind i + -> ATree i + -> ATree i + -> m (ATree i) +binOpBool k lhs rhs = return $ ATNode k (CT.SCAuto CT.CTBool) lhs rhs +binOpCon k lhs rhs = return $ ATNode k (CT.conversion (atype lhs) (atype rhs)) lhs rhs + +binOpIntOnly :: (Monad m, Alternative m, Ord i, Bits i, Show i) + => ATKind i + -> ATree i + -> ATree i + -> m (ATree i) +binOpIntOnly k lhs rhs + | lor [CT.isIntegral, (CT.CTBool==) . CT.toTypeKind] (atype lhs) && + lor [CT.isIntegral, (CT.CTBool ==) . CT.toTypeKind] (atype rhs) = + return $ ATNode k (CT.SCAuto $ CT.CTLong CT.CTInt) lhs rhs + | otherwise = empty + +parser :: (Integral i, Ord i, Bits i, Show i) => Parser i (ASTs i) +parser = (:[]) . defMainFn . atBlock <$> (spaceConsumer >> program) <* M.eof + +program :: (Integral i, Ord i, Bits i, Show i) => Parser i (ASTs i) +program = some stmt + +stmt, + expr, + assign, + logicalOr, + logicalAnd, + bitwiseOr, + bitwiseXor, + bitwiseAnd, + equality, + relational, + add, + term, + unary, + factor, + identifier' :: (Ord i, Bits i, Show i, Integral i) => Parser i (ATree i) + +stmt = choice + [ (atReturn (CT.SCUndef CT.CTUndef) <$> (kReturn >> expr)) <* semi + , expr <* semi ] - where - prefix name f = Prefix (f <$ symbol name) - binary name f = InfixL (f <$ symbol name) - -{- -expr :: Num i => Parser i (ATree i) -expr = do - m <- term - ($ m) . fix $ \f nd -> - ((ATNode ATAdd (CT.SCAuto CT.CTInt) nd <$> (symbol "+" >> term)) >>= f) - <|> ((ATNode ATSub (CT.SCAuto CT.CTInt) nd <$> (symbol "-" >> term)) >>= f) - <|> return nd - -term :: Num i => Parser i (ATree i) -term = do - fac <- factor - ($ fac) . fix $ \f nd -> - ((ATNode ATMul (CT.SCAuto CT.CTInt) nd <$> (symbol "*" >> factor)) >>= f) - <|> ((ATNode ATDiv (CT.SCAuto CT.CTInt) nd <$> (symbol "/" >> factor)) >>= f) - <|> return nd - -factor :: Num i => Parser i (ATree i) -factor = atNumLit <$> integer <|> between (symbol "(") (symbol ")") expr --} + +expr = assign + +assign = do + nd <- logicalOr + choice + [ symbol "=" >> (ATNode ATAssign (atype nd) nd <$> assign) + , return nd + ] + +logicalOr = binaryOperator logicalAnd [(symbol "||", binOpBool ATLOr)] +logicalAnd = binaryOperator bitwiseOr [(symbol "&&", binOpBool ATLAnd)] +bitwiseOr = binaryOperator bitwiseXor [(symbol "|", binOpIntOnly ATOr)] +bitwiseXor = binaryOperator bitwiseAnd [(symbol "^", binOpIntOnly ATXor)] +bitwiseAnd = binaryOperator equality [(symbol "&", binOpIntOnly ATAnd)] + +equality = binaryOperator relational + [ (symbol "==", binOpBool ATEQ) + , (symbol "!=", binOpBool ATNEQ) + ] + +relational = binaryOperator add + [ (symbol "<=", binOpBool ATLEQ) + , (symbol "<", binOpBool ATLT) + , (symbol ">=", binOpBool ATGEQ) + , (symbol ">", binOpBool ATGT) + ] + +add = binaryOperator term + [ (symbol "+", binOpCon ATAdd) + , (symbol "-", binOpCon ATSub) + ] + +term = binaryOperator unary + [ (symbol "*", binOpCon ATMul) + , (symbol "/", binOpCon ATDiv) + ] + +unary = choice + [ symbol "+" >> factor + , (\n -> ATNode ATSub (atype n) (atNumLit 0) n) <$> (symbol "-" >> factor) + , factor + ] + +factor = choice + [ atNumLit <$> natural + , identifier' + , parens expr + , ATEmpty <$ M.eof + ] + +identifier' = do + ident <- identifier + lift $ do + scp <- get + case lookupVar ident scp of + FoundGVar (PV.GVar t _) -> return $ atGVar t ident + FoundLVar sct -> return $ treealize sct + FoundEnum sct -> return $ treealize sct + NotFound -> let Right (lat, scp') = addLVar (CT.SCAuto CT.CTInt) (HT.TokenLCNums 1 1, HT.TKIdent ident) scp in do + put scp' + return lat diff --git a/test/Tests/ComponentsTests/Parser/Combinators.hs b/test/Tests/ComponentsTests/Parser/Combinators.hs index 55662e2..2ffe0f9 100644 --- a/test/Tests/ComponentsTests/Parser/Combinators.hs +++ b/test/Tests/ComponentsTests/Parser/Combinators.hs @@ -15,7 +15,7 @@ import qualified Text.Megaparsec as M type TestParser = M.Parsec Void T.Text -charLiteralTest, stringLiteralTest, hexadecimalTest, octalTest, naturalTest, integerTest, identifierTest, operatorTest :: Test +charLiteralTest, stringLiteralTest, hexadecimalTest, octalTest, naturalTest, integerTest, identifierTest :: Test charLiteralTest = TestLabel "Parser.Combinators.Core.charLiteral" $ TestList [ @@ -154,7 +154,8 @@ identifierTest = TestLabel "Parser.Combinators.Core.identifier" $ TestList [ TestLabel "Parser.Combinators.Core.identifier success patterns" $ TestList [ - "abcde" ~: M.runParser identifier' "" "abcde" ~?= Right "abcde" + "a" ~: M.runParser identifier' "" "a =" ~?= Right "a" + , "abcde" ~: M.runParser identifier' "" "abcde" ~?= Right "abcde" , "_" ~: M.runParser identifier' "" "_" ~?= Right "_" , "a@" ~: M.runParser identifier' "" "a@" ~?= Right "a" , "a1a" ~: M.runParser identifier' "" "a1" ~?= Right "a1" @@ -177,24 +178,6 @@ identifierTest = TestLabel "Parser.Combinators.Core.identifier" $ where identifier' = identifier :: TestParser T.Text -operatorTest = TestLabel "Parser.Combinators.Core.operator" $ - TestList [ - TestLabel "Parser.Combinators.Core.operator success patterns" $ - TestList [ - TestLabel "3 characters" $ TestList [T.unpack op ~: M.runParser operator' "" op ~?= Right op | op <- CR.strOps3] - , TestLabel "2 characters" $ TestList [T.unpack op ~: M.runParser operator' "" op ~?= Right op | op <- CR.strOps2] - , TestLabel "1 character" $ - TestList [[op] ~: M.runParser operator' "" (T.singleton op) ~?= Right (T.singleton op) | op <- CR.charOps] - ] - , TestLabel "Parser.Combinators.Core.operator fail patterns" $ - TestList [ - [c] ~: isLeft (M.runParser operator' "" (T.singleton c)) ~?= True - | c <- ['a'..'z'] <> ['A'..'Z'] - ] - ] - where - operator' = operator :: TestParser T.Text - test :: Test test = TestLabel "Parser.Combinators.Core" $ TestList [ @@ -205,5 +188,4 @@ test = TestLabel "Parser.Combinators.Core" $ , naturalTest , integerTest , identifierTest - , operatorTest ] diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index db3b17e..4799f3e 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -15,25 +15,37 @@ import qualified Htcc.CRules.Types as CT exec :: IO () exec = runTestsEx - [ (StatementEqual.test "1+2", 3) - , (StatementEqual.test "1+2+4", 7) - , (StatementEqual.test "10-7+3", 6) - , (StatementEqual.test "42+23-30", 35) - , (StatementEqual.test "42/2+2-5", 18) - , (StatementEqual.test "(3+5)/2", 4) - , (StatementEqual.test "(4-2)*8+20/4",21) - , (StatementEqual.test "-(-3*+5)", 15) - , (StatementEqual.test "-25+30", 5) - , (StatementEqual.test "42 == 42", 1) - , (StatementEqual.test "42 != 53", 1) - , (StatementEqual.test "42 < 53", 1) - , (StatementEqual.test "53 > 42", 1) - , (StatementEqual.test "42 <= 42", 1) - , (StatementEqual.test "32 <= 42", 1) - , (StatementEqual.test "42 >= 42", 1) - , (StatementEqual.test "53 >= 42", 1) - , (StatementEqual.test "(1 + 1) == 2", 1) - , (StatementEqual.test "(2 * 3) != 2", 1) + [ (StatementEqual.test "return 1+2;", 3) + , (StatementEqual.test "return 1+2+4;", 7) + , (StatementEqual.test "return 10-7+3;", 6) + , (StatementEqual.test "return 42+23-30;", 35) + , (StatementEqual.test "return 42/2+2-5;", 18) + , (StatementEqual.test "return (3+5)/2;", 4) + , (StatementEqual.test "return (4-2)*8+20/4;",21) + , (StatementEqual.test "return -(-3*+5);", 15) + , (StatementEqual.test "return -25+30;", 5) + , (StatementEqual.test "return 42 == 42;", 1) + , (StatementEqual.test "return 42 != 53;", 1) + , (StatementEqual.test "return 42 < 53;", 1) + , (StatementEqual.test "return 53 > 42;", 1) + , (StatementEqual.test "return 42 <= 42;", 1) + , (StatementEqual.test "return 32 <= 42;", 1) + , (StatementEqual.test "return 42 >= 42;", 1) + , (StatementEqual.test "return 53 >= 42;", 1) + , (StatementEqual.test "return (1 + 1) == 2;", 1) + , (StatementEqual.test "return (2 * 3) != 2;", 1) + , (StatementEqual.test "return 1 || 0;", 1) + , (StatementEqual.test "return (1 + 1) || 0 || 0;", 1) + , (StatementEqual.test "return 0 || 0;", 0) + , (StatementEqual.test "return 0 || (1 - 1);", 0) + , (StatementEqual.test "return 2 || 1;", 1) + , (StatementEqual.test "return 1 && 2;", 1) + , (StatementEqual.test "return 2 && 3 && 4 && 0;", 0) + , (StatementEqual.test "a = 1; return a;", 1) + , (StatementEqual.test "a = 42; b = 20; return a + b;", 62) + , (StatementEqual.test "a = 42; b = 20; c = 32; return (a - c) * b / 10;", 20) + , (StatementEqual.test "a = 42; b = 20; return a - b;", 22) + , (StatementEqual.test "a = 3; b = 5 * 6 - 8; return a + b / 2;", 14) ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ From 01ed216a15b9d540dd615c37943b405cfc6f16a5 Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 13 Dec 2020 04:46:23 +0900 Subject: [PATCH 05/51] Module movement --- src/Htcc/Parser/Combinators/BasicOperator.hs | 33 +++++++++++++++++--- src/Htcc/Parser/Combinators/Program.hs | 21 ------------- 2 files changed, 29 insertions(+), 25 deletions(-) diff --git a/src/Htcc/Parser/Combinators/BasicOperator.hs b/src/Htcc/Parser/Combinators/BasicOperator.hs index e7f22e5..132531f 100644 --- a/src/Htcc/Parser/Combinators/BasicOperator.hs +++ b/src/Htcc/Parser/Combinators/BasicOperator.hs @@ -11,16 +11,22 @@ C language parser Combinators -} module Htcc.Parser.Combinators.BasicOperator ( binaryOperator + , binOpBool + , binOpCon + , binOpIntOnly ) where -import Control.Applicative ((<|>)) +import Control.Applicative (Alternative (..)) import Control.Monad.Combinators (choice) import Control.Monad.Fix (fix) -import Htcc.Parser.AST.Core (ATree (..)) +import Data.Bits (Bits (..)) +import Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATKind (..), ATree (..)) import Htcc.Parser.Combinators.Core -import qualified Text.Megaparsec as M +import Htcc.Utils (lor) +import qualified Text.Megaparsec as M --- | A parser combinator that builds a parser for basic binary operators. +-- | A parser combinator that builds a parser for basic binary operators. -- This is useful for syntax such as: -- \\[X::=X'\left("\text{op}_1"\ X'\ \mid\ "\text{op}_2"\ X'\ \mid\cdots\right)\ast\\] binaryOperator :: @@ -32,3 +38,22 @@ binaryOperator p opndMs = do ($ m) . fix $ \f nd -> choice [M.try (opM >> p) >>= ndM nd >>= f | (opM, ndM) <- opndMs] <|> return nd + +binOpBool, binOpCon :: (Monad m, Ord i, Bits i, Show i) + => ATKind i + -> ATree i + -> ATree i + -> m (ATree i) +binOpBool k lhs rhs = return $ ATNode k (CT.SCAuto CT.CTBool) lhs rhs +binOpCon k lhs rhs = return $ ATNode k (CT.conversion (atype lhs) (atype rhs)) lhs rhs + +binOpIntOnly :: (Monad m, Alternative m, Ord i, Bits i, Show i) + => ATKind i + -> ATree i + -> ATree i + -> m (ATree i) +binOpIntOnly k lhs rhs + | lor [CT.isIntegral, (CT.CTBool==) . CT.toTypeKind] (atype lhs) && + lor [CT.isIntegral, (CT.CTBool ==) . CT.toTypeKind] (atype rhs) = + return $ ATNode k (CT.SCAuto $ CT.CTLong CT.CTInt) lhs rhs + | otherwise = empty diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index edfe3e7..f9456fc 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -14,7 +14,6 @@ module Htcc.Parser.Combinators.Program ( parser ) where -import Control.Applicative hiding (many, some) import Control.Monad.Combinators (choice, some) import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.State (get, put) @@ -34,28 +33,8 @@ import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) import qualified Htcc.Parser.ConstructionData.Scope.Var as PV import Htcc.Parser.Development (defMainFn) import qualified Htcc.Tokenizer.Token as HT -import Htcc.Utils (lor) import qualified Text.Megaparsec as M -binOpBool, binOpCon :: (Monad m, Ord i, Bits i, Show i) - => ATKind i - -> ATree i - -> ATree i - -> m (ATree i) -binOpBool k lhs rhs = return $ ATNode k (CT.SCAuto CT.CTBool) lhs rhs -binOpCon k lhs rhs = return $ ATNode k (CT.conversion (atype lhs) (atype rhs)) lhs rhs - -binOpIntOnly :: (Monad m, Alternative m, Ord i, Bits i, Show i) - => ATKind i - -> ATree i - -> ATree i - -> m (ATree i) -binOpIntOnly k lhs rhs - | lor [CT.isIntegral, (CT.CTBool==) . CT.toTypeKind] (atype lhs) && - lor [CT.isIntegral, (CT.CTBool ==) . CT.toTypeKind] (atype rhs) = - return $ ATNode k (CT.SCAuto $ CT.CTLong CT.CTInt) lhs rhs - | otherwise = empty - parser :: (Integral i, Ord i, Bits i, Show i) => Parser i (ASTs i) parser = (:[]) . defMainFn . atBlock <$> (spaceConsumer >> program) <* M.eof From eefd2b3380cad257ef0a5e2c3f4d79355bebe5d8 Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 13 Dec 2020 18:09:31 +0900 Subject: [PATCH 06/51] add if statement --- src/Htcc/Parser/Combinators/BasicOperator.hs | 3 +- src/Htcc/Parser/Combinators/Core.hs | 20 +++-- src/Htcc/Parser/Combinators/Keywords.hs | 93 +++++++++++--------- src/Htcc/Parser/Combinators/Program.hs | 54 +++++++----- test/Tests/SubProcTests.hs | 15 +++- 5 files changed, 108 insertions(+), 77 deletions(-) diff --git a/src/Htcc/Parser/Combinators/BasicOperator.hs b/src/Htcc/Parser/Combinators/BasicOperator.hs index 132531f..18e4a71 100644 --- a/src/Htcc/Parser/Combinators/BasicOperator.hs +++ b/src/Htcc/Parser/Combinators/BasicOperator.hs @@ -36,8 +36,7 @@ binaryOperator :: binaryOperator p opndMs = do m <- p ($ m) . fix $ \f nd -> - choice [M.try (opM >> p) >>= ndM nd >>= f | (opM, ndM) <- opndMs] - <|> return nd + M.option nd $ choice [M.try (opM >> p) >>= ndM nd >>= f | (opM, ndM) <- opndMs] binOpBool, binOpCon :: (Monad m, Ord i, Bits i, Show i) => ATKind i diff --git a/src/Htcc/Parser/Combinators/Core.hs b/src/Htcc/Parser/Combinators/Core.hs index f2593b1..c82a03a 100644 --- a/src/Htcc/Parser/Combinators/Core.hs +++ b/src/Htcc/Parser/Combinators/Core.hs @@ -14,7 +14,7 @@ module Htcc.Parser.Combinators.Core ( runParser , Parser , spaceConsumer - , lexme + , lexeme , symbol , charLiteral , stringLiteral @@ -33,6 +33,7 @@ module Htcc.Parser.Combinators.Core ( , colon , commaSep , commaSep1 + , notFollowedBy ) where import Control.Applicative (Alternative (..)) @@ -58,10 +59,10 @@ type ConstructionDataState i = StateT (ConstructionData i) Identity type Parser i = M.ParsecT Void T.Text (ConstructionDataState i) runParser :: - Parser i (ASTs i) -> - FilePath -> - T.Text -> - Either (M.ParseErrorBundle T.Text Void) (Warnings i, ASTs i, PSV.GlobalVars i, PSV.Literals i) + Parser i (ASTs i) + -> FilePath + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (Warnings i, ASTs i, PSV.GlobalVars i, PSV.Literals i) runParser p fp input = (warns (snd result),, PSV.globals $ PS.vars $ scope $ snd result, PSV.literals $ PS.vars $ scope $ snd result) <$> fst result @@ -71,8 +72,8 @@ runParser p fp input = spaceConsumer :: Ord e => M.ParsecT e T.Text m () spaceConsumer = ML.space MC.space1 (ML.skipLineComment "//") (ML.skipBlockComment "/*" "*/") -lexme :: Ord e => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m a -lexme = ML.lexeme spaceConsumer +lexeme :: Ord e => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m a +lexeme = ML.lexeme spaceConsumer symbol :: Ord e => T.Text -> M.ParsecT e T.Text m T.Text symbol = ML.symbol spaceConsumer @@ -87,7 +88,7 @@ hexadecimal, octal, decimal, natural, integer :: (Ord e, Num i) => M.ParsecT e T hexadecimal = MC.char '0' >> MC.char' 'x' >> ML.hexadecimal octal = MC.char '0' >> ML.octal decimal = ML.decimal -natural = M.try (lexme hexadecimal) <|> M.try (lexme octal) <|> lexme decimal +natural = M.try (lexeme hexadecimal) <|> M.try (lexeme octal) <|> lexeme decimal integer = ML.signed spaceConsumer natural <|> natural parens, braces, angles, brackets :: Ord e => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m a @@ -110,3 +111,6 @@ colon = symbol "." commaSep, commaSep1 :: Ord e => M.ParsecT e T.Text m T.Text -> M.ParsecT e T.Text m [T.Text] commaSep = flip M.sepBy comma commaSep1 = flip M.sepBy1 comma + +notFollowedBy :: Ord e => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m b -> M.ParsecT e T.Text m a +notFollowedBy k p = lexeme (k <* M.notFollowedBy p) diff --git a/src/Htcc/Parser/Combinators/Keywords.hs b/src/Htcc/Parser/Combinators/Keywords.hs index a2b0526..fc58415 100644 --- a/src/Htcc/Parser/Combinators/Keywords.hs +++ b/src/Htcc/Parser/Combinators/Keywords.hs @@ -22,8 +22,13 @@ module Htcc.Parser.Combinators.Keywords ( ) where import qualified Data.Text as T +import qualified Htcc.CRules as CR import Htcc.Parser.Combinators.Core -import qualified Text.Megaparsec as M +import qualified Text.Megaparsec as M +import qualified Text.Megaparsec.Char as MC + +pKeyword :: Ord e => T.Text -> M.ParsecT e T.Text m T.Text +pKeyword = flip notFollowedBy (M.takeWhile1P (Just "valid identifier") CR.isValidChar) . MC.string kAuto, kBreak, kCase, kChar, kConst, kContinue, kDefault, kDo, kDouble, kElse, kEnum, kExtern, @@ -33,50 +38,50 @@ kAuto, kBreak, kCase, kChar, kConst, kContinue, kUnsigned, kVoid, kVolatile, kWhile, k_Alignas, k_Alignof, k_Atomic, k_Bool, k_Complex, k_Generic, k_Imaginary, k_Noreturn, k_Static_assert, k_Thread_local :: Ord e => M.ParsecT e T.Text m T.Text -kAuto = symbol "auto" -kBreak = symbol "break" -kCase = symbol "case" -kChar = symbol "char" -kConst = symbol "const" -kContinue = symbol "continue" -kDefault = symbol "default" -kDo = symbol "do" -kDouble = symbol "double" -kElse = symbol "else" -kEnum = symbol "enum" -kExtern = symbol "extern" -kFloat = symbol "float" -kFor = symbol "for" -kGoto = symbol "goto" -kIf = symbol "if" -kInline = symbol "inline" -kInt = symbol "int" -kLong = symbol "long" -kRegister = symbol "register" +kAuto = pKeyword "auto" +kBreak = pKeyword "break" +kCase = pKeyword "case" +kChar = pKeyword "char" +kConst = pKeyword "const" +kContinue = pKeyword "continue" +kDefault = pKeyword "default" +kDo = pKeyword "do" +kDouble = pKeyword "double" +kElse = pKeyword "else" +kEnum = pKeyword "enum" +kExtern = pKeyword "extern" +kFloat = pKeyword "float" +kFor = pKeyword "for" +kGoto = pKeyword "goto" +kIf = pKeyword "if" +kInline = pKeyword "inline" +kInt = pKeyword "int" +kLong = pKeyword "long" +kRegister = pKeyword "register" kRestrict = "restrict" -kReturn = symbol "return" -kShort = symbol "short" -kSigned = symbol "signed" -kSizeof = symbol "sizeof" -kStatic = symbol "static" -kStruct = symbol "struct" -kSwitch = symbol "switch" -kTypedef = symbol "typedef" -kUnion = symbol "union" -kUnsigned = symbol "unsigned" -kVoid = symbol "void" -kVolatile = symbol "volatile" -kWhile = symbol "while" -k_Alignas = symbol "_Alignas" -k_Alignof = symbol "_Alignof" -k_Atomic = symbol "_Atomic" -k_Bool = symbol "_Bool" -k_Complex = symbol "_Complex" -k_Generic = symbol "_Generic" -k_Imaginary = symbol "_Imaginary" -k_Noreturn = symbol "_Noreturn" -k_Static_assert = symbol "_Static_assert" -k_Thread_local = symbol "_Thread_local" +kReturn = pKeyword "return" +kShort = pKeyword "short" +kSigned = pKeyword "signed" +kSizeof = pKeyword "sizeof" +kStatic = pKeyword "static" +kStruct = pKeyword "struct" +kSwitch = pKeyword "switch" +kTypedef = pKeyword "typedef" +kUnion = pKeyword "union" +kUnsigned = pKeyword "unsigned" +kVoid = pKeyword "void" +kVolatile = pKeyword "volatile" +kWhile = pKeyword "while" +k_Alignas = pKeyword "_Alignas" +k_Alignof = pKeyword "_Alignof" +k_Atomic = pKeyword "_Atomic" +k_Bool = pKeyword "_Bool" +k_Complex = pKeyword "_Complex" +k_Generic = pKeyword "_Generic" +k_Imaginary = pKeyword "_Imaginary" +k_Noreturn = pKeyword "_Noreturn" +k_Static_assert = pKeyword "_Static_assert" +k_Thread_local = pKeyword "_Thread_local" kBasicTypes :: Ord e => [M.ParsecT e T.Text m T.Text] kBasicTypes = [ diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index f9456fc..46a7d87 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -9,7 +9,7 @@ Portability : POSIX C language lexer -} -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings #-} module Htcc.Parser.Combinators.Program ( parser ) where @@ -18,12 +18,13 @@ import Control.Monad.Combinators (choice, some) import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.State (get, put) import Data.Bits (Bits (..)) +import Data.Functor ((<&>)) import Htcc.CRules.Types as CT import Htcc.Parser.AST (Treealizable (..)) import Htcc.Parser.AST.Core (ATKind (..), ATree (..), atBlock, - atGVar, atNumLit, - atReturn) + atElse, atGVar, atIf, + atNumLit, atReturn) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core @@ -35,10 +36,8 @@ import Htcc.Parser.Development (defMainFn) import qualified Htcc.Tokenizer.Token as HT import qualified Text.Megaparsec as M -parser :: (Integral i, Ord i, Bits i, Show i) => Parser i (ASTs i) +parser, program :: (Integral i, Ord i, Bits i, Show i) => Parser i (ASTs i) parser = (:[]) . defMainFn . atBlock <$> (spaceConsumer >> program) <* M.eof - -program :: (Integral i, Ord i, Bits i, Show i) => Parser i (ASTs i) program = some stmt stmt, @@ -54,13 +53,24 @@ stmt, add, term, unary, - factor, - identifier' :: (Ord i, Bits i, Show i, Integral i) => Parser i (ATree i) + factor :: (Ord i, Bits i, Show i, Integral i) => Parser i (ATree i) stmt = choice - [ (atReturn (CT.SCUndef CT.CTUndef) <$> (kReturn >> expr)) <* semi + [ returnStmt + , ifStmt , expr <* semi + , ATEmpty <$ semi ] + where + returnStmt = choice + [ atReturn (CT.SCUndef CT.CTUndef) <$> (M.try kReturn >> expr) <* semi + --, atReturn (CT.SCUndef CT.CTUndef) ATEmpty <$ (kReturn >> semi) + ] + ifStmt = do + r <- atIf <$> (M.try kIf >> parens expr) <*> stmt + M.option ATEmpty (M.try kElse >> stmt) <&> \case + ATEmpty -> r + nd -> atElse r nd expr = assign @@ -68,7 +78,7 @@ assign = do nd <- logicalOr choice [ symbol "=" >> (ATNode ATAssign (atype nd) nd <$> assign) - , return nd + , pure nd ] logicalOr = binaryOperator logicalAnd [(symbol "||", binOpBool ATLOr)] @@ -111,15 +121,15 @@ factor = choice , parens expr , ATEmpty <$ M.eof ] - -identifier' = do - ident <- identifier - lift $ do - scp <- get - case lookupVar ident scp of - FoundGVar (PV.GVar t _) -> return $ atGVar t ident - FoundLVar sct -> return $ treealize sct - FoundEnum sct -> return $ treealize sct - NotFound -> let Right (lat, scp') = addLVar (CT.SCAuto CT.CTInt) (HT.TokenLCNums 1 1, HT.TKIdent ident) scp in do - put scp' - return lat + where + identifier' = do + ident <- identifier + lift $ do + scp <- get + case lookupVar ident scp of + FoundGVar (PV.GVar t _) -> return $ atGVar t ident + FoundLVar sct -> return $ treealize sct + FoundEnum sct -> return $ treealize sct + NotFound -> let Right (lat, scp') = addLVar (CT.SCAuto CT.CTInt) (HT.TokenLCNums 1 1, HT.TKIdent ident) scp in do + put scp' + return lat diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 4799f3e..a56d127 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -45,7 +45,20 @@ exec = runTestsEx , (StatementEqual.test "a = 42; b = 20; return a + b;", 62) , (StatementEqual.test "a = 42; b = 20; c = 32; return (a - c) * b / 10;", 20) , (StatementEqual.test "a = 42; b = 20; return a - b;", 22) - , (StatementEqual.test "a = 3; b = 5 * 6 - 8; return a + b / 2;", 14) + , (StatementEqual.test "a = 3; returnb = 5 * 6 - 8; return a + returnb / 2;", 14) + , (StatementEqual.test "a = 3; return_ = 5 * 6 - 8; return a + return_ / 2;", 14) + , (StatementEqual.test "a /* comment */ = 3; b = 5 */*comment*/ 6 - 8; return a + b / 2;", 14) + , (StatementEqual.test "if (1) return 42; return 53;", 42) + , (StatementEqual.test "if (20*3-60) return 42; return 53;", 53) + , (StatementEqual.test "a = 1; b = 2; if (a) return b; return 42;", 2) + , (StatementEqual.test "if (1) return 42; else return 53;", 42) + , (StatementEqual.test "if (0) return 42; else return 53;", 53) + , (StatementEqual.test "a = 0; b = 2; if (a) return b; else return b * 2;", 4) + , (StatementEqual.test "a = 1; b = 0; if (b) return 42; if (0) return 42; else return a;", 1) + , (StatementEqual.test "a = 1; b = 2; if (a) if (b) return b; else return 53; else return 24;", 2) + , (StatementEqual.test "if (1) if (1) if (1) if (1) if (1) if (0) return 1; else return 2; else return 3; else return 4; else return 5; else return 6; else return 7;", 2) + , (StatementEqual.test "if(1)if(1)return 42;return 53;", 42) + , (StatementEqual.test "if(0); return 0;", 0) ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ From 0d8526e2aac85db2050fe1a9d3da1a0b72c5e478 Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 13 Dec 2020 18:25:34 +0900 Subject: [PATCH 07/51] add while statement --- src/Htcc/Parser/Combinators/Program.hs | 4 +++- test/Tests/SubProcTests.hs | 3 +++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 46a7d87..4d550cb 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -24,7 +24,7 @@ import Htcc.Parser.AST (Treealizable (..)) import Htcc.Parser.AST.Core (ATKind (..), ATree (..), atBlock, atElse, atGVar, atIf, - atNumLit, atReturn) + atNumLit, atReturn, atWhile) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core @@ -58,6 +58,7 @@ stmt, stmt = choice [ returnStmt , ifStmt + , whileStmt , expr <* semi , ATEmpty <$ semi ] @@ -71,6 +72,7 @@ stmt = choice M.option ATEmpty (M.try kElse >> stmt) <&> \case ATEmpty -> r nd -> atElse r nd + whileStmt = atWhile <$> (M.try kWhile >> parens expr) <*> stmt expr = assign diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index a56d127..7e30acc 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -59,6 +59,9 @@ exec = runTestsEx , (StatementEqual.test "if (1) if (1) if (1) if (1) if (1) if (0) return 1; else return 2; else return 3; else return 4; else return 5; else return 6; else return 7;", 2) , (StatementEqual.test "if(1)if(1)return 42;return 53;", 42) , (StatementEqual.test "if(0); return 0;", 0) + , (StatementEqual.test "a = 1; while (a < 10) a = a + 1; return a;", 10) + , (StatementEqual.test "a = 1; while (a < 10) a = a + 1; b = 1; while (b < 20) b = b + 2; return a + b;", 31) + , (StatementEqual.test "a = 0; while (a); return 0;", 0) ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ From bfde4692129731ea642b79a22f6332d259df74b5 Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 13 Dec 2020 19:42:00 +0900 Subject: [PATCH 08/51] add for statement --- src/Htcc/Parser/Combinators/Program.hs | 20 ++++++++++++++++++-- test/Tests/SubProcTests.hs | 9 +++++++++ 2 files changed, 27 insertions(+), 2 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 4d550cb..0e6aef6 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -14,6 +14,7 @@ module Htcc.Parser.Combinators.Program ( parser ) where +import Control.Monad ((>=>)) import Control.Monad.Combinators (choice, some) import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.State (get, put) @@ -22,9 +23,12 @@ import Data.Functor ((<&>)) import Htcc.CRules.Types as CT import Htcc.Parser.AST (Treealizable (..)) import Htcc.Parser.AST.Core (ATKind (..), + ATKindFor (..), ATree (..), atBlock, - atElse, atGVar, atIf, - atNumLit, atReturn, atWhile) + atElse, atExprStmt, + atFor, atGVar, atIf, + atNumLit, atReturn, + atWhile) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core @@ -59,6 +63,7 @@ stmt = choice [ returnStmt , ifStmt , whileStmt + , forStmt , expr <* semi , ATEmpty <$ semi ] @@ -73,6 +78,16 @@ stmt = choice ATEmpty -> r nd -> atElse r nd whileStmt = atWhile <$> (M.try kWhile >> parens expr) <*> stmt + forStmt = do + es <- (>>) (M.try kFor) $ parens $ do + initSect <- ATForInit . atExprStmt + <$> choice [ATEmpty <$ semi, expr <* semi] + condSect <- ATForCond + <$> choice [atNumLit 1 <$ semi, expr <* semi] + incrSect <- ATForIncr . atExprStmt + <$> M.option ATEmpty expr + pure [initSect, condSect, incrSect] + atFor . (es <>) . (:[]) . ATForStmt <$> stmt expr = assign @@ -109,6 +124,7 @@ add = binaryOperator term term = binaryOperator unary [ (symbol "*", binOpCon ATMul) , (symbol "/", binOpCon ATDiv) + , (symbol "%", binOpCon ATMod) ] unary = choice diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 7e30acc..24667f2 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -62,6 +62,15 @@ exec = runTestsEx , (StatementEqual.test "a = 1; while (a < 10) a = a + 1; return a;", 10) , (StatementEqual.test "a = 1; while (a < 10) a = a + 1; b = 1; while (b < 20) b = b + 2; return a + b;", 31) , (StatementEqual.test "a = 0; while (a); return 0;", 0) + , (StatementEqual.test "a = 0; i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; return a;", 110) + , (StatementEqual.test "i = 0; for (; i <= 10;) i = i + 2; return i; ", 12) + , (StatementEqual.test "i = 0; for (; i <= 10; i = i + 2); return i;", 12) + , (StatementEqual.test "a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; return a;", 0) + , (StatementEqual.test "a = 1; b = 1; return a & b;", 1) + , (StatementEqual.test "a = 42; b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) return 1; return 0;", 1) + , (StatementEqual.test "return 1 | 0;", 1) + , (StatementEqual.test "a = 1; b = 0; return a & b ^ a | b;", 1) -- Xor swap + , (StatementEqual.test "a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; return a;", 20) ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ From 0bbd3fb628374629612a78f53041bf3d417db878 Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 13 Dec 2020 19:50:00 +0900 Subject: [PATCH 09/51] add compound statement --- src/Htcc/Parser/Combinators/Core.hs | 6 ------ src/Htcc/Parser/Combinators/Program.hs | 3 ++- test/Tests/SubProcTests.hs | 5 +++++ 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Core.hs b/src/Htcc/Parser/Combinators/Core.hs index c82a03a..a639055 100644 --- a/src/Htcc/Parser/Combinators/Core.hs +++ b/src/Htcc/Parser/Combinators/Core.hs @@ -31,8 +31,6 @@ module Htcc.Parser.Combinators.Core ( , semi , comma , colon - , commaSep - , commaSep1 , notFollowedBy ) where @@ -108,9 +106,5 @@ semi = symbol ";" comma = symbol "," colon = symbol "." -commaSep, commaSep1 :: Ord e => M.ParsecT e T.Text m T.Text -> M.ParsecT e T.Text m [T.Text] -commaSep = flip M.sepBy comma -commaSep1 = flip M.sepBy1 comma - notFollowedBy :: Ord e => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m b -> M.ParsecT e T.Text m a notFollowedBy k p = lexeme (k <* M.notFollowedBy p) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 0e6aef6..b82f3ea 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -14,7 +14,6 @@ module Htcc.Parser.Combinators.Program ( parser ) where -import Control.Monad ((>=>)) import Control.Monad.Combinators (choice, some) import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.State (get, put) @@ -64,6 +63,7 @@ stmt = choice , ifStmt , whileStmt , forStmt + , compoundStmt , expr <* semi , ATEmpty <$ semi ] @@ -88,6 +88,7 @@ stmt = choice <$> M.option ATEmpty expr pure [initSect, condSect, incrSect] atFor . (es <>) . (:[]) . ATForStmt <$> stmt + compoundStmt = atBlock <$> braces (M.many stmt) expr = assign diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 24667f2..d6d8128 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -71,6 +71,11 @@ exec = runTestsEx , (StatementEqual.test "return 1 | 0;", 1) , (StatementEqual.test "a = 1; b = 0; return a & b ^ a | b;", 1) -- Xor swap , (StatementEqual.test "a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; return a;", 20) + , (StatementEqual.test "a = 0; i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } return a;", 0) + , (StatementEqual.test "a = 10; if (a) { a = a * a; a = a / 10; } return a;", 10) + , (StatementEqual.test "a = 0; while (1) { if (a < 10) a = a + 1; else return a; }", 10) + , (StatementEqual.test "a = 0; for (;;) { a = 42; return a; } return a;", 42) + , (StatementEqual.test "a = 0; for (;;) { if (a < 10) a = a + 1; else return a; }", 10) ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ From df429191eb00ea6bd77404a689787d57dc1625e2 Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 13 Dec 2020 21:34:07 +0900 Subject: [PATCH 10/51] add function call --- src/Htcc/Parser/Combinators/Program.hs | 36 +++++++++++++++++++++----- test/Tests/SubProcTests.hs | 3 +++ test/Tests/csrc/test_func5.c | 8 ++++++ 3 files changed, 41 insertions(+), 6 deletions(-) create mode 100644 test/Tests/csrc/test_func5.c diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index b82f3ea..3f719f2 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -27,17 +27,20 @@ import Htcc.Parser.AST.Core (ATKind (..), atElse, atExprStmt, atFor, atGVar, atIf, atNumLit, atReturn, - atWhile) + atWhile, atNoLeaf) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords -import Htcc.Parser.ConstructionData (addLVar, lookupVar) +import Htcc.Parser.ConstructionData (addLVar, lookupVar, lookupFunction) import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) import qualified Htcc.Parser.ConstructionData.Scope.Var as PV import Htcc.Parser.Development (defMainFn) import qualified Htcc.Tokenizer.Token as HT import qualified Text.Megaparsec as M +import qualified Htcc.Parser.ConstructionData.Scope.Function as PSF + +import Text.Megaparsec.Debug (dbg) parser, program :: (Integral i, Ord i, Bits i, Show i) => Parser i (ASTs i) parser = (:[]) . defMainFn . atBlock <$> (spaceConsumer >> program) <* M.eof @@ -56,7 +59,8 @@ stmt, add, term, unary, - factor :: (Ord i, Bits i, Show i, Integral i) => Parser i (ATree i) + factor, + identifier' :: (Ord i, Bits i, Show i, Integral i) => Parser i (ATree i) stmt = choice [ returnStmt @@ -72,12 +76,15 @@ stmt = choice [ atReturn (CT.SCUndef CT.CTUndef) <$> (M.try kReturn >> expr) <* semi --, atReturn (CT.SCUndef CT.CTUndef) ATEmpty <$ (kReturn >> semi) ] + ifStmt = do r <- atIf <$> (M.try kIf >> parens expr) <*> stmt M.option ATEmpty (M.try kElse >> stmt) <&> \case ATEmpty -> r nd -> atElse r nd + whileStmt = atWhile <$> (M.try kWhile >> parens expr) <*> stmt + forStmt = do es <- (>>) (M.try kFor) $ parens $ do initSect <- ATForInit . atExprStmt @@ -88,6 +95,7 @@ stmt = choice <$> M.option ATEmpty expr pure [initSect, condSect, incrSect] atFor . (es <>) . (:[]) . ATForStmt <$> stmt + compoundStmt = atBlock <$> braces (M.many stmt) expr = assign @@ -140,10 +148,15 @@ factor = choice , parens expr , ATEmpty <$ M.eof ] + +identifier' = do + ident <- identifier + choice + [ fnCall ident + , variable ident + ] where - identifier' = do - ident <- identifier - lift $ do + variable ident = lift $ do scp <- get case lookupVar ident scp of FoundGVar (PV.GVar t _) -> return $ atGVar t ident @@ -152,3 +165,14 @@ factor = choice NotFound -> let Right (lat, scp') = addLVar (CT.SCAuto CT.CTInt) (HT.TokenLCNums 1 1, HT.TKIdent ident) scp in do put scp' return lat + + fnCall ident = do + params <- symbol "(" >> M.manyTill (M.try (expr <* comma) M.<|> expr) (symbol ")") + let params' = if length params == 0 then Nothing else Just params + lift $ do + scp <- get + return $ case lookupFunction ident scp of + -- TODO: set warning message + -- TODO: Infer the return type of a function + Nothing -> atNoLeaf (ATCallFunc ident params') (CT.SCAuto CT.CTInt) + Just fn -> atNoLeaf (ATCallFunc ident params') (PSF.fntype fn) diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index d6d8128..3a74dd0 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -76,6 +76,9 @@ exec = runTestsEx , (StatementEqual.test "a = 0; while (1) { if (a < 10) a = a + 1; else return a; }", 10) , (StatementEqual.test "a = 0; for (;;) { a = 42; return a; } return a;", 42) , (StatementEqual.test "a = 0; for (;;) { if (a < 10) a = a + 1; else return a; }", 10) + , (LinkFuncRet.test "a = test_func1(); test_func1(); return a;" ["test_func1"], 0) + , (LinkFuncRet.test "return test_func2(40);" ["test_func2"], 0) + , (LinkFuncRet.test "return test_func5(1, 2);" ["test_func5"], 3) ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ diff --git a/test/Tests/csrc/test_func5.c b/test/Tests/csrc/test_func5.c new file mode 100644 index 0000000..99462bc --- /dev/null +++ b/test/Tests/csrc/test_func5.c @@ -0,0 +1,8 @@ +#include +#include +#include + +int test_func5(int l, int r) +{ + return l + r; +} From b89b27bb0e09b6f7d50ed89c0594ea4dedda327f Mon Sep 17 00:00:00 2001 From: roki Date: Mon, 14 Dec 2020 02:56:46 +0900 Subject: [PATCH 11/51] add function definition --- src/Htcc/Parser/Combinators/BasicOperator.hs | 12 +- src/Htcc/Parser/Combinators/Program.hs | 45 +++- test/Tests/SubProcTests.hs | 220 +++++++------------ 3 files changed, 131 insertions(+), 146 deletions(-) diff --git a/src/Htcc/Parser/Combinators/BasicOperator.hs b/src/Htcc/Parser/Combinators/BasicOperator.hs index 18e4a71..87970f1 100644 --- a/src/Htcc/Parser/Combinators/BasicOperator.hs +++ b/src/Htcc/Parser/Combinators/BasicOperator.hs @@ -46,7 +46,7 @@ binOpBool, binOpCon :: (Monad m, Ord i, Bits i, Show i) binOpBool k lhs rhs = return $ ATNode k (CT.SCAuto CT.CTBool) lhs rhs binOpCon k lhs rhs = return $ ATNode k (CT.conversion (atype lhs) (atype rhs)) lhs rhs -binOpIntOnly :: (Monad m, Alternative m, Ord i, Bits i, Show i) +binOpIntOnly :: (Monad m, MonadFail m, Alternative m, Ord i, Bits i, Show i) => ATKind i -> ATree i -> ATree i @@ -55,4 +55,12 @@ binOpIntOnly k lhs rhs | lor [CT.isIntegral, (CT.CTBool==) . CT.toTypeKind] (atype lhs) && lor [CT.isIntegral, (CT.CTBool ==) . CT.toTypeKind] (atype rhs) = return $ ATNode k (CT.SCAuto $ CT.CTLong CT.CTInt) lhs rhs - | otherwise = empty + | otherwise = fail $ mconcat + [ "invalid operands of types '" + , show (atype lhs) + , "' and '" + , show (atype rhs) + , "' to binary '" + , show k + , "'" + ] diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 3f719f2..0e8d52a 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -14,9 +14,10 @@ module Htcc.Parser.Combinators.Program ( parser ) where +import Control.Monad (void, forM) import Control.Monad.Combinators (choice, some) import Control.Monad.Trans (MonadTrans (..)) -import Control.Monad.Trans.State (get, put) +import Control.Monad.Trans.State (get, gets, put, modify) import Data.Bits (Bits (..)) import Data.Functor ((<&>)) import Htcc.CRules.Types as CT @@ -27,26 +28,29 @@ import Htcc.Parser.AST.Core (ATKind (..), atElse, atExprStmt, atFor, atGVar, atIf, atNumLit, atReturn, - atWhile, atNoLeaf) + atWhile, atNoLeaf, atDefFunc) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords -import Htcc.Parser.ConstructionData (addLVar, lookupVar, lookupFunction) +import Htcc.Parser.ConstructionData (addLVar, lookupVar, lookupFunction, resetLocal, addFunction) import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) import qualified Htcc.Parser.ConstructionData.Scope.Var as PV import Htcc.Parser.Development (defMainFn) import qualified Htcc.Tokenizer.Token as HT import qualified Text.Megaparsec as M import qualified Htcc.Parser.ConstructionData.Scope.Function as PSF +import qualified Data.Text as T import Text.Megaparsec.Debug (dbg) parser, program :: (Integral i, Ord i, Bits i, Show i) => Parser i (ASTs i) -parser = (:[]) . defMainFn . atBlock <$> (spaceConsumer >> program) <* M.eof -program = some stmt +parser = (spaceConsumer >> program) <* M.eof +program = some global -stmt, +global, + function, + stmt, expr, assign, logicalOr, @@ -62,6 +66,35 @@ stmt, factor, identifier' :: (Ord i, Bits i, Show i, Integral i) => Parser i (ATree i) +global = choice + [ function + ] + +function = do + ident <- identifier + params <- symbol "(" >> M.manyTill (M.try (identifier <* comma) M.<|> identifier) (symbol ")") + lift $ modify resetLocal + choice + [ declaration ident + , definition ident params + ] + where + declaration ident = do + void semi + scp <- lift get + case addFunction False (CT.SCAuto CT.CTInt) (HT.TokenLCNums 1 1, HT.TKIdent ident) scp of + Right scp' -> ATEmpty <$ lift (put scp') + Left y -> fail $ T.unpack $ fst y + + definition ident params = do + void $ M.lookAhead (symbol "{") + params' <- forM params $ \p -> do + scp <- lift get + case addLVar (CT.SCAuto CT.CTInt) (HT.TokenLCNums 1 1, HT.TKIdent p) scp of + Right (lat, scp') -> lat <$ lift (put scp') + Left x -> fail $ T.unpack $ fst x + atDefFunc ident (if null params' then Nothing else Just params') (CT.SCAuto CT.CTInt) <$> stmt + stmt = choice [ returnStmt , ifStmt diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 3a74dd0..fe364f3 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -15,128 +15,80 @@ import qualified Htcc.CRules.Types as CT exec :: IO () exec = runTestsEx - [ (StatementEqual.test "return 1+2;", 3) - , (StatementEqual.test "return 1+2+4;", 7) - , (StatementEqual.test "return 10-7+3;", 6) - , (StatementEqual.test "return 42+23-30;", 35) - , (StatementEqual.test "return 42/2+2-5;", 18) - , (StatementEqual.test "return (3+5)/2;", 4) - , (StatementEqual.test "return (4-2)*8+20/4;",21) - , (StatementEqual.test "return -(-3*+5);", 15) - , (StatementEqual.test "return -25+30;", 5) - , (StatementEqual.test "return 42 == 42;", 1) - , (StatementEqual.test "return 42 != 53;", 1) - , (StatementEqual.test "return 42 < 53;", 1) - , (StatementEqual.test "return 53 > 42;", 1) - , (StatementEqual.test "return 42 <= 42;", 1) - , (StatementEqual.test "return 32 <= 42;", 1) - , (StatementEqual.test "return 42 >= 42;", 1) - , (StatementEqual.test "return 53 >= 42;", 1) - , (StatementEqual.test "return (1 + 1) == 2;", 1) - , (StatementEqual.test "return (2 * 3) != 2;", 1) - , (StatementEqual.test "return 1 || 0;", 1) - , (StatementEqual.test "return (1 + 1) || 0 || 0;", 1) - , (StatementEqual.test "return 0 || 0;", 0) - , (StatementEqual.test "return 0 || (1 - 1);", 0) - , (StatementEqual.test "return 2 || 1;", 1) - , (StatementEqual.test "return 1 && 2;", 1) - , (StatementEqual.test "return 2 && 3 && 4 && 0;", 0) - , (StatementEqual.test "a = 1; return a;", 1) - , (StatementEqual.test "a = 42; b = 20; return a + b;", 62) - , (StatementEqual.test "a = 42; b = 20; c = 32; return (a - c) * b / 10;", 20) - , (StatementEqual.test "a = 42; b = 20; return a - b;", 22) - , (StatementEqual.test "a = 3; returnb = 5 * 6 - 8; return a + returnb / 2;", 14) - , (StatementEqual.test "a = 3; return_ = 5 * 6 - 8; return a + return_ / 2;", 14) - , (StatementEqual.test "a /* comment */ = 3; b = 5 */*comment*/ 6 - 8; return a + b / 2;", 14) - , (StatementEqual.test "if (1) return 42; return 53;", 42) - , (StatementEqual.test "if (20*3-60) return 42; return 53;", 53) - , (StatementEqual.test "a = 1; b = 2; if (a) return b; return 42;", 2) - , (StatementEqual.test "if (1) return 42; else return 53;", 42) - , (StatementEqual.test "if (0) return 42; else return 53;", 53) - , (StatementEqual.test "a = 0; b = 2; if (a) return b; else return b * 2;", 4) - , (StatementEqual.test "a = 1; b = 0; if (b) return 42; if (0) return 42; else return a;", 1) - , (StatementEqual.test "a = 1; b = 2; if (a) if (b) return b; else return 53; else return 24;", 2) - , (StatementEqual.test "if (1) if (1) if (1) if (1) if (1) if (0) return 1; else return 2; else return 3; else return 4; else return 5; else return 6; else return 7;", 2) - , (StatementEqual.test "if(1)if(1)return 42;return 53;", 42) - , (StatementEqual.test "if(0); return 0;", 0) - , (StatementEqual.test "a = 1; while (a < 10) a = a + 1; return a;", 10) - , (StatementEqual.test "a = 1; while (a < 10) a = a + 1; b = 1; while (b < 20) b = b + 2; return a + b;", 31) - , (StatementEqual.test "a = 0; while (a); return 0;", 0) - , (StatementEqual.test "a = 0; i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; return a;", 110) - , (StatementEqual.test "i = 0; for (; i <= 10;) i = i + 2; return i; ", 12) - , (StatementEqual.test "i = 0; for (; i <= 10; i = i + 2); return i;", 12) - , (StatementEqual.test "a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; return a;", 0) - , (StatementEqual.test "a = 1; b = 1; return a & b;", 1) - , (StatementEqual.test "a = 42; b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) return 1; return 0;", 1) - , (StatementEqual.test "return 1 | 0;", 1) - , (StatementEqual.test "a = 1; b = 0; return a & b ^ a | b;", 1) -- Xor swap - , (StatementEqual.test "a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; return a;", 20) - , (StatementEqual.test "a = 0; i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } return a;", 0) - , (StatementEqual.test "a = 10; if (a) { a = a * a; a = a / 10; } return a;", 10) - , (StatementEqual.test "a = 0; while (1) { if (a < 10) a = a + 1; else return a; }", 10) - , (StatementEqual.test "a = 0; for (;;) { a = 42; return a; } return a;", 42) - , (StatementEqual.test "a = 0; for (;;) { if (a < 10) a = a + 1; else return a; }", 10) - , (LinkFuncRet.test "a = test_func1(); test_func1(); return a;" ["test_func1"], 0) - , (LinkFuncRet.test "return test_func2(40);" ["test_func2"], 0) - , (LinkFuncRet.test "return test_func5(1, 2);" ["test_func5"], 3) + [ (StatementEqual.test "main() { return 1+2; }", 3) + , (StatementEqual.test "main() { return 1+2+4; }", 7) + , (StatementEqual.test "main() { return 10-7+3; }", 6) + , (StatementEqual.test "main() { return 42+23-30; }", 35) + , (StatementEqual.test "main() { return 42/2+2-5; }", 18) + , (StatementEqual.test "main() { return (3+5)/2; }", 4) + , (StatementEqual.test "main() { return (4-2)*8+20/4; }",21) + , (StatementEqual.test "main() { return -(-3*+5); }", 15) + , (StatementEqual.test "main() { return -25+30; }", 5) + , (StatementEqual.test "main() { return 42 == 42; }", 1) + , (StatementEqual.test "main() { return 42 != 53; }", 1) + , (StatementEqual.test "main() { return 42 < 53; }", 1) + , (StatementEqual.test "main() { return 53 > 42; }", 1) + , (StatementEqual.test "main() { return 42 <= 42; }", 1) + , (StatementEqual.test "main() { return 32 <= 42; }", 1) + , (StatementEqual.test "main() { return 42 >= 42; }", 1) + , (StatementEqual.test "main() { return 53 >= 42; }", 1) + , (StatementEqual.test "main() { return (1 + 1) == 2; }", 1) + , (StatementEqual.test "main() { return (2 * 3) != 2; }", 1) + , (StatementEqual.test "main() { return 1 || 0; }", 1) + , (StatementEqual.test "main() { return (1 + 1) || 0 || 0; }", 1) + , (StatementEqual.test "main() { return 0 || 0; }", 0) + , (StatementEqual.test "main() { return 0 || (1 - 1); }", 0) + , (StatementEqual.test "main() { return 2 || 1; }", 1) + , (StatementEqual.test "main() { return 1 && 2; }", 1) + , (StatementEqual.test "main() { return 2 && 3 && 4 && 0; }", 0) + , (StatementEqual.test "main() { a = 1; return a; }", 1) + , (StatementEqual.test "main() { a = 42; b = 20; return a + b; }", 62) + , (StatementEqual.test "main() { a = 42; b = 20; c = 32; return (a - c) * b / 10; }", 20) + , (StatementEqual.test "main() { a = 42; b = 20; return a - b; }", 22) + , (StatementEqual.test "main() { a = 3; returnb = 5 * 6 - 8; return a + returnb / 2; }", 14) + , (StatementEqual.test "main() { a = 3; return_ = 5 * 6 - 8; return a + return_ / 2; }", 14) + , (StatementEqual.test "main() { a /* comment */ = 3; b = 5 */*comment*/ 6 - 8; return a + b / 2; }", 14) + , (StatementEqual.test "main() { if (1) return 42; return 53; }", 42) + , (StatementEqual.test "main() { if (20*3-60) return 42; return 53; }", 53) + , (StatementEqual.test "main() { a = 1; b = 2; if (a) return b; return 42; }", 2) + , (StatementEqual.test "main() { if (1) return 42; else return 53; }", 42) + , (StatementEqual.test "main() { if (0) return 42; else return 53; }", 53) + , (StatementEqual.test "main() { a = 0; b = 2; if (a) return b; else return b * 2; }", 4) + , (StatementEqual.test "main() { a = 1; b = 0; if (b) return 42; if (0) return 42; else return a; }", 1) + , (StatementEqual.test "main() { a = 1; b = 2; if (a) if (b) return b; else return 53; else return 24; }", 2) + , (StatementEqual.test "main() { if (1) if (1) if (1) if (1) if (1) if (0) return 1; else return 2; else return 3; else return 4; else return 5; else return 6; else return 7; }", 2) + , (StatementEqual.test "main() { if(1)if(1)return 42;return 53; }", 42) + , (StatementEqual.test "main() { if(0); return 0; }", 0) + , (StatementEqual.test "main() { a = 1; while (a < 10) a = a + 1; return a; }", 10) + , (StatementEqual.test "main() { a = 1; while (a < 10) a = a + 1; b = 1; while (b < 20) b = b + 2; return a + b; }", 31) + , (StatementEqual.test "main() { a = 0; while (a); return 0; }", 0) + , (StatementEqual.test "main() { a = 0; i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; return a; }", 110) + , (StatementEqual.test "main() { i = 0; for (; i <= 10;) i = i + 2; return i; }", 12) + , (StatementEqual.test "main() { i = 0; for (; i <= 10; i = i + 2); return i; }", 12) + , (StatementEqual.test "main() { a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; return a; }", 0) + , (StatementEqual.test "main() { a = 1; b = 1; return a & b; }", 1) + , (StatementEqual.test "main() { a = 42; b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) return 1; return 0; }", 1) + , (StatementEqual.test "main() { return 1 | 0; }", 1) + , (StatementEqual.test "main() { a = 1; b = 0; return a & b ^ a | b; }", 1) -- Xor swap + , (StatementEqual.test "main() { a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; return a; }", 20) + , (StatementEqual.test "main() { a = 0; i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } return a; }", 0) + , (StatementEqual.test "main() { a = 10; if (a) { a = a * a; a = a / 10; } return a; }", 10) + , (StatementEqual.test "main() { a = 0; while (1) { if (a < 10) a = a + 1; else return a; } }", 10) + , (StatementEqual.test "main() { a = 0; for (;;) { a = 42; return a; } return a; }", 42) + , (StatementEqual.test "main() { a = 0; for (;;) { if (a < 10) a = a + 1; else return a; } }", 10) + , (LinkFuncRet.test "main() { a = test_func1(); test_func1(); return a; }" ["test_func1"], 0) + , (LinkFuncRet.test "main() { return test_func2(40); }" ["test_func2"], 0) + , (LinkFuncRet.test "main() { return test_func5(1, 2); }" ["test_func5"], 3) + , (StatementEqual.test "f() { return 42; } main() { return f(); }", 42) + , (StatementEqual.test "g() { return 42; } f() { return g(); } main() { return f(); }", 42) + , (StatementEqual.test "id(a) { return a; } main() { a = 1; return id(a-1) + id(1); }", 1) + , (StatementEqual.test "get1() { return 1; } get2() { return 2; } main() { a = get1(); return a + get2(); }", 3) + , (StatementEqual.test "add(a, b) { return a + b; } main() { return add(1, 2); }", 3) + , (StatementEqual.test "rec(a) { if (a == 0) return 42; return rec(a - 1); } main() { b = rec(2); return 1 + 2; }", 3) + , (StatementEqual.test "fib(n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } main() { return fib(5); }", 8) -- fibonacci number ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ - (StatementEqual.test "int main() { return 42; }", 42), - (StatementEqual.test "int main() { return 1+2; }", 3), - (StatementEqual.test "int main() { return 1+2+4; }", 7), - (StatementEqual.test "int main() { return 10-7+3; }", 6), - (StatementEqual.test "int main() { return 42+23-30; }", 35), - (StatementEqual.test "int main() { return 42/2+2-5; }", 18), - (StatementEqual.test "int main() { return (3+5)/2; }", 4), - (StatementEqual.test "int main() { return (4-2)*8+20/4; }",21), - (StatementEqual.test "int main() { return -(-3*+5); }", 15), - (StatementEqual.test "int main() { return -25+30; }", 5), - (StatementEqual.test "int main() { return 42 == 42; }", 1), - (StatementEqual.test "int main() { return 42 != 53; }", 1), - (StatementEqual.test "int main() { return 42 < 53; }", 1), - (StatementEqual.test "int main() { return 53 > 42; }", 1), - (StatementEqual.test "int main() { return 42 <= 42; }", 1), - (StatementEqual.test "int main() { return 32 <= 42; }", 1), - (StatementEqual.test "int main() { return 42 >= 42; }", 1), - (StatementEqual.test "int main() { return 53 >= 42; }", 1), - (StatementEqual.test "int main() { return (1 + 1) == 2; }", 1), - (StatementEqual.test "int main() { return (2 * 3) != 2; }", 1), - (StatementEqual.test "int main() { int a=42; int b=20; return a+b; }", 62), - (StatementEqual.test "int main() { int a=42; int b=20; int c=32; return (a - c) * b / 10; }", 20), - (StatementEqual.test "int main() { int hoge=42; int foo=20; return hoge - foo; }", 22), - (StatementEqual.test "int main() { int returnx = 42; return returnx; return 53; }", 42), - (StatementEqual.test "int main() { int a = 3; int b = 5 * 6 - 8; return a + b / 2; }", 14), - (StatementEqual.test "int main() { if (1) return 42; return 53; }", 42), - (StatementEqual.test "int main() { if (20*3-60) return 42; return 53; }", 53), - (StatementEqual.test "int main() { int a = 1; int b = 2; if (a) return b; return 42; }", 2), - (StatementEqual.test "int main() { if (1) return 42; else return 53; }", 42), - (StatementEqual.test "int main() { if (0) return 42; else return 53; }", 53), - (StatementEqual.test "int main() { int a = 0; int b = 2; if (a) return b; else return b * 2; }", 4), - (StatementEqual.test "int main() { int a = 1; int b = 0; if (b) return 42; if (0) return 42; else return a; }", 1), - (StatementEqual.test "int main() { int a = 1; int b = 2; if (a) if (b) return b; else return 53; else return 24; }", 2), - (StatementEqual.test "int main() { if (1) if (1) if (1) if (1) if (1) if (0) return 1; else return 2; else return 3; else return 4; else return 5; else return 6; else return 7; }", 2), - (StatementEqual.test "int main() { if(1)if(1)return 42;return 53; }", 42), - (StatementEqual.test "int main() { if(0); return 0; }", 0), - (StatementEqual.test "int main() { int a = 1; while (a < 10) a = a + 1; return a; }", 10), - (StatementEqual.test "int main() { int a = 1; while (a < 10) a = a + 1; int b = 1; while (b < 20) b = b + 2; return a + b; }", 31), - (StatementEqual.test "int main() { int a = 0; while (a); return 0; }", 0), - (StatementEqual.test "int main() { int a = 0; int i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; return a; }", 110), - (StatementEqual.test "int main() { int i = 0; for (; i <= 10;) i = i + 2; return i; }", 12), - (StatementEqual.test "int main() { int i = 0; for (; i <= 10; i = i + 2); return i; }", 12), - (StatementEqual.test "int main() { int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; return a; }", 0), - (StatementEqual.test "int main() { { int a = 42; int b = 2; return a / b; } }", 21), - (StatementEqual.test "int main() { int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } return a; }", 0), - (StatementEqual.test "int main() { int a = 10; if (a) { a = a * a; a = a / 10; } return a; }", 10), - (StatementEqual.test "int main() { int a = 0; while (1) { if (a < 10) a = a + 1; else return a; } }", 10), - (StatementEqual.test "int main() { int a = 0; for (;;) { a = 42; return a; } return a; }", 42), - (StatementEqual.test "int main() { int a = 0; for (;;) { if (a < 10) a = a + 1; else return a; } }", 10), - (LinkFuncRet.test "int test_func1(); int main() { int a = test_func1(); test_func1(); return a; }" ["test_func1"], 0), - (StatementEqual.test "int main() { int a = 1; int b = 1; return a & b; }", 1), - (StatementEqual.test "int main() { int a = 42; int b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) return 1; return 0; }", 1), - (StatementEqual.test "int main() { return 1 | 0; }", 1), - (StatementEqual.test "int main() { int a = 1; int b = 0; return a & b ^ a | b; }", 1), -- Xor swap - (StatementEqual.test "int main() { int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; return a; }", 20), (StatementEqual.test "int main() { return !0; }", 1), (StatementEqual.test "int main() { return !42; }", 0), (StatementEqual.test "int main() { return !!!0; }", 1), @@ -147,16 +99,8 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ (StatementEqual.test "int main() { int a = 2 << 4; return (a & (a - 1)) == 0; }", 1), -- Determining if an integer is a power of 2 (StatementEqual.test "int main() { 1; {2;} return 3; }", 3), -- (LinkFuncRet.test "int main() { return sum7(1, 1, 1, 1, 1, 1, 1); }" ["test_func3"], 7), - (LinkFuncRet.test "int test_func2(); int main() { return test_func2(40); }" ["test_func2"], 0), -- (LinkFuncRet.test "int main() { return test_func2(sum7(1, 2, 3, 4, 5, 6, 7)); }" ["test_func2", "test_func3"], 0), -- (LinkFuncRet.test "int main() { return sum16(1,1,1,1,1,1,11,10,9,8,7,6,5,4,3,2); }" ["test_func3"], 11), - (StatementEqual.test "int f() { return 42; } int main() { return f(); }", 42), - (StatementEqual.test "int g() { return 42; } int f() { return g(); } int main() { return f(); }", 42), - (StatementEqual.test "int id(int a) { return a; } int main() { int a = 1; return id(a-1) + id(1); }", 1), - (StatementEqual.test "int get1() { return 1; } int get2() { return 2; } int main() { int a = get1(); return a + get2(); }", 3), - (StatementEqual.test "int add(int a, int b) { return a + b; } int main() { return add(1, 2); }", 3), - (StatementEqual.test "int rec(int a) { if (a == 0) return 42; return rec(a - 1); } int main() { int b = rec(2); return 1 + 2; }", 3), - (StatementEqual.test "int fib(int n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } int main() { return fib(5); }", 8), -- fibonacci number (StatementEqual.test "int main() { int a = 42; int* b = &a; return *b; }", 42), (StatementEqual.test "int main() { int a = 42; return *&a; }", 42), (StatementEqual.test "int main() { int a = 42; int* b = &a; int** c = &b; return **c; }", 42), @@ -171,9 +115,9 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *ar; }", 1), (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *(ar + 1); }", 2), (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *(ar + 2); }", 3), - (StatementEqual.test "int f(int* p) { *p = 42; return 0; } int main() { int a = 0; f(&a); return a; }", 42), + (StatementEqual.test "main() { int f(int* p) { *p = 42; return 0; } int main() { int a = 0; f(&a); return a; }", 42), (StatementEqual.test "int main() { int ar[10]; int i = 0; for (; i < 10; i = i + 1) { *(ar + i) = i; } int sum = 0; for (i = 0; i < 10; i = i + 1) { sum = sum + *(ar + i); } return sum; }", 45), - (StatementEqual.test "int sum(int* p, int n) { int sum = 0; int i = 0; for (; i < n; i = i + 1) sum = sum + *(p + i); return sum; } int main() { int ar[10]; int i = 0; for (; i < 10; i = i + 1) *(ar + i) = i; return sum(ar, 10); }", 45), + (StatementEqual.test "main() { int sum(int* p, int n) { int sum = 0; int i = 0; for (; i < n; i = i + 1) sum = sum + *(p + i); return sum; } int main() { int ar[10]; int i = 0; for (; i < 10; i = i + 1) *(ar + i) = i; return sum(ar, 10); }", 45), (StatementEqual.test "int main() { int ar[2][3]; int sum = 0; int i = 0; for (; i < 2; i = i + 1) { int j = 0; for (; j < 3; j = j + 1) { *(*(ar + i) + j) = i + j; sum = sum + *(*(ar + i) + j); } } return sum; } ", 9), (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; *p = 42; return **ar; }", 42), (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; *(p + 1) = 42; return *(*ar + 1); }", 42), @@ -203,18 +147,18 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ (StatementEqual.test "int main() { int ar[3][5]; return sizeof **ar + 1; }", succ $ fromIntegral $ sizeof CT.CTInt), (StatementEqual.test "int main() { int ar[3][5]; return sizeof(**ar + 1); }", fromIntegral $ sizeof $ CT.CTLong CT.CTInt), (StatementEqual.test "int main() { int ar[2]; 2[ar] = 42; return ar[2]; }", 42), - (StatementEqual.test "int g; int main() { return g; }", 0), - (StatementEqual.test "int g; int main() { g = 42; return g; }", 42), - (StatementEqual.test "int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[0]; }", 1), - (StatementEqual.test "int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[1]; }", 2), - (StatementEqual.test "int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[2]; }", 3), + (StatementEqual.test "main() { int g; int main() { return g; }", 0), + (StatementEqual.test "main() { int g; int main() { g = 42; return g; }", 42), + (StatementEqual.test "main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[0]; }", 1), + (StatementEqual.test "main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[1]; }", 2), + (StatementEqual.test "main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[2]; }", 3), (StatementEqual.test "int main() { char c = 1; return c; }", 1), (StatementEqual.test "int main() { char c1 = 1; char c2 = 2; return c1; }", 1), (StatementEqual.test "int main() { char c1 = 1; char c2 = 2; return c2; }", 2), (StatementEqual.test "int main() { char x; return sizeof x; }", 1), (StatementEqual.test "int main() { char ar[10]; return sizeof ar; }", fromIntegral $ sizeof $ CT.CTArray 10 CT.CTChar), - (StatementEqual.test "int f(char a, char b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1), - (StatementEqual.test "int f(char a, int b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1), + (StatementEqual.test "main() { int f(char a, char b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1), + (StatementEqual.test "main() { int f(char a, int b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1), (StatementEqual.test "int main() { return \"abc\"[0]; }", ord 'a'), (StatementEqual.test "int main() { return \"abc\"[1]; }", ord 'b'), (StatementEqual.test "int main() { return \"abc\"[2]; }", ord 'c'), @@ -244,7 +188,7 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ (StatementEqual.test "int main() { int a = 42; { a = 32; } return a; }", 32), (StatementEqual.test "int main() { int* ar[3]; int x; ar[0] = &x; x = 42; ar[0][0]; }", 42) ] >> runTestsEx [ - (LinkFuncStdOut.test "int test_func1(); int main() { return test_func1(); }" ["test_func1"], Right "test/Tests/csrc/test_func1.c::test_func1(): [OK]"), - (LinkFuncStdOut.test "int test_func2(); int main() { return test_func2(40); }" ["test_func2"], Right "test/Tests/csrc/test_func2.c::test_func2(40) outputs: \"2 3 5 7 11 13 17 19 23 29 31 37 \": [OK]"), + (LinkFuncStdOut.test "main() { int test_func1(); int main() { return test_func1(); }" ["test_func1"], Right "test/Tests/csrc/test_func1.c::test_func1(): [OK]"), + (LinkFuncStdOut.test "main() { int test_func2(); int main() { return test_func2(40); }" ["test_func2"], Right "test/Tests/csrc/test_func2.c::test_func2(40) outputs: \"2 3 5 7 11 13 17 19 23 29 31 37 \": [OK]"), ] -} From d4d084553450a1c21f9c537d724b41cdafc16489 Mon Sep 17 00:00:00 2001 From: roki Date: Mon, 14 Dec 2020 04:52:45 +0900 Subject: [PATCH 12/51] add unary * and & --- htcc.cabal | 3 +- src/Htcc/Parser/Combinators/BasicOperator.hs | 4 + src/Htcc/Parser/Combinators/Program.hs | 112 ++++++++++++------- src/Htcc/Parser/Development.hs | 22 ---- test/Tests/SubProcTests.hs | 4 +- 5 files changed, 81 insertions(+), 64 deletions(-) delete mode 100644 src/Htcc/Parser/Development.hs diff --git a/htcc.cabal b/htcc.cabal index ad0c3db..5135223 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 7820f03d55b3883d2f23b4561ae836c295ade3fa98f3eab9e4e44d9636218d0b +-- hash: f8ff139d7a8b4675999113daed2e9e05240b03c0f429230a35d0a449fe444c14 name: htcc version: 0.0.0.1 @@ -85,7 +85,6 @@ library Htcc.Parser.ConstructionData.Scope.Typedef Htcc.Parser.ConstructionData.Scope.Utils Htcc.Parser.ConstructionData.Scope.Var - Htcc.Parser.Development Htcc.Parser.Parsing Htcc.Parser.Parsing.Core Htcc.Parser.Parsing.Global diff --git a/src/Htcc/Parser/Combinators/BasicOperator.hs b/src/Htcc/Parser/Combinators/BasicOperator.hs index 87970f1..61df7de 100644 --- a/src/Htcc/Parser/Combinators/BasicOperator.hs +++ b/src/Htcc/Parser/Combinators/BasicOperator.hs @@ -14,6 +14,7 @@ module Htcc.Parser.Combinators.BasicOperator ( , binOpBool , binOpCon , binOpIntOnly + , notFollowedOp ) where import Control.Applicative (Alternative (..)) @@ -64,3 +65,6 @@ binOpIntOnly k lhs rhs , show k , "'" ] + +notFollowedOp :: Parser i a -> Parser i b -> Parser i a +notFollowedOp op nop = M.try $ lexeme $ op `notFollowedBy` nop diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 0e8d52a..0bde04b 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -14,35 +14,50 @@ module Htcc.Parser.Combinators.Program ( parser ) where -import Control.Monad (void, forM) -import Control.Monad.Combinators (choice, some) -import Control.Monad.Trans (MonadTrans (..)) -import Control.Monad.Trans.State (get, gets, put, modify) -import Data.Bits (Bits (..)) -import Data.Functor ((<&>)) -import Htcc.CRules.Types as CT -import Htcc.Parser.AST (Treealizable (..)) -import Htcc.Parser.AST.Core (ATKind (..), - ATKindFor (..), - ATree (..), atBlock, - atElse, atExprStmt, - atFor, atGVar, atIf, - atNumLit, atReturn, - atWhile, atNoLeaf, atDefFunc) -import Htcc.Parser.AST.Type (ASTs) +import Control.Monad (forM, void, (>=>)) +import Control.Monad.Combinators (choice, some) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.Maybe (MaybeT (..), + runMaybeT) +import Control.Monad.Trans.State (get, gets, modify, + put) +import Data.Bits (Bits (..)) +import Data.Functor ((<&>)) +import Data.Maybe (fromJust, + fromMaybe) +import qualified Data.Text as T +import Htcc.CRules.Types as CT +import Htcc.Parser.AST (Treealizable (..)) +import Htcc.Parser.AST.Core (ATKind (..), + ATKindFor (..), + ATree (..), + atBlock, + atDefFunc, atElse, + atExprStmt, atFor, + atGVar, atIf, + atNoLeaf, + atNumLit, + atReturn, atUnary, + atWhile) +import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords -import Htcc.Parser.ConstructionData (addLVar, lookupVar, lookupFunction, resetLocal, addFunction) -import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) -import qualified Htcc.Parser.ConstructionData.Scope.Var as PV -import Htcc.Parser.Development (defMainFn) -import qualified Htcc.Tokenizer.Token as HT -import qualified Text.Megaparsec as M -import qualified Htcc.Parser.ConstructionData.Scope.Function as PSF -import qualified Data.Text as T - -import Text.Megaparsec.Debug (dbg) +import Htcc.Parser.ConstructionData (addFunction, + addLVar, + incomplete, + lookupFunction, + lookupVar, + resetLocal) +import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) +import qualified Htcc.Parser.ConstructionData.Scope.Function as PSF +import qualified Htcc.Parser.ConstructionData.Scope.Var as PV +import qualified Htcc.Tokenizer.Token as HT +import Htcc.Utils (maybe') +import qualified Text.Megaparsec as M +import qualified Text.Megaparsec.Char as MC + +import Text.Megaparsec.Debug (dbg) parser, program :: (Integral i, Ord i, Bits i, Show i) => Parser i (ASTs i) parser = (spaceConsumer >> program) <* M.eof @@ -84,15 +99,15 @@ function = do scp <- lift get case addFunction False (CT.SCAuto CT.CTInt) (HT.TokenLCNums 1 1, HT.TKIdent ident) scp of Right scp' -> ATEmpty <$ lift (put scp') - Left y -> fail $ T.unpack $ fst y - + Left y -> fail $ T.unpack $ fst y + definition ident params = do void $ M.lookAhead (symbol "{") params' <- forM params $ \p -> do scp <- lift get case addLVar (CT.SCAuto CT.CTInt) (HT.TokenLCNums 1 1, HT.TKIdent p) scp of Right (lat, scp') -> lat <$ lift (put scp') - Left x -> fail $ T.unpack $ fst x + Left x -> fail $ T.unpack $ fst x atDefFunc ident (if null params' then Nothing else Just params') (CT.SCAuto CT.CTInt) <$> stmt stmt = choice @@ -109,15 +124,15 @@ stmt = choice [ atReturn (CT.SCUndef CT.CTUndef) <$> (M.try kReturn >> expr) <* semi --, atReturn (CT.SCUndef CT.CTUndef) ATEmpty <$ (kReturn >> semi) ] - + ifStmt = do r <- atIf <$> (M.try kIf >> parens expr) <*> stmt M.option ATEmpty (M.try kElse >> stmt) <&> \case ATEmpty -> r nd -> atElse r nd - + whileStmt = atWhile <$> (M.try kWhile >> parens expr) <*> stmt - + forStmt = do es <- (>>) (M.try kFor) $ parens $ do initSect <- ATForInit . atExprStmt @@ -128,7 +143,7 @@ stmt = choice <$> M.option ATEmpty expr pure [initSect, condSect, incrSect] atFor . (es <>) . (:[]) . ATForStmt <$> stmt - + compoundStmt = atBlock <$> braces (M.many stmt) expr = assign @@ -144,7 +159,7 @@ logicalOr = binaryOperator logicalAnd [(symbol "||", binOpBool ATLOr)] logicalAnd = binaryOperator bitwiseOr [(symbol "&&", binOpBool ATLAnd)] bitwiseOr = binaryOperator bitwiseXor [(symbol "|", binOpIntOnly ATOr)] bitwiseXor = binaryOperator bitwiseAnd [(symbol "^", binOpIntOnly ATXor)] -bitwiseAnd = binaryOperator equality [(symbol "&", binOpIntOnly ATAnd)] +bitwiseAnd = binaryOperator equality [(MC.char '&' `notFollowedOp` MC.char '&', binOpIntOnly ATAnd)] equality = binaryOperator relational [ (symbol "==", binOpBool ATEQ) @@ -171,9 +186,30 @@ term = binaryOperator unary unary = choice [ symbol "+" >> factor - , (\n -> ATNode ATSub (atype n) (atNumLit 0) n) <$> (symbol "-" >> factor) + , symbol "-" >> factor <&> \n -> ATNode ATSub (atype n) (atNumLit 0) n + , MC.char '&' `notFollowedOp` MC.char '&' >> unary <&> \n -> + let ty = if CT.isArray (atype n) then fromJust $ CT.deref $ atype n else atype n in + atUnary ATAddr (CT.mapTypeKind CT.CTPtr ty) n + , symbol "*" >> unary >>= deref' , factor ] + where + deref' :: Ord i => ATree i -> Parser i (ATree i) + deref' = runMaybeT . deref'' >=> maybe M.empty pure + + deref'' :: Ord i => ATree i -> MaybeT (Parser i) (ATree i) + deref'' n = lift $ pure $ atUnary ATDeref (CT.SCAuto CT.CTInt) n + + {- After implementing the type, use: + deref'' n = do + ty <- MaybeT $ pure (CT.deref $ atype n) + case CT.toTypeKind ty of + CT.CTVoid -> lift $ fail "void value not ignored as it ought to be" + _ -> do + scp <- lift $ lift get + ty' <- MaybeT $ pure (incomplete ty scp) + lift $ pure $ atUnary ATDeref ty' n + -} factor = choice [ atNumLit <$> natural @@ -181,10 +217,10 @@ factor = choice , parens expr , ATEmpty <$ M.eof ] - + identifier' = do ident <- identifier - choice + choice [ fnCall ident , variable ident ] @@ -201,7 +237,7 @@ identifier' = do fnCall ident = do params <- symbol "(" >> M.manyTill (M.try (expr <* comma) M.<|> expr) (symbol ")") - let params' = if length params == 0 then Nothing else Just params + let params' = if null params then Nothing else Just params lift $ do scp <- get return $ case lookupFunction ident scp of diff --git a/src/Htcc/Parser/Development.hs b/src/Htcc/Parser/Development.hs deleted file mode 100644 index 3c939cb..0000000 --- a/src/Htcc/Parser/Development.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-| -Module : Htcc.Parser.Development -Description : C language lexer -Copyright : (c) roki, 2020~ -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -C language lexer --} -{-# LANGUAGE OverloadedStrings #-} -module Htcc.Parser.Development ( - defMainFn -) where - -import Htcc.CRules.Types as CT -import Htcc.Parser.AST.Core (ATree (..), - atDefFunc) - -defMainFn :: ATree i -> ATree i -defMainFn = atDefFunc "main" Nothing (CT.SCAuto CT.CTInt) diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index fe364f3..93886ac 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -86,6 +86,8 @@ exec = runTestsEx , (StatementEqual.test "add(a, b) { return a + b; } main() { return add(1, 2); }", 3) , (StatementEqual.test "rec(a) { if (a == 0) return 42; return rec(a - 1); } main() { b = rec(2); return 1 + 2; }", 3) , (StatementEqual.test "fib(n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } main() { return fib(5); }", 8) -- fibonacci number + , (StatementEqual.test "main() { a = 42; b = &a; return a; }", 42) + , (StatementEqual.test "main() { a = 42; return *&a; }", 42) ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ @@ -101,8 +103,6 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ -- (LinkFuncRet.test "int main() { return sum7(1, 1, 1, 1, 1, 1, 1); }" ["test_func3"], 7), -- (LinkFuncRet.test "int main() { return test_func2(sum7(1, 2, 3, 4, 5, 6, 7)); }" ["test_func2", "test_func3"], 0), -- (LinkFuncRet.test "int main() { return sum16(1,1,1,1,1,1,11,10,9,8,7,6,5,4,3,2); }" ["test_func3"], 11), - (StatementEqual.test "int main() { int a = 42; int* b = &a; return *b; }", 42), - (StatementEqual.test "int main() { int a = 42; return *&a; }", 42), (StatementEqual.test "int main() { int a = 42; int* b = &a; int** c = &b; return **c; }", 42), (StatementEqual.test "int main() { int a = 42; int* b = &a; *b = a * 2; return a; }", 84), (StatementEqual.test "int main() { int a = 42; int b = 5; return *(&b+1); }", 42), From 0ce3eccdcb4a437422d643c9dd3f9dbe8f8517c4 Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 20 Dec 2020 14:03:22 +0900 Subject: [PATCH 13/51] Add declaration of local variable (int only) --- src/Htcc/Parser/Combinators/Program.hs | 35 +++++++++---- test/Tests/SubProcTests.hs | 70 +++++++++++++------------- 2 files changed, 61 insertions(+), 44 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 0bde04b..534755d 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -38,7 +38,7 @@ import Htcc.Parser.AST.Core (ATKind (..), atNoLeaf, atNumLit, atReturn, atUnary, - atWhile) + atWhile, atNull) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core @@ -59,11 +59,22 @@ import qualified Text.Megaparsec.Char as MC import Text.Megaparsec.Debug (dbg) -parser, program :: (Integral i, Ord i, Bits i, Show i) => Parser i (ASTs i) +registerLVar :: (Bits i, Integral i) => CT.StorageClass i -> T.Text -> Parser i (ATree i) +registerLVar ty ident = do + x <- lift $ gets $ addLVar ty (HT.TokenLCNums 1 1, HT.TKIdent ident) + case x of + Right (lat, scp') -> lift (atNull lat <$ put scp') + Left err -> fail $ T.unpack $ fst err + +cType :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) +cType = SCAuto . read . T.unpack <$> choice kBasicTypes + +parser, program :: (Integral i, Bits i, Read i, Show i) => Parser i (ASTs i) parser = (spaceConsumer >> program) <* M.eof program = some global global, + varDecl, function, stmt, expr, @@ -79,12 +90,19 @@ global, term, unary, factor, - identifier' :: (Ord i, Bits i, Show i, Integral i) => Parser i (ATree i) + identifier' :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) global = choice [ function ] +varDecl = do + ty <- cType + choice + [ ATEmpty <$ symbol ";" + , (identifier >>= registerLVar ty) <* symbol ";" + ] + function = do ident <- identifier params <- symbol "(" >> M.manyTill (M.try (identifier <* comma) M.<|> identifier) (symbol ")") @@ -116,6 +134,7 @@ stmt = choice , whileStmt , forStmt , compoundStmt + , varDecl , expr <* semi , ATEmpty <$ semi ] @@ -225,15 +244,13 @@ identifier' = do , variable ident ] where - variable ident = lift $ do - scp <- get - case lookupVar ident scp of + variable ident = do + lookupResult <- lift $ gets $ lookupVar ident + case lookupResult of FoundGVar (PV.GVar t _) -> return $ atGVar t ident FoundLVar sct -> return $ treealize sct FoundEnum sct -> return $ treealize sct - NotFound -> let Right (lat, scp') = addLVar (CT.SCAuto CT.CTInt) (HT.TokenLCNums 1 1, HT.TKIdent ident) scp in do - put scp' - return lat + NotFound -> fail $ "The '" <> T.unpack ident <> "' is not defined identifier" fnCall ident = do params <- symbol "(" >> M.manyTill (M.try (expr <* comma) M.<|> expr) (symbol ")") diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 93886ac..1ff4aea 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -41,53 +41,53 @@ exec = runTestsEx , (StatementEqual.test "main() { return 2 || 1; }", 1) , (StatementEqual.test "main() { return 1 && 2; }", 1) , (StatementEqual.test "main() { return 2 && 3 && 4 && 0; }", 0) - , (StatementEqual.test "main() { a = 1; return a; }", 1) - , (StatementEqual.test "main() { a = 42; b = 20; return a + b; }", 62) - , (StatementEqual.test "main() { a = 42; b = 20; c = 32; return (a - c) * b / 10; }", 20) - , (StatementEqual.test "main() { a = 42; b = 20; return a - b; }", 22) - , (StatementEqual.test "main() { a = 3; returnb = 5 * 6 - 8; return a + returnb / 2; }", 14) - , (StatementEqual.test "main() { a = 3; return_ = 5 * 6 - 8; return a + return_ / 2; }", 14) - , (StatementEqual.test "main() { a /* comment */ = 3; b = 5 */*comment*/ 6 - 8; return a + b / 2; }", 14) + , (StatementEqual.test "main() { int a; a = 1; return a; }", 1) + , (StatementEqual.test "main() { int a; int b; a = 42; b = 20; return a + b; }", 62) + , (StatementEqual.test "main() { int a; int b; int c; a = 42; b = 20; c = 32; return (a - c) * b / 10; }", 20) + , (StatementEqual.test "main() { int a; int b; a = 42; b = 20; return a - b; }", 22) + , (StatementEqual.test "main() { int a; int returnb; a = 3; returnb = 5 * 6 - 8; return a + returnb / 2; }", 14) + , (StatementEqual.test "main() { int a; int return_; a = 3; return_ = 5 * 6 - 8; return a + return_ / 2; }", 14) + , (StatementEqual.test "main() { int a; int b; a /* comment */ = 3; b = 5 */*comment*/ 6 - 8; return a + b / 2; }", 14) , (StatementEqual.test "main() { if (1) return 42; return 53; }", 42) , (StatementEqual.test "main() { if (20*3-60) return 42; return 53; }", 53) - , (StatementEqual.test "main() { a = 1; b = 2; if (a) return b; return 42; }", 2) + , (StatementEqual.test "main() { int a; int b; a = 1; b = 2; if (a) return b; return 42; }", 2) , (StatementEqual.test "main() { if (1) return 42; else return 53; }", 42) , (StatementEqual.test "main() { if (0) return 42; else return 53; }", 53) - , (StatementEqual.test "main() { a = 0; b = 2; if (a) return b; else return b * 2; }", 4) - , (StatementEqual.test "main() { a = 1; b = 0; if (b) return 42; if (0) return 42; else return a; }", 1) - , (StatementEqual.test "main() { a = 1; b = 2; if (a) if (b) return b; else return 53; else return 24; }", 2) + , (StatementEqual.test "main() { int a; int b; a = 0; b = 2; if (a) return b; else return b * 2; }", 4) + , (StatementEqual.test "main() { int a; int b; a = 1; b = 0; if (b) return 42; if (0) return 42; else return a; }", 1) + , (StatementEqual.test "main() { int a; int b; a = 1; b = 2; if (a) if (b) return b; else return 53; else return 24; }", 2) , (StatementEqual.test "main() { if (1) if (1) if (1) if (1) if (1) if (0) return 1; else return 2; else return 3; else return 4; else return 5; else return 6; else return 7; }", 2) , (StatementEqual.test "main() { if(1)if(1)return 42;return 53; }", 42) , (StatementEqual.test "main() { if(0); return 0; }", 0) - , (StatementEqual.test "main() { a = 1; while (a < 10) a = a + 1; return a; }", 10) - , (StatementEqual.test "main() { a = 1; while (a < 10) a = a + 1; b = 1; while (b < 20) b = b + 2; return a + b; }", 31) - , (StatementEqual.test "main() { a = 0; while (a); return 0; }", 0) - , (StatementEqual.test "main() { a = 0; i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; return a; }", 110) - , (StatementEqual.test "main() { i = 0; for (; i <= 10;) i = i + 2; return i; }", 12) - , (StatementEqual.test "main() { i = 0; for (; i <= 10; i = i + 2); return i; }", 12) - , (StatementEqual.test "main() { a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; return a; }", 0) - , (StatementEqual.test "main() { a = 1; b = 1; return a & b; }", 1) - , (StatementEqual.test "main() { a = 42; b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) return 1; return 0; }", 1) + , (StatementEqual.test "main() { int a; a = 1; while (a < 10) a = a + 1; return a; }", 10) + , (StatementEqual.test "main() { int a; int b; a = 1; while (a < 10) a = a + 1; b = 1; while (b < 20) b = b + 2; return a + b; }", 31) + , (StatementEqual.test "main() { int a; a = 0; while (a); return 0; }", 0) + , (StatementEqual.test "main() { int a; int i; a = 0; i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; return a; }", 110) + , (StatementEqual.test "main() { int i; i = 0; for (; i <= 10;) i = i + 2; return i; }", 12) + , (StatementEqual.test "main() { int i; i = 0; for (; i <= 10; i = i + 2); return i; }", 12) + , (StatementEqual.test "main() { int a; int i; a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; return a; }", 0) + , (StatementEqual.test "main() { int a; int b; a = 1; b = 1; return a & b; }", 1) + , (StatementEqual.test "main() { int a; int b; a = 42; b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) return 1; return 0; }", 1) , (StatementEqual.test "main() { return 1 | 0; }", 1) - , (StatementEqual.test "main() { a = 1; b = 0; return a & b ^ a | b; }", 1) -- Xor swap - , (StatementEqual.test "main() { a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; return a; }", 20) - , (StatementEqual.test "main() { a = 0; i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } return a; }", 0) - , (StatementEqual.test "main() { a = 10; if (a) { a = a * a; a = a / 10; } return a; }", 10) - , (StatementEqual.test "main() { a = 0; while (1) { if (a < 10) a = a + 1; else return a; } }", 10) - , (StatementEqual.test "main() { a = 0; for (;;) { a = 42; return a; } return a; }", 42) - , (StatementEqual.test "main() { a = 0; for (;;) { if (a < 10) a = a + 1; else return a; } }", 10) - , (LinkFuncRet.test "main() { a = test_func1(); test_func1(); return a; }" ["test_func1"], 0) + , (StatementEqual.test "main() { int a; int b; a = 1; b = 0; return a & b ^ a | b; }", 1) -- Xor swap + , (StatementEqual.test "main() { int a; int i; a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; return a; }", 20) + , (StatementEqual.test "main() { int a; int i; a = 0; i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } return a; }", 0) + , (StatementEqual.test "main() { int a; a = 10; if (a) { a = a * a; a = a / 10; } return a; }", 10) + , (StatementEqual.test "main() { int a; a = 0; while (1) { if (a < 10) a = a + 1; else return a; } }", 10) + , (StatementEqual.test "main() { int a; a = 0; for (;;) { a = 42; return a; } return a; }", 42) + , (StatementEqual.test "main() { int a; a = 0; for (;;) { if (a < 10) a = a + 1; else return a; } }", 10) + , (LinkFuncRet.test "main() { int a; a = test_func1(); test_func1(); return a; }" ["test_func1"], 0) , (LinkFuncRet.test "main() { return test_func2(40); }" ["test_func2"], 0) , (LinkFuncRet.test "main() { return test_func5(1, 2); }" ["test_func5"], 3) , (StatementEqual.test "f() { return 42; } main() { return f(); }", 42) , (StatementEqual.test "g() { return 42; } f() { return g(); } main() { return f(); }", 42) - , (StatementEqual.test "id(a) { return a; } main() { a = 1; return id(a-1) + id(1); }", 1) - , (StatementEqual.test "get1() { return 1; } get2() { return 2; } main() { a = get1(); return a + get2(); }", 3) - , (StatementEqual.test "add(a, b) { return a + b; } main() { return add(1, 2); }", 3) - , (StatementEqual.test "rec(a) { if (a == 0) return 42; return rec(a - 1); } main() { b = rec(2); return 1 + 2; }", 3) - , (StatementEqual.test "fib(n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } main() { return fib(5); }", 8) -- fibonacci number - , (StatementEqual.test "main() { a = 42; b = &a; return a; }", 42) - , (StatementEqual.test "main() { a = 42; return *&a; }", 42) + -- , (StatementEqual.test "id(a) { return a; } main() { a = 1; return id(a-1) + id(1); }", 1) + , (StatementEqual.test "get1() { return 1; } get2() { return 2; } main() { int a; a = get1(); return a + get2(); }", 3) + -- , (StatementEqual.test "add(a, b) { return a + b; } main() { return add(1, 2); }", 3) + -- , (StatementEqual.test "rec(a) { if (a == 0) return 42; return rec(a - 1); } main() { b = rec(2); return 1 + 2; }", 3) + -- , (StatementEqual.test "fib(n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } main() { return fib(5); }", 8) -- fibonacci number + , (StatementEqual.test "main() { int a; int b; a = 42; b = &a; return a; }", 42) + , (StatementEqual.test "main() { int a; a = 42; return *&a; }", 42) ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ From 5b285f4de7ee5207903134e1ed99a15516cfb70e Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 20 Dec 2020 15:34:23 +0900 Subject: [PATCH 14/51] Changed to be able to type in function parameters --- src/Htcc/Parser/Combinators/Program.hs | 44 ++++++++++++++------------ test/Tests/SubProcTests.hs | 8 ++--- 2 files changed, 27 insertions(+), 25 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 534755d..a70cb7d 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -9,11 +9,12 @@ Portability : POSIX C language lexer -} -{-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings, TupleSections #-} module Htcc.Parser.Combinators.Program ( parser ) where +import Data.Either (rights) import Control.Monad (forM, void, (>=>)) import Control.Monad.Combinators (choice, some) import Control.Monad.Trans (MonadTrans (..)) @@ -59,22 +60,30 @@ import qualified Text.Megaparsec.Char as MC import Text.Megaparsec.Debug (dbg) +declIdent :: (Show i, Read i, Integral i) + => Parser i a + -> Parser i (Either (CT.StorageClass i) (CT.StorageClass i, T.Text)) +declIdent sep = do + ty <- cType + choice + [ Left ty <$ sep + , Right . (ty, ) <$> identifier <* sep + ] + where + cType = SCAuto . read . T.unpack <$> choice kBasicTypes + registerLVar :: (Bits i, Integral i) => CT.StorageClass i -> T.Text -> Parser i (ATree i) registerLVar ty ident = do x <- lift $ gets $ addLVar ty (HT.TokenLCNums 1 1, HT.TKIdent ident) case x of - Right (lat, scp') -> lift (atNull lat <$ put scp') + Right (lat, scp') -> lift (lat <$ put scp') Left err -> fail $ T.unpack $ fst err -cType :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) -cType = SCAuto . read . T.unpack <$> choice kBasicTypes - parser, program :: (Integral i, Bits i, Read i, Show i) => Parser i (ASTs i) parser = (spaceConsumer >> program) <* M.eof program = some global global, - varDecl, function, stmt, expr, @@ -96,16 +105,10 @@ global = choice [ function ] -varDecl = do - ty <- cType - choice - [ ATEmpty <$ symbol ";" - , (identifier >>= registerLVar ty) <* symbol ";" - ] - function = do ident <- identifier - params <- symbol "(" >> M.manyTill (M.try (identifier <* comma) M.<|> identifier) (symbol ")") + params <- symbol "(" + >> M.manyTill (M.try (declIdent comma) M.<|> (declIdent $ M.lookAhead (symbol ")"))) (symbol ")") lift $ modify resetLocal choice [ declaration ident @@ -120,12 +123,8 @@ function = do Left y -> fail $ T.unpack $ fst y definition ident params = do - void $ M.lookAhead (symbol "{") - params' <- forM params $ \p -> do - scp <- lift get - case addLVar (CT.SCAuto CT.CTInt) (HT.TokenLCNums 1 1, HT.TKIdent p) scp of - Right (lat, scp') -> lat <$ lift (put scp') - Left x -> fail $ T.unpack $ fst x + void $ M.lookAhead $ symbol "{" + params' <- forM (rights params) $ uncurry registerLVar atDefFunc ident (if null params' then Nothing else Just params') (CT.SCAuto CT.CTInt) <$> stmt stmt = choice @@ -134,7 +133,7 @@ stmt = choice , whileStmt , forStmt , compoundStmt - , varDecl + , lvarStmt , expr <* semi , ATEmpty <$ semi ] @@ -165,6 +164,9 @@ stmt = choice compoundStmt = atBlock <$> braces (M.many stmt) + lvarStmt = declIdent semi + >>= either (const $ return ATEmpty) (fmap atNull . uncurry registerLVar) + expr = assign assign = do diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 1ff4aea..01057aa 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -81,11 +81,11 @@ exec = runTestsEx , (LinkFuncRet.test "main() { return test_func5(1, 2); }" ["test_func5"], 3) , (StatementEqual.test "f() { return 42; } main() { return f(); }", 42) , (StatementEqual.test "g() { return 42; } f() { return g(); } main() { return f(); }", 42) - -- , (StatementEqual.test "id(a) { return a; } main() { a = 1; return id(a-1) + id(1); }", 1) + , (StatementEqual.test "id(int a) { return a; } main() { int a; a = 1; return id(a-1) + id(1); }", 1) , (StatementEqual.test "get1() { return 1; } get2() { return 2; } main() { int a; a = get1(); return a + get2(); }", 3) - -- , (StatementEqual.test "add(a, b) { return a + b; } main() { return add(1, 2); }", 3) - -- , (StatementEqual.test "rec(a) { if (a == 0) return 42; return rec(a - 1); } main() { b = rec(2); return 1 + 2; }", 3) - -- , (StatementEqual.test "fib(n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } main() { return fib(5); }", 8) -- fibonacci number + , (StatementEqual.test "add(int a, int b) { return a + b; } main() { return add(1, 2); }", 3) + , (StatementEqual.test "rec(int a) { if (a == 0) return 42; return rec(a - 1); } main() { int b; b = rec(2); return 1 + 2; }", 3) + , (StatementEqual.test "fib(int n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } main() { return fib(5); }", 8) -- fibonacci number , (StatementEqual.test "main() { int a; int b; a = 42; b = &a; return a; }", 42) , (StatementEqual.test "main() { int a; a = 42; return *&a; }", 42) ] From bef7cbff2bb6fec6fdd5143d097194e8c32fe1be Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 20 Dec 2020 16:49:15 +0900 Subject: [PATCH 15/51] Changed function declarations and definitions to be typed --- htcc.cabal | 6 +- package.yaml | 1 - src/Htcc/Parser/Combinators/Program.hs | 59 +++++---- test/Tests/SubProcTests.hs | 168 ++++++++++++------------- 4 files changed, 119 insertions(+), 115 deletions(-) diff --git a/htcc.cabal b/htcc.cabal index 5135223..ff230e9 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: f8ff139d7a8b4675999113daed2e9e05240b03c0f429230a35d0a449fe444c14 +-- hash: b66e6a875f19a96fcebcd35b2b8fed0395cf7d04fb59c94b3fe72819dffd4521 name: htcc version: 0.0.0.1 @@ -133,7 +133,6 @@ library , parser-combinators , safe , split - , template-haskell , text , transformers default-language: Haskell2010 @@ -169,7 +168,6 @@ executable htcc , parser-combinators , safe , split - , template-haskell , text , transformers default-language: Haskell2010 @@ -221,7 +219,6 @@ test-suite htcc-test , process , safe , split - , template-haskell , text , time , transformers @@ -258,7 +255,6 @@ benchmark criterion , parser-combinators , safe , split - , template-haskell , text , transformers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index d18a67e..f70b119 100644 --- a/package.yaml +++ b/package.yaml @@ -48,7 +48,6 @@ dependencies: - optparse-applicative - megaparsec - parser-combinators -- template-haskell library: source-dirs: src diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index a70cb7d..e15e314 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -14,7 +14,6 @@ module Htcc.Parser.Combinators.Program ( parser ) where -import Data.Either (rights) import Control.Monad (forM, void, (>=>)) import Control.Monad.Combinators (choice, some) import Control.Monad.Trans (MonadTrans (..)) @@ -23,6 +22,7 @@ import Control.Monad.Trans.Maybe (MaybeT (..), import Control.Monad.Trans.State (get, gets, modify, put) import Data.Bits (Bits (..)) +import Data.Either (rights) import Data.Functor ((<&>)) import Data.Maybe (fromJust, fromMaybe) @@ -36,10 +36,10 @@ import Htcc.Parser.AST.Core (ATKind (..), atDefFunc, atElse, atExprStmt, atFor, atGVar, atIf, - atNoLeaf, + atNoLeaf, atNull, atNumLit, atReturn, atUnary, - atWhile, atNull) + atWhile) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core @@ -54,14 +54,13 @@ import Htcc.Parser.ConstructionData.Scope (LookupVarResult (. import qualified Htcc.Parser.ConstructionData.Scope.Function as PSF import qualified Htcc.Parser.ConstructionData.Scope.Var as PV import qualified Htcc.Tokenizer.Token as HT -import Htcc.Utils (maybe') import qualified Text.Megaparsec as M import qualified Text.Megaparsec.Char as MC import Text.Megaparsec.Debug (dbg) -declIdent :: (Show i, Read i, Integral i) - => Parser i a +declIdent :: (Show i, Read i, Integral i) + => Parser i a -> Parser i (Either (CT.StorageClass i) (CT.StorageClass i, T.Text)) declIdent sep = do ty <- cType @@ -77,7 +76,7 @@ registerLVar ty ident = do x <- lift $ gets $ addLVar ty (HT.TokenLCNums 1 1, HT.TKIdent ident) case x of Right (lat, scp') -> lift (lat <$ put scp') - Left err -> fail $ T.unpack $ fst err + Left err -> fail $ T.unpack $ fst err parser, program :: (Integral i, Bits i, Read i, Show i) => Parser i (ASTs i) parser = (spaceConsumer >> program) <* M.eof @@ -105,27 +104,37 @@ global = choice [ function ] -function = do - ident <- identifier - params <- symbol "(" - >> M.manyTill (M.try (declIdent comma) M.<|> (declIdent $ M.lookAhead (symbol ")"))) (symbol ")") - lift $ modify resetLocal - choice - [ declaration ident - , definition ident params - ] +function = + declIdent (symbol "(") + >>= \case + Left _ -> fail "unexpected '(' token, expected an identifier" + Right (ty, ident) -> do + params <- takeParameters + lift $ modify resetLocal + choice + [ declaration ty ident + , definition ty ident params + ] where - declaration ident = do + takeParameters = + M.manyTill (M.try (declIdent comma) M.<|> (declIdent $ M.lookAhead (symbol ")"))) (symbol ")") + + declaration ty ident = void semi - scp <- lift get - case addFunction False (CT.SCAuto CT.CTInt) (HT.TokenLCNums 1 1, HT.TKIdent ident) scp of - Right scp' -> ATEmpty <$ lift (put scp') - Left y -> fail $ T.unpack $ fst y + >> lift (gets $ addFunction False ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) + >>= \case + Right scp' -> ATEmpty <$ lift (put scp') + Left err -> fail $ T.unpack $ fst err - definition ident params = do - void $ M.lookAhead $ symbol "{" - params' <- forM (rights params) $ uncurry registerLVar - atDefFunc ident (if null params' then Nothing else Just params') (CT.SCAuto CT.CTInt) <$> stmt + definition ty ident params = + void (M.lookAhead $ symbol "{") + >> lift (gets $ addFunction True ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) + >>= \case + Right scp' -> do + lift $ put scp' + params' <- forM (rights params) $ uncurry registerLVar + atDefFunc ident (if null params' then Nothing else Just params') ty <$> stmt + Left err -> fail $ T.unpack $ fst err stmt = choice [ returnStmt diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 01057aa..4174d7b 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -15,79 +15,79 @@ import qualified Htcc.CRules.Types as CT exec :: IO () exec = runTestsEx - [ (StatementEqual.test "main() { return 1+2; }", 3) - , (StatementEqual.test "main() { return 1+2+4; }", 7) - , (StatementEqual.test "main() { return 10-7+3; }", 6) - , (StatementEqual.test "main() { return 42+23-30; }", 35) - , (StatementEqual.test "main() { return 42/2+2-5; }", 18) - , (StatementEqual.test "main() { return (3+5)/2; }", 4) - , (StatementEqual.test "main() { return (4-2)*8+20/4; }",21) - , (StatementEqual.test "main() { return -(-3*+5); }", 15) - , (StatementEqual.test "main() { return -25+30; }", 5) - , (StatementEqual.test "main() { return 42 == 42; }", 1) - , (StatementEqual.test "main() { return 42 != 53; }", 1) - , (StatementEqual.test "main() { return 42 < 53; }", 1) - , (StatementEqual.test "main() { return 53 > 42; }", 1) - , (StatementEqual.test "main() { return 42 <= 42; }", 1) - , (StatementEqual.test "main() { return 32 <= 42; }", 1) - , (StatementEqual.test "main() { return 42 >= 42; }", 1) - , (StatementEqual.test "main() { return 53 >= 42; }", 1) - , (StatementEqual.test "main() { return (1 + 1) == 2; }", 1) - , (StatementEqual.test "main() { return (2 * 3) != 2; }", 1) - , (StatementEqual.test "main() { return 1 || 0; }", 1) - , (StatementEqual.test "main() { return (1 + 1) || 0 || 0; }", 1) - , (StatementEqual.test "main() { return 0 || 0; }", 0) - , (StatementEqual.test "main() { return 0 || (1 - 1); }", 0) - , (StatementEqual.test "main() { return 2 || 1; }", 1) - , (StatementEqual.test "main() { return 1 && 2; }", 1) - , (StatementEqual.test "main() { return 2 && 3 && 4 && 0; }", 0) - , (StatementEqual.test "main() { int a; a = 1; return a; }", 1) - , (StatementEqual.test "main() { int a; int b; a = 42; b = 20; return a + b; }", 62) - , (StatementEqual.test "main() { int a; int b; int c; a = 42; b = 20; c = 32; return (a - c) * b / 10; }", 20) - , (StatementEqual.test "main() { int a; int b; a = 42; b = 20; return a - b; }", 22) - , (StatementEqual.test "main() { int a; int returnb; a = 3; returnb = 5 * 6 - 8; return a + returnb / 2; }", 14) - , (StatementEqual.test "main() { int a; int return_; a = 3; return_ = 5 * 6 - 8; return a + return_ / 2; }", 14) - , (StatementEqual.test "main() { int a; int b; a /* comment */ = 3; b = 5 */*comment*/ 6 - 8; return a + b / 2; }", 14) - , (StatementEqual.test "main() { if (1) return 42; return 53; }", 42) - , (StatementEqual.test "main() { if (20*3-60) return 42; return 53; }", 53) - , (StatementEqual.test "main() { int a; int b; a = 1; b = 2; if (a) return b; return 42; }", 2) - , (StatementEqual.test "main() { if (1) return 42; else return 53; }", 42) - , (StatementEqual.test "main() { if (0) return 42; else return 53; }", 53) - , (StatementEqual.test "main() { int a; int b; a = 0; b = 2; if (a) return b; else return b * 2; }", 4) - , (StatementEqual.test "main() { int a; int b; a = 1; b = 0; if (b) return 42; if (0) return 42; else return a; }", 1) - , (StatementEqual.test "main() { int a; int b; a = 1; b = 2; if (a) if (b) return b; else return 53; else return 24; }", 2) - , (StatementEqual.test "main() { if (1) if (1) if (1) if (1) if (1) if (0) return 1; else return 2; else return 3; else return 4; else return 5; else return 6; else return 7; }", 2) - , (StatementEqual.test "main() { if(1)if(1)return 42;return 53; }", 42) - , (StatementEqual.test "main() { if(0); return 0; }", 0) - , (StatementEqual.test "main() { int a; a = 1; while (a < 10) a = a + 1; return a; }", 10) - , (StatementEqual.test "main() { int a; int b; a = 1; while (a < 10) a = a + 1; b = 1; while (b < 20) b = b + 2; return a + b; }", 31) - , (StatementEqual.test "main() { int a; a = 0; while (a); return 0; }", 0) - , (StatementEqual.test "main() { int a; int i; a = 0; i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; return a; }", 110) - , (StatementEqual.test "main() { int i; i = 0; for (; i <= 10;) i = i + 2; return i; }", 12) - , (StatementEqual.test "main() { int i; i = 0; for (; i <= 10; i = i + 2); return i; }", 12) - , (StatementEqual.test "main() { int a; int i; a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; return a; }", 0) - , (StatementEqual.test "main() { int a; int b; a = 1; b = 1; return a & b; }", 1) - , (StatementEqual.test "main() { int a; int b; a = 42; b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) return 1; return 0; }", 1) - , (StatementEqual.test "main() { return 1 | 0; }", 1) - , (StatementEqual.test "main() { int a; int b; a = 1; b = 0; return a & b ^ a | b; }", 1) -- Xor swap - , (StatementEqual.test "main() { int a; int i; a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; return a; }", 20) - , (StatementEqual.test "main() { int a; int i; a = 0; i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } return a; }", 0) - , (StatementEqual.test "main() { int a; a = 10; if (a) { a = a * a; a = a / 10; } return a; }", 10) - , (StatementEqual.test "main() { int a; a = 0; while (1) { if (a < 10) a = a + 1; else return a; } }", 10) - , (StatementEqual.test "main() { int a; a = 0; for (;;) { a = 42; return a; } return a; }", 42) - , (StatementEqual.test "main() { int a; a = 0; for (;;) { if (a < 10) a = a + 1; else return a; } }", 10) - , (LinkFuncRet.test "main() { int a; a = test_func1(); test_func1(); return a; }" ["test_func1"], 0) - , (LinkFuncRet.test "main() { return test_func2(40); }" ["test_func2"], 0) - , (LinkFuncRet.test "main() { return test_func5(1, 2); }" ["test_func5"], 3) - , (StatementEqual.test "f() { return 42; } main() { return f(); }", 42) - , (StatementEqual.test "g() { return 42; } f() { return g(); } main() { return f(); }", 42) - , (StatementEqual.test "id(int a) { return a; } main() { int a; a = 1; return id(a-1) + id(1); }", 1) - , (StatementEqual.test "get1() { return 1; } get2() { return 2; } main() { int a; a = get1(); return a + get2(); }", 3) - , (StatementEqual.test "add(int a, int b) { return a + b; } main() { return add(1, 2); }", 3) - , (StatementEqual.test "rec(int a) { if (a == 0) return 42; return rec(a - 1); } main() { int b; b = rec(2); return 1 + 2; }", 3) - , (StatementEqual.test "fib(int n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } main() { return fib(5); }", 8) -- fibonacci number - , (StatementEqual.test "main() { int a; int b; a = 42; b = &a; return a; }", 42) - , (StatementEqual.test "main() { int a; a = 42; return *&a; }", 42) + [ (StatementEqual.test "int main() { return 1+2; }", 3) + , (StatementEqual.test "int main() { return 1+2+4; }", 7) + , (StatementEqual.test "int main() { return 10-7+3; }", 6) + , (StatementEqual.test "int main() { return 42+23-30; }", 35) + , (StatementEqual.test "int main() { return 42/2+2-5; }", 18) + , (StatementEqual.test "int main() { return (3+5)/2; }", 4) + , (StatementEqual.test "int main() { return (4-2)*8+20/4; }",21) + , (StatementEqual.test "int main() { return -(-3*+5); }", 15) + , (StatementEqual.test "int main() { return -25+30; }", 5) + , (StatementEqual.test "int main() { return 42 == 42; }", 1) + , (StatementEqual.test "int main() { return 42 != 53; }", 1) + , (StatementEqual.test "int main() { return 42 < 53; }", 1) + , (StatementEqual.test "int main() { return 53 > 42; }", 1) + , (StatementEqual.test "int main() { return 42 <= 42; }", 1) + , (StatementEqual.test "int main() { return 32 <= 42; }", 1) + , (StatementEqual.test "int main() { return 42 >= 42; }", 1) + , (StatementEqual.test "int main() { return 53 >= 42; }", 1) + , (StatementEqual.test "int main() { return (1 + 1) == 2; }", 1) + , (StatementEqual.test "int main() { return (2 * 3) != 2; }", 1) + , (StatementEqual.test "int main() { return 1 || 0; }", 1) + , (StatementEqual.test "int main() { return (1 + 1) || 0 || 0; }", 1) + , (StatementEqual.test "int main() { return 0 || 0; }", 0) + , (StatementEqual.test "int main() { return 0 || (1 - 1); }", 0) + , (StatementEqual.test "int main() { return 2 || 1; }", 1) + , (StatementEqual.test "int main() { return 1 && 2; }", 1) + , (StatementEqual.test "int main() { return 2 && 3 && 4 && 0; }", 0) + , (StatementEqual.test "int main() { int a; a = 1; return a; }", 1) + , (StatementEqual.test "int main() { int a; int b; a = 42; b = 20; return a + b; }", 62) + , (StatementEqual.test "int main() { int a; int b; int c; a = 42; b = 20; c = 32; return (a - c) * b / 10; }", 20) + , (StatementEqual.test "int main() { int a; int b; a = 42; b = 20; return a - b; }", 22) + , (StatementEqual.test "int main() { int a; int returnb; a = 3; returnb = 5 * 6 - 8; return a + returnb / 2; }", 14) + , (StatementEqual.test "int main() { int a; int return_; a = 3; return_ = 5 * 6 - 8; return a + return_ / 2; }", 14) + , (StatementEqual.test "int main() { int a; int b; a /* comment */ = 3; b = 5 */*comment*/ 6 - 8; return a + b / 2; }", 14) + , (StatementEqual.test "int main() { if (1) return 42; return 53; }", 42) + , (StatementEqual.test "int main() { if (20*3-60) return 42; return 53; }", 53) + , (StatementEqual.test "int main() { int a; int b; a = 1; b = 2; if (a) return b; return 42; }", 2) + , (StatementEqual.test "int main() { if (1) return 42; else return 53; }", 42) + , (StatementEqual.test "int main() { if (0) return 42; else return 53; }", 53) + , (StatementEqual.test "int main() { int a; int b; a = 0; b = 2; if (a) return b; else return b * 2; }", 4) + , (StatementEqual.test "int main() { int a; int b; a = 1; b = 0; if (b) return 42; if (0) return 42; else return a; }", 1) + , (StatementEqual.test "int main() { int a; int b; a = 1; b = 2; if (a) if (b) return b; else return 53; else return 24; }", 2) + , (StatementEqual.test "int main() { if (1) if (1) if (1) if (1) if (1) if (0) return 1; else return 2; else return 3; else return 4; else return 5; else return 6; else return 7; }", 2) + , (StatementEqual.test "int main() { if(1)if(1)return 42;return 53; }", 42) + , (StatementEqual.test "int main() { if(0); return 0; }", 0) + , (StatementEqual.test "int main() { int a; a = 1; while (a < 10) a = a + 1; return a; }", 10) + , (StatementEqual.test "int main() { int a; int b; a = 1; while (a < 10) a = a + 1; b = 1; while (b < 20) b = b + 2; return a + b; }", 31) + , (StatementEqual.test "int main() { int a; a = 0; while (a); return 0; }", 0) + , (StatementEqual.test "int main() { int a; int i; a = 0; i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; return a; }", 110) + , (StatementEqual.test "int main() { int i; i = 0; for (; i <= 10;) i = i + 2; return i; }", 12) + , (StatementEqual.test "int main() { int i; i = 0; for (; i <= 10; i = i + 2); return i; }", 12) + , (StatementEqual.test "int main() { int a; int i; a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; return a; }", 0) + , (StatementEqual.test "int main() { int a; int b; a = 1; b = 1; return a & b; }", 1) + , (StatementEqual.test "int main() { int a; int b; a = 42; b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) return 1; return 0; }", 1) + , (StatementEqual.test "int main() { return 1 | 0; }", 1) + , (StatementEqual.test "int main() { int a; int b; a = 1; b = 0; return a & b ^ a | b; }", 1) -- Xor swap + , (StatementEqual.test "int main() { int a; int i; a = 0; i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; return a; }", 20) + , (StatementEqual.test "int main() { int a; int i; a = 0; i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } return a; }", 0) + , (StatementEqual.test "int main() { int a; a = 10; if (a) { a = a * a; a = a / 10; } return a; }", 10) + , (StatementEqual.test "int main() { int a; a = 0; while (1) { if (a < 10) a = a + 1; else return a; } }", 10) + , (StatementEqual.test "int main() { int a; a = 0; for (;;) { a = 42; return a; } return a; }", 42) + , (StatementEqual.test "int main() { int a; a = 0; for (;;) { if (a < 10) a = a + 1; else return a; } }", 10) + , (LinkFuncRet.test "int main() { int a; a = test_func1(); test_func1(); return a; }" ["test_func1"], 0) + , (LinkFuncRet.test "int main() { return test_func2(40); }" ["test_func2"], 0) + , (LinkFuncRet.test "int main() { return test_func5(1, 2); }" ["test_func5"], 3) + , (StatementEqual.test "int f() { return 42; } int main() { return f(); }", 42) + , (StatementEqual.test "int g() { return 42; } int f() { return g(); } int main() { return f(); }", 42) + , (StatementEqual.test "int id(int a) { return a; } int main() { int a; a = 1; return id(a-1) + id(1); }", 1) + , (StatementEqual.test "int get1() { return 1; } int get2() { return 2; } int main() { int a; a = get1(); return a + get2(); }", 3) + , (StatementEqual.test "int add(int a, int b) { return a + b; } int main() { return add(1, 2); }", 3) + , (StatementEqual.test "int rec(int a) { if (a == 0) return 42; return rec(a - 1); } int main() { int b; b = rec(2); return 1 + 2; }", 3) + , (StatementEqual.test "int fib(int n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } int main() { return fib(5); }", 8) -- fibonacci number + , (StatementEqual.test "int main() { int a; int b; a = 42; b = &a; return a; }", 42) + , (StatementEqual.test "int main() { int a; a = 42; return *&a; }", 42) ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ @@ -115,9 +115,9 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *ar; }", 1), (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *(ar + 1); }", 2), (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *(ar + 2); }", 3), - (StatementEqual.test "main() { int f(int* p) { *p = 42; return 0; } int main() { int a = 0; f(&a); return a; }", 42), + (StatementEqual.test "int main() { int f(int* p) { *p = 42; return 0; } int main() { int a = 0; f(&a); return a; }", 42), (StatementEqual.test "int main() { int ar[10]; int i = 0; for (; i < 10; i = i + 1) { *(ar + i) = i; } int sum = 0; for (i = 0; i < 10; i = i + 1) { sum = sum + *(ar + i); } return sum; }", 45), - (StatementEqual.test "main() { int sum(int* p, int n) { int sum = 0; int i = 0; for (; i < n; i = i + 1) sum = sum + *(p + i); return sum; } int main() { int ar[10]; int i = 0; for (; i < 10; i = i + 1) *(ar + i) = i; return sum(ar, 10); }", 45), + (StatementEqual.test "int main() { int sum(int* p, int n) { int sum = 0; int i = 0; for (; i < n; i = i + 1) sum = sum + *(p + i); return sum; } int main() { int ar[10]; int i = 0; for (; i < 10; i = i + 1) *(ar + i) = i; return sum(ar, 10); }", 45), (StatementEqual.test "int main() { int ar[2][3]; int sum = 0; int i = 0; for (; i < 2; i = i + 1) { int j = 0; for (; j < 3; j = j + 1) { *(*(ar + i) + j) = i + j; sum = sum + *(*(ar + i) + j); } } return sum; } ", 9), (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; *p = 42; return **ar; }", 42), (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; *(p + 1) = 42; return *(*ar + 1); }", 42), @@ -147,18 +147,18 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ (StatementEqual.test "int main() { int ar[3][5]; return sizeof **ar + 1; }", succ $ fromIntegral $ sizeof CT.CTInt), (StatementEqual.test "int main() { int ar[3][5]; return sizeof(**ar + 1); }", fromIntegral $ sizeof $ CT.CTLong CT.CTInt), (StatementEqual.test "int main() { int ar[2]; 2[ar] = 42; return ar[2]; }", 42), - (StatementEqual.test "main() { int g; int main() { return g; }", 0), - (StatementEqual.test "main() { int g; int main() { g = 42; return g; }", 42), - (StatementEqual.test "main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[0]; }", 1), - (StatementEqual.test "main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[1]; }", 2), - (StatementEqual.test "main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[2]; }", 3), + (StatementEqual.test "int main() { int g; int main() { return g; }", 0), + (StatementEqual.test "int main() { int g; int main() { g = 42; return g; }", 42), + (StatementEqual.test "int main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[0]; }", 1), + (StatementEqual.test "int main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[1]; }", 2), + (StatementEqual.test "int main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[2]; }", 3), (StatementEqual.test "int main() { char c = 1; return c; }", 1), (StatementEqual.test "int main() { char c1 = 1; char c2 = 2; return c1; }", 1), (StatementEqual.test "int main() { char c1 = 1; char c2 = 2; return c2; }", 2), (StatementEqual.test "int main() { char x; return sizeof x; }", 1), (StatementEqual.test "int main() { char ar[10]; return sizeof ar; }", fromIntegral $ sizeof $ CT.CTArray 10 CT.CTChar), - (StatementEqual.test "main() { int f(char a, char b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1), - (StatementEqual.test "main() { int f(char a, int b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1), + (StatementEqual.test "int main() { int f(char a, char b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1), + (StatementEqual.test "int main() { int f(char a, int b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1), (StatementEqual.test "int main() { return \"abc\"[0]; }", ord 'a'), (StatementEqual.test "int main() { return \"abc\"[1]; }", ord 'b'), (StatementEqual.test "int main() { return \"abc\"[2]; }", ord 'c'), @@ -188,7 +188,7 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ (StatementEqual.test "int main() { int a = 42; { a = 32; } return a; }", 32), (StatementEqual.test "int main() { int* ar[3]; int x; ar[0] = &x; x = 42; ar[0][0]; }", 42) ] >> runTestsEx [ - (LinkFuncStdOut.test "main() { int test_func1(); int main() { return test_func1(); }" ["test_func1"], Right "test/Tests/csrc/test_func1.c::test_func1(): [OK]"), - (LinkFuncStdOut.test "main() { int test_func2(); int main() { return test_func2(40); }" ["test_func2"], Right "test/Tests/csrc/test_func2.c::test_func2(40) outputs: \"2 3 5 7 11 13 17 19 23 29 31 37 \": [OK]"), + (LinkFuncStdOut.test "int main() { int test_func1(); int main() { return test_func1(); }" ["test_func1"], Right "test/Tests/csrc/test_func1.c::test_func1(): [OK]"), + (LinkFuncStdOut.test "int main() { int test_func2(); int main() { return test_func2(40); }" ["test_func2"], Right "test/Tests/csrc/test_func2.c::test_func2(40) outputs: \"2 3 5 7 11 13 17 19 23 29 31 37 \": [OK]"), ] -} From 996159402e638bf16b788f0442328029d2a090a2 Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 20 Dec 2020 19:38:51 +0900 Subject: [PATCH 16/51] Add pointer type --- app/Main.hs | 2 +- htcc.cabal | 3 +- src/Htcc/Parser/Combinators/Program.hs | 82 ++++++++++++-------------- src/Htcc/Parser/Combinators/Type.hs | 41 +++++++++++++ test/Tests/SubProcTests.hs | 8 ++- 5 files changed, 89 insertions(+), 47 deletions(-) create mode 100644 src/Htcc/Parser/Combinators/Type.hs diff --git a/app/Main.hs b/app/Main.hs index 60297ff..bde4ec3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -91,7 +91,7 @@ main = do txt <- T.readFile fname case runParser parser fname txt :: Either (M.ParseErrorBundle T.Text Void) (Warnings Integer, ASTs Integer, GlobalVars Integer, Literals Integer) of - Left x -> print x + Left x -> print x -- putStr $ M.errorBundlePretty x Right r -> runAsm' $ casm' (snd4 r) (thd4 r) (fou4 r) where runAsm' = SI.runAsm :: SI.Asm SI.AsmCodeCtx Integer a -> IO a diff --git a/htcc.cabal b/htcc.cabal index ff230e9..ef31bd2 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: b66e6a875f19a96fcebcd35b2b8fed0395cf7d04fb59c94b3fe72819dffd4521 +-- hash: 0a6f7ec02e3df248fd99bdf5c5994002b16d028dd5e733e0014a093970230942 name: htcc version: 0.0.0.1 @@ -75,6 +75,7 @@ library Htcc.Parser.Combinators.Core Htcc.Parser.Combinators.Keywords Htcc.Parser.Combinators.Program + Htcc.Parser.Combinators.Type Htcc.Parser.ConstructionData Htcc.Parser.ConstructionData.Core Htcc.Parser.ConstructionData.Scope diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index e15e314..3fb5c1e 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -24,8 +24,7 @@ import Control.Monad.Trans.State (get, gets, modify, import Data.Bits (Bits (..)) import Data.Either (rights) import Data.Functor ((<&>)) -import Data.Maybe (fromJust, - fromMaybe) +import Data.Maybe (fromJust) import qualified Data.Text as T import Htcc.CRules.Types as CT import Htcc.Parser.AST (Treealizable (..)) @@ -44,6 +43,7 @@ import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords +import Htcc.Parser.Combinators.Type (cType) import Htcc.Parser.ConstructionData (addFunction, addLVar, incomplete, @@ -59,24 +59,25 @@ import qualified Text.Megaparsec.Char as MC import Text.Megaparsec.Debug (dbg) -declIdent :: (Show i, Read i, Integral i) +declIdent :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i, T.Text) +declIdent = (,) <$> cType <*> identifier + +declIdent' :: (Show i, Read i, Integral i) => Parser i a -> Parser i (Either (CT.StorageClass i) (CT.StorageClass i, T.Text)) -declIdent sep = do +declIdent' sep = do ty <- cType choice [ Left ty <$ sep , Right . (ty, ) <$> identifier <* sep ] - where - cType = SCAuto . read . T.unpack <$> choice kBasicTypes registerLVar :: (Bits i, Integral i) => CT.StorageClass i -> T.Text -> Parser i (ATree i) -registerLVar ty ident = do - x <- lift $ gets $ addLVar ty (HT.TokenLCNums 1 1, HT.TKIdent ident) - case x of - Right (lat, scp') -> lift (lat <$ put scp') - Left err -> fail $ T.unpack $ fst err +registerLVar ty ident = + lift (gets $ addLVar ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) + >>= \case + Right (lat, scp') -> lift (lat <$ put scp') + Left err -> fail $ T.unpack $ fst err parser, program :: (Integral i, Bits i, Read i, Show i) => Parser i (ASTs i) parser = (spaceConsumer >> program) <* M.eof @@ -85,6 +86,7 @@ program = some global global, function, stmt, + lvarStmt, expr, assign, logicalOr, @@ -104,20 +106,17 @@ global = choice [ function ] -function = - declIdent (symbol "(") - >>= \case - Left _ -> fail "unexpected '(' token, expected an identifier" - Right (ty, ident) -> do - params <- takeParameters - lift $ modify resetLocal - choice - [ declaration ty ident - , definition ty ident params - ] +function = do + (ty, ident) <- declIdent <* symbol "(" + params <- takeParameters + lift $ modify resetLocal + choice + [ declaration ty ident + , definition ty ident params + ] where takeParameters = - M.manyTill (M.try (declIdent comma) M.<|> (declIdent $ M.lookAhead (symbol ")"))) (symbol ")") + M.manyTill (M.try (declIdent' comma) M.<|> (declIdent' $ M.lookAhead (symbol ")"))) (symbol ")") declaration ty ident = void semi @@ -136,6 +135,11 @@ function = atDefFunc ident (if null params' then Nothing else Just params') ty <$> stmt Left err -> fail $ T.unpack $ fst err +lvarStmt = choice + [ ATEmpty <$ M.try (cType <* semi) + , declIdent <* semi >>= fmap atNull . uncurry registerLVar + ] + stmt = choice [ returnStmt , ifStmt @@ -173,9 +177,6 @@ stmt = choice compoundStmt = atBlock <$> braces (M.many stmt) - lvarStmt = declIdent semi - >>= either (const $ return ATEmpty) (fmap atNull . uncurry registerLVar) - expr = assign assign = do @@ -227,10 +228,6 @@ unary = choice deref' :: Ord i => ATree i -> Parser i (ATree i) deref' = runMaybeT . deref'' >=> maybe M.empty pure - deref'' :: Ord i => ATree i -> MaybeT (Parser i) (ATree i) - deref'' n = lift $ pure $ atUnary ATDeref (CT.SCAuto CT.CTInt) n - - {- After implementing the type, use: deref'' n = do ty <- MaybeT $ pure (CT.deref $ atype n) case CT.toTypeKind ty of @@ -239,7 +236,6 @@ unary = choice scp <- lift $ lift get ty' <- MaybeT $ pure (incomplete ty scp) lift $ pure $ atUnary ATDeref ty' n - -} factor = choice [ atNumLit <$> natural @@ -256,20 +252,18 @@ identifier' = do ] where variable ident = do - lookupResult <- lift $ gets $ lookupVar ident - case lookupResult of - FoundGVar (PV.GVar t _) -> return $ atGVar t ident - FoundLVar sct -> return $ treealize sct - FoundEnum sct -> return $ treealize sct - NotFound -> fail $ "The '" <> T.unpack ident <> "' is not defined identifier" + lift (gets $ lookupVar ident) + >>= \case + FoundGVar (PV.GVar t _) -> return $ atGVar t ident + FoundLVar sct -> return $ treealize sct + FoundEnum sct -> return $ treealize sct + NotFound -> fail $ "The '" <> T.unpack ident <> "' is not defined identifier" fnCall ident = do params <- symbol "(" >> M.manyTill (M.try (expr <* comma) M.<|> expr) (symbol ")") let params' = if null params then Nothing else Just params - lift $ do - scp <- get - return $ case lookupFunction ident scp of - -- TODO: set warning message - -- TODO: Infer the return type of a function - Nothing -> atNoLeaf (ATCallFunc ident params') (CT.SCAuto CT.CTInt) - Just fn -> atNoLeaf (ATCallFunc ident params') (PSF.fntype fn) + lift (gets $ lookupFunction ident) <&> \case + -- TODO: set warning message + -- TODO: Infer the return type of a function + Nothing -> atNoLeaf (ATCallFunc ident params') (CT.SCAuto CT.CTInt) + Just fn -> atNoLeaf (ATCallFunc ident params') (PSF.fntype fn) diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs new file mode 100644 index 0000000..000573e --- /dev/null +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -0,0 +1,41 @@ +{-| +Module : Htcc.Parser.Combinators.Type +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +{-# LANGUAGE OverloadedStrings #-} +module Htcc.Parser.Combinators.Type ( + cType +) where +import Control.Monad.Combinators (choice) +import qualified Data.Text as T +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.Keywords +import Htcc.Utils (toNatural) +import qualified Text.Megaparsec as M + + +preType, cType :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) +preType = choice + [ kStatic >> (CT.SCStatic . CT.toTypeKind <$> preType) + , kRegister >> (CT.SCRegister . CT.toTypeKind <$> preType) + , kAuto >> preType + , CT.SCAuto . CT.toTypeKind . CT.implicitInt . read' . T.unpack + <$> choice kBasicTypes + ] + where + read' :: (Show i, Read i, Integral i) + => String + -> CT.TypeKind i + read' = read + +cType = flip id + <$> preType + <*> (CT.ctorPtr . toNatural . length <$> M.many (symbol "*")) diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 4174d7b..e17d3bb 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -86,8 +86,14 @@ exec = runTestsEx , (StatementEqual.test "int add(int a, int b) { return a + b; } int main() { return add(1, 2); }", 3) , (StatementEqual.test "int rec(int a) { if (a == 0) return 42; return rec(a - 1); } int main() { int b; b = rec(2); return 1 + 2; }", 3) , (StatementEqual.test "int fib(int n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } int main() { return fib(5); }", 8) -- fibonacci number - , (StatementEqual.test "int main() { int a; int b; a = 42; b = &a; return a; }", 42) + , (StatementEqual.test "int main() { int a; int* b; a = 42; b = &a; return a; }", 42) , (StatementEqual.test "int main() { int a; a = 42; return *&a; }", 42) + , (StatementEqual.test "int f(int) { return 42; } int main() { int; int a; a = f(0); return a; }", 42) + , (StatementEqual.test "int main() { int a; a = 42; int* b; b = &a; int** c; c = &b; return **c; }", 42) + , (StatementEqual.test "int main() { int a; a = 42; int* b; b = &a; *b = a * 2; return a; }", 84) + --, (StatementEqual.test "int main() { int a; a = 42; int b; b = 5; return *(&b+1); }", 42) + --, (StatementEqual.test "int main() { int a; a = 42; int b; b = 5; *(&a-1) = 53; return b; }", 53) + -- , (StatementEqual.test "int main() { int a = 42; int b = 5; *(&b+1) = 53; return a; }", 53) ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ From 1c8baebb55e7acfb500f984b4ed884df90960dde Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 20 Dec 2020 20:05:41 +0900 Subject: [PATCH 17/51] Add pointer calculation --- src/Htcc/Parser/Combinators/Program.hs | 6 +++--- src/Htcc/Parser/Combinators/Type.hs | 7 ++++--- test/Tests/SubProcTests.hs | 13 ++++--------- 3 files changed, 11 insertions(+), 15 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 3fb5c1e..f280e40 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -27,7 +27,7 @@ import Data.Functor ((<&>)) import Data.Maybe (fromJust) import qualified Data.Text as T import Htcc.CRules.Types as CT -import Htcc.Parser.AST (Treealizable (..)) +import Htcc.Parser.AST (Treealizable (..), addKind, subKind) import Htcc.Parser.AST.Core (ATKind (..), ATKindFor (..), ATree (..), @@ -205,8 +205,8 @@ relational = binaryOperator add ] add = binaryOperator term - [ (symbol "+", binOpCon ATAdd) - , (symbol "-", binOpCon ATSub) + [ (symbol "+", \l r -> maybe (fail "invalid operands") pure $ addKind l r) + , (symbol "-", \l r -> maybe (fail "invalid operands") pure $ subKind l r) ] term = binaryOperator unary diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs index 000573e..f267e13 100644 --- a/src/Htcc/Parser/Combinators/Type.hs +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -36,6 +36,7 @@ preType = choice -> CT.TypeKind i read' = read -cType = flip id - <$> preType - <*> (CT.ctorPtr . toNatural . length <$> M.many (symbol "*")) +cType = do + pt <- preType + fn <- CT.ctorPtr . toNatural . length <$> M.many (symbol "*") + pure $ fn pt diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index e17d3bb..8fdc0cd 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -91,9 +91,10 @@ exec = runTestsEx , (StatementEqual.test "int f(int) { return 42; } int main() { int; int a; a = f(0); return a; }", 42) , (StatementEqual.test "int main() { int a; a = 42; int* b; b = &a; int** c; c = &b; return **c; }", 42) , (StatementEqual.test "int main() { int a; a = 42; int* b; b = &a; *b = a * 2; return a; }", 84) - --, (StatementEqual.test "int main() { int a; a = 42; int b; b = 5; return *(&b+1); }", 42) - --, (StatementEqual.test "int main() { int a; a = 42; int b; b = 5; *(&a-1) = 53; return b; }", 53) - -- , (StatementEqual.test "int main() { int a = 42; int b = 5; *(&b+1) = 53; return a; }", 53) + , (StatementEqual.test "int main() { int a; a = 42; int b; b = 5; return *(&b+1); }", 42) + , (StatementEqual.test "int main() { int a; a = 42; int b; b = 5; *(&a-1) = 53; return b; }", 53) + , (StatementEqual.test "int main() { int a; a = 42; int b; b = 5; *(&b+1) = 53; return a; }", 53) + , (StatementEqual.test "int main() { int sum; sum = 0; int i; i = 1; for (; i < 4; i = i + 1) sum = sum + i; return sum; }", 6) ] {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ @@ -109,12 +110,6 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ -- (LinkFuncRet.test "int main() { return sum7(1, 1, 1, 1, 1, 1, 1); }" ["test_func3"], 7), -- (LinkFuncRet.test "int main() { return test_func2(sum7(1, 2, 3, 4, 5, 6, 7)); }" ["test_func2", "test_func3"], 0), -- (LinkFuncRet.test "int main() { return sum16(1,1,1,1,1,1,11,10,9,8,7,6,5,4,3,2); }" ["test_func3"], 11), - (StatementEqual.test "int main() { int a = 42; int* b = &a; int** c = &b; return **c; }", 42), - (StatementEqual.test "int main() { int a = 42; int* b = &a; *b = a * 2; return a; }", 84), - (StatementEqual.test "int main() { int a = 42; int b = 5; return *(&b+1); }", 42), - (StatementEqual.test "int main() { int a = 42; int b = 5; *(&a-1) = 53; return b; }", 53), - (StatementEqual.test "int main() { int a = 42; int b = 5; *(&b+1) = 53; return a; }", 53), - (StatementEqual.test "int main() { int sum = 0; int i = 1; for (; i < 4; i = i + 1) sum = sum + i; return sum; }", 6), (StatementEqual.test "int main() { int ar[2]; int* p = ar; *p = 3; return *ar; }", 3), (StatementEqual.test "int main() { int ar[2]; int* p = ar; *(p + 1) = 3; return *(ar + 1); }", 3), (StatementEqual.test "int main() { int ar[2]; int* p = ar; *p = 2; *(p + 1) = 3; return *ar + *(ar + 1); }", 5), From 1fce7acb3277d776b5bff6918e79437e624d7673 Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 20 Dec 2020 20:30:53 +0900 Subject: [PATCH 18/51] Add sizeof --- src/Htcc/Parser/Combinators/Program.hs | 11 ++++++++++- test/Tests/SubProcTests.hs | 6 ++++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index f280e40..749a549 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -26,7 +26,7 @@ import Data.Either (rights) import Data.Functor ((<&>)) import Data.Maybe (fromJust) import qualified Data.Text as T -import Htcc.CRules.Types as CT +import qualified Htcc.CRules.Types as CT import Htcc.Parser.AST (Treealizable (..), addKind, subKind) import Htcc.Parser.AST.Core (ATKind (..), ATKindFor (..), @@ -100,6 +100,7 @@ global, term, unary, factor, + sizeof, identifier' :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) global = choice @@ -239,11 +240,19 @@ unary = choice factor = choice [ atNumLit <$> natural + , sizeof , identifier' , parens expr , ATEmpty <$ M.eof ] +sizeof = kSizeof >> choice + [ incomplete <$> M.try (parens cType) <*> lift get + >>= maybe (fail "invalid application of 'sizeof' to incomplete type") + (pure . atNumLit . fromIntegral . CT.sizeof) + , atNumLit . fromIntegral . CT.sizeof . atype <$> unary + ] + identifier' = do ident <- identifier choice diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 8fdc0cd..331c035 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -95,7 +95,13 @@ exec = runTestsEx , (StatementEqual.test "int main() { int a; a = 42; int b; b = 5; *(&a-1) = 53; return b; }", 53) , (StatementEqual.test "int main() { int a; a = 42; int b; b = 5; *(&b+1) = 53; return a; }", 53) , (StatementEqual.test "int main() { int sum; sum = 0; int i; i = 1; for (; i < 4; i = i + 1) sum = sum + i; return sum; }", 6) + , (StatementEqual.test "int main() { int a; return sizeof(a); }", fromIntegral $ sizeof CT.CTInt) + , (StatementEqual.test "int main() { int a; return sizeof a; }", fromIntegral $ sizeof CT.CTInt) + , (StatementEqual.test "int main() { int* p; return sizeof p; }", fromIntegral $ sizeof $ CT.CTPtr CT.CTInt) + , (StatementEqual.test "int main() { return sizeof(int); }", fromIntegral $ sizeof CT.CTInt) ] + where + sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ (StatementEqual.test "int main() { return !0; }", 1), From 22f202c26fbc15bcfee5b7bee3417d02dd62ade1 Mon Sep 17 00:00:00 2001 From: roki Date: Wed, 23 Dec 2020 04:10:41 +0900 Subject: [PATCH 19/51] Allowed parsing of array declarations with number of elements --- src/Htcc/Parser/Combinators/Program.hs | 38 +++++++++---- src/Htcc/Parser/Combinators/Program.hs-boot | 7 +++ src/Htcc/Parser/Combinators/Type.hs | 61 ++++++++++++++++++++- test/Tests/SubProcTests.hs | 4 ++ 4 files changed, 97 insertions(+), 13 deletions(-) create mode 100644 src/Htcc/Parser/Combinators/Program.hs-boot diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 749a549..c9b821d 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -12,6 +12,7 @@ C language lexer {-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings, TupleSections #-} module Htcc.Parser.Combinators.Program ( parser + , logicalOr ) where import Control.Monad (forM, void, (>=>)) @@ -24,10 +25,12 @@ import Control.Monad.Trans.State (get, gets, modify, import Data.Bits (Bits (..)) import Data.Either (rights) import Data.Functor ((<&>)) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, + fromMaybe) import qualified Data.Text as T import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST (Treealizable (..), addKind, subKind) +import Htcc.Parser.AST (Treealizable (..), + addKind, subKind) import Htcc.Parser.AST.Core (ATKind (..), ATKindFor (..), ATree (..), @@ -43,7 +46,8 @@ import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords -import Htcc.Parser.Combinators.Type (cType) +import Htcc.Parser.Combinators.Type (arraySuffix, + cType) import Htcc.Parser.ConstructionData (addFunction, addLVar, incomplete, @@ -59,18 +63,28 @@ import qualified Text.Megaparsec.Char as MC import Text.Megaparsec.Debug (dbg) -declIdent :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i, T.Text) -declIdent = (,) <$> cType <*> identifier +declIdent :: (Show i, Read i, Bits i, Integral i) => Parser i (CT.StorageClass i, T.Text) +declIdent = do + ty <- cType + ident <- identifier + (,ident) <$> M.option ty (arraySuffix ty) -declIdent' :: (Show i, Read i, Integral i) +declIdentFuncArg :: (Show i, Read i, Bits i, Integral i) => Parser i a -> Parser i (Either (CT.StorageClass i) (CT.StorageClass i, T.Text)) -declIdent' sep = do +declIdentFuncArg sep = do ty <- cType - choice - [ Left ty <$ sep - , Right . (ty, ) <$> identifier <* sep - ] + anonymousArg ty M.<|> namedArg ty + where + anonymousArg ty = Left <$> M.option ty (arraySuffix ty) <* sep + namedArg ty = do + ident <- identifier + Right . (,ident) <$> M.option ty (narrowPtr <$> arraySuffix ty) <* sep + + narrowPtr ty + | CT.isCTArray ty = fromMaybe ty $ CT.mapTypeKind CT.CTPtr <$> CT.deref ty + | CT.isIncompleteArray ty = + CT.mapTypeKind (\(CT.CTIncomplete (CT.IncompleteArray t')) -> CT.CTPtr t') ty registerLVar :: (Bits i, Integral i) => CT.StorageClass i -> T.Text -> Parser i (ATree i) registerLVar ty ident = @@ -117,7 +131,7 @@ function = do ] where takeParameters = - M.manyTill (M.try (declIdent' comma) M.<|> (declIdent' $ M.lookAhead (symbol ")"))) (symbol ")") + M.manyTill (M.try (declIdentFuncArg comma) M.<|> (declIdentFuncArg $ M.lookAhead (symbol ")"))) (symbol ")") declaration ty ident = void semi diff --git a/src/Htcc/Parser/Combinators/Program.hs-boot b/src/Htcc/Parser/Combinators/Program.hs-boot new file mode 100644 index 0000000..f5c1988 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Program.hs-boot @@ -0,0 +1,7 @@ +module Htcc.Parser.Combinators.Program where + +import Data.Bits (Bits) +import Htcc.Parser.AST (ATree) +import Htcc.Parser.Combinators.Core (Parser) + +logicalOr :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs index f267e13..8b38b22 100644 --- a/src/Htcc/Parser/Combinators/Type.hs +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -12,17 +12,76 @@ C language parser Combinators {-# LANGUAGE OverloadedStrings #-} module Htcc.Parser.Combinators.Type ( cType + , arraySuffix ) where import Control.Monad.Combinators (choice) +import Data.Bits (Bits (..)) +import Data.Bool (bool) import qualified Data.Text as T import qualified Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATKind (..), ATree (..)) import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords +import {-# SOURCE #-} Htcc.Parser.Combinators.Program (logicalOr) import Htcc.Utils (toNatural) import qualified Text.Megaparsec as M +constantExp :: (Bits i, Integral i, Show i, Read i) => Parser i i +constantExp = logicalOr >>= constantExp' + where + fromBool = fromIntegral . fromEnum :: Num i => Bool -> i + toBool x | x == 0 = False | otherwise = True + + constantExp' (ATNode k _ lhs rhs) = case k of + ATAdd -> binop (+) + ATSub -> binop (-) + ATMul -> binop (*) + ATDiv -> binop div + ATAnd -> binop (.&.) + ATXor -> binop xor + ATOr -> binop (.|.) + ATShl -> binop (flip (.) fromIntegral . shiftL) + ATShr -> binop (flip (.) fromIntegral . shiftR) + ATEQ -> binop ((.) fromBool . (==)) + ATNEQ -> binop ((.) fromBool . (/=)) + ATLT -> binop ((.) fromBool . (<)) + ATGT -> binop ((.) fromBool . (>)) + ATLEQ -> binop ((.) fromBool . (<=)) + ATGEQ -> binop ((.) fromBool . (>=)) + ATConditional cn th el -> constantExp' cn + >>= bool (constantExp' el) (constantExp' th) . toBool + ATComma -> constantExp' rhs + ATNot -> fromIntegral . fromEnum . not . toBool <$> constantExp' lhs + ATBitNot -> complement <$> constantExp' lhs + ATLAnd -> binop ((.) fromBool . flip (.) toBool . (&&) . toBool) + ATOr -> binop ((.) fromBool . flip (.) toBool . (||) . toBool) + ATNum v -> pure v + _ -> fail "The expression is not constant-expression" + where + binop f = constantExp' lhs + >>= \lhs' -> fromIntegral . f lhs' <$> constantExp' rhs + constantExp' ATEmpty = fail "The expression is not constant-expression" + +arraySuffix :: (Show i, Read i, Bits i, Integral i) + => CT.StorageClass i + -> Parser i (CT.StorageClass i) +arraySuffix ty = choice + [ withConstantExp + ] + where + withConstantExp = do + val <- M.try (brackets constantExp) + M.option (CT.mapTypeKind (CT.CTArray (toNatural val)) ty) $ do + ty' <- arraySuffix ty + case CT.concatCTArray (CT.mapTypeKind (CT.CTArray (toNatural val)) ty) ty' of + Nothing -> fail $ show ty' + Just ty'' + | CT.isValidIncomplete ty'' -> pure ty'' + | otherwise -> fail $ show ty' + +preType, + cType :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) -preType, cType :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) preType = choice [ kStatic >> (CT.SCStatic . CT.toTypeKind <$> preType) , kRegister >> (CT.SCRegister . CT.toTypeKind <$> preType) diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 331c035..1fc2928 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -99,6 +99,10 @@ exec = runTestsEx , (StatementEqual.test "int main() { int a; return sizeof a; }", fromIntegral $ sizeof CT.CTInt) , (StatementEqual.test "int main() { int* p; return sizeof p; }", fromIntegral $ sizeof $ CT.CTPtr CT.CTInt) , (StatementEqual.test "int main() { return sizeof(int); }", fromIntegral $ sizeof CT.CTInt) + , (StatementEqual.test "int main() { int ar[10]; return 0; }", 0) + , (StatementEqual.test "int main() { int ar[1+2/1]; return 0; }", 0) + , (StatementEqual.test "int f(int[10]) { return 42; } int main() { int ar[10]; return f(ar); }", 42) + , (StatementEqual.test "int f(int ar[10]) { return 42; } int main() { int ar[10]; return f(ar); }", 42) ] where sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural From f73091f399508d009f3c382f98c806acd3b61794 Mon Sep 17 00:00:00 2001 From: roki Date: Wed, 23 Dec 2020 04:28:45 +0900 Subject: [PATCH 20/51] Add an array test --- src/Htcc/Parser/Combinators/Program.hs | 1 + src/Htcc/Parser/Combinators/Type.hs | 2 +- test/Tests/SubProcTests.hs | 3 ++- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index c9b821d..dceaadc 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -85,6 +85,7 @@ declIdentFuncArg sep = do | CT.isCTArray ty = fromMaybe ty $ CT.mapTypeKind CT.CTPtr <$> CT.deref ty | CT.isIncompleteArray ty = CT.mapTypeKind (\(CT.CTIncomplete (CT.IncompleteArray t')) -> CT.CTPtr t') ty + | otherwise = ty registerLVar :: (Bits i, Integral i) => CT.StorageClass i -> T.Text -> Parser i (ATree i) registerLVar ty ident = diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs index 8b38b22..4a48d61 100644 --- a/src/Htcc/Parser/Combinators/Type.hs +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -54,7 +54,7 @@ constantExp = logicalOr >>= constantExp' ATNot -> fromIntegral . fromEnum . not . toBool <$> constantExp' lhs ATBitNot -> complement <$> constantExp' lhs ATLAnd -> binop ((.) fromBool . flip (.) toBool . (&&) . toBool) - ATOr -> binop ((.) fromBool . flip (.) toBool . (||) . toBool) + ATLOr -> binop ((.) fromBool . flip (.) toBool . (||) . toBool) ATNum v -> pure v _ -> fail "The expression is not constant-expression" where diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 1fc2928..12fdc7a 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -101,8 +101,10 @@ exec = runTestsEx , (StatementEqual.test "int main() { return sizeof(int); }", fromIntegral $ sizeof CT.CTInt) , (StatementEqual.test "int main() { int ar[10]; return 0; }", 0) , (StatementEqual.test "int main() { int ar[1+2/1]; return 0; }", 0) + , (StatementEqual.test "int main() { int ar[10][1+2/1]; return 0; }", 0) , (StatementEqual.test "int f(int[10]) { return 42; } int main() { int ar[10]; return f(ar); }", 42) , (StatementEqual.test "int f(int ar[10]) { return 42; } int main() { int ar[10]; return f(ar); }", 42) + , (StatementEqual.test "int main() { int ar[2]; int* p; p = ar; *p = 3; return *ar; }", 3) ] where sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural @@ -120,7 +122,6 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ -- (LinkFuncRet.test "int main() { return sum7(1, 1, 1, 1, 1, 1, 1); }" ["test_func3"], 7), -- (LinkFuncRet.test "int main() { return test_func2(sum7(1, 2, 3, 4, 5, 6, 7)); }" ["test_func2", "test_func3"], 0), -- (LinkFuncRet.test "int main() { return sum16(1,1,1,1,1,1,11,10,9,8,7,6,5,4,3,2); }" ["test_func3"], 11), - (StatementEqual.test "int main() { int ar[2]; int* p = ar; *p = 3; return *ar; }", 3), (StatementEqual.test "int main() { int ar[2]; int* p = ar; *(p + 1) = 3; return *(ar + 1); }", 3), (StatementEqual.test "int main() { int ar[2]; int* p = ar; *p = 2; *(p + 1) = 3; return *ar + *(ar + 1); }", 5), (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *ar; }", 1), From a4e61fe5301fdb9f068d42b0480a034986a16c58 Mon Sep 17 00:00:00 2001 From: roki Date: Fri, 25 Dec 2020 04:23:25 +0900 Subject: [PATCH 21/51] Add incomplete array type parser --- src/Htcc/Parser/Combinators/Type.hs | 43 +++++++++++++++++++++++------ 1 file changed, 34 insertions(+), 9 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs index 4a48d61..9bf8b3a 100644 --- a/src/Htcc/Parser/Combinators/Type.hs +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -9,20 +9,27 @@ Portability : POSIX C language parser Combinators -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase, OverloadedStrings #-} module Htcc.Parser.Combinators.Type ( cType , arraySuffix ) where +import Control.Monad (mfilter, void) import Control.Monad.Combinators (choice) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Control.Monad.Trans.State (gets) import Data.Bits (Bits (..)) import Data.Bool (bool) +import Data.Maybe (fromJust) import qualified Data.Text as T +import Data.Tuple.Extra (dupe, first) import qualified Htcc.CRules.Types as CT import Htcc.Parser.AST.Core (ATKind (..), ATree (..)) import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords import {-# SOURCE #-} Htcc.Parser.Combinators.Program (logicalOr) +import Htcc.Parser.ConstructionData (incomplete) import Htcc.Utils (toNatural) import qualified Text.Megaparsec as M @@ -67,17 +74,35 @@ arraySuffix :: (Show i, Read i, Bits i, Integral i) -> Parser i (CT.StorageClass i) arraySuffix ty = choice [ withConstantExp + , nonConstantExp ] where + failWithTypeMaybe ty' = maybe (fail $ show ty') pure + withConstantExp = do - val <- M.try (brackets constantExp) - M.option (CT.mapTypeKind (CT.CTArray (toNatural val)) ty) $ do - ty' <- arraySuffix ty - case CT.concatCTArray (CT.mapTypeKind (CT.CTArray (toNatural val)) ty) ty' of - Nothing -> fail $ show ty' - Just ty'' - | CT.isValidIncomplete ty'' -> pure ty'' - | otherwise -> fail $ show ty' + arty <- flip id ty . CT.mapTypeKind . CT.CTArray . toNatural <$> M.try (brackets constantExp) + M.option Nothing (Just <$> arraySuffix ty) + >>= \case + Nothing -> pure arty + Just ty' -> + runMaybeT (mfilter CT.isValidIncomplete $ MaybeT $ pure $ CT.concatCTArray arty ty') + >>= failWithTypeMaybe ty' + + nonConstantExp = let mtIncomplete ty' = MaybeT $ lift $ gets $ incomplete ty' in + void (brackets M.eof) + >> M.option Nothing (Just <$> arraySuffix ty) + >>= \case + Nothing -> + runMaybeT (CT.mapTypeKind (CT.CTIncomplete . CT.IncompleteArray) <$> mtIncomplete ty) + >>= failWithTypeMaybe ty + Just ty' -> + runMaybeT (multiple <$> mtIncomplete ty') + >>= failWithTypeMaybe ty' + where + multiple = CT.mapTypeKind $ + uncurry ((.) fromJust . CT.concatCTArray) + . first (CT.CTIncomplete . CT.IncompleteArray . CT.removeAllExtents) + . dupe preType, cType :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) From 2a83c860776d1747cf3e18490d2da27c48b30407 Mon Sep 17 00:00:00 2001 From: roki Date: Sat, 26 Dec 2020 16:24:30 +0900 Subject: [PATCH 22/51] Add index access --- src/Htcc/Parser/Combinators/Program.hs | 41 +++++++++----- src/Htcc/Parser/Combinators/Type.hs | 4 +- test/Tests/SubProcTests.hs | 74 +++++++++++++------------- 3 files changed, 66 insertions(+), 53 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index dceaadc..bc3f3c1 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -234,24 +234,37 @@ term = binaryOperator unary unary = choice [ symbol "+" >> factor , symbol "-" >> factor <&> \n -> ATNode ATSub (atype n) (atNumLit 0) n - , MC.char '&' `notFollowedOp` MC.char '&' >> unary <&> \n -> - let ty = if CT.isArray (atype n) then fromJust $ CT.deref $ atype n else atype n in - atUnary ATAddr (CT.mapTypeKind CT.CTPtr ty) n + , addr , symbol "*" >> unary >>= deref' - , factor + , factor' ] where - deref' :: Ord i => ATree i -> Parser i (ATree i) - deref' = runMaybeT . deref'' >=> maybe M.empty pure + addr = MC.char '&' `notFollowedOp` MC.char '&' >> unary <&> \n -> + let ty = if CT.isArray (atype n) then fromJust $ CT.deref $ atype n else atype n in + atUnary ATAddr (CT.mapTypeKind CT.CTPtr ty) n + + factor' = factor >>= allAcc + where + allAcc fac = M.option fac $ choice + [ idxAcc fac + ] - deref'' n = do - ty <- MaybeT $ pure (CT.deref $ atype n) - case CT.toTypeKind ty of - CT.CTVoid -> lift $ fail "void value not ignored as it ought to be" - _ -> do - scp <- lift $ lift get - ty' <- MaybeT $ pure (incomplete ty scp) - lift $ pure $ atUnary ATDeref ty' n + idxAcc fac = do + idx <- brackets expr + kt <- maybe (fail "invalid operands") pure (addKind fac idx) + ty <- maybe (fail "subscripted value is neither array nor pointer nor vector") pure + $ CT.deref $ atype kt + ty' <- maybe (fail "incomplete value dereference") pure =<< lift (gets $ incomplete ty) + allAcc $ atUnary ATDeref ty' kt + + deref' = runMaybeT . deref'' >=> maybe M.empty pure + where + deref'' n = do + ty <- MaybeT $ pure (CT.deref $ atype n) + case CT.toTypeKind ty of + CT.CTVoid -> lift $ fail "void value not ignored as it ought to be" + _ -> MaybeT (lift $ gets $ incomplete ty) + >>= lift . pure . flip (atUnary ATDeref) n factor = choice [ atNumLit <$> natural diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs index 9bf8b3a..f8008ef 100644 --- a/src/Htcc/Parser/Combinators/Type.hs +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -14,7 +14,7 @@ module Htcc.Parser.Combinators.Type ( cType , arraySuffix ) where -import Control.Monad (mfilter, void) +import Control.Monad (mfilter) import Control.Monad.Combinators (choice) import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) @@ -89,7 +89,7 @@ arraySuffix ty = choice >>= failWithTypeMaybe ty' nonConstantExp = let mtIncomplete ty' = MaybeT $ lift $ gets $ incomplete ty' in - void (brackets M.eof) + brackets M.eof >> M.option Nothing (Just <$> arraySuffix ty) >>= \case Nothing -> diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 12fdc7a..87908dd 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -105,6 +105,43 @@ exec = runTestsEx , (StatementEqual.test "int f(int[10]) { return 42; } int main() { int ar[10]; return f(ar); }", 42) , (StatementEqual.test "int f(int ar[10]) { return 42; } int main() { int ar[10]; return f(ar); }", 42) , (StatementEqual.test "int main() { int ar[2]; int* p; p = ar; *p = 3; return *ar; }", 3) + , (StatementEqual.test "int main() { int ar[2]; int* p; p = ar; *(p + 1) = 3; return *(ar + 1); }", 3) + , (StatementEqual.test "int main() { int ar[2]; int* p; p = ar; *p = 2; *(p + 1) = 3; return *ar + *(ar + 1); }", 5) + , (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *ar; }", 1) + , (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *(ar + 1); }", 2) + , (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *(ar + 2); }", 3) + , (StatementEqual.test "int f(int* p) { *p = 42; return 0; } int main() { int a; a = 0; f(&a); return a; }", 42) + , (StatementEqual.test "int main() { int ar[10]; int i; i = 0; for (; i < 10; i = i + 1) { *(ar + i) = i; } int sum; sum = 0; for (i = 0; i < 10; i = i + 1) { sum = sum + *(ar + i); } return sum; }", 45) + , (StatementEqual.test "int sum(int* p, int n) { int sum; sum = 0; int i; i = 0; for (; i < n; i = i + 1) sum = sum + *(p + i); return sum; } int main() { int ar[10]; int i; i = 0; for (; i < 10; i = i + 1) *(ar + i) = i; return sum(ar, 10); }", 45) + , (StatementEqual.test "int main() { int ar[2][3]; int sum; sum = 0; int i; i = 0; for (; i < 2; i = i + 1) { int j; j = 0; for (; j < 3; j = j + 1) { *(*(ar + i) + j) = i + j; sum = sum + *(*(ar + i) + j); } } return sum; } ", 9) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; *p = 42; return **ar; }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; *(p + 1) = 42; return *(*ar + 1); }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; *(p + 2) = 42; return *(*ar + 2); }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; *(p + 3) = 42; return **(ar + 1); }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; *(p + 4) = 42; return *(*(ar + 1) + 1); }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; *(p + 5) = 42; return *(*(ar + 1) + 2); }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; *(p + 6) = 42; return **(ar + 2); }", 42) + , (StatementEqual.test "int main() { int ar[3]; int i; i = 0; for (; i < 3; i = i + 1) ar[i] = i; return ar[0]; }", 0) + , (StatementEqual.test "int main() { int ar[3]; int i; i = 0; for (; i < 3; i = i + 1) ar[i] = i; return ar[1]; }", 1) + , (StatementEqual.test "int main() { int ar[3]; int i; i = 0; for (; i < 3; i = i + 1) ar[i] = i; return ar[2]; }", 2) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; p[0] = 42; return ar[0][0]; }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; p[1] = 42; return ar[0][1]; }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; p[2] = 42; return ar[0][2]; }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; p[3] = 42; return ar[1][0]; }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; p[4] = 42; return ar[1][1]; }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; p[5] = 42; return ar[1][2]; }", 42) + , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; p[6] = 42; return ar[2][0]; }", 42) + , (StatementEqual.test "int main() { int a; return sizeof(a); }", fromIntegral $ sizeof CT.CTInt) + , (StatementEqual.test "int main() { int a; return sizeof a; }", fromIntegral $ sizeof CT.CTInt) + , (StatementEqual.test "int main() { int* p; return sizeof p; }", fromIntegral $ sizeof $ CT.CTPtr CT.CTInt) + , (StatementEqual.test "int main() { int ar[3]; return sizeof ar; }", fromIntegral $ sizeof $ CT.CTArray 3 CT.CTInt) + , (StatementEqual.test "int main() { int ar[3][5]; return sizeof ar; }", fromIntegral $ sizeof $ CT.CTArray 5 $ CT.CTArray 3 CT.CTInt) + , (StatementEqual.test "int main() { int ar[3][5]; return sizeof *ar; }", fromIntegral $ sizeof $ CT.CTArray 5 CT.CTInt) + , (StatementEqual.test "int main() { int ar[3][5]; return sizeof **ar; }", fromIntegral $ sizeof CT.CTInt) + , (StatementEqual.test "int main() { int ar[3][5]; return sizeof(**ar) + 1; }", succ $ fromIntegral $ sizeof CT.CTInt) + , (StatementEqual.test "int main() { int ar[3][5]; return sizeof **ar + 1; }", succ $ fromIntegral $ sizeof CT.CTInt) + , (StatementEqual.test "int main() { int ar[3][5]; return sizeof(**ar + 1); }", fromIntegral $ sizeof $ CT.CTLong CT.CTInt) + , (StatementEqual.test "int main() { int ar[2]; 2[ar] = 42; return ar[2]; }", 42) ] where sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural @@ -122,43 +159,6 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ -- (LinkFuncRet.test "int main() { return sum7(1, 1, 1, 1, 1, 1, 1); }" ["test_func3"], 7), -- (LinkFuncRet.test "int main() { return test_func2(sum7(1, 2, 3, 4, 5, 6, 7)); }" ["test_func2", "test_func3"], 0), -- (LinkFuncRet.test "int main() { return sum16(1,1,1,1,1,1,11,10,9,8,7,6,5,4,3,2); }" ["test_func3"], 11), - (StatementEqual.test "int main() { int ar[2]; int* p = ar; *(p + 1) = 3; return *(ar + 1); }", 3), - (StatementEqual.test "int main() { int ar[2]; int* p = ar; *p = 2; *(p + 1) = 3; return *ar + *(ar + 1); }", 5), - (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *ar; }", 1), - (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *(ar + 1); }", 2), - (StatementEqual.test "int main() { int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; return *(ar + 2); }", 3), - (StatementEqual.test "int main() { int f(int* p) { *p = 42; return 0; } int main() { int a = 0; f(&a); return a; }", 42), - (StatementEqual.test "int main() { int ar[10]; int i = 0; for (; i < 10; i = i + 1) { *(ar + i) = i; } int sum = 0; for (i = 0; i < 10; i = i + 1) { sum = sum + *(ar + i); } return sum; }", 45), - (StatementEqual.test "int main() { int sum(int* p, int n) { int sum = 0; int i = 0; for (; i < n; i = i + 1) sum = sum + *(p + i); return sum; } int main() { int ar[10]; int i = 0; for (; i < 10; i = i + 1) *(ar + i) = i; return sum(ar, 10); }", 45), - (StatementEqual.test "int main() { int ar[2][3]; int sum = 0; int i = 0; for (; i < 2; i = i + 1) { int j = 0; for (; j < 3; j = j + 1) { *(*(ar + i) + j) = i + j; sum = sum + *(*(ar + i) + j); } } return sum; } ", 9), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; *p = 42; return **ar; }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; *(p + 1) = 42; return *(*ar + 1); }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; *(p + 2) = 42; return *(*ar + 2); }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; *(p + 3) = 42; return **(ar + 1); }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; *(p + 4) = 42; return *(*(ar + 1) + 1); }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; *(p + 5) = 42; return *(*(ar + 1) + 2); }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; *(p + 6) = 42; return **(ar + 2); }", 42), - (StatementEqual.test "int main() { int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; return ar[0]; }", 0), - (StatementEqual.test "int main() { int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; return ar[1]; }", 1), - (StatementEqual.test "int main() { int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; return ar[2]; }", 2), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; p[0] = 42; return ar[0][0]; }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; p[1] = 42; return ar[0][1]; }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; p[2] = 42; return ar[0][2]; }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; p[3] = 42; return ar[1][0]; }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; p[4] = 42; return ar[1][1]; }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; p[5] = 42; return ar[1][2]; }", 42), - (StatementEqual.test "int main() { int ar[2][3]; int* p = ar; p[6] = 42; return ar[2][0]; }", 42), - (StatementEqual.test "int main() { int a; return sizeof(a); }", fromIntegral $ sizeof CT.CTInt), - (StatementEqual.test "int main() { int a; return sizeof a; }", fromIntegral $ sizeof CT.CTInt), - (StatementEqual.test "int main() { int* p; return sizeof p; }", fromIntegral $ sizeof $ CT.CTPtr CT.CTInt), - (StatementEqual.test "int main() { int ar[3]; return sizeof ar; }", fromIntegral $ sizeof $ CT.CTArray 3 CT.CTInt), - (StatementEqual.test "int main() { int ar[3][5]; return sizeof ar; }", fromIntegral $ sizeof $ CT.CTArray 5 $ CT.CTArray 3 CT.CTInt), - (StatementEqual.test "int main() { int ar[3][5]; return sizeof *ar; }", fromIntegral $ sizeof $ CT.CTArray 5 CT.CTInt), - (StatementEqual.test "int main() { int ar[3][5]; return sizeof **ar; }", fromIntegral $ sizeof CT.CTInt), - (StatementEqual.test "int main() { int ar[3][5]; return sizeof(**ar) + 1; }", succ $ fromIntegral $ sizeof CT.CTInt), - (StatementEqual.test "int main() { int ar[3][5]; return sizeof **ar + 1; }", succ $ fromIntegral $ sizeof CT.CTInt), - (StatementEqual.test "int main() { int ar[3][5]; return sizeof(**ar + 1); }", fromIntegral $ sizeof $ CT.CTLong CT.CTInt), - (StatementEqual.test "int main() { int ar[2]; 2[ar] = 42; return ar[2]; }", 42), (StatementEqual.test "int main() { int g; int main() { return g; }", 0), (StatementEqual.test "int main() { int g; int main() { g = 42; return g; }", 42), (StatementEqual.test "int main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[0]; }", 1), From 392ce1b0f6852748c2d3c3edc9839c01b8f7c4ef Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 27 Dec 2020 16:25:41 +0900 Subject: [PATCH 23/51] Add global variable and char tests --- src/Htcc/Parser/Combinators/Program.hs | 68 ++++++++++++++++++++++++-- src/Htcc/Parser/Combinators/Type.hs | 3 +- test/Tests/SubProcTests.hs | 27 +++++----- 3 files changed, 82 insertions(+), 16 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index bc3f3c1..230045a 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -46,10 +46,12 @@ import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords -import Htcc.Parser.Combinators.Type (arraySuffix, +import Htcc.Parser.Combinators.Type (constantExp, arraySuffix, cType) import Htcc.Parser.ConstructionData (addFunction, addLVar, + addGVar, + addGVarWith, incomplete, lookupFunction, lookupVar, @@ -100,6 +102,7 @@ program = some global global, function, + gvar, stmt, lvarStmt, expr, @@ -119,11 +122,13 @@ global, identifier' :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) global = choice - [ function + [ ATEmpty <$ M.try (cType >> semi) + , function + , gvar ] function = do - (ty, ident) <- declIdent <* symbol "(" + (ty, ident) <- M.try (declIdent <* symbol "(") params <- takeParameters lift $ modify resetLocal choice @@ -151,6 +156,63 @@ function = do atDefFunc ident (if null params' then Nothing else Just params') ty <$> stmt Left err -> fail $ T.unpack $ fst err +gvar = do + (ty, ident) <- declIdent + choice + [ nonInit ty ident + , withInit ty ident + ] + where + tmpTKIdent ident = (HT.TokenLCNums 1 1, HT.TKIdent ident) + + nonInit ty ident = do + void semi + ty' <- maybe (fail "defining global variables with a incomplete type") pure + =<< lift (gets $ incomplete ty) + lift (gets (addGVar ty' (tmpTKIdent ident))) + >>= \case + Left err -> fail $ T.unpack $ fst err + Right (_, scp) -> ATEmpty <$ lift (put scp) + + withInit ty ident = do + void $ symbol "=" + ty' <- maybe (fail "defining global variables with a incomplete type") pure + =<< lift (gets $ incomplete ty) + gvarInit ty' ident <* semi + + gvarInit ty ident = choice + [ M.try fromConstant + , fromOG + ] + where + fromOG = do + ast <- logicalOr + case (atkind ast, atkind (atL ast)) of + (ATAddr, ATGVar _ name) -> lift (gets (gvarInitWithOG ty name)) + >>= \case + Left err -> fail $ T.unpack $ fst err + Right (_, scp) -> ATEmpty <$ lift (put scp) + (ATAddr, _) -> fail "invalid initializer in global variable" + (ATGVar t name, _) + | CT.isCTArray t -> lift (gets (gvarInitWithOG ty name)) + >>= \case + Left err -> fail $ T.unpack $ fst err + Right (_, scp) -> ATEmpty <$ lift (put scp) + -- TODO: support initializing from other global variables + | otherwise -> fail "initializer element is not constant" + _ -> fail "initializer element is not constant" + + gvarInitWithOG ty' to = addGVarWith ty' (tmpTKIdent ident) (PV.GVarInitWithOG to) + gvarInitWithVal ty' to = addGVarWith ty' (tmpTKIdent ident) (PV.GVarInitWithVal to) + + fromConstant = do + cval <- constantExp + lift (gets (gvarInitWithVal ty cval)) + >>= \case + Left err -> fail $ T.unpack $ fst err + Right (_, scp) -> ATEmpty <$ lift (put scp) + + lvarStmt = choice [ ATEmpty <$ M.try (cType <* semi) , declIdent <* semi >>= fmap atNull . uncurry registerLVar diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs index f8008ef..66bce99 100644 --- a/src/Htcc/Parser/Combinators/Type.hs +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -11,7 +11,8 @@ C language parser Combinators -} {-# LANGUAGE LambdaCase, OverloadedStrings #-} module Htcc.Parser.Combinators.Type ( - cType + constantExp + , cType , arraySuffix ) where import Control.Monad (mfilter) diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 87908dd..9757a42 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -142,6 +142,21 @@ exec = runTestsEx , (StatementEqual.test "int main() { int ar[3][5]; return sizeof **ar + 1; }", succ $ fromIntegral $ sizeof CT.CTInt) , (StatementEqual.test "int main() { int ar[3][5]; return sizeof(**ar + 1); }", fromIntegral $ sizeof $ CT.CTLong CT.CTInt) , (StatementEqual.test "int main() { int ar[2]; 2[ar] = 42; return ar[2]; }", 42) + , (StatementEqual.test "int g; int main() { return g; }", 0) + , (StatementEqual.test "int g; int main() { g = 42; return g; }", 42) + , (StatementEqual.test "int g = 42; int main() { return g; }", 42) + --, (StatementEqual.test "int g = 42; int h = g; int main() { return h; }", 42) + , (StatementEqual.test "int g = 42; int* h = &g; int main() { return *h; }", 42) + , (StatementEqual.test "int gr[3]; int main() { int i; i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[0]; }", 1) + , (StatementEqual.test "int gr[3]; int main() { int i; i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[1]; }", 2) + , (StatementEqual.test "int gr[3]; int main() { int i; i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[2]; }", 3) + , (StatementEqual.test "int main() { char c; c = 1; return c; }", 1) + , (StatementEqual.test "int main() { char c1; c1 = 1; char c2; c2 = 2; return c1; }", 1) + , (StatementEqual.test "int main() { char c1; c1 = 1; char c2; c2 = 2; return c2; }", 2) + , (StatementEqual.test "int main() { char x; return sizeof x; }", 1) + , (StatementEqual.test "int main() { char ar[10]; return sizeof ar; }", fromIntegral $ sizeof $ CT.CTArray 10 CT.CTChar) + , (StatementEqual.test "int f(char a, char b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1) + , (StatementEqual.test "int f(char a, int b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1) ] where sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural @@ -159,18 +174,6 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ -- (LinkFuncRet.test "int main() { return sum7(1, 1, 1, 1, 1, 1, 1); }" ["test_func3"], 7), -- (LinkFuncRet.test "int main() { return test_func2(sum7(1, 2, 3, 4, 5, 6, 7)); }" ["test_func2", "test_func3"], 0), -- (LinkFuncRet.test "int main() { return sum16(1,1,1,1,1,1,11,10,9,8,7,6,5,4,3,2); }" ["test_func3"], 11), - (StatementEqual.test "int main() { int g; int main() { return g; }", 0), - (StatementEqual.test "int main() { int g; int main() { g = 42; return g; }", 42), - (StatementEqual.test "int main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[0]; }", 1), - (StatementEqual.test "int main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[1]; }", 2), - (StatementEqual.test "int main() { int gr[3]; int main() { int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[2]; }", 3), - (StatementEqual.test "int main() { char c = 1; return c; }", 1), - (StatementEqual.test "int main() { char c1 = 1; char c2 = 2; return c1; }", 1), - (StatementEqual.test "int main() { char c1 = 1; char c2 = 2; return c2; }", 2), - (StatementEqual.test "int main() { char x; return sizeof x; }", 1), - (StatementEqual.test "int main() { char ar[10]; return sizeof ar; }", fromIntegral $ sizeof $ CT.CTArray 10 CT.CTChar), - (StatementEqual.test "int main() { int f(char a, char b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1), - (StatementEqual.test "int main() { int f(char a, int b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1), (StatementEqual.test "int main() { return \"abc\"[0]; }", ord 'a'), (StatementEqual.test "int main() { return \"abc\"[1]; }", ord 'b'), (StatementEqual.test "int main() { return \"abc\"[2]; }", ord 'c'), From 54f9119e24a38d14daa139ec081dcd030d265a1e Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 27 Dec 2020 17:26:01 +0900 Subject: [PATCH 24/51] Add string literals --- htcc.cabal | 5 ++- package.yaml | 1 + src/Htcc/Parser/Combinators/Core.hs | 2 +- src/Htcc/Parser/Combinators/Program.hs | 32 +++++++++++++----- .../ComponentsTests/Parser/Combinators.hs | 6 ++-- test/Tests/SubProcTests.hs | 33 +++++++++---------- 6 files changed, 48 insertions(+), 31 deletions(-) diff --git a/htcc.cabal b/htcc.cabal index ef31bd2..3e0ea3b 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 0a6f7ec02e3df248fd99bdf5c5994002b16d028dd5e733e0014a093970230942 +-- hash: fb71932dd3267d5d6b0cf4dcd5b4ad1098bba4925012b3d82e2229544cc0037f name: htcc version: 0.0.0.1 @@ -136,6 +136,7 @@ library , split , text , transformers + , utf8-string default-language: Haskell2010 executable htcc @@ -171,6 +172,7 @@ executable htcc , split , text , transformers + , utf8-string default-language: Haskell2010 test-suite htcc-test @@ -258,4 +260,5 @@ benchmark criterion , split , text , transformers + , utf8-string default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index f70b119..217031f 100644 --- a/package.yaml +++ b/package.yaml @@ -48,6 +48,7 @@ dependencies: - optparse-applicative - megaparsec - parser-combinators +- utf8-string library: source-dirs: src diff --git a/src/Htcc/Parser/Combinators/Core.hs b/src/Htcc/Parser/Combinators/Core.hs index a639055..6059857 100644 --- a/src/Htcc/Parser/Combinators/Core.hs +++ b/src/Htcc/Parser/Combinators/Core.hs @@ -80,7 +80,7 @@ charLiteral :: Ord e => M.ParsecT e T.Text m Char charLiteral = M.between (MC.char '\'') (MC.char '\'') ML.charLiteral stringLiteral :: Ord e => M.ParsecT e T.Text m String -stringLiteral = MC.char '\"' *> M.manyTill ML.charLiteral (MC.char '\"') +stringLiteral = MC.char '\"' *> ((<> "\0") <$> M.manyTill ML.charLiteral (MC.char '\"')) hexadecimal, octal, decimal, natural, integer :: (Ord e, Num i) => M.ParsecT e T.Text m i hexadecimal = MC.char '0' >> MC.char' 'x' >> ML.hexadecimal diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 230045a..0cd97f0 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -15,6 +15,8 @@ module Htcc.Parser.Combinators.Program ( , logicalOr ) where +import qualified Data.ByteString.UTF8 as BSU + import Control.Monad (forM, void, (>=>)) import Control.Monad.Combinators (choice, some) import Control.Monad.Trans (MonadTrans (..)) @@ -23,6 +25,7 @@ import Control.Monad.Trans.Maybe (MaybeT (..), import Control.Monad.Trans.State (get, gets, modify, put) import Data.Bits (Bits (..)) +import Data.Char (ord) import Data.Either (rights) import Data.Functor ((<&>)) import Data.Maybe (fromJust, @@ -46,12 +49,14 @@ import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords -import Htcc.Parser.Combinators.Type (constantExp, arraySuffix, - cType) +import Htcc.Parser.Combinators.Type (arraySuffix, + cType, + constantExp) import Htcc.Parser.ConstructionData (addFunction, - addLVar, addGVar, addGVarWith, + addLVar, + addLiteral, incomplete, lookupFunction, lookupVar, @@ -82,7 +87,7 @@ declIdentFuncArg sep = do namedArg ty = do ident <- identifier Right . (,ident) <$> M.option ty (narrowPtr <$> arraySuffix ty) <* sep - + narrowPtr ty | CT.isCTArray ty = fromMaybe ty $ CT.mapTypeKind CT.CTPtr <$> CT.deref ty | CT.isIncompleteArray ty = @@ -173,7 +178,7 @@ gvar = do >>= \case Left err -> fail $ T.unpack $ fst err Right (_, scp) -> ATEmpty <$ lift (put scp) - + withInit ty ident = do void $ symbol "=" ty' <- maybe (fail "defining global variables with a incomplete type") pure @@ -201,7 +206,7 @@ gvar = do -- TODO: support initializing from other global variables | otherwise -> fail "initializer element is not constant" _ -> fail "initializer element is not constant" - + gvarInitWithOG ty' to = addGVarWith ty' (tmpTKIdent ident) (PV.GVarInitWithOG to) gvarInitWithVal ty' to = addGVarWith ty' (tmpTKIdent ident) (PV.GVarInitWithVal to) @@ -211,7 +216,7 @@ gvar = do >>= \case Left err -> fail $ T.unpack $ fst err Right (_, scp) -> ATEmpty <$ lift (put scp) - + lvarStmt = choice [ ATEmpty <$ M.try (cType <* semi) @@ -314,7 +319,7 @@ unary = choice idxAcc fac = do idx <- brackets expr kt <- maybe (fail "invalid operands") pure (addKind fac idx) - ty <- maybe (fail "subscripted value is neither array nor pointer nor vector") pure + ty <- maybe (fail "subscripted value is neither array nor pointer nor vector") pure $ CT.deref $ atype kt ty' <- maybe (fail "incomplete value dereference") pure =<< lift (gets $ incomplete ty) allAcc $ atUnary ATDeref ty' kt @@ -330,11 +335,22 @@ unary = choice factor = choice [ atNumLit <$> natural + , atNumLit . fromIntegral . ord <$> charLiteral , sizeof + , strLiteral , identifier' , parens expr , ATEmpty <$ M.eof ] + where + strLiteral = do + s <- stringLiteral + lit <- lift $ gets $ + addLiteral (CT.SCAuto $ CT.CTArray (fromIntegral $ length s) CT.CTChar) $ + (HT.TokenLCNums 1 1, HT.TKString $ BSU.fromString s) + case lit of + Left err -> fail $ T.unpack $ fst err + Right (nd, scp) -> nd <$ lift (put scp) sizeof = kSizeof >> choice [ incomplete <$> M.try (parens cType) <*> lift get diff --git a/test/Tests/ComponentsTests/Parser/Combinators.hs b/test/Tests/ComponentsTests/Parser/Combinators.hs index 2ffe0f9..96c1e22 100644 --- a/test/Tests/ComponentsTests/Parser/Combinators.hs +++ b/test/Tests/ComponentsTests/Parser/Combinators.hs @@ -53,9 +53,9 @@ stringLiteralTest = TestLabel "Parser.Combinators.Core.stringLiteral" $ TestList [ TestLabel "Parser.Combinators.Core.stringLiteral success patterns" $ TestList [ - "\"abc\" == abc" ~: M.runParser stringLiteral' "" "\"abc\"" ~?= Right "abc" - , "\"012\" == 012" ~: M.runParser stringLiteral' "" "\"012\"" ~?= Right "012" - , "\"012\"3 == 012" ~: M.runParser stringLiteral' "" "\"012\"3" ~?= Right "012" + "\"abc\" == abc" ~: M.runParser stringLiteral' "" "\"abc\"" ~?= Right "abc\0" + , "\"012\" == 012" ~: M.runParser stringLiteral' "" "\"012\"" ~?= Right "012\0" + , "\"012\"3 == 012" ~: M.runParser stringLiteral' "" "\"012\"3" ~?= Right "012\0" ] , TestLabel "Parser.Combinators.Core.stringLiteral fail patterns" $ TestList [ diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 9757a42..6f7cd17 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -157,6 +157,21 @@ exec = runTestsEx , (StatementEqual.test "int main() { char ar[10]; return sizeof ar; }", fromIntegral $ sizeof $ CT.CTArray 10 CT.CTChar) , (StatementEqual.test "int f(char a, char b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1) , (StatementEqual.test "int f(char a, int b, char c) { return a - b - c; } int main() { return f(7, 3, 3); }", 1) + , (StatementEqual.test "int main() { return \"abc\"[0]; }", ord 'a') + , (StatementEqual.test "int main() { return \"abc\"[1]; }", ord 'b') + , (StatementEqual.test "int main() { return \"abc\"[2]; }", ord 'c') + , (StatementEqual.test "int main() { return \"abc\"[3]; }", 0) + , (StatementEqual.test "int main() { char* p; p = \"abc\"; return p[2]; }", ord 'c') + , (StatementEqual.test "int main() { return sizeof \"abc\"; }", 4) + , (StatementEqual.test "int main() { return \"\\a\"[0]; }", ord '\a') + , (StatementEqual.test "int main() { return \"\\b\"[0]; }", ord '\b') + , (StatementEqual.test "int main() { return \"\\t\"[0]; }", ord '\t') + , (StatementEqual.test "int main() { return \"\\n\"[0]; }", ord '\n') + , (StatementEqual.test "int main() { return \"\\v\"[0]; }", ord '\v') + , (StatementEqual.test "int main() { return \"\\f\"[0]; }", ord '\f') + , (StatementEqual.test "int main() { return \"\\r\"[0]; }", ord '\r') + , (StatementEqual.test "int main() { return \"\\e\"[0]; }", ord '\ESC') + , (StatementEqual.test "int main() { return \"\\\\0\"[0]; }", ord '\0') ] where sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural @@ -174,24 +189,6 @@ exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ -- (LinkFuncRet.test "int main() { return sum7(1, 1, 1, 1, 1, 1, 1); }" ["test_func3"], 7), -- (LinkFuncRet.test "int main() { return test_func2(sum7(1, 2, 3, 4, 5, 6, 7)); }" ["test_func2", "test_func3"], 0), -- (LinkFuncRet.test "int main() { return sum16(1,1,1,1,1,1,11,10,9,8,7,6,5,4,3,2); }" ["test_func3"], 11), - (StatementEqual.test "int main() { return \"abc\"[0]; }", ord 'a'), - (StatementEqual.test "int main() { return \"abc\"[1]; }", ord 'b'), - (StatementEqual.test "int main() { return \"abc\"[2]; }", ord 'c'), - (StatementEqual.test "int main() { return \"abc\"[3]; }", 0), - (StatementEqual.test "int main() { char* p = \"abc\"; return p[2]; }", ord 'c'), - (StatementEqual.test "int main() { return sizeof \"abc\"; }", 4), - (StatementEqual.test "int main() { return \"\\a\"[0]; }", ord '\a'), - (StatementEqual.test "int main() { return \"\\b\"[0]; }", ord '\b'), - (StatementEqual.test "int main() { return \"\\t\"[0]; }", ord '\t'), - (StatementEqual.test "int main() { return \"\\n\"[0]; }", ord '\n'), - (StatementEqual.test "int main() { return \"\\v\"[0]; }", ord '\v'), - (StatementEqual.test "int main() { return \"\\f\"[0]; }", ord '\f'), - (StatementEqual.test "int main() { return \"\\r\"[0]; }", ord '\r'), - (StatementEqual.test "int main() { return \"\\e\"[0]; }", ord '\ESC'), - (StatementEqual.test "int main() { return \"\\\\0\"[0]; }", ord '\0'), - (StatementEqual.test "int main() { return \"\\j\"[0]; }", ord 'j'), - (StatementEqual.test "int main() { return \"\\k\"[0]; }", ord 'k'), - (StatementEqual.test "int main() { return \"\\l\"[0]; }", ord 'l'), (StatementEqual.test "int main() { return ({ 42; }); }", 42), (StatementEqual.test "int main() { return ({ 1; 2; 3; }); }", 3), (StatementEqual.test "int main() { ({ 1; return 2; 3; }); return 4; }", 2), From a74400be39b3d059dad71c8fb84010b2c31314ee Mon Sep 17 00:00:00 2001 From: roki Date: Sun, 27 Dec 2020 17:44:35 +0900 Subject: [PATCH 25/51] Add bits and boolean operators --- src/Htcc/Parser/Combinators/Program.hs | 22 +++++++++++++++------- test/Tests/SubProcTests.hs | 16 ++++++++-------- 2 files changed, 23 insertions(+), 15 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 0cd97f0..fcad81d 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -15,7 +15,7 @@ module Htcc.Parser.Combinators.Program ( , logicalOr ) where -import qualified Data.ByteString.UTF8 as BSU +import qualified Data.ByteString.UTF8 as BSU import Control.Monad (forM, void, (>=>)) import Control.Monad.Combinators (choice, some) @@ -24,7 +24,7 @@ import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Control.Monad.Trans.State (get, gets, modify, put) -import Data.Bits (Bits (..)) +import Data.Bits (Bits) import Data.Char (ord) import Data.Either (rights) import Data.Functor ((<&>)) @@ -119,6 +119,7 @@ global, bitwiseAnd, equality, relational, + shift, add, term, unary, @@ -280,13 +281,18 @@ equality = binaryOperator relational , (symbol "!=", binOpBool ATNEQ) ] -relational = binaryOperator add +relational = binaryOperator shift [ (symbol "<=", binOpBool ATLEQ) , (symbol "<", binOpBool ATLT) , (symbol ">=", binOpBool ATGEQ) , (symbol ">", binOpBool ATGT) ] +shift = binaryOperator add + [ (symbol "<<", binOpIntOnly ATShl) + , (symbol ">>", binOpIntOnly ATShr) + ] + add = binaryOperator term [ (symbol "+", \l r -> maybe (fail "invalid operands") pure $ addKind l r) , (symbol "-", \l r -> maybe (fail "invalid operands") pure $ subKind l r) @@ -299,8 +305,10 @@ term = binaryOperator unary ] unary = choice - [ symbol "+" >> factor - , symbol "-" >> factor <&> \n -> ATNode ATSub (atype n) (atNumLit 0) n + [ symbol "+" >> unary + , symbol "-" >> unary <&> \n -> ATNode ATSub (atype n) (atNumLit 0) n + , symbol "!" >> unary <&> flip (ATNode ATNot (CT.SCAuto CT.CTBool)) ATEmpty + , symbol "~" >> unary <&> flip (ATNode ATBitNot (CT.SCAuto CT.CTInt)) ATEmpty , addr , symbol "*" >> unary >>= deref' , factor' @@ -345,11 +353,11 @@ factor = choice where strLiteral = do s <- stringLiteral - lit <- lift $ gets $ + lit <- lift $ gets $ addLiteral (CT.SCAuto $ CT.CTArray (fromIntegral $ length s) CT.CTChar) $ (HT.TokenLCNums 1 1, HT.TKString $ BSU.fromString s) case lit of - Left err -> fail $ T.unpack $ fst err + Left err -> fail $ T.unpack $ fst err Right (nd, scp) -> nd <$ lift (put scp) sizeof = kSizeof >> choice diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 6f7cd17..4f2fb65 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -172,19 +172,19 @@ exec = runTestsEx , (StatementEqual.test "int main() { return \"\\r\"[0]; }", ord '\r') , (StatementEqual.test "int main() { return \"\\e\"[0]; }", ord '\ESC') , (StatementEqual.test "int main() { return \"\\\\0\"[0]; }", ord '\0') + , (StatementEqual.test "int main() { return !0; }", 1) + , (StatementEqual.test "int main() { return !42; }", 0) + , (StatementEqual.test "int main() { return !!!0; }", 1) + , (StatementEqual.test "int main() { return ~(-42); }", 41) + , (StatementEqual.test "int main() { return ~~~~42; }", 42) + , (StatementEqual.test "int main() { return (2 * 4) == (2 << 2); }", 1) + , (StatementEqual.test "int main() { return (8 / 4) == (8 >> 2); }", 1) + , (StatementEqual.test "int main() { int a; a = 2 << 4; return (a & (a - 1)) == 0; }", 1) -- Determining if an integer is a power of 2 ] where sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ - (StatementEqual.test "int main() { return !0; }", 1), - (StatementEqual.test "int main() { return !42; }", 0), - (StatementEqual.test "int main() { return !!!0; }", 1), - (StatementEqual.test "int main() { return ~(-42); }", 41), - (StatementEqual.test "int main() { return ~~~~42; }", 42), - (StatementEqual.test "int main() { return (2 * 4) == (2 << 2); }", 1), - (StatementEqual.test "int main() { return (8 / 4) == (8 >> 2); }", 1), - (StatementEqual.test "int main() { int a = 2 << 4; return (a & (a - 1)) == 0; }", 1), -- Determining if an integer is a power of 2 (StatementEqual.test "int main() { 1; {2;} return 3; }", 3), -- (LinkFuncRet.test "int main() { return sum7(1, 1, 1, 1, 1, 1, 1); }" ["test_func3"], 7), -- (LinkFuncRet.test "int main() { return test_func2(sum7(1, 2, 3, 4, 5, 6, 7)); }" ["test_func2", "test_func3"], 0), From b5924ca8a708f2dbf10d2aca9b2353d9f4ee0179 Mon Sep 17 00:00:00 2001 From: roki Date: Mon, 28 Dec 2020 19:36:19 +0900 Subject: [PATCH 26/51] Add statement expression Supports initialization of local variables other than arrays --- htcc.cabal | 4 +- src/Htcc/Parser/Combinators/Program.hs | 134 ++++++++++++++----------- src/Htcc/Parser/Combinators/Utils.hs | 42 ++++++++ src/Htcc/Parser/Combinators/Var.hs | 81 +++++++++++++++ test/Tests/SubProcTests.hs | 16 ++- test/Tests/csrc/test_core.c | 24 ++--- 6 files changed, 225 insertions(+), 76 deletions(-) create mode 100644 src/Htcc/Parser/Combinators/Utils.hs create mode 100644 src/Htcc/Parser/Combinators/Var.hs diff --git a/htcc.cabal b/htcc.cabal index 3e0ea3b..24c9ecb 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: fb71932dd3267d5d6b0cf4dcd5b4ad1098bba4925012b3d82e2229544cc0037f +-- hash: 82c6e6209364a3de198c302bcc53905a157a8bfd5c720be89ff9f32d6e7f356b name: htcc version: 0.0.0.1 @@ -76,6 +76,8 @@ library Htcc.Parser.Combinators.Keywords Htcc.Parser.Combinators.Program Htcc.Parser.Combinators.Type + Htcc.Parser.Combinators.Utils + Htcc.Parser.Combinators.Var Htcc.Parser.ConstructionData Htcc.Parser.ConstructionData.Core Htcc.Parser.ConstructionData.Scope diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index fcad81d..ba4e26e 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -15,8 +15,6 @@ module Htcc.Parser.Combinators.Program ( , logicalOr ) where -import qualified Data.ByteString.UTF8 as BSU - import Control.Monad (forM, void, (>=>)) import Control.Monad.Combinators (choice, some) import Control.Monad.Trans (MonadTrans (..)) @@ -25,6 +23,7 @@ import Control.Monad.Trans.Maybe (MaybeT (..), import Control.Monad.Trans.State (get, gets, modify, put) import Data.Bits (Bits) +import qualified Data.ByteString.UTF8 as BSU import Data.Char (ord) import Data.Either (rights) import Data.Functor ((<&>)) @@ -44,7 +43,9 @@ import Htcc.Parser.AST.Core (ATKind (..), atNoLeaf, atNull, atNumLit, atReturn, atUnary, - atWhile) + atWhile, + fromATKindFor, + isEmptyExprStmt) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core @@ -52,15 +53,19 @@ import Htcc.Parser.Combinators.Keywords import Htcc.Parser.Combinators.Type (arraySuffix, cType, constantExp) +import Htcc.Parser.Combinators.Utils (bracket, + registerLVar) +import Htcc.Parser.Combinators.Var (varInit) import Htcc.Parser.ConstructionData (addFunction, addGVar, addGVarWith, - addLVar, addLiteral, + fallBack, incomplete, lookupFunction, lookupVar, - resetLocal) + resetLocal, + succNest) import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) import qualified Htcc.Parser.ConstructionData.Scope.Function as PSF import qualified Htcc.Parser.ConstructionData.Scope.Var as PV @@ -94,13 +99,6 @@ declIdentFuncArg sep = do CT.mapTypeKind (\(CT.CTIncomplete (CT.IncompleteArray t')) -> CT.CTPtr t') ty | otherwise = ty -registerLVar :: (Bits i, Integral i) => CT.StorageClass i -> T.Text -> Parser i (ATree i) -registerLVar ty ident = - lift (gets $ addLVar ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) - >>= \case - Right (lat, scp') -> lift (lat <$ put scp') - Left err -> fail $ T.unpack $ fst err - parser, program :: (Integral i, Bits i, Read i, Show i) => Parser i (ASTs i) parser = (spaceConsumer >> program) <* M.eof program = some global @@ -109,7 +107,6 @@ global, function, gvar, stmt, - lvarStmt, expr, assign, logicalOr, @@ -123,9 +120,7 @@ global, add, term, unary, - factor, - sizeof, - identifier' :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) + factor :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) global = choice [ ATEmpty <$ M.try (cType >> semi) @@ -218,20 +213,18 @@ gvar = do Left err -> fail $ T.unpack $ fst err Right (_, scp) -> ATEmpty <$ lift (put scp) - -lvarStmt = choice - [ ATEmpty <$ M.try (cType <* semi) - , declIdent <* semi >>= fmap atNull . uncurry registerLVar - ] +compoundStmt :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i [ATree i] +compoundStmt = bracket (lift get) (lift . modify . fallBack) $ const $ + braces (lift (modify succNest) *> M.many stmt) stmt = choice [ returnStmt , ifStmt , whileStmt , forStmt - , compoundStmt + , atBlock <$> compoundStmt , lvarStmt - , expr <* semi + , atExprStmt <$> (expr <* semi) , ATEmpty <$ semi ] where @@ -248,18 +241,26 @@ stmt = choice whileStmt = atWhile <$> (M.try kWhile >> parens expr) <*> stmt - forStmt = do - es <- (>>) (M.try kFor) $ parens $ do - initSect <- ATForInit . atExprStmt - <$> choice [ATEmpty <$ semi, expr <* semi] + forStmt = (>>) (M.try kFor) $ bracket (lift get) (lift . modify . fallBack) $ const $ do + es <- parens $ do + lift $ modify succNest + initSect <- ATForInit + <$> choice [ATEmpty <$ semi, M.try (atExprStmt <$> expr <* semi), lvarStmt] condSect <- ATForCond <$> choice [atNumLit 1 <$ semi, expr <* semi] - incrSect <- ATForIncr . atExprStmt - <$> M.option ATEmpty expr - pure [initSect, condSect, incrSect] + incrSect <- ATForIncr + <$> M.option ATEmpty (atExprStmt <$> expr) + pure + [ x | x <- [initSect, condSect, incrSect] + , case fromATKindFor x of ATEmpty -> False; x' -> not $ isEmptyExprStmt x' + ] atFor . (es <>) . (:[]) . ATForStmt <$> stmt - compoundStmt = atBlock <$> braces (M.many stmt) + lvarStmt = choice + [ ATEmpty <$ M.try (cType <* semi) + , M.try (declIdent <* semi) >>= fmap atNull . uncurry registerLVar + , (declIdent <* symbol "=" >>= uncurry (varInit assign)) <* semi + ] expr = assign @@ -271,9 +272,13 @@ assign = do ] logicalOr = binaryOperator logicalAnd [(symbol "||", binOpBool ATLOr)] + logicalAnd = binaryOperator bitwiseOr [(symbol "&&", binOpBool ATLAnd)] + bitwiseOr = binaryOperator bitwiseXor [(symbol "|", binOpIntOnly ATOr)] + bitwiseXor = binaryOperator bitwiseAnd [(symbol "^", binOpIntOnly ATXor)] + bitwiseAnd = binaryOperator equality [(MC.char '&' `notFollowedOp` MC.char '&', binOpIntOnly ATAnd)] equality = binaryOperator relational @@ -347,10 +352,18 @@ factor = choice , sizeof , strLiteral , identifier' - , parens expr + , M.try (parens expr) + , stmtExpr , ATEmpty <$ M.eof ] where + sizeof = kSizeof >> choice + [ incomplete <$> M.try (parens cType) <*> lift get + >>= maybe (fail "invalid application of 'sizeof' to incomplete type") + (pure . atNumLit . fromIntegral . CT.sizeof) + , atNumLit . fromIntegral . CT.sizeof . atype <$> unary + ] + strLiteral = do s <- stringLiteral lit <- lift $ gets $ @@ -360,33 +373,32 @@ factor = choice Left err -> fail $ T.unpack $ fst err Right (nd, scp) -> nd <$ lift (put scp) -sizeof = kSizeof >> choice - [ incomplete <$> M.try (parens cType) <*> lift get - >>= maybe (fail "invalid application of 'sizeof' to incomplete type") - (pure . atNumLit . fromIntegral . CT.sizeof) - , atNumLit . fromIntegral . CT.sizeof . atype <$> unary - ] + stmtExpr = do + k <- parens compoundStmt + if null k then fail "void value not ignored as it ought to be" else case last k of + (ATNode ATExprStmt _ n _) -> pure $ atNoLeaf (ATStmtExpr $ init k <> [n]) (atype n) + _ -> fail "void value not ignored as it ought to be" -identifier' = do - ident <- identifier - choice - [ fnCall ident - , variable ident - ] - where - variable ident = do - lift (gets $ lookupVar ident) - >>= \case - FoundGVar (PV.GVar t _) -> return $ atGVar t ident - FoundLVar sct -> return $ treealize sct - FoundEnum sct -> return $ treealize sct - NotFound -> fail $ "The '" <> T.unpack ident <> "' is not defined identifier" - - fnCall ident = do - params <- symbol "(" >> M.manyTill (M.try (expr <* comma) M.<|> expr) (symbol ")") - let params' = if null params then Nothing else Just params - lift (gets $ lookupFunction ident) <&> \case - -- TODO: set warning message - -- TODO: Infer the return type of a function - Nothing -> atNoLeaf (ATCallFunc ident params') (CT.SCAuto CT.CTInt) - Just fn -> atNoLeaf (ATCallFunc ident params') (PSF.fntype fn) + identifier' = do + ident <- identifier + choice + [ fnCall ident + , variable ident + ] + where + variable ident = do + lift (gets $ lookupVar ident) + >>= \case + FoundGVar (PV.GVar t _) -> return $ atGVar t ident + FoundLVar sct -> return $ treealize sct + FoundEnum sct -> return $ treealize sct + NotFound -> fail $ "The '" <> T.unpack ident <> "' is not defined identifier" + + fnCall ident = do + params <- symbol "(" >> M.manyTill (M.try (expr <* comma) M.<|> expr) (symbol ")") + let params' = if null params then Nothing else Just params + lift (gets $ lookupFunction ident) <&> \case + -- TODO: set warning message + -- TODO: Infer the return type of a function + Nothing -> atNoLeaf (ATCallFunc ident params') (CT.SCAuto CT.CTInt) + Just fn -> atNoLeaf (ATCallFunc ident params') (PSF.fntype fn) diff --git a/src/Htcc/Parser/Combinators/Utils.hs b/src/Htcc/Parser/Combinators/Utils.hs new file mode 100644 index 0000000..f952d65 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Utils.hs @@ -0,0 +1,42 @@ +{-| +Module : Htcc.Parser.Combinators.Utils +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +{-# LANGUAGE LambdaCase, Rank2Types, TypeOperators #-} +module Htcc.Parser.Combinators.Utils ( + maybeToParser + , registerLVar + , bracket +) where +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.State (gets, put) +import Control.Natural (type (~>)) +import Data.Bits (Bits (..)) +import qualified Data.Text as T +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATree (..)) +import Htcc.Parser.Combinators.Core +import Htcc.Parser.ConstructionData (addLVar) +import qualified Htcc.Tokenizer.Token as HT +import qualified Text.Megaparsec as M + +maybeToParser :: String -> Maybe ~> Parser i +maybeToParser s = maybe (fail s) pure + +registerLVar :: (Bits i, Integral i) => CT.StorageClass i -> T.Text -> Parser i (ATree i) +registerLVar ty ident = lift (gets $ addLVar ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) + >>= \case + Right (lat, scp') -> lift (lat <$ put scp') + Left err -> fail $ T.unpack $ fst err + +bracket :: Parser i a -> (a -> Parser i b) -> (a -> Parser i c) -> Parser i c +bracket beg end m = do + b <- beg + M.withRecovery (\err -> end b *> M.parseError err) (m b) <* end b diff --git a/src/Htcc/Parser/Combinators/Var.hs b/src/Htcc/Parser/Combinators/Var.hs new file mode 100644 index 0000000..2797c13 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Var.hs @@ -0,0 +1,81 @@ +{-| +Module : Htcc.Parser.Combinators.Var +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +module Htcc.Parser.Combinators.Var ( + varInit +) where +import Control.Monad (forM) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.State (gets) +import Data.Bits (Bits) +import Data.Functor ((<&>)) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.AST (ATKind (..), ATree (..), + addKind, atAssign, atExprStmt, + atMemberAcc, atNumLit, atUnary, + treealize) +import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.Utils (maybeToParser, registerLVar) +import Htcc.Parser.ConstructionData (incomplete, lookupLVar) +import qualified Text.Megaparsec as M + +chkValidAssign :: Eq i => ATree i -> Parser i (ATree i) +chkValidAssign at@(ATNode _ ty _ _) + | CT.toTypeKind ty == CT.CTVoid = fail "void value not ignored as it ought to be" + | otherwise = pure at +chkValidAssign _ = fail "expected to assign" + +desgNode :: (Num i, Ord i, Show i) + => T.Text + -> ATree i + -> [CT.Desg i] + -> Parser i (ATree i) +desgNode ident rhs desg = fmap (atExprStmt . flip atAssign rhs) $ + flip (`foldr` ntLVarTree) desg $ \idx acc -> case idx of + CT.DesgIdx idx' -> do + at <- acc + nd' <- maybeToParser' $ addKind at $ atNumLit idx' + flip (atUnary ATDeref) nd' <$> maybeToParser' (CT.deref (atype nd')) + CT.DesgMem mem -> atMemberAcc mem <$> acc + where + maybeToParser' = maybeToParser "invalid initializer-list" + ntLVarTree = treealize + <$> (maybeToParser' =<< lift (gets $ lookupLVar ident)) + +initZero :: (Num i, Ord i, Show i, Enum i) + => CT.TypeKind i + -> T.Text + -> [CT.Desg i] + -> Parser i [ATree i] +initZero (CT.CTArray n t) ident desg = fmap concat $ + forM [0..fromIntegral (pred n)] $ initZero t ident . (:desg) . CT.DesgIdx +initZero _ ident desg = (:[]) <$> desgNode ident (atNumLit 0) desg + +varInit' :: (Integral i, Bits i, Read i, Show i) + => Parser i (ATree i) + -> CT.StorageClass i + -> T.Text + -> ATree i + -> Parser i (ATree i) +varInit' p ty ident lat + | CT.isArray ty || CT.isCTStruct ty = error "sorry, not support yet" + | otherwise = p >>= chkValidAssign <&> atExprStmt . ATNode ATAssign (atype lat) lat + +varInit :: (Integral i, Bits i, Read i, Show i) + => Parser i (ATree i) + -> CT.StorageClass i + -> T.Text + -> Parser i (ATree i) +varInit p ty ident = do + ty' <- fromMaybe ty <$> lift (gets $ incomplete ty) + registerLVar ty' ident >>= varInit' p ty ident diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 4f2fb65..78d039f 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -180,12 +180,26 @@ exec = runTestsEx , (StatementEqual.test "int main() { return (2 * 4) == (2 << 2); }", 1) , (StatementEqual.test "int main() { return (8 / 4) == (8 >> 2); }", 1) , (StatementEqual.test "int main() { int a; a = 2 << 4; return (a & (a - 1)) == 0; }", 1) -- Determining if an integer is a power of 2 + , (StatementEqual.test "int main() { int a; a = 1; { int a; a = 42; } return a; }", 1) + , (StatementEqual.test "int main() { int a; a = 1; if (1) { int a; a = 42; } return a; }", 1) + , (StatementEqual.test "int main() { 1; {2;} return 3; }", 3) + , (StatementEqual.test "int main() { return ({ 42; }); }", 42) + , (StatementEqual.test "int main() { return ({ 1; 2; 3; }); }", 3) + , (StatementEqual.test "int main() { ({ 1; return 2; 3; }); return 4; }", 2) + , (StatementEqual.test "int main() { return ({ int a; a = 42; a; }); }", 42) + , (StatementEqual.test "int main() { /* return 0; */ return 42; }", 42) + , (StatementEqual.test "int main() { // hoge\nreturn 42; }", 42) + , (StatementEqual.test "int main() { int a; a = 42; { int a; a = 32; } return a; }", 42) + , (StatementEqual.test "int main() { int a; a = 42; { int a; a = 32; } { int a; a = 53; return a; } return 42; }", 53) + , (StatementEqual.test "int main() { int a; a = 42; { a = 32; } return a; }", 32) + , (StatementEqual.test "int main() { int* ar[3]; int x; ar[0] = &x; x = 42; ar[0][0]; }", 42) + , (StatementEqual.test "int main() { int a = 42; return ({ a; }); }", 42) + , (StatementEqual.test "int main() { return ({ int a = 42; int b = 1; a + b; }); }", 43) ] where sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural {- exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ - (StatementEqual.test "int main() { 1; {2;} return 3; }", 3), -- (LinkFuncRet.test "int main() { return sum7(1, 1, 1, 1, 1, 1, 1); }" ["test_func3"], 7), -- (LinkFuncRet.test "int main() { return test_func2(sum7(1, 2, 3, 4, 5, 6, 7)); }" ["test_func2", "test_func3"], 0), -- (LinkFuncRet.test "int main() { return sum16(1,1,1,1,1,1,11,10,9,8,7,6,5,4,3,2); }" ["test_func3"], 11), diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/test_core.c index 0a42353..cf50b18 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/test_core.c @@ -6,19 +6,19 @@ int printf(); int exit(); int strcmp(char* p, char* q); - int test_num; + int g; int gr[3]; +/* int (*gpa)[3]; - char gc = 1; short gsh = 2; int gi = 3; long gl = 4; int* gp = &gi; char* gstr = "abc"; - +*/ int assert(long expected, long actual, char* code) { if (expected == actual) { @@ -36,16 +36,16 @@ int add(int x, int y) { return x + y; } int rec(int a) { if (a == 0) return 42; return rec(a - 1); } int fib(int n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } int gg(int* p) { *p = 42; return 0; } -int sum(int* p, int n) { int s = 0; int i = 0; for (; i < n; i = i + 1) s = s + *(p + i); return s; } +int sum(int* p, int n) { int s = 0; for (int i = 0; i < n; i = i + 1) s = s + *(p + i); return s; } int sub3(int a, int b, int c) { return a - b - c; } int sub3_short(short a, short b, short c) { return a - b - c; } int sub3_long(long a, long b, long c) { return a - b - c; } -int ptr2ar(int (*p)[3]) { int i = 0; for (; i < sizeof *p / sizeof **p; i = i + 1) p[0][i] = i + 1; return 0; } +/*int ptr2ar(int (*p)[3]) { int i = 0; for (; i < sizeof *p / sizeof **p; i = i + 1) p[0][i] = i + 1; return 0; } static int static_fun() { return 42; } void swap(int* a, int* b) { *a ^= *b; *b ^= *a; *a ^= *b; } void void_fn(int* a) { *a = 42; return; *a = 53; } int param_decay(int ar[]) { return ar[0]; } - +*/ int main() { test_num = 1; @@ -68,7 +68,9 @@ int main() assert(1, 53 >= 42, "53 >= 42"); assert(1, (1 + 1) == 2, "(1 + 1) == 2"); assert(1, (2 * 3) != 2, "(2 * 3) != 2"); - assert(62, ({ int a = 42; int b = 20; a + b; }), "({ int a = 42; int b = 20; a + b; })"); + assert(42, ({ int a = 42; a; }), "({ int a = 42; a; })"); + assert(42, ( { int a = 42; a; } ), "( { int a = 42; a; } )"); + assert(44, ({ int a = 42; int b = 2; a + b; }), "({ int a = 42; int b = 2; a + b; })"); assert(20, ({ int a = 42; int b = 20; int c = 32; (a - c) * b / 10; }), "({ int a = 42; int b = 20; int c = 32; (a - c) * b / 10; })"); assert(22, ({ int hoge = 42; int foo = 20; hoge - foo; }), "({ int hoge = 42; int foo = 20; hoge - foo; })"); assert(14, ({ int a = 3; int b = 5 * 6 - 8; a + b / 2; }), "({ int a = 3; int b = 5 * 6 - 8; a + b / 2; })"); @@ -177,16 +179,12 @@ int main() assert(11, "\v"[0], "\"\\v\"[0]"); assert(12, "\f"[0], "\"\\f\"[0]"); assert(13, "\r"[0], "\"\\r\"[0]"); - assert(27, "\e"[0], "\"\\e\"[0]"); assert(0, "\0"[0], "\\0[0]"); - assert(106, "\j"[0], "\\j[0]"); - assert(107, "\k"[0], "\\k[0]"); - assert(108, "\l"[0], "\\l[0]"); assert(92, "\\"[0], "a"); assert(42, ({ int a = 42; { int a = 32; } a; }), "({ int a = 42; { int a = 32; } a; })"); assert(32, ({ int a = 42; { a = 32; } a; }), "({ int a = 42; { a = 32; } a; })"); assert(2, ({ int ar[5]; int* p = ar + 2; p - ar; }), "({ int ar[5]; int* p = ar + 2; p - ar; })"); - assert(1, ({ struct { int a; int b; } x; x.a = 1; x.b = 2; x.a; }), "({ struct { int a; int b; } x; x.a = 1; x.b = 2; x.a; })"); + /*assert(1, ({ struct { int a; int b; } x; x.a = 1; x.b = 2; x.a; }), "({ struct { int a; int b; } x; x.a = 1; x.b = 2; x.a; })"); assert(2, ({ struct { int a; int b; } x; x.a = 1; x.b = 2; x.b; }), "({ struct { int a; int b; } x; x.a = 1; x.b = 2; x.b; })"); assert(1, ({ struct { char a; int b; char c; } x; x.a = 1; x.b = 2; x.c = 3; x.a; }), "({ struct { char a; int b; char c; } x; x.a = 1; x.b = 2; x.c = 3; x.a; })"); assert(2, ({ struct { char a; int b; char c; } x; x.a = 1; x.b = 2; x.c = 3; x.b; }), "({ struct { char a; int b; char c; } x; x.a = 1; x.b = 2; x.c = 3; x.b; })"); @@ -491,7 +489,7 @@ int main() assert(4, gl, "gl"); assert(3, *gp, "*gp"); assert(0, strcmp(gstr, "abc"), "strcmp(gstr, \"abc\")"); - + */ printf("All tests are passed!\n"); return 0; From 12e0a09de1fc39416c60d4d2d7ff29f28e30e3c8 Mon Sep 17 00:00:00 2001 From: roki Date: Mon, 28 Dec 2020 21:20:14 +0900 Subject: [PATCH 27/51] Allow no body for statements --- src/Htcc/Parser/Combinators/Program.hs | 24 +++++++++++------------- test/Tests/csrc/test_core.c | 1 + 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index ba4e26e..46216f7 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -54,6 +54,7 @@ import Htcc.Parser.Combinators.Type (arraySuffix, cType, constantExp) import Htcc.Parser.Combinators.Utils (bracket, + maybeToParser, registerLVar) import Htcc.Parser.Combinators.Var (varInit) import Htcc.Parser.ConstructionData (addFunction, @@ -168,8 +169,7 @@ gvar = do nonInit ty ident = do void semi - ty' <- maybe (fail "defining global variables with a incomplete type") pure - =<< lift (gets $ incomplete ty) + ty' <- maybeToParser "defining global variables with a incomplete type" =<< lift (gets $ incomplete ty) lift (gets (addGVar ty' (tmpTKIdent ident))) >>= \case Left err -> fail $ T.unpack $ fst err @@ -177,8 +177,7 @@ gvar = do withInit ty ident = do void $ symbol "=" - ty' <- maybe (fail "defining global variables with a incomplete type") pure - =<< lift (gets $ incomplete ty) + ty' <- maybeToParser "defining global variables with a incomplete type" =<< lift (gets $ incomplete ty) gvarInit ty' ident <* semi gvarInit ty ident = choice @@ -254,7 +253,7 @@ stmt = choice [ x | x <- [initSect, condSect, incrSect] , case fromATKindFor x of ATEmpty -> False; x' -> not $ isEmptyExprStmt x' ] - atFor . (es <>) . (:[]) . ATForStmt <$> stmt + atFor es <$ semi M.<|> atFor . (es <>) . (:[]) . ATForStmt <$> stmt lvarStmt = choice [ ATEmpty <$ M.try (cType <* semi) @@ -299,8 +298,8 @@ shift = binaryOperator add ] add = binaryOperator term - [ (symbol "+", \l r -> maybe (fail "invalid operands") pure $ addKind l r) - , (symbol "-", \l r -> maybe (fail "invalid operands") pure $ subKind l r) + [ (symbol "+", \l r -> maybeToParser "invalid operands" $ addKind l r) + , (symbol "-", \l r -> maybeToParser "invalid operands" $ subKind l r) ] term = binaryOperator unary @@ -331,10 +330,9 @@ unary = choice idxAcc fac = do idx <- brackets expr - kt <- maybe (fail "invalid operands") pure (addKind fac idx) - ty <- maybe (fail "subscripted value is neither array nor pointer nor vector") pure - $ CT.deref $ atype kt - ty' <- maybe (fail "incomplete value dereference") pure =<< lift (gets $ incomplete ty) + kt <- maybeToParser "invalid operands" (addKind fac idx) + ty <- maybeToParser "subscripted value is neither array nor pointer nor vector" $ CT.deref $ atype kt + ty' <- maybeToParser "incomplete value dereference" =<< lift (gets $ incomplete ty) allAcc $ atUnary ATDeref ty' kt deref' = runMaybeT . deref'' >=> maybe M.empty pure @@ -359,8 +357,8 @@ factor = choice where sizeof = kSizeof >> choice [ incomplete <$> M.try (parens cType) <*> lift get - >>= maybe (fail "invalid application of 'sizeof' to incomplete type") - (pure . atNumLit . fromIntegral . CT.sizeof) + >>= fmap (atNumLit . fromIntegral . CT.sizeof) + . maybeToParser "invalid application of 'sizeof' to incomplete type" , atNumLit . fromIntegral . CT.sizeof . atype <$> unary ] diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/test_core.c index cf50b18..e95af84 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/test_core.c @@ -118,6 +118,7 @@ int main() assert(53, ({ int a = 42; int b = 5; *(&a-1) = 53; b; }), "({ int a = 42; int b = 5; *(&a-1) = 53; b; })"); assert(53, ({ int a = 42; int b = 5; *(&b+1) = 53; a; }), "({ int a = 42; int b = 5; *(&b+1) = 53; a; })"); assert(6, ({ int s = 0; int i = 1; for (; i < 4; i = i + 1) s = s + i; s; }), "({ int s = 0; int i = 1; for (; i < 4; i = i + 1) s = s + i; return s; })"); + assert(3, ({ int a = 0; for(; a < 3; a = a + 1); a; }), "({ int a = 0; for(; a < 3; a = a + 1); a; })"); assert(3, ({ int ar[2]; int* p = ar; *p = 3; *ar; }), "({ int ar[2]; int* p = ar; *p = 3; *ar; })"); assert(3, ({ int ar[2]; int* p = ar; *(p + 1) = 3; *(ar + 1); }), "({ int ar[2]; int* p = ar; *(p + 1) = 3; *(ar + 1); })"); assert(5, ({ int ar[2]; int* p = ar; *p = 2; *(p + 1) = 3; *ar + *(ar + 1); }), "({ int ar[2]; int* p = ar; *p = 2; *(p + 1) = 3; *ar + *(ar + 1); })"); From 02f0344f436ced3516377c97846800ac2fae202e Mon Sep 17 00:00:00 2001 From: roki Date: Mon, 28 Dec 2020 22:23:19 +0900 Subject: [PATCH 28/51] Add a conditional operator --- src/Htcc/Parser/Combinators/Program.hs | 23 ++++++++++++++++----- src/Htcc/Parser/Combinators/Program.hs-boot | 2 +- src/Htcc/Parser/Combinators/Type.hs | 4 ++-- test/Tests/csrc/test_core.c | 20 +++++++++--------- 4 files changed, 31 insertions(+), 18 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 46216f7..dc3300f 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -12,11 +12,12 @@ C language lexer {-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings, TupleSections #-} module Htcc.Parser.Combinators.Program ( parser - , logicalOr + , conditional ) where import Control.Monad (forM, void, (>=>)) import Control.Monad.Combinators (choice, some) +import Control.Monad.Extra (ifM) import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) @@ -37,6 +38,7 @@ import Htcc.Parser.AST.Core (ATKind (..), ATKindFor (..), ATree (..), atBlock, + atConditional, atDefFunc, atElse, atExprStmt, atFor, atGVar, atIf, @@ -110,6 +112,7 @@ global, stmt, expr, assign, + conditional, logicalOr, logicalAnd, bitwiseOr, @@ -186,7 +189,7 @@ gvar = do ] where fromOG = do - ast <- logicalOr + ast <- conditional case (atkind ast, atkind (atL ast)) of (ATAddr, ATGVar _ name) -> lift (gets (gvarInitWithOG ty name)) >>= \case @@ -264,12 +267,22 @@ stmt = choice expr = assign assign = do - nd <- logicalOr + nd <- conditional choice [ symbol "=" >> (ATNode ATAssign (atype nd) nd <$> assign) , pure nd ] +conditional = do + nd <- logicalOr + ifM (M.option False (True <$ M.lookAhead "?")) (gnuCondOmitted nd M.<|> condOp nd) $ pure nd + where + -- GNU extension (Conditionals with Omitted Operands, see also: https://gcc.gnu.org/onlinedocs/gcc/Conditionals.html) + gnuCondOmitted nd = M.try (symbol "?" *> symbol ":") *> ((atConditional (atype nd) nd ATEmpty) <$> conditional) + condOp nd = (\thn c -> atConditional (atype thn) nd thn c) + <$> (symbol "?" *> expr <* symbol ":") + <*> conditional + logicalOr = binaryOperator logicalAnd [(symbol "||", binOpBool ATLOr)] logicalAnd = binaryOperator bitwiseOr [(symbol "&&", binOpBool ATLAnd)] @@ -351,7 +364,7 @@ factor = choice , strLiteral , identifier' , M.try (parens expr) - , stmtExpr + , gnuStmtExpr , ATEmpty <$ M.eof ] where @@ -371,7 +384,7 @@ factor = choice Left err -> fail $ T.unpack $ fst err Right (nd, scp) -> nd <$ lift (put scp) - stmtExpr = do + gnuStmtExpr = do k <- parens compoundStmt if null k then fail "void value not ignored as it ought to be" else case last k of (ATNode ATExprStmt _ n _) -> pure $ atNoLeaf (ATStmtExpr $ init k <> [n]) (atype n) diff --git a/src/Htcc/Parser/Combinators/Program.hs-boot b/src/Htcc/Parser/Combinators/Program.hs-boot index f5c1988..cb88adb 100644 --- a/src/Htcc/Parser/Combinators/Program.hs-boot +++ b/src/Htcc/Parser/Combinators/Program.hs-boot @@ -4,4 +4,4 @@ import Data.Bits (Bits) import Htcc.Parser.AST (ATree) import Htcc.Parser.Combinators.Core (Parser) -logicalOr :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) +conditional :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs index 66bce99..8744719 100644 --- a/src/Htcc/Parser/Combinators/Type.hs +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -29,13 +29,13 @@ import qualified Htcc.CRules.Types as CT import Htcc.Parser.AST.Core (ATKind (..), ATree (..)) import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords -import {-# SOURCE #-} Htcc.Parser.Combinators.Program (logicalOr) +import {-# SOURCE #-} Htcc.Parser.Combinators.Program (conditional) import Htcc.Parser.ConstructionData (incomplete) import Htcc.Utils (toNatural) import qualified Text.Megaparsec as M constantExp :: (Bits i, Integral i, Show i, Read i) => Parser i i -constantExp = logicalOr >>= constantExp' +constantExp = conditional >>= constantExp' where fromBool = fromIntegral . fromEnum :: Num i => Bool -> i toBool x | x == 0 = False | otherwise = True diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/test_core.c index e95af84..5381b5b 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/test_core.c @@ -325,13 +325,13 @@ int main() assert(42, ({ int a = 84; a /= 2; a; }), "int a = 84; a /= 2; a;"); assert(42, ({ int a = 84; a /= 2; }), "int a = 84; a /= 2;"); assert(1, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar; p += 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar; p += 1; *p; })"); - assert(0, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; })"); + assert(0, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; })");*/ assert(1, 1 || 0, "1 || 0"); assert(1, (1 + 1) || 0 || 0, "(1 + 1) || 0 || 0"); assert(0, 0 || 0, "0 || 0"); assert(0, 0 || (1 - 1), "0 || (1 - 1)"); assert(1, 1 && 2, "1 && 2"); - assert(0, 2 && 3 && 4 && 0, "2 && 3 && 4 && 0"); + assert(0, 2 && 3 && 4 && 0, "2 && 3 && 4 && 0");/* assert(2, ({ int a = 6; a &= 3; a; }), "({ int a = 6; a &= 3; a; })"); assert(2, ({ int a = 6; a &= 3; }), "({ int a = 6; a &= 3; })"); assert(7, ({ int a = 6; a |= 3; a; }), "({ int a = 6; a |= 3; a; })"); @@ -342,17 +342,17 @@ int main() assert(2, ({ int a = 1; a <<= 1; }), "({ int a = 1; a <<= 1; })"); assert(2, ({ int a = 4; a >>= 1; a; }), "({ int a = 4; a >>= 1; a; })"); assert(2, ({ int a = 4; a >>= 1; }), "({ int a = 4; a >>= 1; })"); - assert(-1, ({ int a = -1; a >>= 1; }), "({ int a = -1; a >>= 1; })"); + assert(-1, ({ int a = -1; a >>= 1; }), "({ int a = -1; a >>= 1; })");*/ assert(42, 1 ? 42 : 0, "1 ? 42 : 0"); assert(42, 0 ? 0 : 42, "0 ? 0 : 42"); assert(42, ({ int a = 1; int b = 0; a || b ? 42 : 0; }), "({ int a = 1; int b = 0; a || b ? 42 : 0; })"); assert(42, ({ int a = 1; int b = 0; a && b ? 0 : 42; }), "({ int a = 1; int b = 0; a && b ? 0 : 42; })"); assert(42, ({ 42 ?: 0; }), "({ 42 ?: 0; })"); - assert(42, ({ int a = 42; a++ ?: 0; }), "({ int a = 42; a++ ?: 0; })"); + //assert(42, ({ int a = 42; a++ ?: 0; }), "({ int a = 42; a++ ?: 0; })"); assert(42, ({ sub3(2, 1, 1) ?: 42; }), "({ sub3(2, 1, 1) ?: 42; })"); - assert(43, ({ enum { a = 14 + 14 + 14, b }; b; }), "({ enum { a = 14 + 14 + 14, b }; b; })"); + //assert(43, ({ enum { a = 14 + 14 + 14, b }; b; }), "({ enum { a = 14 + 14 + 14, b }; b; })"); assert(10, ({ int ar[2 ? 5 * 2 : 5]; sizeof ar / sizeof *ar; }), "({ int ar[2 ? 5 * 2 : 5]; sizeof ar / sizeof *ar; })"); - assert(1, sizeof(signed char), "sizeof(signed char)"); +/* assert(1, sizeof(signed char), "sizeof(signed char)"); assert(1, sizeof(char signed), "sizeof(char signed)"); assert(4, sizeof(signed int), "sizeof(signed int)"); assert(4, sizeof(int signed), "sizeof(int signed)"); @@ -385,20 +385,20 @@ int main() assert(42, ({ auto struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; }), "({ register struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; })"); assert(42, ({ int i = 42; for (int i = 0; i < 10; ++i); i; }), "({ int i = 42; for (int i = 0; i < 10; ++i); i; })"); assert(42, ({ int i = 42; for (auto int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; }), "for (int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; })"); - assert(42, ({ for (struct { int x; } x; 0;); 42; }), "({ for (struct { int x; } x; 0;); 42; })"); + assert(42, ({ for (struct { int x; } x; 0;); 42; }), "({ for (struct { int x; } x; 0;); 42; })");*/ assert(511, 0777, "0777"); assert(0, 0x0, "0x0"); assert(10, 0xa, "0xa"); assert(10, 0Xa, "0Xa"); assert(48879, 0xbeef, "0xbeef"); assert(48879, 0xBEEF, "0xBEEF"); - assert(0, 0b0, "0b0"); + /*assert(0, 0b0, "0b0"); assert(1, 0b1, "0b1"); assert(42, 0b101010, "0b101010"); - assert(42, 0B101010, "0B101010"); + assert(42, 0B101010, "0B101010");*/ assert(49389, 0xc0ed, "0xc0ed"); assert(49389, 0xC0eD, "0xC0eD"); - assert(42, ({ int a = 53; int b = 42; swap(&a, &b); a; }), "({ int a = 53; int b = 42; swap(&a, &b); a; })"); +/* assert(42, ({ int a = 53; int b = 42; swap(&a, &b); a; }), "({ int a = 53; int b = 42; swap(&a, &b); a; })"); assert(42, ({ int a = 0; void_fn(&a); a; }), "({ int a = 53; int b = 42; swap(&a, &b); a; })"); assert(42, ({ int ar[2]; ar[0] = 42; param_decay(ar); }), "({ int ar[2]; ar[0] = 0; param_decay(ar); })"); assert(4, ({ struct X *a; struct X { int x; }; sizeof(struct X); }), " ({ struct X *a; struct X { int x; }; sizeof(struct X); })"); From 95b5b838579c0d9a4d4dd62420079791c0fee0cf Mon Sep 17 00:00:00 2001 From: roki Date: Tue, 29 Dec 2020 02:27:21 +0900 Subject: [PATCH 29/51] Add assignment operators --- src/Htcc/Parser/Combinators/Program.hs | 21 ++++++++++++++++----- test/Tests/csrc/test_core.c | 18 +++++++++--------- 2 files changed, 25 insertions(+), 14 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index dc3300f..53e37df 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -31,13 +31,14 @@ import Data.Functor ((<&>)) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Text as T +import Data.Tuple.Extra (dupe, first) import qualified Htcc.CRules.Types as CT import Htcc.Parser.AST (Treealizable (..), addKind, subKind) import Htcc.Parser.AST.Core (ATKind (..), ATKindFor (..), ATree (..), - atBlock, + atBlock, atComma, atConditional, atDefFunc, atElse, atExprStmt, atFor, @@ -268,10 +269,20 @@ expr = assign assign = do nd <- conditional - choice - [ symbol "=" >> (ATNode ATAssign (atype nd) nd <$> assign) - , pure nd + M.option nd $ choice $ map (`id` nd) $ + [ assignOp ATAssign "=" + , assignOp ATMulAssign "*=" + , assignOp ATDivAssign "/=" + , assignOp ATAndAssign "&=" + , assignOp ATOrAssign "|=" + , assignOp ATXorAssign "^=" + , assignOp ATShlAssign "<<=" + , assignOp ATShrAssign ">>=" + , assignOp (maybe ATAddAssign (const ATAddPtrAssign) $ CT.deref (atype nd)) "+=" + , assignOp (maybe ATSubAssign (const ATSubPtrAssign) $ CT.deref (atype nd)) "-=" ] + where + assignOp k s nd = symbol s *> (ATNode k (atype nd) nd <$> assign) conditional = do nd <- logicalOr @@ -279,7 +290,7 @@ conditional = do where -- GNU extension (Conditionals with Omitted Operands, see also: https://gcc.gnu.org/onlinedocs/gcc/Conditionals.html) gnuCondOmitted nd = M.try (symbol "?" *> symbol ":") *> ((atConditional (atype nd) nd ATEmpty) <$> conditional) - condOp nd = (\thn c -> atConditional (atype thn) nd thn c) + condOp nd = uncurry (flip atConditional nd) . first atype . dupe <$> (symbol "?" *> expr <* symbol ":") <*> conditional diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/test_core.c index 5381b5b..302c9a7 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/test_core.c @@ -41,11 +41,11 @@ int sub3(int a, int b, int c) { return a - b - c; } int sub3_short(short a, short b, short c) { return a - b - c; } int sub3_long(long a, long b, long c) { return a - b - c; } /*int ptr2ar(int (*p)[3]) { int i = 0; for (; i < sizeof *p / sizeof **p; i = i + 1) p[0][i] = i + 1; return 0; } -static int static_fun() { return 42; } -void swap(int* a, int* b) { *a ^= *b; *b ^= *a; *a ^= *b; } +static int static_fun() { return 42; }*/ +/*void swap(int* a, int* b) { *a ^= *b; *b ^= *a; *a ^= *b; } void void_fn(int* a) { *a = 42; return; *a = 53; } -int param_decay(int ar[]) { return ar[0]; } -*/ +int param_decay(int ar[]) { return ar[0]; }*/ + int main() { test_num = 1; @@ -315,7 +315,7 @@ int main() assert(0, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; ar[0]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; ar[0]; })"); assert(0, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[1]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[1]; })"); assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[2]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[2]; })"); - assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; })"); + assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; })");*/ assert(42, ({ int a = 2; a += 40; a; }), "int a = 2; a += 40; a;"); assert(42, ({ int a = 2; a += 40; }), "int a = 2; a += 40;"); assert(42, ({ int a = 44; a -= 2; a; }), "int a = 44; a -= 2; a;"); @@ -323,7 +323,7 @@ int main() assert(42, ({ int a = 21; a *= 2; a; }), "int a = 21; a *= 2; a;"); assert(42, ({ int a = 21; a *= 2; }), "int a = 21; a *= 2;"); assert(42, ({ int a = 84; a /= 2; a; }), "int a = 84; a /= 2; a;"); - assert(42, ({ int a = 84; a /= 2; }), "int a = 84; a /= 2;"); + assert(42, ({ int a = 84; a /= 2; }), "int a = 84; a /= 2;");/* assert(1, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar; p += 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar; p += 1; *p; })"); assert(0, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; })");*/ assert(1, 1 || 0, "1 || 0"); @@ -331,7 +331,7 @@ int main() assert(0, 0 || 0, "0 || 0"); assert(0, 0 || (1 - 1), "0 || (1 - 1)"); assert(1, 1 && 2, "1 && 2"); - assert(0, 2 && 3 && 4 && 0, "2 && 3 && 4 && 0");/* + assert(0, 2 && 3 && 4 && 0, "2 && 3 && 4 && 0"); assert(2, ({ int a = 6; a &= 3; a; }), "({ int a = 6; a &= 3; a; })"); assert(2, ({ int a = 6; a &= 3; }), "({ int a = 6; a &= 3; })"); assert(7, ({ int a = 6; a |= 3; a; }), "({ int a = 6; a |= 3; a; })"); @@ -342,7 +342,7 @@ int main() assert(2, ({ int a = 1; a <<= 1; }), "({ int a = 1; a <<= 1; })"); assert(2, ({ int a = 4; a >>= 1; a; }), "({ int a = 4; a >>= 1; a; })"); assert(2, ({ int a = 4; a >>= 1; }), "({ int a = 4; a >>= 1; })"); - assert(-1, ({ int a = -1; a >>= 1; }), "({ int a = -1; a >>= 1; })");*/ + assert(-1, ({ int a = -1; a >>= 1; }), "({ int a = -1; a >>= 1; })"); assert(42, 1 ? 42 : 0, "1 ? 42 : 0"); assert(42, 0 ? 0 : 42, "0 ? 0 : 42"); assert(42, ({ int a = 1; int b = 0; a || b ? 42 : 0; }), "({ int a = 1; int b = 0; a || b ? 42 : 0; })"); @@ -398,7 +398,7 @@ int main() assert(42, 0B101010, "0B101010");*/ assert(49389, 0xc0ed, "0xc0ed"); assert(49389, 0xC0eD, "0xC0eD"); -/* assert(42, ({ int a = 53; int b = 42; swap(&a, &b); a; }), "({ int a = 53; int b = 42; swap(&a, &b); a; })"); + /*assert(42, ({ int a = 53; int b = 42; swap(&a, &b); a; }), "({ int a = 53; int b = 42; swap(&a, &b); a; })"); assert(42, ({ int a = 0; void_fn(&a); a; }), "({ int a = 53; int b = 42; swap(&a, &b); a; })"); assert(42, ({ int ar[2]; ar[0] = 42; param_decay(ar); }), "({ int ar[2]; ar[0] = 0; param_decay(ar); })"); assert(4, ({ struct X *a; struct X { int x; }; sizeof(struct X); }), " ({ struct X *a; struct X { int x; }; sizeof(struct X); })"); From 84c7e45c6386fe65ec1c247699a4bb341271c9a2 Mon Sep 17 00:00:00 2001 From: roki Date: Tue, 29 Dec 2020 02:40:45 +0900 Subject: [PATCH 30/51] Add the pre/post increment and decrement operator --- src/Htcc/Parser/Combinators/Program.hs | 17 ++++++++++++----- test/Tests/csrc/test_core.c | 14 +++++++------- 2 files changed, 19 insertions(+), 12 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 53e37df..c7ff44b 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -333,12 +333,14 @@ term = binaryOperator unary ] unary = choice - [ symbol "+" >> unary - , symbol "-" >> unary <&> \n -> ATNode ATSub (atype n) (atNumLit 0) n - , symbol "!" >> unary <&> flip (ATNode ATNot (CT.SCAuto CT.CTBool)) ATEmpty - , symbol "~" >> unary <&> flip (ATNode ATBitNot (CT.SCAuto CT.CTInt)) ATEmpty + [ symbol "++" *> unary <&> \n -> ATNode ATPreInc (atype n) n ATEmpty + , symbol "--" *> unary <&> \n -> ATNode ATPreDec (atype n) n ATEmpty + , symbol "+" *> unary + , symbol "-" *> unary <&> \n -> ATNode ATSub (atype n) (atNumLit 0) n + , symbol "!" *> unary <&> flip (ATNode ATNot (CT.SCAuto CT.CTBool)) ATEmpty + , symbol "~" *> unary <&> flip (ATNode ATBitNot (CT.SCAuto CT.CTInt)) ATEmpty , addr - , symbol "*" >> unary >>= deref' + , symbol "*" *> unary >>= deref' , factor' ] where @@ -350,6 +352,8 @@ unary = choice where allAcc fac = M.option fac $ choice [ idxAcc fac + , postInc fac + , postDec fac ] idxAcc fac = do @@ -359,6 +363,9 @@ unary = choice ty' <- maybeToParser "incomplete value dereference" =<< lift (gets $ incomplete ty) allAcc $ atUnary ATDeref ty' kt + postInc fac = allAcc =<< atUnary ATPostInc (atype fac) fac <$ symbol "++" + postDec fac = allAcc =<< atUnary ATPostDec (atype fac) fac <$ symbol "--" + deref' = runMaybeT . deref'' >=> maybe M.empty pure where deref'' n = do diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/test_core.c index 302c9a7..d016622 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/test_core.c @@ -301,7 +301,7 @@ int main() assert(4, ({ enum { zero, one, two } x; sizeof x; }), "enum { zero, one, two } x; sizeof x;"); assert(4, ({ enum t { zero, one, two }; enum t y; sizeof y; }), "enum t { zero, one, two }; enum t y; sizeof y;"); assert(0, ({ typedef enum { zero } e; e y = zero; y; }), " ({ typedef enum { zero } e; e y = zero; y; })"); - assert(42, (1, 2, 42), "(1, 2, 42)"); + assert(42, (1, 2, 42), "(1, 2, 42)");*/ assert(42, ({ int a = 41; ++a; }), "({ int a = 41; ++a; })"); assert(42, ({ int a = 43; --a; }), "({ int a = 43; --a; })"); assert(42, ({ int a = 42; a++; }), "({ int a = 41; a++; })"); @@ -315,7 +315,7 @@ int main() assert(0, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; ar[0]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; ar[0]; })"); assert(0, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[1]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[1]; })"); assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[2]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[2]; })"); - assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; })");*/ + assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; })"); assert(42, ({ int a = 2; a += 40; a; }), "int a = 2; a += 40; a;"); assert(42, ({ int a = 2; a += 40; }), "int a = 2; a += 40;"); assert(42, ({ int a = 44; a -= 2; a; }), "int a = 44; a -= 2; a;"); @@ -323,9 +323,9 @@ int main() assert(42, ({ int a = 21; a *= 2; a; }), "int a = 21; a *= 2; a;"); assert(42, ({ int a = 21; a *= 2; }), "int a = 21; a *= 2;"); assert(42, ({ int a = 84; a /= 2; a; }), "int a = 84; a /= 2; a;"); - assert(42, ({ int a = 84; a /= 2; }), "int a = 84; a /= 2;");/* + assert(42, ({ int a = 84; a /= 2; }), "int a = 84; a /= 2;"); assert(1, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar; p += 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar; p += 1; *p; })"); - assert(0, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; })");*/ + assert(0, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; })"); assert(1, 1 || 0, "1 || 0"); assert(1, (1 + 1) || 0 || 0, "(1 + 1) || 0 || 0"); assert(0, 0 || 0, "0 || 0"); @@ -348,7 +348,7 @@ int main() assert(42, ({ int a = 1; int b = 0; a || b ? 42 : 0; }), "({ int a = 1; int b = 0; a || b ? 42 : 0; })"); assert(42, ({ int a = 1; int b = 0; a && b ? 0 : 42; }), "({ int a = 1; int b = 0; a && b ? 0 : 42; })"); assert(42, ({ 42 ?: 0; }), "({ 42 ?: 0; })"); - //assert(42, ({ int a = 42; a++ ?: 0; }), "({ int a = 42; a++ ?: 0; })"); + assert(42, ({ int a = 42; a++ ?: 0; }), "({ int a = 42; a++ ?: 0; })"); assert(42, ({ sub3(2, 1, 1) ?: 42; }), "({ sub3(2, 1, 1) ?: 42; })"); //assert(43, ({ enum { a = 14 + 14 + 14, b }; b; }), "({ enum { a = 14 + 14 + 14, b }; b; })"); assert(10, ({ int ar[2 ? 5 * 2 : 5]; sizeof ar / sizeof *ar; }), "({ int ar[2 ? 5 * 2 : 5]; sizeof ar / sizeof *ar; })"); @@ -382,9 +382,9 @@ int main() assert(42, ({ register struct { int x; } x; x.x = 42; x.x; }), "({ register struct { int x; } x; x.x = 42; x.x; })"); assert(42, ({ register struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; }), "({ register struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; })"); assert(42, ({ auto struct { int x; } x; x.x = 42; x.x; }), "({ auto struct { int x; } x; x.x = 42; x.x; })"); - assert(42, ({ auto struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; }), "({ register struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; })"); + assert(42, ({ auto struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; }), "({ register struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; })");*/ assert(42, ({ int i = 42; for (int i = 0; i < 10; ++i); i; }), "({ int i = 42; for (int i = 0; i < 10; ++i); i; })"); - assert(42, ({ int i = 42; for (auto int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; }), "for (int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; })"); + /*assert(42, ({ int i = 42; for (auto int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; }), "for (int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; })"); assert(42, ({ for (struct { int x; } x; 0;); 42; }), "({ for (struct { int x; } x; 0;); 42; })");*/ assert(511, 0777, "0777"); assert(0, 0x0, "0x0"); From 4023eea9c4df952634d71612fe51f3ca3a5182d2 Mon Sep 17 00:00:00 2001 From: roki Date: Tue, 29 Dec 2020 02:48:01 +0900 Subject: [PATCH 31/51] Add the break statement --- src/Htcc/Parser/Combinators/Program.hs | 5 ++++- test/Tests/csrc/test_core.c | 5 ++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index c7ff44b..d30091b 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -46,7 +46,7 @@ import Htcc.Parser.AST.Core (ATKind (..), atNoLeaf, atNull, atNumLit, atReturn, atUnary, - atWhile, + atWhile, atBreak, fromATKindFor, isEmptyExprStmt) import Htcc.Parser.AST.Type (ASTs) @@ -225,6 +225,7 @@ stmt = choice , ifStmt , whileStmt , forStmt + , breakStmt , atBlock <$> compoundStmt , lvarStmt , atExprStmt <$> (expr <* semi) @@ -259,6 +260,8 @@ stmt = choice ] atFor es <$ semi M.<|> atFor . (es <>) . (:[]) . ATForStmt <$> stmt + breakStmt = atBreak <$ (M.try kBreak *> semi) + lvarStmt = choice [ ATEmpty <$ M.try (cType <* semi) , M.try (declIdent <* semi) >>= fmap atNull . uncurry registerLVar diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/test_core.c index d016622..1c2534b 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/test_core.c @@ -402,12 +402,11 @@ int main() assert(42, ({ int a = 0; void_fn(&a); a; }), "({ int a = 53; int b = 42; swap(&a, &b); a; })"); assert(42, ({ int ar[2]; ar[0] = 42; param_decay(ar); }), "({ int ar[2]; ar[0] = 0; param_decay(ar); })"); assert(4, ({ struct X *a; struct X { int x; }; sizeof(struct X); }), " ({ struct X *a; struct X { int x; }; sizeof(struct X); })"); - assert(42, ({ struct X { struct X* next; int x; } a; struct X b; b.x = 42; a.next = &b; a.next->x; }), "({ struct X { struct X* next; int x; } a; struct X b; b.x = 42; a.next = &b; a.next->x; })"); + assert(42, ({ struct X { struct X* next; int x; } a; struct X b; b.x = 42; a.next = &b; a.next->x; }), "({ struct X { struct X* next; int x; } a; struct X b; b.x = 42; a.next = &b; a.next->x; })");*/ assert(3, ({ int i = 0; for (; i < 10; ++i) { if (i == 3) break; } i; }), "({ int i = 0; for (; i < 10; ++i) { if (i == 3) break; } i; })"); assert(3, ({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; }), "({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; })"); assert(4, ({ int i = 0; while (1) { if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { if (i++ == 3) break; } i; })"); - assert(4, ({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; })"); - printf(">> All tests passed <<\n"); + assert(4, ({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; })");/* assert(10, ({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } i; }), "({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } i; })"); assert(6, ({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } j; }), "({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } j; })"); assert(10, ({ int i = 0; int j = 0; for (; !i;) { for (; j != 10; ++j) continue; break; } j; }), "({ int i = 0; int j = 0; for (; !i;) { for (; j != 10; ++j) continue; break; } j; }),"); From 511afebb2dcde4b4be1685a3426aa770886b46e1 Mon Sep 17 00:00:00 2001 From: roki Date: Tue, 29 Dec 2020 02:51:13 +0900 Subject: [PATCH 32/51] Add the continue statement --- src/Htcc/Parser/Combinators/Program.hs | 5 ++++- test/Tests/csrc/test_core.c | 4 ++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index d30091b..8325e49 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -47,7 +47,7 @@ import Htcc.Parser.AST.Core (ATKind (..), atNumLit, atReturn, atUnary, atWhile, atBreak, - fromATKindFor, + fromATKindFor, atContinue, isEmptyExprStmt) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator @@ -226,6 +226,7 @@ stmt = choice , whileStmt , forStmt , breakStmt + , continueStmt , atBlock <$> compoundStmt , lvarStmt , atExprStmt <$> (expr <* semi) @@ -262,6 +263,8 @@ stmt = choice breakStmt = atBreak <$ (M.try kBreak *> semi) + continueStmt = atContinue <$ (M.try kContinue *> semi) + lvarStmt = choice [ ATEmpty <$ M.try (cType <* semi) , M.try (declIdent <* semi) >>= fmap atNull . uncurry registerLVar diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/test_core.c index 1c2534b..c2cfa8b 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/test_core.c @@ -406,13 +406,13 @@ int main() assert(3, ({ int i = 0; for (; i < 10; ++i) { if (i == 3) break; } i; }), "({ int i = 0; for (; i < 10; ++i) { if (i == 3) break; } i; })"); assert(3, ({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; }), "({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; })"); assert(4, ({ int i = 0; while (1) { if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { if (i++ == 3) break; } i; })"); - assert(4, ({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; })");/* + assert(4, ({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; })"); assert(10, ({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } i; }), "({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } i; })"); assert(6, ({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } j; }), "({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } j; })"); assert(10, ({ int i = 0; int j = 0; for (; !i;) { for (; j != 10; ++j) continue; break; } j; }), "({ int i = 0; int j = 0; for (; !i;) { for (; j != 10; ++j) continue; break; } j; }),"); assert(11, ({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } i; }), "({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } i; })"); assert(5, ({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } j; }), "({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } j; })"); - assert(11, ({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; }), "({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; })"); + assert(11, ({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; }), "({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; })");/* assert(3, ({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; }), "({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; })"); assert(2, ({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; }), "({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; })"); assert(1, ({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; }), "({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; })"); From ae48ab8b59a04204dd85bc615d3c762c569cd808 Mon Sep 17 00:00:00 2001 From: roki Date: Tue, 29 Dec 2020 03:13:06 +0900 Subject: [PATCH 33/51] Add the switch, case and default statement --- src/Htcc/Parser/Combinators/Program.hs | 37 ++++++++++++++++++++++---- test/Tests/csrc/test_core.c | 4 +-- 2 files changed, 34 insertions(+), 7 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 8325e49..01aad68 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -38,16 +38,20 @@ import Htcc.Parser.AST (Treealizable (..), import Htcc.Parser.AST.Core (ATKind (..), ATKindFor (..), ATree (..), - atBlock, atComma, + atBlock, atBreak, + atCase, atComma, atConditional, - atDefFunc, atElse, + atContinue, + atDefFunc, + atDefault, atElse, atExprStmt, atFor, atGVar, atIf, atNoLeaf, atNull, atNumLit, - atReturn, atUnary, - atWhile, atBreak, - fromATKindFor, atContinue, + atReturn, + atSwitch, atUnary, + atWhile, + fromATKindFor, isEmptyExprStmt) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator @@ -66,6 +70,7 @@ import Htcc.Parser.ConstructionData (addFunction, addLiteral, fallBack, incomplete, + isSwitchStmt, lookupFunction, lookupVar, resetLocal, @@ -227,6 +232,9 @@ stmt = choice , forStmt , breakStmt , continueStmt + , switchStmt + , caseStmt + , defaultStmt , atBlock <$> compoundStmt , lvarStmt , atExprStmt <$> (expr <* semi) @@ -265,6 +273,25 @@ stmt = choice continueStmt = atContinue <$ (M.try kContinue *> semi) + switchStmt = do + cond <- M.try kSwitch *> parens expr + bracket (putSwitchState True) (const $ putSwitchState False) (const stmt) + >>= \case + ATNode (ATBlock ats) ty _ _ -> pure $ atSwitch cond ats ty + _ -> fail "expected compound statement after the token ')'" + where + putSwitchState b = lift $ modify $ \scp -> scp { isSwitchStmt = b } + + caseStmt = M.try kCase + *> ifM (lift $ gets isSwitchStmt) + ((atCase 0 <$> constantExp <* symbol ":") <*> stmt) + (fail "stray 'case'") + + defaultStmt = (M.try kDefault <* symbol ":") + *> ifM (lift $ gets isSwitchStmt) + (atDefault 0 <$> stmt) + (fail "stray 'default'") + lvarStmt = choice [ ATEmpty <$ M.try (cType <* semi) , M.try (declIdent <* semi) >>= fmap atNull . uncurry registerLVar diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/test_core.c index c2cfa8b..2611654 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/test_core.c @@ -415,7 +415,7 @@ int main() assert(11, ({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; }), "({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; })");/* assert(3, ({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; }), "({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; })"); assert(2, ({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; }), "({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; })"); - assert(1, ({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; }), "({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; })"); + assert(1, ({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; }), "({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; })");*/ assert(42, ({ int i = 0; switch (0) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (0) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); assert(43, ({ int i = 0; switch (1) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (1) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); assert(44, ({ int i = 0; switch (2) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (2) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); @@ -425,7 +425,7 @@ int main() assert(42, ({ int i = 0; switch (1) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; }), "({ int i = 0; switch (1) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; })"); assert(0, ({ int i = 0; switch (3) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; }), "({ int i = 0; switch (3) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; })"); assert(42, ({ int i = 40; switch (0) { case 0: ++i; case 1: ++i; } i; }), "({ int i = 40; switch (0) { case 0: ++i; case 1: ++i; } i; })"); - assert(41, ({ int i = 40; switch (i) { case 20 * 2: ++i; } i; }), "({ int i = 40; switch (i) { case 20 * 2: ++i; } i; })"); + assert(41, ({ int i = 40; switch (i) { case 20 * 2: ++i; } i; }), "({ int i = 40; switch (i) { case 20 * 2: ++i; } i; })");/* assert(1, ({ int ar[3] = { 1, 2, 3 }; ar[0]; }), "({ int ar[2] = { 1, 2, 3 }; ar[0]; })"); assert(2, ({ int ar[3] = { 1, 2, 3 }; ar[1]; }), "({ int ar[2] = { 1, 2, 3 }; ar[1]; })"); assert(3, ({ int ar[3] = { 1, 2, 3 }; ar[2]; }), "({ int ar[2] = { 1, 2, 3 }; ar[2]; })"); From 56a65bf2e2cc861f2409b7584ff9894c8fe6d866 Mon Sep 17 00:00:00 2001 From: roki Date: Tue, 29 Dec 2020 03:19:52 +0900 Subject: [PATCH 34/51] Add the goto statement --- src/Htcc/Parser/Combinators/Program.hs | 10 ++++++++-- test/Tests/csrc/test_core.c | 4 ++-- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 01aad68..6a5fa7a 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -47,11 +47,11 @@ import Htcc.Parser.AST.Core (ATKind (..), atExprStmt, atFor, atGVar, atIf, atNoLeaf, atNull, - atNumLit, + atNumLit, atLabel, atReturn, atSwitch, atUnary, atWhile, - fromATKindFor, + fromATKindFor, atGoto, isEmptyExprStmt) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator @@ -235,6 +235,8 @@ stmt = choice , switchStmt , caseStmt , defaultStmt + , gotoStmt + , labelStmt , atBlock <$> compoundStmt , lvarStmt , atExprStmt <$> (expr <* semi) @@ -292,6 +294,10 @@ stmt = choice (atDefault 0 <$> stmt) (fail "stray 'default'") + gotoStmt = atGoto <$> (M.try kGoto *> identifier <* semi) + + labelStmt = atLabel <$> M.try (identifier <* symbol ":") + lvarStmt = choice [ ATEmpty <$ M.try (cType <* semi) , M.try (declIdent <* semi) >>= fmap atNull . uncurry registerLVar diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/test_core.c index 2611654..d4b2d9e 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/test_core.c @@ -412,10 +412,10 @@ int main() assert(10, ({ int i = 0; int j = 0; for (; !i;) { for (; j != 10; ++j) continue; break; } j; }), "({ int i = 0; int j = 0; for (; !i;) { for (; j != 10; ++j) continue; break; } j; }),"); assert(11, ({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } i; }), "({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } i; })"); assert(5, ({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } j; }), "({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } j; })"); - assert(11, ({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; }), "({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; })");/* + assert(11, ({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; }), "({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; })"); assert(3, ({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; }), "({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; })"); assert(2, ({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; }), "({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; })"); - assert(1, ({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; }), "({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; })");*/ + assert(1, ({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; }), "({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; })"); assert(42, ({ int i = 0; switch (0) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (0) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); assert(43, ({ int i = 0; switch (1) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (1) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); assert(44, ({ int i = 0; switch (2) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (2) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); From db52236115e40823dc1b690243d75ce67e138c59 Mon Sep 17 00:00:00 2001 From: roki Date: Tue, 29 Dec 2020 03:23:07 +0900 Subject: [PATCH 35/51] Add tests --- test/Tests/csrc/test_core.c | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/test_core.c index d4b2d9e..7e3bb68 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/test_core.c @@ -10,15 +10,14 @@ int test_num; int g; int gr[3]; -/* -int (*gpa)[3]; +//int (*gpa)[3]; char gc = 1; short gsh = 2; int gi = 3; long gl = 4; int* gp = &gi; char* gstr = "abc"; -*/ + int assert(long expected, long actual, char* code) { if (expected == actual) { @@ -286,9 +285,9 @@ int main() assert(1, (long)1, "(long)1"); assert(0, (long)&*(int *)0, "(long)&*(int *)0"); assert(42, ({ int a = 42 ; long b = (long)&a; *(int*)b; }), "int a = 42; long b = (long)&a; *(int*)b"); - assert(2147483648, ({ int a = 2147483647; long b = a + 1; b; }), " ({ int a = 2147483647; long b = a + 1; b; })"); + assert(2147483648, ({ int a = 2147483647; long b = a + 1; b; }), " ({ int a = 2147483647; long b = a + 1; b; })");*/ assert(97, 'a', "'a'"); - assert(10, '\n', "\'\\n\'"); + assert(10, '\n', "\'\\n\'");/* assert(0, ({ enum { zero, one, two }; zero; }), "enum { zero, one, two }; zero;"); assert(1, ({ enum { zero, one, two }; one; }), "enum { zero, one, two }; one;"); assert(2, ({ enum { zero, one, two }; two; }), "enum { zero, one, two }; two;"); @@ -482,14 +481,14 @@ int main() assert(0, ({ struct { int a; int b; } x[2] = { { 1, 2 } }; x[1].a; }), "({ struct { int a; int b; } x[2] = { { 1, 2 } }; x[1].a; })"); assert(0, ({ struct { int a; int b; } x[2] = { { 1, 2 } }; x[1].b; }), "({ struct { int a; int b; } x[2] = { { 1, 2 } }; x[1].b; })"); assert(0, ({ struct { int a; int b; } x = {}; x.a; }), "({ struct { int a; int b; } x = {}; x.a; })"); - assert(0, ({ struct { int a; int b; } x = {}; x.b; }), "({ struct { int a; int b; } x = {}; x.b; })"); + assert(0, ({ struct { int a; int b; } x = {}; x.b; }), "({ struct { int a; int b; } x = {}; x.b; })");*/ assert(1, gc, "gc"); assert(2, gsh, "gsh"); assert(3, gi, "gi"); assert(4, gl, "gl"); assert(3, *gp, "*gp"); assert(0, strcmp(gstr, "abc"), "strcmp(gstr, \"abc\")"); - */ + printf("All tests are passed!\n"); return 0; From a44188f8fcac804c87af83392e254d53b2e770ea Mon Sep 17 00:00:00 2001 From: roki Date: Tue, 29 Dec 2020 03:50:06 +0900 Subject: [PATCH 36/51] refactoring: Separated parser combinator for GNU extensions --- htcc.cabal | 3 +- src/Htcc/Parser/Combinators/GNUExtensions.hs | 37 ++++++++++++++++++++ src/Htcc/Parser/Combinators/Program.hs | 23 +++++------- src/Htcc/Parser/Combinators/Program.hs-boot | 2 ++ 4 files changed, 50 insertions(+), 15 deletions(-) create mode 100644 src/Htcc/Parser/Combinators/GNUExtensions.hs diff --git a/htcc.cabal b/htcc.cabal index 24c9ecb..0bfbd79 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 82c6e6209364a3de198c302bcc53905a157a8bfd5c720be89ff9f32d6e7f356b +-- hash: ff5121aa8a5d3d8d22e341046abb4b45d00032001dab233a2a2f65d2d62deafe name: htcc version: 0.0.0.1 @@ -73,6 +73,7 @@ library Htcc.Parser.Combinators Htcc.Parser.Combinators.BasicOperator Htcc.Parser.Combinators.Core + Htcc.Parser.Combinators.GNUExtensions Htcc.Parser.Combinators.Keywords Htcc.Parser.Combinators.Program Htcc.Parser.Combinators.Type diff --git a/src/Htcc/Parser/Combinators/GNUExtensions.hs b/src/Htcc/Parser/Combinators/GNUExtensions.hs new file mode 100644 index 0000000..320d617 --- /dev/null +++ b/src/Htcc/Parser/Combinators/GNUExtensions.hs @@ -0,0 +1,37 @@ +{-| +Module : Htcc.Parser.Combinators.GNUExtensions +Description : Combinators of GNU extensions +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +Combinators of GNU extensions +-} +{-# LANGUAGE OverloadedStrings #-} +module Htcc.Parser.Combinators.GNUExtensions ( + condOmitted + , stmtExpr +) where + +import Data.Bits (Bits) +import Htcc.Parser.AST.Core (ATKind (..), ATree (..), + atConditional, atNoLeaf) +import Htcc.Parser.Combinators.Core +import {-# SOURCE #-} Htcc.Parser.Combinators.Program (compoundStmt, + conditional) +import qualified Text.Megaparsec as M + + +-- Conditionals with Omitted Operands, see also: https://gcc.gnu.org/onlinedocs/gcc/Conditionals.html +condOmitted :: (Ord i, Bits i, Read i, Show i, Integral i) => ATree i -> Parser i (ATree i) +condOmitted nd = M.try (symbol "?" *> symbol ":") *> ((atConditional (atype nd) nd ATEmpty) <$> conditional) + +-- Statements and Declarations in Expressions, see also: https://gcc.gnu.org/onlinedocs/gcc/Statement-Exprs.html +stmtExpr :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) +stmtExpr = do + k <- parens compoundStmt + if null k then fail "void value not ignored as it ought to be" else case last k of + (ATNode ATExprStmt _ n _) -> pure $ atNoLeaf (ATStmtExpr $ init k <> [n]) (atype n) + _ -> fail "void value not ignored as it ought to be" diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 6a5fa7a..98a1893 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -13,6 +13,7 @@ C language lexer module Htcc.Parser.Combinators.Program ( parser , conditional + , compoundStmt ) where import Control.Monad (forM, void, (>=>)) @@ -39,23 +40,25 @@ import Htcc.Parser.AST.Core (ATKind (..), ATKindFor (..), ATree (..), atBlock, atBreak, - atCase, atComma, + atCase, atConditional, atContinue, atDefFunc, atDefault, atElse, atExprStmt, atFor, - atGVar, atIf, + atGVar, atGoto, + atIf, atLabel, atNoLeaf, atNull, - atNumLit, atLabel, + atNumLit, atReturn, atSwitch, atUnary, atWhile, - fromATKindFor, atGoto, + fromATKindFor, isEmptyExprStmt) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.GNUExtensions as GNU import Htcc.Parser.Combinators.Keywords import Htcc.Parser.Combinators.Type (arraySuffix, cType, @@ -325,10 +328,8 @@ assign = do conditional = do nd <- logicalOr - ifM (M.option False (True <$ M.lookAhead "?")) (gnuCondOmitted nd M.<|> condOp nd) $ pure nd + ifM (M.option False (True <$ M.lookAhead "?")) (GNU.condOmitted nd M.<|> condOp nd) $ pure nd where - -- GNU extension (Conditionals with Omitted Operands, see also: https://gcc.gnu.org/onlinedocs/gcc/Conditionals.html) - gnuCondOmitted nd = M.try (symbol "?" *> symbol ":") *> ((atConditional (atype nd) nd ATEmpty) <$> conditional) condOp nd = uncurry (flip atConditional nd) . first atype . dupe <$> (symbol "?" *> expr <* symbol ":") <*> conditional @@ -421,7 +422,7 @@ factor = choice , strLiteral , identifier' , M.try (parens expr) - , gnuStmtExpr + , GNU.stmtExpr , ATEmpty <$ M.eof ] where @@ -441,12 +442,6 @@ factor = choice Left err -> fail $ T.unpack $ fst err Right (nd, scp) -> nd <$ lift (put scp) - gnuStmtExpr = do - k <- parens compoundStmt - if null k then fail "void value not ignored as it ought to be" else case last k of - (ATNode ATExprStmt _ n _) -> pure $ atNoLeaf (ATStmtExpr $ init k <> [n]) (atype n) - _ -> fail "void value not ignored as it ought to be" - identifier' = do ident <- identifier choice diff --git a/src/Htcc/Parser/Combinators/Program.hs-boot b/src/Htcc/Parser/Combinators/Program.hs-boot index cb88adb..b02f140 100644 --- a/src/Htcc/Parser/Combinators/Program.hs-boot +++ b/src/Htcc/Parser/Combinators/Program.hs-boot @@ -5,3 +5,5 @@ import Htcc.Parser.AST (ATree) import Htcc.Parser.Combinators.Core (Parser) conditional :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) + +compoundStmt :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i [ATree i] From 87711a4bbda47b04cd17775f1455e999bc33cf67 Mon Sep 17 00:00:00 2001 From: roki Date: Wed, 6 Jan 2021 02:47:10 +0900 Subject: [PATCH 37/51] Allow array initialization list --- src/Htcc/Parser/Combinators/Core.hs | 81 +++++++++-- src/Htcc/Parser/Combinators/Program.hs | 49 ++++--- src/Htcc/Parser/Combinators/Type.hs | 5 +- src/Htcc/Parser/Combinators/Utils.hs | 4 + src/Htcc/Parser/Combinators/Var.hs | 180 +++++++++++++++++++++---- test/Tests/csrc/test_core.c | 30 +++-- 6 files changed, 282 insertions(+), 67 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Core.hs b/src/Htcc/Parser/Combinators/Core.hs index 6059857..92b36c0 100644 --- a/src/Htcc/Parser/Combinators/Core.hs +++ b/src/Htcc/Parser/Combinators/Core.hs @@ -31,6 +31,26 @@ module Htcc.Parser.Combinators.Core ( , semi , comma , colon + , lnot + , sharp + , ampersand + , lparen + , rparen + , lbrace + , rbrace + , langle + , rangle + , lbracket + , rbracket + , star + , period + , slash + , equal + , question + , hat + , tilda + , vertical + , percent , notFollowedBy ) where @@ -90,21 +110,66 @@ natural = M.try (lexeme hexadecimal) <|> M.try (lexeme octal) <|> lexeme decimal integer = ML.signed spaceConsumer natural <|> natural parens, braces, angles, brackets :: Ord e => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m a -parens = between (symbol "(") (symbol ")") -braces = between (symbol "{") (symbol "}") -angles = between (symbol "<") (symbol ">") -brackets = between (symbol "[") (symbol "]") +parens = between lparen rparen +braces = between lbrace rbrace +angles = between langle rangle +brackets = between lbracket rbracket -identifier, semi, comma, colon :: Ord e => M.ParsecT e T.Text m T.Text +identifier, + semi, + comma, + colon, + lnot, + sharp, + ampersand, + lparen, + rparen, + lbrace, + rbrace, + langle, + rangle, + lbracket, + rbracket, + star, + period, + slash, + equal, + question, + hat, + tilda, + vertical, + percent :: Ord e => M.ParsecT e T.Text m T.Text identifier = mappend <$> M.takeWhile1P (Just "valid identifier") (lor [isAlpha, (=='_')]) <*> M.takeWhileP (Just "valid identifier") CR.isValidChar <* spaceConsumer - semi = symbol ";" comma = symbol "," -colon = symbol "." +colon = symbol ":" +lnot = symbol "!" +sharp = symbol "#" +ampersand = symbol "&" +lparen = symbol "(" +rparen = symbol ")" +lbrace = symbol "{" +rbrace = symbol "}" +langle = symbol "<" +rangle = symbol ">" +lbracket = symbol "[" +rbracket = symbol "]" +star = symbol "*" +period = symbol "." +slash = symbol "/" +equal = symbol "=" +question = symbol "?" +hat = symbol "^" +tilda = symbol "~" +vertical = symbol "|" +percent = symbol "%" -notFollowedBy :: Ord e => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m b -> M.ParsecT e T.Text m a +notFollowedBy :: Ord e + => M.ParsecT e T.Text m a + -> M.ParsecT e T.Text m b + -> M.ParsecT e T.Text m a notFollowedBy k p = lexeme (k <* M.notFollowedBy p) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 98a1893..e5a4e26 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -58,14 +58,15 @@ import Htcc.Parser.AST.Core (ATKind (..), import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.GNUExtensions as GNU +import qualified Htcc.Parser.Combinators.GNUExtensions as GNU import Htcc.Parser.Combinators.Keywords import Htcc.Parser.Combinators.Type (arraySuffix, cType, constantExp) import Htcc.Parser.Combinators.Utils (bracket, maybeToParser, - registerLVar) + registerLVar, + tmpTKIdent) import Htcc.Parser.Combinators.Var (varInit) import Htcc.Parser.ConstructionData (addFunction, addGVar, @@ -142,7 +143,7 @@ global = choice ] function = do - (ty, ident) <- M.try (declIdent <* symbol "(") + (ty, ident) <- M.try (declIdent <* lparen) params <- takeParameters lift $ modify resetLocal choice @@ -151,7 +152,7 @@ function = do ] where takeParameters = - M.manyTill (M.try (declIdentFuncArg comma) M.<|> (declIdentFuncArg $ M.lookAhead (symbol ")"))) (symbol ")") + M.manyTill (M.try (declIdentFuncArg comma) M.<|> (declIdentFuncArg $ M.lookAhead rparen)) rparen declaration ty ident = void semi @@ -161,7 +162,7 @@ function = do Left err -> fail $ T.unpack $ fst err definition ty ident params = - void (M.lookAhead $ symbol "{") + void (M.lookAhead lbrace) >> lift (gets $ addFunction True ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) >>= \case Right scp' -> do @@ -177,8 +178,6 @@ gvar = do , withInit ty ident ] where - tmpTKIdent ident = (HT.TokenLCNums 1 1, HT.TKIdent ident) - nonInit ty ident = do void semi ty' <- maybeToParser "defining global variables with a incomplete type" =<< lift (gets $ incomplete ty) @@ -188,7 +187,7 @@ gvar = do Right (_, scp) -> ATEmpty <$ lift (put scp) withInit ty ident = do - void $ symbol "=" + void equal ty' <- maybeToParser "defining global variables with a incomplete type" =<< lift (gets $ incomplete ty) gvarInit ty' ident <* semi @@ -289,22 +288,22 @@ stmt = choice caseStmt = M.try kCase *> ifM (lift $ gets isSwitchStmt) - ((atCase 0 <$> constantExp <* symbol ":") <*> stmt) + ((atCase 0 <$> constantExp <* colon) <*> stmt) (fail "stray 'case'") - defaultStmt = (M.try kDefault <* symbol ":") + defaultStmt = (M.try kDefault <* colon) *> ifM (lift $ gets isSwitchStmt) (atDefault 0 <$> stmt) (fail "stray 'default'") gotoStmt = atGoto <$> (M.try kGoto *> identifier <* semi) - labelStmt = atLabel <$> M.try (identifier <* symbol ":") + labelStmt = atLabel <$> M.try (identifier <* colon) lvarStmt = choice [ ATEmpty <$ M.try (cType <* semi) , M.try (declIdent <* semi) >>= fmap atNull . uncurry registerLVar - , (declIdent <* symbol "=" >>= uncurry (varInit assign)) <* semi + , (declIdent <* equal >>= uncurry (varInit assign)) <* semi ] expr = assign @@ -328,19 +327,19 @@ assign = do conditional = do nd <- logicalOr - ifM (M.option False (True <$ M.lookAhead "?")) (GNU.condOmitted nd M.<|> condOp nd) $ pure nd + ifM (M.option False (True <$ M.lookAhead question)) (GNU.condOmitted nd M.<|> condOp nd) $ pure nd where condOp nd = uncurry (flip atConditional nd) . first atype . dupe - <$> (symbol "?" *> expr <* symbol ":") + <$> (question *> expr <* colon) <*> conditional logicalOr = binaryOperator logicalAnd [(symbol "||", binOpBool ATLOr)] logicalAnd = binaryOperator bitwiseOr [(symbol "&&", binOpBool ATLAnd)] -bitwiseOr = binaryOperator bitwiseXor [(symbol "|", binOpIntOnly ATOr)] +bitwiseOr = binaryOperator bitwiseXor [(vertical, binOpIntOnly ATOr)] -bitwiseXor = binaryOperator bitwiseAnd [(symbol "^", binOpIntOnly ATXor)] +bitwiseXor = binaryOperator bitwiseAnd [(hat, binOpIntOnly ATXor)] bitwiseAnd = binaryOperator equality [(MC.char '&' `notFollowedOp` MC.char '&', binOpIntOnly ATAnd)] @@ -351,9 +350,9 @@ equality = binaryOperator relational relational = binaryOperator shift [ (symbol "<=", binOpBool ATLEQ) - , (symbol "<", binOpBool ATLT) + , (langle, binOpBool ATLT) , (symbol ">=", binOpBool ATGEQ) - , (symbol ">", binOpBool ATGT) + , (rangle, binOpBool ATGT) ] shift = binaryOperator add @@ -367,9 +366,9 @@ add = binaryOperator term ] term = binaryOperator unary - [ (symbol "*", binOpCon ATMul) - , (symbol "/", binOpCon ATDiv) - , (symbol "%", binOpCon ATMod) + [ (star, binOpCon ATMul) + , (slash, binOpCon ATDiv) + , (percent, binOpCon ATMod) ] unary = choice @@ -377,10 +376,10 @@ unary = choice , symbol "--" *> unary <&> \n -> ATNode ATPreDec (atype n) n ATEmpty , symbol "+" *> unary , symbol "-" *> unary <&> \n -> ATNode ATSub (atype n) (atNumLit 0) n - , symbol "!" *> unary <&> flip (ATNode ATNot (CT.SCAuto CT.CTBool)) ATEmpty - , symbol "~" *> unary <&> flip (ATNode ATBitNot (CT.SCAuto CT.CTInt)) ATEmpty + , lnot *> unary <&> flip (ATNode ATNot (CT.SCAuto CT.CTBool)) ATEmpty + , tilda *> unary <&> flip (ATNode ATBitNot (CT.SCAuto CT.CTInt)) ATEmpty , addr - , symbol "*" *> unary >>= deref' + , star *> unary >>= deref' , factor' ] where @@ -458,7 +457,7 @@ factor = choice NotFound -> fail $ "The '" <> T.unpack ident <> "' is not defined identifier" fnCall ident = do - params <- symbol "(" >> M.manyTill (M.try (expr <* comma) M.<|> expr) (symbol ")") + params <- lparen *> M.manyTill (M.try (expr <* comma) M.<|> expr) rparen let params' = if null params then Nothing else Just params lift (gets $ lookupFunction ident) <&> \case -- TODO: set warning message diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs index 8744719..dcba38f 100644 --- a/src/Htcc/Parser/Combinators/Type.hs +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -90,8 +90,9 @@ arraySuffix ty = choice >>= failWithTypeMaybe ty' nonConstantExp = let mtIncomplete ty' = MaybeT $ lift $ gets $ incomplete ty' in - brackets M.eof - >> M.option Nothing (Just <$> arraySuffix ty) + symbol "[" + *> symbol "]" + *> M.option Nothing (Just <$> arraySuffix ty) >>= \case Nothing -> runMaybeT (CT.mapTypeKind (CT.CTIncomplete . CT.IncompleteArray) <$> mtIncomplete ty) diff --git a/src/Htcc/Parser/Combinators/Utils.hs b/src/Htcc/Parser/Combinators/Utils.hs index f952d65..58ac1d7 100644 --- a/src/Htcc/Parser/Combinators/Utils.hs +++ b/src/Htcc/Parser/Combinators/Utils.hs @@ -14,6 +14,7 @@ module Htcc.Parser.Combinators.Utils ( maybeToParser , registerLVar , bracket + , tmpTKIdent ) where import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.State (gets, put) @@ -40,3 +41,6 @@ bracket :: Parser i a -> (a -> Parser i b) -> (a -> Parser i c) -> Parser i c bracket beg end m = do b <- beg M.withRecovery (\err -> end b *> M.parseError err) (m b) <* end b + +tmpTKIdent :: Num i => T.Text -> HT.TokenLC i +tmpTKIdent ident = (HT.TokenLCNums 1 1, HT.TKIdent ident) diff --git a/src/Htcc/Parser/Combinators/Var.hs b/src/Htcc/Parser/Combinators/Var.hs index 2797c13..5c19eba 100644 --- a/src/Htcc/Parser/Combinators/Var.hs +++ b/src/Htcc/Parser/Combinators/Var.hs @@ -9,39 +9,91 @@ Portability : POSIX C language parser Combinators -} +{-# LANGUAGE OverloadedStrings #-} module Htcc.Parser.Combinators.Var ( varInit + , lengthArrayBrace ) where -import Control.Monad (forM) +import Control.Monad (forM, void, (>=>)) +import Control.Monad.Extra (andM) +import Control.Monad.Fix (fix) import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.State (gets) import Data.Bits (Bits) +import Data.Bool (bool) +import Data.Foldable (toList) import Data.Functor ((<&>)) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromJust, fromMaybe) +import qualified Data.Sequence as SQ import qualified Data.Text as T +import Data.Void import qualified Htcc.CRules.Types as CT import Htcc.Parser.AST (ATKind (..), ATree (..), - addKind, atAssign, atExprStmt, - atMemberAcc, atNumLit, atUnary, - treealize) + addKind, atAssign, atBlock, + atExprStmt, atMemberAcc, + atNumLit, atUnary, treealize) import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Utils (maybeToParser, registerLVar) +import Htcc.Parser.Combinators.Utils (bracket, maybeToParser, + registerLVar) import Htcc.Parser.ConstructionData (incomplete, lookupLVar) +import Htcc.Utils (tshow) import qualified Text.Megaparsec as M -chkValidAssign :: Eq i => ATree i -> Parser i (ATree i) -chkValidAssign at@(ATNode _ ty _ _) +import Text.Megaparsec.Debug (dbg) + +fromValidAssignAST :: Eq i => ATree i -> Parser i (ATree i) +fromValidAssignAST at@(ATNode _ ty _ _) | CT.toTypeKind ty == CT.CTVoid = fail "void value not ignored as it ought to be" | otherwise = pure at -chkValidAssign _ = fail "expected to assign" +fromValidAssignAST _ = fail "expected to assign" + +lengthArrayBrace :: Parser i Int +lengthArrayBrace = braces (arrayBrace 0) + where + arrayBrace c = M.choice + [ (+) <$> M.try (acc c <$> braces (arrayBrace (succ c)) <* comma) <*> arrayBrace c + , acc c <$> braces (arrayBrace $ succ c) + , (+) <$> M.try (accN c <$ validCharSets <* comma) <*> arrayBrace c + , accN c <$ validCharSets <* M.lookAhead "}" + , 0 <$ (M.lookAhead "}") + ] + acc n | n == 0 = succ | otherwise = id + accN n | n == 0 = 1 | otherwise = 0 + validCharSets = M.choice + [ identifier + , T.pack <$> stringLiteral + , T.singleton <$> charLiteral + , tshow <$> integer + , semi + , comma + , colon + , lnot + , sharp + , ampersand + , lparen + , rparen + , langle + , rangle + , lbracket + , rbracket + , star + , period + , slash + , equal + , question + , hat + , tilda + , vertical + ] + desgNode :: (Num i, Ord i, Show i) => T.Text -> ATree i - -> [CT.Desg i] + -> SQ.Seq (CT.Desg i) -> Parser i (ATree i) -desgNode ident rhs desg = fmap (atExprStmt . flip atAssign rhs) $ - flip (`foldr` ntLVarTree) desg $ \idx acc -> case idx of +desgNode ident nd desg = fmap (atExprStmt . flip atAssign nd) $ + flip (`foldr` (treealize <$> (maybeToParser' =<< lift (gets $ lookupLVar ident)))) desg $ \idx acc -> case idx of CT.DesgIdx idx' -> do at <- acc nd' <- maybeToParser' $ addKind at $ atNumLit idx' @@ -49,17 +101,97 @@ desgNode ident rhs desg = fmap (atExprStmt . flip atAssign rhs) $ CT.DesgMem mem -> atMemberAcc mem <$> acc where maybeToParser' = maybeToParser "invalid initializer-list" - ntLVarTree = treealize - <$> (maybeToParser' =<< lift (gets $ lookupLVar ident)) + +initLoop :: (Integral i, Bits i, Read i, Show i) + => Parser i (ATree i) + -> CT.StorageClass i + -> T.Text + -> SQ.Seq (ATree i) + -> SQ.Seq (CT.Desg i) + -> Parser i (SQ.Seq (ATree i), i) +initLoop p ty ident ai desg = initLoop' ai <* rbrace + where + initLoop' ai' = case CT.toTypeKind ty of + CT.CTArray _ _ -> ($ (0, ai')) . fix $ \f (idx, rl) -> do + rs <- desgInit p (fromJust $ CT.deref ty) ident rl (CT.DesgIdx idx SQ.<| desg) + M.choice + [ (rs, succ idx) <$ M.lookAhead "}" + , comma *> f (succ idx, rs) + ] + _ -> fail "internal compiler error" initZero :: (Num i, Ord i, Show i, Enum i) => CT.TypeKind i -> T.Text - -> [CT.Desg i] - -> Parser i [ATree i] -initZero (CT.CTArray n t) ident desg = fmap concat $ - forM [0..fromIntegral (pred n)] $ initZero t ident . (:desg) . CT.DesgIdx -initZero _ ident desg = (:[]) <$> desgNode ident (atNumLit 0) desg + -> SQ.Seq (CT.Desg i) + -> Parser i (SQ.Seq (ATree i)) +initZero (CT.CTArray n ty) ident desg = foldr idxs (pure SQ.empty) [0..fromIntegral (pred n)] + where + idxs idx acc = (SQ.><) <$> initZero ty ident (CT.DesgIdx idx SQ.<| desg) <*> acc +initZero _ ident desg = SQ.singleton <$> desgNode ident (atNumLit 0) desg + +initializerList :: (Integral i, Bits i, Read i, Show i) + => Parser i (ATree i) + -> CT.StorageClass i + -> T.Text + -> SQ.Seq (ATree i) + -> SQ.Seq (CT.Desg i) + -> Parser i (SQ.Seq (ATree i)) +initializerList p ty ident ai desg = M.choice + [ allZeroInit + , withInitElements + ] + where + allZeroInit = do + void $ M.try (lbrace *> rbrace) + (ai SQ.><) . SQ.fromList <$> forM + (CT.accessibleIndices $ CT.toTypeKind ty) + (desgNode ident (atNumLit 0) . (SQ.>< desg) . SQ.fromList) + + withInitElements + | CT.isIncompleteArray ty = do + newt <- bracket M.getInput M.setInput (const $ arType <$> lengthArrayBrace) + registerLVar newt ident *> desgInit p newt ident ai desg + | otherwise = do + void lbrace + case CT.toTypeKind ty of + CT.CTArray n bt -> do + (ast, idx) <- initLoop p ty ident ai desg + (ai SQ.><) . (ast SQ.><) + <$> foldr (idxs bt) (pure SQ.empty) [fromIntegral idx..pred (fromIntegral n)] + _ -> fail "internal compiler error" + where + idxs bt idx acc = (SQ.><) + <$> initZero bt ident (CT.DesgIdx idx SQ.<| desg) + <*> acc + + arType len = snd (CT.dctorArray ty) $ + CT.mapTypeKind (CT.CTArray (fromIntegral len) . fromJust . CT.fromIncompleteArray) ty + +lookInitializerString :: Ord i => CT.StorageClass i -> Parser i () +lookInitializerString ty = bool M.empty (pure ()) =<< andM + [ pure $ CT.isArray ty + , pure $ maybe False ((==CT.CTChar) . CT.toTypeKind) (CT.deref ty) + , M.option False (True <$ M.lookAhead stringLiteral) + ] + +lookInitializerList, lookStructInit :: CT.StorageClass i -> Parser i () +lookInitializerList = bool M.empty (pure ()) . CT.isArray +lookStructInit = bool M.empty (pure ()) . CT.isCTStruct + +desgInit :: (Integral i, Bits i, Read i, Show i) + => Parser i (ATree i) + -> CT.StorageClass i + -> T.Text + -> SQ.Seq (ATree i) + -> SQ.Seq (CT.Desg i) + -> Parser i (SQ.Seq (ATree i)) +desgInit p ty ident ai desg = M.choice + [ ai <$ lookInitializerString ty + , lookInitializerList ty *> initializerList p ty ident ai desg + , ai <$ lookStructInit ty + , p >>= (flip (desgNode ident) desg >=> pure . (SQ.|>) ai) + ] varInit' :: (Integral i, Bits i, Read i, Show i) => Parser i (ATree i) @@ -68,14 +200,14 @@ varInit' :: (Integral i, Bits i, Read i, Show i) -> ATree i -> Parser i (ATree i) varInit' p ty ident lat - | CT.isArray ty || CT.isCTStruct ty = error "sorry, not support yet" - | otherwise = p >>= chkValidAssign <&> atExprStmt . ATNode ATAssign (atype lat) lat + | CT.isArray ty || CT.isCTStruct ty = atBlock . toList <$> desgInit p ty ident SQ.empty SQ.empty + | otherwise = p >>= fromValidAssignAST <&> atExprStmt . ATNode ATAssign (atype lat) lat varInit :: (Integral i, Bits i, Read i, Show i) => Parser i (ATree i) -> CT.StorageClass i -> T.Text -> Parser i (ATree i) -varInit p ty ident = do - ty' <- fromMaybe ty <$> lift (gets $ incomplete ty) - registerLVar ty' ident >>= varInit' p ty ident +varInit p ty ident = fromMaybe ty <$> lift (gets $ incomplete ty) + >>= flip registerLVar ident + >>= varInit' p ty ident diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/test_core.c index 7e3bb68..0fa495b 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/test_core.c @@ -424,10 +424,12 @@ int main() assert(42, ({ int i = 0; switch (1) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; }), "({ int i = 0; switch (1) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; })"); assert(0, ({ int i = 0; switch (3) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; }), "({ int i = 0; switch (3) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; })"); assert(42, ({ int i = 40; switch (0) { case 0: ++i; case 1: ++i; } i; }), "({ int i = 40; switch (0) { case 0: ++i; case 1: ++i; } i; })"); - assert(41, ({ int i = 40; switch (i) { case 20 * 2: ++i; } i; }), "({ int i = 40; switch (i) { case 20 * 2: ++i; } i; })");/* - assert(1, ({ int ar[3] = { 1, 2, 3 }; ar[0]; }), "({ int ar[2] = { 1, 2, 3 }; ar[0]; })"); - assert(2, ({ int ar[3] = { 1, 2, 3 }; ar[1]; }), "({ int ar[2] = { 1, 2, 3 }; ar[1]; })"); - assert(3, ({ int ar[3] = { 1, 2, 3 }; ar[2]; }), "({ int ar[2] = { 1, 2, 3 }; ar[2]; })"); + assert(41, ({ int i = 40; switch (i) { case 20 * 2: ++i; } i; }), "({ int i = 40; switch (i) { case 20 * 2: ++i; } i; })"); + assert(0, ({ int ar[]; 0; }), "({ int ar[]; 0; })"); + assert(42, ({ int ar[1] = { 42 }; ar[0]; }), "({ int ar[1] = { 42 }; ar[0]; })"); + assert(1, ({ int ar[3] = { 1, 2, 3 }; ar[0]; }), "({ int ar[3] = { 1, 2, 3 }; ar[0]; })"); + assert(2, ({ int ar[3] = { 1, 2, 3 }; ar[1]; }), "({ int ar[3] = { 1, 2, 3 }; ar[1]; })"); + assert(3, ({ int ar[3] = { 1, 2, 3 }; ar[2]; }), "({ int ar[3] = { 1, 2, 3 }; ar[2]; })"); assert(2, ({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[0][1]; }), "({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[0][1]; })"); assert(4, ({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][0]; }), "({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][0]; })"); assert(6, ({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][2]; }), "({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][2]; })"); @@ -436,9 +438,21 @@ int main() assert(0, ({ int ar[3] = {}; ar[0]; }), "({ int ar[3] = {}; ar[0]; })"); assert(0, ({ int ar[3] = {}; ar[1]; }), "({ int ar[3] = {}; ar[1]; })"); assert(0, ({ int ar[3] = {}; ar[2]; }), "({ int ar[3] = {}; ar[2]; })"); - assert(2, ({ int ar[2][3] = { { 1, 2 } }; ar[0][1]; }), "({ int ar[2][3] = { { 1, 2 } }; ar[0][1]; })"); - assert(0, ({ int ar[2][3] = { { 1, 2 } }; ar[1][0]; }), "({ int ar[2][3] = { { 1, 2 } }; ar[1][0]; })"); - assert(0, ({ int ar[2][3] = { { 1, 2 } }; ar[1][2]; }), "({ int ar[2][3] = { { 1, 2 } }; ar[1][2]; })"); + assert(0, ({ int ar[3][2] = {}; ar[0][0]; }), "({ int ar[3][2] = {}; ar[0][0]; })"); + assert(0, ({ int ar[3][2] = {}; ar[0][1]; }), "({ int ar[3][2] = {}; ar[0][1]; })"); + assert(0, ({ int ar[3][2] = {}; ar[1][0]; }), "({ int ar[3][2] = {}; ar[1][0]; })"); + assert(0, ({ int ar[3][2] = {}; ar[1][1]; }), "({ int ar[3][2] = {}; ar[1][1]; })"); + assert(0, ({ int ar[3][2] = {}; ar[2][0]; }), "({ int ar[3][2] = {}; ar[2][0]; })"); + assert(0, ({ int ar[3][2] = {}; ar[2][1]; }), "({ int ar[3][2] = {}; ar[2][1]; })"); + assert(2, ({ int ar[2][3] = { { 42, 2 } }; ar[0][1]; }), "({ int ar[2][3] = { { 42, 2 } }; ar[0][1]; })"); + assert(0, ({ int ar[2][3] = { { 42, 2 } }; ar[1][0]; }), "({ int ar[2][3] = { { 42, 2 } }; ar[1][0]; })"); + assert(0, ({ int ar[2][3] = { { 42, 2 } }; ar[1][2]; }), "({ int ar[2][3] = { { 42, 2 } }; ar[1][2]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[0][0]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[0][0]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[0][1]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[0][1]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[1][0]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[1][0]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[1][1]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[1][1]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[2][0]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[2][0]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[2][1]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[2][1]; })"); assert(0, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][0]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][0]; })"); assert(0, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][1]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][1]; })"); assert(0, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[1][0]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[1][0]; })"); @@ -451,7 +465,7 @@ int main() assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][0]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][0]; })"); assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; })"); assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; })"); - assert(0, ({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; }), "({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; })"); + assert(0, ({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; }), "({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; })");/* assert('a', ({ char str[4] = "abc"; str[0]; }), "({ int str[4] = \"abc\"; str[0]; })"); assert('c', ({ char str[4] = "abc"; str[2]; }), "({ int str[4] = \"abc\"; str[2]; })"); assert(0, ({ char str[4] = "abc"; str[3]; }), "({ int str[4] = \"abc\"; str[3]; })"); From e157e8027973ec33b3e353267ebc45a5fc0c1e27 Mon Sep 17 00:00:00 2001 From: roki Date: Wed, 6 Jan 2021 04:10:38 +0900 Subject: [PATCH 38/51] refactoring --- src/Htcc/Parser/Combinators/Var.hs | 54 ++++++++++++++---------------- 1 file changed, 25 insertions(+), 29 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Var.hs b/src/Htcc/Parser/Combinators/Var.hs index 5c19eba..a4d0482 100644 --- a/src/Htcc/Parser/Combinators/Var.hs +++ b/src/Htcc/Parser/Combinators/Var.hs @@ -12,9 +12,8 @@ C language parser Combinators {-# LANGUAGE OverloadedStrings #-} module Htcc.Parser.Combinators.Var ( varInit - , lengthArrayBrace ) where -import Control.Monad (forM, void, (>=>)) +import Control.Monad (foldM, forM, void, (>=>)) import Control.Monad.Extra (andM) import Control.Monad.Fix (fix) import Control.Monad.Trans (MonadTrans (..)) @@ -26,7 +25,6 @@ import Data.Functor ((<&>)) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Sequence as SQ import qualified Data.Text as T -import Data.Void import qualified Htcc.CRules.Types as CT import Htcc.Parser.AST (ATKind (..), ATree (..), addKind, atAssign, atBlock, @@ -54,8 +52,8 @@ lengthArrayBrace = braces (arrayBrace 0) [ (+) <$> M.try (acc c <$> braces (arrayBrace (succ c)) <* comma) <*> arrayBrace c , acc c <$> braces (arrayBrace $ succ c) , (+) <$> M.try (accN c <$ validCharSets <* comma) <*> arrayBrace c - , accN c <$ validCharSets <* M.lookAhead "}" - , 0 <$ (M.lookAhead "}") + , accN c <$ validCharSets <* M.lookAhead rbrace + , 0 <$ M.lookAhead rbrace ] acc n | n == 0 = succ | otherwise = id accN n | n == 0 = 1 | otherwise = 0 @@ -84,9 +82,9 @@ lengthArrayBrace = braces (arrayBrace 0) , hat , tilda , vertical + , percent ] - desgNode :: (Num i, Ord i, Show i) => T.Text -> ATree i @@ -115,7 +113,7 @@ initLoop p ty ident ai desg = initLoop' ai <* rbrace CT.CTArray _ _ -> ($ (0, ai')) . fix $ \f (idx, rl) -> do rs <- desgInit p (fromJust $ CT.deref ty) ident rl (CT.DesgIdx idx SQ.<| desg) M.choice - [ (rs, succ idx) <$ M.lookAhead "}" + [ (rs, succ idx) <$ M.lookAhead rbrace , comma *> f (succ idx, rs) ] _ -> fail "internal compiler error" @@ -125,9 +123,11 @@ initZero :: (Num i, Ord i, Show i, Enum i) -> T.Text -> SQ.Seq (CT.Desg i) -> Parser i (SQ.Seq (ATree i)) -initZero (CT.CTArray n ty) ident desg = foldr idxs (pure SQ.empty) [0..fromIntegral (pred n)] - where - idxs idx acc = (SQ.><) <$> initZero ty ident (CT.DesgIdx idx SQ.<| desg) <*> acc +initZero (CT.CTArray n ty) ident desg = + foldM + (\acc idx -> (SQ.>< acc) <$> initZero ty ident (CT.DesgIdx idx SQ.<| desg)) + SQ.empty + [0..fromIntegral (pred n)] initZero _ ident desg = SQ.singleton <$> desgNode ident (atNumLit 0) desg initializerList :: (Integral i, Bits i, Read i, Show i) @@ -158,27 +158,15 @@ initializerList p ty ident ai desg = M.choice CT.CTArray n bt -> do (ast, idx) <- initLoop p ty ident ai desg (ai SQ.><) . (ast SQ.><) - <$> foldr (idxs bt) (pure SQ.empty) [fromIntegral idx..pred (fromIntegral n)] + <$> foldM + (\acc idx' -> (SQ.>< acc) <$> initZero bt ident (CT.DesgIdx idx' SQ.<| desg)) + SQ.empty + [fromIntegral idx..pred (fromIntegral n)] _ -> fail "internal compiler error" where - idxs bt idx acc = (SQ.><) - <$> initZero bt ident (CT.DesgIdx idx SQ.<| desg) - <*> acc - arType len = snd (CT.dctorArray ty) $ CT.mapTypeKind (CT.CTArray (fromIntegral len) . fromJust . CT.fromIncompleteArray) ty -lookInitializerString :: Ord i => CT.StorageClass i -> Parser i () -lookInitializerString ty = bool M.empty (pure ()) =<< andM - [ pure $ CT.isArray ty - , pure $ maybe False ((==CT.CTChar) . CT.toTypeKind) (CT.deref ty) - , M.option False (True <$ M.lookAhead stringLiteral) - ] - -lookInitializerList, lookStructInit :: CT.StorageClass i -> Parser i () -lookInitializerList = bool M.empty (pure ()) . CT.isArray -lookStructInit = bool M.empty (pure ()) . CT.isCTStruct - desgInit :: (Integral i, Bits i, Read i, Show i) => Parser i (ATree i) -> CT.StorageClass i @@ -187,11 +175,19 @@ desgInit :: (Integral i, Bits i, Read i, Show i) -> SQ.Seq (CT.Desg i) -> Parser i (SQ.Seq (ATree i)) desgInit p ty ident ai desg = M.choice - [ ai <$ lookInitializerString ty - , lookInitializerList ty *> initializerList p ty ident ai desg - , ai <$ lookStructInit ty + [ ai <$ lookInitializerString + , lookInitializerList *> initializerList p ty ident ai desg + , ai <$ lookStructInit , p >>= (flip (desgNode ident) desg >=> pure . (SQ.|>) ai) ] + where + lookInitializerString = bool M.empty (pure ()) =<< andM + [ pure $ CT.isArray ty + , pure $ maybe False ((==CT.CTChar) . CT.toTypeKind) (CT.deref ty) + , M.option False (True <$ M.lookAhead stringLiteral) + ] + lookInitializerList = bool M.empty (pure ()) $ CT.isArray ty + lookStructInit = bool M.empty (pure ()) $ CT.isCTStruct ty varInit' :: (Integral i, Bits i, Read i, Show i) => Parser i (ATree i) From bce7196aa0b2174e393e07e229995448a5485585 Mon Sep 17 00:00:00 2001 From: roki Date: Fri, 8 Jan 2021 02:31:31 +0900 Subject: [PATCH 39/51] Changed so that unit test files can be executed separately --- docker/scripts/test.sh | 7 + docker/test.dhall | 4 +- htcc.cabal | 8 +- test/Spec.hs | 98 +++++++---- .../ComponentsTests/Parser/Combinators.hs | 8 +- test/Tests/SubProcTests.hs | 40 ++--- test/Tests/SubProcTests/LinkFuncRet.hs | 29 ++++ test/Tests/SubProcTests/LinkFuncStdOut.hs | 31 ++++ test/Tests/SubProcTests/StatementEqual.hs | 20 +++ test/Tests/Test1.hs | 13 -- test/Tests/Test2.hs | 17 -- test/Tests/Test3.hs | 18 -- test/Tests/Utils.hs | 37 ++-- test/Tests/csrc/{ => externals}/test_func1.c | 2 +- test/Tests/csrc/{ => externals}/test_func2.c | 0 test/Tests/csrc/{ => externals}/test_func3.c | 0 test/Tests/csrc/{ => externals}/test_func4.c | 0 test/Tests/csrc/{ => externals}/test_func5.c | 0 test/Tests/csrc/self/array/basic.c | 161 ++++++++++++++++++ test/Tests/csrc/self/expressions/operators.c | 106 ++++++++++++ test/Tests/csrc/self/statements/continue.c | 36 ++++ test/Tests/csrc/self/statements/for.c | 45 +++++ test/Tests/csrc/self/statements/while.c | 35 ++++ test/Tests/csrc/{ => self}/test_core.c | 99 +---------- 24 files changed, 585 insertions(+), 229 deletions(-) create mode 100755 docker/scripts/test.sh create mode 100644 test/Tests/SubProcTests/LinkFuncRet.hs create mode 100644 test/Tests/SubProcTests/LinkFuncStdOut.hs create mode 100644 test/Tests/SubProcTests/StatementEqual.hs delete mode 100644 test/Tests/Test1.hs delete mode 100644 test/Tests/Test2.hs delete mode 100644 test/Tests/Test3.hs rename test/Tests/csrc/{ => externals}/test_func1.c (79%) rename test/Tests/csrc/{ => externals}/test_func2.c (100%) rename test/Tests/csrc/{ => externals}/test_func3.c (100%) rename test/Tests/csrc/{ => externals}/test_func4.c (100%) rename test/Tests/csrc/{ => externals}/test_func5.c (100%) create mode 100644 test/Tests/csrc/self/array/basic.c create mode 100644 test/Tests/csrc/self/expressions/operators.c create mode 100644 test/Tests/csrc/self/statements/continue.c create mode 100644 test/Tests/csrc/self/statements/for.c create mode 100644 test/Tests/csrc/self/statements/while.c rename test/Tests/csrc/{ => self}/test_core.c (82%) diff --git a/docker/scripts/test.sh b/docker/scripts/test.sh new file mode 100755 index 0000000..a758926 --- /dev/null +++ b/docker/scripts/test.sh @@ -0,0 +1,7 @@ +#!/bin/bash +find /htcc_work -name "*.s" -type f |\ + while read fname; do + gcc -xassembler -no-pie -o "$(dirname $fname)/$(basename $fname '.s').o" $fname + echo ">>>>> $fname" + ./$(dirname $fname)/$(basename $fname ".s").o + done diff --git a/docker/test.dhall b/docker/test.dhall index ba1029a..c635d53 100644 --- a/docker/test.dhall +++ b/docker/test.dhall @@ -9,9 +9,9 @@ let htccService = ⫽ { image = Some "roki/htcc_test:1.0.0" , command = Some ( types.StringOrList.String - "/bin/sh -c 'gcc -no-pie -o spec /htcc_work/spec.s && ./spec'" + "/bin/bash /htcc_work/scripts/test.sh" ) - , volumes = Some [ "/tmp/htcc:/htcc_work" ] + , volumes = Some [ "/tmp/htcc:/htcc_work", "./docker/scripts:/htcc_work/scripts" ] , build = Some ( types.Build.Object { context = "." diff --git a/htcc.cabal b/htcc.cabal index 0bfbd79..cc1b7e6 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: ff5121aa8a5d3d8d22e341046abb4b45d00032001dab233a2a2f65d2d62deafe +-- hash: 2eed65682adb7b03154ede97ff35806be8a937984b5dfcb70a644b23832bf2a2 name: htcc version: 0.0.0.1 @@ -185,9 +185,9 @@ test-suite htcc-test Tests.ComponentsTests Tests.ComponentsTests.Parser.Combinators Tests.SubProcTests - Tests.Test1 - Tests.Test2 - Tests.Test3 + Tests.SubProcTests.LinkFuncRet + Tests.SubProcTests.LinkFuncStdOut + Tests.SubProcTests.StatementEqual Tests.Utils Paths_htcc hs-source-dirs: diff --git a/test/Spec.hs b/test/Spec.hs index 8de8afe..921a517 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,30 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Codec.Binary.UTF8.String (decodeString) -import Control.Exception (finally) -import qualified Data.ByteString.Char8 as B -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Dhall.JSON (omitNull) -import Dhall.Yaml (Options (..), defaultOptions, - dhallToYaml) -import qualified Options.Applicative as OA -import System.Directory (createDirectoryIfMissing) -import System.FilePath (()) -import System.Process (readCreateProcess, shell) +import Codec.Binary.UTF8.String (decodeString) +import Control.Exception (finally) +import Control.Monad (foldM) +import Control.Monad.Extra (partitionM) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.State (StateT, evalStateT, get, modify, + put) +import qualified Data.ByteString.Char8 as B +import Data.List (isSuffixOf) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Dhall.JSON (omitNull) +import Dhall.Yaml (Options (..), defaultOptions, + dhallToYaml) +import Htcc.Utils (tshow) +import qualified Options.Applicative as OA +import System.Directory (createDirectoryIfMissing) +import System.Directory (doesDirectoryExist, listDirectory) +import System.FilePath (()) +import System.Process (readCreateProcess, shell) import qualified Tests.ComponentsTests as ComponentsTests -import qualified Tests.SubProcTests as SubProcTests +import qualified Tests.SubProcTests as SubProcTests import Tests.Utils workDir :: FilePath workDir = "/tmp" "htcc" -specPath :: FilePath -specPath = workDir "spec.s" +asmDir :: FilePath +asmDir = workDir "asm" dockerComposePath :: FilePath -dockerComposePath = "./docker" "test.dhall" +dockerComposePath = "." "docker" "test.dhall" data Command = WithSubProc | WithDocker | WithSelf | WithComponents @@ -71,12 +79,43 @@ optsParser = OA.info (OA.helper <*> programOptions) $ mconcat [ , OA.progDesc $ "The htcc unit tester" ] -genTestAsm :: IO () -genTestAsm = do - createDirectoryIfMissing False workDir - execErrFin $ "stack exec htcc -- " <> T.pack testCoreFile <> " > " <> T.pack specPath +genTestAsm' :: StateT Int IO [T.Text] +genTestAsm' = lift (createDirectoryIfMissing False workDir *> createDirectoryIfMissing False asmDir) + *> go [] ("." "test" "Tests" "csrc" "self") where - testCoreFile = "./test" "Tests" "csrc" "test_core.c" + go s fname = do + names <- lift $ map (fname ) <$> listDirectory fname + (dirPaths, filePaths) <- lift $ partitionM doesDirectoryExist names + foldM (\fs f -> if ".c" `isSuffixOf` f then (:fs) <$> mkBin f else pure fs) s filePaths + >>= flip (foldM go) dirPaths + + mkBin fname = do + n <- get + lift $ execErrFin $ + mconcat + [ "stack exec htcc -- " + , T.pack fname + , " > " + , T.pack (asmDir "spec") + , tshow n + , ".s" + ] + mconcat [T.pack (asmDir "spec"), tshow n, ".s"] <$ modify succ + +genTestAsm :: IO [T.Text] +genTestAsm = evalStateT genTestAsm' 0 + +genTestBins' :: StateT Int IO [T.Text] +genTestBins' = (genTestAsm' <* put 0) >>= mapM f + where + f fname = do + n <- get + let binName = mconcat [T.pack (workDir "spec"), tshow n, ".out"] + lift $ execErrFin ("gcc -xassembler -no-pie -o " <> binName <> " " <> fname) + binName <$ modify succ + +genTestBins :: IO [T.Text] +genTestBins = evalStateT genTestBins' 0 createProcessDhallDocker :: FilePath -> String -> IO () createProcessDhallDocker fp cmd = T.readFile fp @@ -84,19 +123,16 @@ createProcessDhallDocker fp cmd = T.readFile fp >>= readCreateProcess (shell $ "docker-compose -f - " <> cmd) . decodeString . B.unpack >>= putStrLn +runDhallDocker :: String -> IO () +runDhallDocker = createProcessDhallDocker dockerComposePath + main :: IO () main = do opts <- OA.execParser optsParser case optCmd opts of WithSubProc -> SubProcTests.exec - WithDocker -> let runDhallDocker = createProcessDhallDocker dockerComposePath in - if optClean opts then - runDhallDocker "down --rmi all" - else - flip finally (clean [workDir]) $ - genTestAsm >> runDhallDocker "up --build" - WithSelf -> flip finally (clean [workDir, "spec"]) $ do - genTestAsm - execErrFin $ "gcc -no-pie -o spec " <> T.pack specPath - execErrFin "./spec" + WithDocker + | optClean opts -> runDhallDocker "down --rmi all" + | otherwise -> genTestAsm *> runDhallDocker "up --build" *> clean [workDir] + WithSelf -> genTestBins >>= mapM_ execErrFin >> clean [workDir] WithComponents -> ComponentsTests.exec diff --git a/test/Tests/ComponentsTests/Parser/Combinators.hs b/test/Tests/ComponentsTests/Parser/Combinators.hs index 96c1e22..d988d82 100644 --- a/test/Tests/ComponentsTests/Parser/Combinators.hs +++ b/test/Tests/ComponentsTests/Parser/Combinators.hs @@ -15,7 +15,13 @@ import qualified Text.Megaparsec as M type TestParser = M.Parsec Void T.Text -charLiteralTest, stringLiteralTest, hexadecimalTest, octalTest, naturalTest, integerTest, identifierTest :: Test +charLiteralTest, + stringLiteralTest, + hexadecimalTest, + octalTest, + naturalTest, + integerTest, + identifierTest :: Test charLiteralTest = TestLabel "Parser.Combinators.Core.charLiteral" $ TestList [ diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 78d039f..294d3d9 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -3,15 +3,13 @@ module Tests.SubProcTests ( exec ) where -import Data.Char (ord) +import Data.Char (ord) +import qualified Htcc.CRules.Types as CT import Numeric.Natural - -import qualified Tests.Test1 as StatementEqual -import qualified Tests.Test2 as LinkFuncRet -import qualified Tests.Test3 as LinkFuncStdOut -import Tests.Utils hiding (exec) - -import qualified Htcc.CRules.Types as CT +import qualified Tests.SubProcTests.LinkFuncRet as LinkFuncRet +import qualified Tests.SubProcTests.LinkFuncStdOut as LinkFuncStdOut +import qualified Tests.SubProcTests.StatementEqual as StatementEqual +import Tests.Utils hiding (exec) exec :: IO () exec = runTestsEx @@ -195,26 +193,10 @@ exec = runTestsEx , (StatementEqual.test "int main() { int* ar[3]; int x; ar[0] = &x; x = 42; ar[0][0]; }", 42) , (StatementEqual.test "int main() { int a = 42; return ({ a; }); }", 42) , (StatementEqual.test "int main() { return ({ int a = 42; int b = 1; a + b; }); }", 43) + ] *> runTestsEx + [ (LinkFuncStdOut.test "int test_func1(); int main() { return test_func1(); }" ["test_func1"], Right "test/Tests/csrc/externals/test_func1.c::test_func1(): [OK]") + , (LinkFuncStdOut.test "int test_func2(); int main() { return test_func2(40); }" ["test_func2"], Right "test/Tests/csrc/externals/test_func2.c::test_func2(40) outputs: \"2 3 5 7 11 13 17 19 23 29 31 37 \": [OK]") ] + where - sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural -{- -exec = let sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural in runTestsEx [ - -- (LinkFuncRet.test "int main() { return sum7(1, 1, 1, 1, 1, 1, 1); }" ["test_func3"], 7), - -- (LinkFuncRet.test "int main() { return test_func2(sum7(1, 2, 3, 4, 5, 6, 7)); }" ["test_func2", "test_func3"], 0), - -- (LinkFuncRet.test "int main() { return sum16(1,1,1,1,1,1,11,10,9,8,7,6,5,4,3,2); }" ["test_func3"], 11), - (StatementEqual.test "int main() { return ({ 42; }); }", 42), - (StatementEqual.test "int main() { return ({ 1; 2; 3; }); }", 3), - (StatementEqual.test "int main() { ({ 1; return 2; 3; }); return 4; }", 2), - (StatementEqual.test "int main() { return ({ int a = 42; a; }); }", 42), - (StatementEqual.test "int main() { /* return 0; */ return 42; }", 42), - (StatementEqual.test "int main() { // hoge\nreturn 42; }", 42), - (StatementEqual.test "int main() { int a = 42; { int a = 32; } return a; }", 42), - (StatementEqual.test "int main() { int a = 42; { int a = 32; } { int a = 53; return a; } return 42; }", 53), - (StatementEqual.test "int main() { int a = 42; { a = 32; } return a; }", 32), - (StatementEqual.test "int main() { int* ar[3]; int x; ar[0] = &x; x = 42; ar[0][0]; }", 42) - ] >> runTestsEx [ - (LinkFuncStdOut.test "int main() { int test_func1(); int main() { return test_func1(); }" ["test_func1"], Right "test/Tests/csrc/test_func1.c::test_func1(): [OK]"), - (LinkFuncStdOut.test "int main() { int test_func2(); int main() { return test_func2(40); }" ["test_func2"], Right "test/Tests/csrc/test_func2.c::test_func2(40) outputs: \"2 3 5 7 11 13 17 19 23 29 31 37 \": [OK]"), - ] --} + sizeof = CT.sizeof :: CT.TypeKind Integer -> Natural diff --git a/test/Tests/SubProcTests/LinkFuncRet.hs b/test/Tests/SubProcTests/LinkFuncRet.hs new file mode 100644 index 0000000..ed085dd --- /dev/null +++ b/test/Tests/SubProcTests/LinkFuncRet.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings, TupleSections #-} +module Tests.SubProcTests.LinkFuncRet ( + test +) where + +import Control.Exception (finally) +import Control.Monad (forM_) +import qualified Data.Text as T +import Tests.Utils + +test :: String -> [String] -> IO (Int, String) +test x fnames = let obj = map (++".o") fnames in + flip finally (clean $ ["tmp", "tmp.s"] ++ obj) $ do + execErrFin $ mconcat + [ "echo \'" + , T.pack x + , "\' | stack exec htcc -- /dev/stdin > tmp.s" + ] + forM_ fnames $ \fname -> execErrFin $ mconcat + [ "cc -c test/Tests/csrc/externals/" + , T.pack fname + , ".c" + ] + execErrFin $ mconcat + [ "gcc " + , T.pack (unwords obj) + , " tmp.s -o tmp" + ] + exitCode (,x) (0, x) <$> exec "./tmp" diff --git a/test/Tests/SubProcTests/LinkFuncStdOut.hs b/test/Tests/SubProcTests/LinkFuncStdOut.hs new file mode 100644 index 0000000..933a7b8 --- /dev/null +++ b/test/Tests/SubProcTests/LinkFuncStdOut.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings, TupleSections #-} +module Tests.SubProcTests.LinkFuncStdOut ( + test +) where + +import Control.Exception (finally) +import Control.Monad (forM_) +import qualified Data.Text as T +import Tests.Utils + +-- | `test` performs a test by comparison with the standard output string. +test :: String -> [String] -> IO (Either T.Text T.Text, String) +test x fnames = let obj = map (++".o") fnames in + flip finally (clean $ ["tmp", "tmp.s"] ++ obj) $ do + execErrFin $ mconcat + [ "echo \'" + , T.pack x + , "\' | stack exec htcc -- /dev/stdin > tmp.s" + ] + forM_ fnames $ \fname -> execErrFin $ mconcat + [ "cc -c test/Tests/csrc/externals/" + , T.pack fname + , ".c" + ] + execErrFin $ mconcat + [ "gcc " + , T.pack (unwords obj) + , " tmp.s -o tmp" + ] + maybe (Left "The command did not execute successfully", x) ((, x) . Right) + <$> execStdOut "./tmp" diff --git a/test/Tests/SubProcTests/StatementEqual.hs b/test/Tests/SubProcTests/StatementEqual.hs new file mode 100644 index 0000000..9f5883f --- /dev/null +++ b/test/Tests/SubProcTests/StatementEqual.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +module Tests.SubProcTests.StatementEqual ( + test +) where + +import Control.Exception (finally) +import qualified Data.Text as T +import Tests.Utils + +test :: String -> IO (Int, String) +test x = flip finally (clean ["tmp"]) $ do + execErrFin $ mconcat + [ "echo '" + , T.pack x + , "' | stack exec htcc -- /dev/stdin | gcc -no-pie -xassembler -o tmp -" + ] + exec "./tmp" + >>= exitCode + (\ec -> (ec, x) <$ (putStr x *> putStrLn " [Compiling]")) + (return (0, x)) diff --git a/test/Tests/Test1.hs b/test/Tests/Test1.hs deleted file mode 100644 index 3c18e7c..0000000 --- a/test/Tests/Test1.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Tests.Test1 ( - test -) where - -import Control.Exception (finally) -import qualified Data.Text as T -import Tests.Utils - -test :: String -> IO (Int, String) -test x = flip finally (clean ["tmp"]) $ do - execErrFin $ "echo '" <> T.pack x <> "' | stack exec htcc -- /dev/stdin | gcc -no-pie -xassembler -o tmp -" - exec "./tmp" >>= exitCode (\ec -> (ec, x) <$ (putStr x *> putStrLn ": [Processing]")) (return (0, x)) diff --git a/test/Tests/Test2.hs b/test/Tests/Test2.hs deleted file mode 100644 index 6136828..0000000 --- a/test/Tests/Test2.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TupleSections #-} -module Tests.Test2 ( - test -) where - -import Control.Exception (finally) -import Control.Monad (forM_) -import qualified Data.Text as T -import Tests.Utils - -test :: String -> [String] -> IO (Int, String) -test x fnames = let obj = map (++".o") fnames in - flip finally (clean $ ["tmp", "tmp.s"] ++ obj) $ do - execErrFin $ "echo \'" <> T.pack x <> "\' | stack exec htcc -- /dev/stdin > tmp.s" - forM_ fnames $ \fname -> execErrFin $ "cc -c test/Tests/csrc/" <> T.pack fname <> ".c" - execErrFin $ "gcc " <> T.pack (unwords obj) <> " tmp.s -o tmp" - exitCode (,x) (0, x) <$> exec "./tmp" diff --git a/test/Tests/Test3.hs b/test/Tests/Test3.hs deleted file mode 100644 index b35be04..0000000 --- a/test/Tests/Test3.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TupleSections #-} -module Tests.Test3 ( - test -) where - -import Control.Exception (finally) -import Control.Monad (forM_) -import qualified Data.Text as T -import Tests.Utils - --- | `test` performs a test by comparison with the standard output string. -test :: String -> [String] -> IO (Either T.Text T.Text, String) -test x fnames = let obj = map (++".o") fnames in - flip finally (clean $ ["tmp", "tmp.s"] ++ obj) $ do - execErrFin $ "echo \'" <> T.pack x <> "\' | stack exec htcc -- /dev/stdin > tmp.s" - forM_ fnames $ \fname -> execErrFin $ "cc -c test/Tests/csrc/" <> T.pack fname <> ".c" - execErrFin $ "gcc " <> T.pack (unwords obj) <> " tmp.s -o tmp" - maybe (Left "The command did not execute successfully", x) ((, x) . Right) <$> execStdOut "./tmp" diff --git a/test/Tests/Utils.hs b/test/Tests/Utils.hs index 93ab889..f7557d4 100644 --- a/test/Tests/Utils.hs +++ b/test/Tests/Utils.hs @@ -1,20 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} module Tests.Utils ( - runTests, - runTestsEx, - Test (..), - (~:), - (~?=), - exitCode, - exec, - execStdOut, - execErrFin, - clean + runTests + , runTestsEx + , Test (..) + , (~:) + , (~?=) + , exitCode + , exec + , execStdOut + , execErrFin + , clean ) where import qualified Control.Foldl as F import Control.Monad (void, when, zipWithM) import Data.Bool (bool) +import Data.Functor ((<&>)) import qualified Data.Text as DT import System.Directory (doesDirectoryExist, doesFileExist, removeDirectoryRecursive, removeFile) @@ -25,12 +26,12 @@ import Test.Hspec.Core.Runner (Config (..), defaultConfig, import Test.HUnit (Test (..), (~:), (~?=)) import qualified Turtle as T -{-# INLINE cfg #-} cfg :: Config cfg = defaultConfig { configPrintCpuTime = True } runTests :: Test -> IO () -runTests ts = runSpec (parallel $ fromHUnitTest ts) cfg >>= evaluateSummary +runTests ts = runSpec (parallel $ fromHUnitTest ts) cfg + >>= evaluateSummary exitCode :: (Int -> a) -> a -> T.ExitCode -> a exitCode _ x T.ExitSuccess = x @@ -40,15 +41,21 @@ exec :: T.MonadIO m => DT.Text -> m T.ExitCode exec = flip T.shell T.empty execStdOut :: T.MonadIO m => DT.Text -> m (Maybe T.Text) -execStdOut cmd = fmap T.lineToText <$> T.fold (T.inshell cmd T.empty) F.head +execStdOut cmd = fmap T.lineToText + <$> T.fold (T.inshell cmd T.empty) F.head execErrFin :: T.MonadIO m => DT.Text -> m () -execErrFin cmd = T.shell cmd T.empty >>= exitCode (\x -> void $ T.die (cmd <> " failed with exit code: " <> T.repr x)) (return ()) +execErrFin cmd = T.shell cmd T.empty + >>= exitCode (\x -> void $ T.die (cmd <> " failed with exit code: " <> T.repr x)) (return ()) runTestsEx :: (Eq a, Show a) => [(IO (a, String), a)] -> IO () -runTestsEx ts = putStrLn "\n\n== Unit Tests started ==" >> zipWithM (\(t, e) i -> fmap (\(ec, t') -> (~:) ("test: #" ++ show i ++ ": " ++ t' ++ "\"") $ (~?= e) ec) t) ts ms >>= runTests . TestList +runTestsEx ts = putStrLn "\n\n== Unit Tests started ==" + *> zipWithM f ts ms + >>= runTests . TestList where ms = take (length ts) $ iterate (+1) (1 :: Int) + f (t, e) i = t + <&> \(ec, t') -> (~:) ("test: #" ++ show i ++ ": " ++ t' ++ "\"") $ (~?= e) ec clean :: [FilePath] -> IO () clean = mapM_ $ \x -> (>>=) (doesFileExist x) $ flip bool (removeFile x) $ diff --git a/test/Tests/csrc/test_func1.c b/test/Tests/csrc/externals/test_func1.c similarity index 79% rename from test/Tests/csrc/test_func1.c rename to test/Tests/csrc/externals/test_func1.c index 3a583ed..1a3a4b8 100644 --- a/test/Tests/csrc/test_func1.c +++ b/test/Tests/csrc/externals/test_func1.c @@ -1,4 +1,4 @@ -#include "test_utils.h" +#include "../test_utils.h" #include int test_func1() diff --git a/test/Tests/csrc/test_func2.c b/test/Tests/csrc/externals/test_func2.c similarity index 100% rename from test/Tests/csrc/test_func2.c rename to test/Tests/csrc/externals/test_func2.c diff --git a/test/Tests/csrc/test_func3.c b/test/Tests/csrc/externals/test_func3.c similarity index 100% rename from test/Tests/csrc/test_func3.c rename to test/Tests/csrc/externals/test_func3.c diff --git a/test/Tests/csrc/test_func4.c b/test/Tests/csrc/externals/test_func4.c similarity index 100% rename from test/Tests/csrc/test_func4.c rename to test/Tests/csrc/externals/test_func4.c diff --git a/test/Tests/csrc/test_func5.c b/test/Tests/csrc/externals/test_func5.c similarity index 100% rename from test/Tests/csrc/test_func5.c rename to test/Tests/csrc/externals/test_func5.c diff --git a/test/Tests/csrc/self/array/basic.c b/test/Tests/csrc/self/array/basic.c new file mode 100644 index 0000000..f4f14aa --- /dev/null +++ b/test/Tests/csrc/self/array/basic.c @@ -0,0 +1,161 @@ +// This is a c compiler test file. This comment itself is a line comment test. +/* + * This comment is also a block comment test. + */ + +int printf(); +int exit(); +int strcmp(char* p, char* q); +int test_num; + +int gr[3]; +//int (*gpa)[3]; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:array/basic test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:array/basic test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int gg(int* p) { *p = 42; return 0; } +int sum(int* p, int n) { int s = 0; for (int i = 0; i < n; i = i + 1) s = s + *(p + i); return s; } + +int main() +{ + printf(">>>> tests: array/basic\n"); + + test_num = 1; + assert(3, ({ int ar[2]; int* p = ar; *p = 3; *ar; }), "({ int ar[2]; int* p = ar; *p = 3; *ar; })"); + assert(3, ({ int ar[2]; int* p = ar; *(p + 1) = 3; *(ar + 1); }), "({ int ar[2]; int* p = ar; *(p + 1) = 3; *(ar + 1); })"); + assert(5, ({ int ar[2]; int* p = ar; *p = 2; *(p + 1) = 3; *ar + *(ar + 1); }), "({ int ar[2]; int* p = ar; *p = 2; *(p + 1) = 3; *ar + *(ar + 1); })"); + assert(1, ({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *ar; }), "({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *ar; })"); + assert(2, ({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *(ar + 1); }), "({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *(ar + 1); })"); + assert(3, ({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *(ar + 2); }), "({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *(ar + 2); })"); + assert(42, ({ int a = 0; gg(&a); a; }), "({ int a = 0; gg(&a); a; })"); + assert(45, ({ int ar[10]; int i = 0; for (; i < 10; i = i + 1) { *(ar + i) = i; } int s = 0; for (i = 0; i < 10; i = i + 1) { s = s + *(ar + i); } s; }), "({ int ar[10]; int i = 0; for (; i < 10; i = i + 1) { *(ar + i) = i; } int s = 0; for (i = 0; i < 10; i = i + 1) { s = s + *(ar + i); } s; })"); + assert(45, ({ int ar[10]; int i = 0; for (; i < 10; i = i + 1) *(ar + i) = i; sum(ar, 10); }), "({ int ar[10]; int i = 0; for (; i < 10; i = i + 1) *(ar + i) = i; sum(ar, 10); })"); + assert(9, ({ int ar[2][3]; int s = 0; int i = 0; for (; i < 2; i = i + 1) { int j = 0; for (; j < 3; j = j + 1) { *(*(ar + i) + j) = i + j; s = s + *(*(ar + i) + j); } } s; }), "({ int ar[2][3]; int s = 0; int i = 0; for (; i < 2; i = i + 1) { int j = 0; for (; j < 3; j = j + 1) { *(*(ar + i) + j) = i + j; s = s + *(*(ar + i) + j); } } s; })"); + assert(42, ({ int ar[2][3]; int* p = ar; *p = 42; **ar; }), "({ int ar[2][3]; int* p = ar; *p = 42; **ar; }"); + assert(42, ({ int ar[2][3]; int* p = ar; *(p + 1) = 42; *(*ar + 1); }), "({ int ar[2][3]; int* p = ar; *(p + 1) = 42; *(*ar + 1); })"); + assert(42, ({ int ar[2][3]; int* p = ar; *(p + 2) = 42; *(*ar + 2); }), "({ int ar[2][3]; int* p = ar; *(p + 2) = 42; *(*ar + 2); })"); + assert(42, ({ int ar[2][3]; int* p = ar; *(p + 3) = 42; **(ar + 1); }), "({ int ar[2][3]; int* p = ar; *(p + 3) = 42; **(ar + 1); })"); + assert(42, ({ int ar[2][3]; int* p = ar; *(p + 4) = 42; *(*(ar + 1) + 1); }), "({ int ar[2][3]; int* p = ar; *(p + 4) = 42; *(*(ar + 1) + 1); })"); + assert(42, ({ int ar[2][3]; int* p = ar; *(p + 5) = 42; *(*(ar + 1) + 2); }), "({ int ar[2][3]; int* p = ar; *(p + 5) = 42; *(*(ar + 1) + 2); })"); + assert(42, ({ int ar[2][3]; int* p = ar; *(p + 6) = 42; **(ar + 2); }), "({ int ar[2][3]; int* p = ar; *(p + 6) = 42; **(ar + 2); })"); + assert(0, ({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[0]; }), "({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[0]; })"); + assert(1, ({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[1]; }), "({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[1]; })"); + assert(2, ({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[2]; }), "({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[2]; })"); + assert(42, ({ int ar[2][3]; int* p = ar; p[0] = 42; ar[0][0]; }), "({ int ar[2][3]; int* p = ar; p[0] = 42; ar[0][0]; })"); + assert(42, ({ int ar[2][3]; int* p = ar; p[1] = 42; ar[0][1]; }), "({ int ar[2][3]; int* p = ar; p[1] = 42; ar[0][1]; })"); + assert(42, ({ int ar[2][3]; int* p = ar; p[2] = 42; ar[0][2]; }), "({ int ar[2][3]; int* p = ar; p[2] = 42; ar[0][2]; })"); + assert(42, ({ int ar[2][3]; int* p = ar; p[3] = 42; ar[1][0]; }), "({ int ar[2][3]; int* p = ar; p[3] = 42; ar[1][0]; })"); + assert(42, ({ int ar[2][3]; int* p = ar; p[4] = 42; ar[1][1]; }), "({ int ar[2][3]; int* p = ar; p[4] = 42; ar[1][1]; })"); + assert(42, ({ int ar[2][3]; int* p = ar; p[5] = 42; ar[1][2]; }), "({ int ar[2][3]; int* p = ar; p[5] = 42; ar[1][2]; })"); + assert(42, ({ int ar[2][3]; int* p = ar; p[6] = 42; ar[2][0]; }), "({ int ar[2][3]; int* p = ar; p[6] = 42; ar[2][0]; })"); + assert(3 * 4, ({ int ar[3]; sizeof ar; }), "({ int ar[3]; sizeof ar; })"); + assert(3 * 5 * 4, ({int ar[3][5]; sizeof ar; }), "({int ar[3][5]; return sizeof ar; })"); + assert(5 * 4, ({ int ar[3][5]; sizeof *ar; }), "({ int ar[3][5]; sizeof *ar; })"); + assert(4, ({ int ar[3][5]; sizeof **ar; }), "({ int ar[3][5]; sizeof **ar; })"); + assert(4 + 1, ({ int ar[3][5]; sizeof(**ar) + 1; }), "({ int ar[3][5]; sizeof(**ar) + 1; })"); + assert(4 + 1, ({ int ar[3][5]; sizeof **ar + 1; }), "({ int ar[3][5]; return sizeof **ar + 1; })"); + assert(8, ({ int ar[3][5]; sizeof(**ar + 1); }), "({ int ar[3][5]; sizeof(**ar + 1); })"); + assert(42, ({ int ar[2]; 2[ar] = 42; ar[2]; }), "({ int ar[2]; 2[ar] = 42; ar[2]; })"); + assert(1, ({ int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; gr[0]; }), "({ int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; gr[0]; })"); + assert(2, gr[1], "gr[1]"); + assert(3, gr[2], "gr[2]"); + assert(10, ({ char ar[10]; sizeof ar; }), "({ char ar[10]; return sizeof ar; })"); + assert(97, "abc"[0], "\"abc\"[0]"); + assert(98, "abc"[1], "\"abc\"[1];"); + assert(99, "abc"[2], "\"abc\"[2];"); + assert(0, "abc"[3], "\"abc\"[3];"); + assert(99, ({ char* p = "abc"; p[2]; }), "({ char* p = \"abc\"; p[2]; })"); + assert(7, "\a"[0], "\"\\a\"[0]"); + assert(8, "\b"[0], "\"\\b\"[0]"); + assert(9, "\t"[0], "\"\\t\"[0]"); + assert(10, "\n"[0], "\"\\n\"[0]"); + assert(11, "\v"[0], "\"\\v\"[0]"); + assert(12, "\f"[0], "\"\\f\"[0]"); + assert(13, "\r"[0], "\"\\r\"[0]"); + assert(0, "\0"[0], "\\0[0]"); + assert(92, "\\"[0], "a"); + assert(2, ({ int ar[5]; int* p = ar + 2; p - ar; }), "({ int ar[5]; int* p = ar + 2; p - ar; })"); + assert(1, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; })"); + assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; ++*p++; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; })"); + assert(1, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p--; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; })"); + assert(0, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; --*p; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; --*p; })"); + assert(0, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; ar[0]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; ar[0]; })"); + assert(0, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[1]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[1]; })"); + assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[2]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[2]; })"); + assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; })"); + assert(1, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar; p += 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar; p += 1; *p; })"); + assert(0, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; })"); + assert(10, ({ int ar[2 ? 5 * 2 : 5]; sizeof ar / sizeof *ar; }), "({ int ar[2 ? 5 * 2 : 5]; sizeof ar / sizeof *ar; })"); + assert(0, ({ int ar[]; 0; }), "({ int ar[]; 0; })"); + assert(42, ({ int ar[1] = { 42 }; ar[0]; }), "({ int ar[1] = { 42 }; ar[0]; })"); + assert(1, ({ int ar[3] = { 1, 2, 3 }; ar[0]; }), "({ int ar[3] = { 1, 2, 3 }; ar[0]; })"); + assert(2, ({ int ar[3] = { 1, 2, 3 }; ar[1]; }), "({ int ar[3] = { 1, 2, 3 }; ar[1]; })"); + assert(3, ({ int ar[3] = { 1, 2, 3 }; ar[2]; }), "({ int ar[3] = { 1, 2, 3 }; ar[2]; })"); + assert(2, ({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[0][1]; }), "({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[0][1]; })"); + assert(4, ({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][0]; }), "({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][0]; })"); + assert(6, ({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][2]; }), "({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][2]; })"); + assert(1, ({ int a = 0; int ar[2] = { a = 1 }; ar[0]; }), "({ int a = 0; int ar[2] = { a = 1 }; ar[0]; })"); + assert(1, ({ int a = 0; int ar[2] = { a = 1 }; a; }), "({ int a = 0; int ar[2] = { a = 1 }; a; })"); + assert(0, ({ int ar[3] = {}; ar[0]; }), "({ int ar[3] = {}; ar[0]; })"); + assert(0, ({ int ar[3] = {}; ar[1]; }), "({ int ar[3] = {}; ar[1]; })"); + assert(0, ({ int ar[3] = {}; ar[2]; }), "({ int ar[3] = {}; ar[2]; })"); + assert(0, ({ int ar[3][2] = {}; ar[0][0]; }), "({ int ar[3][2] = {}; ar[0][0]; })"); + assert(0, ({ int ar[3][2] = {}; ar[0][1]; }), "({ int ar[3][2] = {}; ar[0][1]; })"); + assert(0, ({ int ar[3][2] = {}; ar[1][0]; }), "({ int ar[3][2] = {}; ar[1][0]; })"); + assert(0, ({ int ar[3][2] = {}; ar[1][1]; }), "({ int ar[3][2] = {}; ar[1][1]; })"); + assert(0, ({ int ar[3][2] = {}; ar[2][0]; }), "({ int ar[3][2] = {}; ar[2][0]; })"); + assert(0, ({ int ar[3][2] = {}; ar[2][1]; }), "({ int ar[3][2] = {}; ar[2][1]; })"); + assert(2, ({ int ar[2][3] = { { 42, 2 } }; ar[0][1]; }), "({ int ar[2][3] = { { 42, 2 } }; ar[0][1]; })"); + assert(0, ({ int ar[2][3] = { { 42, 2 } }; ar[1][0]; }), "({ int ar[2][3] = { { 42, 2 } }; ar[1][0]; })"); + assert(0, ({ int ar[2][3] = { { 42, 2 } }; ar[1][2]; }), "({ int ar[2][3] = { { 42, 2 } }; ar[1][2]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[0][0]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[0][0]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[0][1]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[0][1]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[1][0]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[1][0]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[1][1]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[1][1]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[2][0]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[2][0]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[2][1]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[2][1]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][0]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][0]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][1]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][1]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[1][0]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[1][0]; })"); + assert(0, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[1][1]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[1][1]; })"); + assert(1, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[2][0]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[2][0]; })"); + assert(2, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[2][1]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[2][1]; })"); + assert(1, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][0]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][0]; })"); + assert(2, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][1]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][1]; })"); + assert(3, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][2]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][2]; })"); + assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][0]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][0]; })"); + assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; })"); + assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; })"); + assert(0, ({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; }), "({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; })"); + /* + assert('a', ({ char str[4] = "abc"; str[0]; }), "({ int str[4] = \"abc\"; str[0]; })"); + assert('c', ({ char str[4] = "abc"; str[2]; }), "({ int str[4] = \"abc\"; str[2]; })"); + assert(0, ({ char str[4] = "abc"; str[3]; }), "({ int str[4] = \"abc\"; str[3]; })"); + assert('a', ({ char str[2][4] = { "abc", "def" }; str[0][0]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][0]; })"); + assert('b', ({ char str[2][4] = { "abc", "def" }; str[0][1]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][1]; })"); + assert('c', ({ char str[2][4] = { "abc", "def" }; str[0][2]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][2]; })"); + assert(0, ({ char str[2][4] = { "abc", "def" }; str[0][3]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][3]; })"); + assert('d', ({ char str[2][4] = { "abc", "def" }; str[1][0]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][0]; })"); + assert('e', ({ char str[2][4] = { "abc", "def" }; str[1][1]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][1]; })"); + assert('f', ({ char str[2][4] = { "abc", "def" }; str[1][2]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][2]; })"); + assert(0, ({ char str[2][4] = { "abc", "def" }; str[1][3]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][3]; })"); + assert(3, ({ int ar[] = { 0, 1, 2, 3 }; ar[3]; }), "({ int ar[] = { 0, 1, 2, 3 }; ar[3]; })"); + assert(16, ({ int ar[] = { 0, 1, 2, 3 }; sizeof ar; }), "({ int ar[] = { 0, 1, 2, 3 }; sizeof ar; })"); + assert(4, ({ char str[] = "foo"; sizeof str; }), "({ char str[] = \"foo\"; sizeof str; })"); + assert('d', ({ char str[] = "abcd"; str[3]; }), "({ char str[] = \"abcd\"; str[3]; })"); + assert(0, ({ char str[] = "abcd"; str[4]; }), "({ char str[] = \"abcd\"; str[4]; })");*/ + + printf("All tests are passed!\n"); + + return 0; +} diff --git a/test/Tests/csrc/self/expressions/operators.c b/test/Tests/csrc/self/expressions/operators.c new file mode 100644 index 0000000..5239fb6 --- /dev/null +++ b/test/Tests/csrc/self/expressions/operators.c @@ -0,0 +1,106 @@ +// This is a c compiler test file. This comment itself is a line comment test. +/* + * This comment is also a block comment test. + */ + +int printf(); +int exit(); +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:expressions/operators test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:expressions/operators test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int sub3(int a, int b, int c) { return a - b - c; } + +int main() +{ + printf(">>>> tests: expressions/operators\n"); + test_num = 1; + assert(42, 42, "42"); + assert(7, 1 + 2 + 4, "1 + 2 + 4"); + assert(6, 10 - 7 + 3, "10 - 7 + 3"); + assert(35, 42 + 23 - 30, "42 + 23 - 30"); + assert(18, 42 / 2 + 2 - 5, "42 / 2 + 2 - 5"); + assert(4, (3 + 5) / 2, "(3 + 5) / 2"); + assert(21, (4 - 2) * 8 + 20 / 4, "(4 - 2) * 8 + 20 / 4"); + assert(15, -(-3 * +5), "-(-3 * +5)"); + assert(5, -25 + 30, "-25 + 30"); + assert(1, 42 == 42, "42 == 42"); + assert(1, 42 != 53, "42 != 53"); + assert(1, 42 < 53, "42 < 53"); + assert(1, 53 > 42, "53 > 42"); + assert(1, 42 <= 42, "42 <= 42"); + assert(1, 32 <= 42, "32 <= 42"); + assert(1, 42 >= 42, "42 >= 42"); + assert(1, 53 >= 42, "53 >= 42"); + assert(1, (1 + 1) == 2, "(1 + 1) == 2"); + assert(1, (2 * 3) != 2, "(2 * 3) != 2"); + assert(1, ({ int a = 1; int b = 1; a & b; }), "({ int a = 1; int b = 1; return a & b; })"); + assert(1, ({ int a = 42; int b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) a = 1; else a = 0; a; }), "({ int a = 42; int b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) a = 1; else a = 0; a; })"); + assert(1, 1 | 0, "1 | 0"); + assert(1, ({ int a = 1; int b = 0; a & b ^ a | b; }), "({ int a = 1; int b = 0; a & b ^ a | b; })"); // Xor swap + assert(20, ({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; a; }), "({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; a; })"); + assert(1, !0, "!0"); + assert(0, !42, "!42"); + assert(1, !!!0, "!!!0"); + assert(41, ~(-42), "~(-42)"); + assert(42, ~~~~42, "~~~~42"); + assert(1, (2 * 4) == (2 << 2), "(2 * 4) == (2 << 2)"); + assert(1, (8 / 4) == (8 >> 2), "(8 / 4) == (8 >> 2)"); + assert(1, ({ int a = 2 << 4; (a & (a - 1)) == 0; }), "({ int a = 2 << 4; (a & (a - 1)) == 0; })"); // Determining if an integer is a power of 2 + assert(3, ({ 1; {2;} 3; }), "({ 1; {2;} 3; })"); + assert(4, ({ int a; sizeof(a); }), "({ int a; sizeof(a); })"); + assert(4, ({ int a; sizeof a; }), "({ int a; sizeof a; })"); + assert(8, ({ int* p; sizeof p; }), "({ int* p; sizeof p; })"); + assert(42, ({ int a = 41; ++a; }), "({ int a = 41; ++a; })"); + assert(42, ({ int a = 43; --a; }), "({ int a = 43; --a; })"); + assert(42, ({ int a = 42; a++; }), "({ int a = 41; a++; })"); + assert(42, ({ int a = 42; a--; }), "({ int a = 43; a--; })"); + assert(42, ({ int a = 41; a++; a; }), "({ int a = 41; a++; a; })"); + assert(42, ({ int a = 43; a--; a; }), "({ int a = 43; a--; a; })"); + assert(42, ({ int a = 2; a += 40; a; }), "int a = 2; a += 40; a;"); + assert(42, ({ int a = 2; a += 40; }), "int a = 2; a += 40;"); + assert(42, ({ int a = 44; a -= 2; a; }), "int a = 44; a -= 2; a;"); + assert(42, ({ int a = 44; a -= 2; }), "int a = 44; a -= 2;"); + assert(42, ({ int a = 21; a *= 2; a; }), "int a = 21; a *= 2; a;"); + assert(42, ({ int a = 21; a *= 2; }), "int a = 21; a *= 2;"); + assert(42, ({ int a = 84; a /= 2; a; }), "int a = 84; a /= 2; a;"); + assert(42, ({ int a = 84; a /= 2; }), "int a = 84; a /= 2;"); + assert(1, 1 || 0, "1 || 0"); + assert(1, (1 + 1) || 0 || 0, "(1 + 1) || 0 || 0"); + assert(0, 0 || 0, "0 || 0"); + assert(0, 0 || (1 - 1), "0 || (1 - 1)"); + assert(1, 1 && 2, "1 && 2"); + assert(0, 2 && 3 && 4 && 0, "2 && 3 && 4 && 0"); + assert(2, ({ int a = 6; a &= 3; a; }), "({ int a = 6; a &= 3; a; })"); + assert(2, ({ int a = 6; a &= 3; }), "({ int a = 6; a &= 3; })"); + assert(7, ({ int a = 6; a |= 3; a; }), "({ int a = 6; a |= 3; a; })"); + assert(7, ({ int a = 6; a |= 3; }), "({ int a = 6; a |= 3; })"); + assert(10, ({ int a = 15; a ^= 5; a; }), "({ int a = 15; a ^= 5; a; })"); + assert(10, ({ int a = 15; a ^= 5; }), "({ int a = 15; a ^= 5; })"); + assert(2, ({ int a = 1; a <<= 1; a; }), "({ int a = 1; a <<= 1; a; })"); + assert(2, ({ int a = 1; a <<= 1; }), "({ int a = 1; a <<= 1; })"); + assert(2, ({ int a = 4; a >>= 1; a; }), "({ int a = 4; a >>= 1; a; })"); + assert(2, ({ int a = 4; a >>= 1; }), "({ int a = 4; a >>= 1; })"); + assert(-1, ({ int a = -1; a >>= 1; }), "({ int a = -1; a >>= 1; })"); + assert(42, 1 ? 42 : 0, "1 ? 42 : 0"); + assert(42, 0 ? 0 : 42, "0 ? 0 : 42"); + assert(42, ({ int a = 1; int b = 0; a || b ? 42 : 0; }), "({ int a = 1; int b = 0; a || b ? 42 : 0; })"); + assert(42, ({ int a = 1; int b = 0; a && b ? 0 : 42; }), "({ int a = 1; int b = 0; a && b ? 0 : 42; })"); + assert(42, ({ 42 ?: 0; }), "({ 42 ?: 0; })"); + assert(42, ({ int a = 42; a++ ?: 0; }), "({ int a = 42; a++ ?: 0; })"); + assert(42, ({ sub3(2, 1, 1) ?: 42; }), "({ sub3(2, 1, 1) ?: 42; })"); + + printf("All tests are passed!\n"); + + return 0; +} diff --git a/test/Tests/csrc/self/statements/continue.c b/test/Tests/csrc/self/statements/continue.c new file mode 100644 index 0000000..d07d565 --- /dev/null +++ b/test/Tests/csrc/self/statements/continue.c @@ -0,0 +1,36 @@ +// This is a c compiler test file. This comment itself is a line comment test. +/* + * This comment is also a block comment test. + */ + +int printf(); +int exit(); +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:statements/continue test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:statements/continue test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int main() +{ + printf(">>>> tests: statements/continue\n"); + + test_num = 1; + assert(10, ({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } i; }), "({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } i; })"); + assert(6, ({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } j; }), "({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } j; })"); + assert(10, ({ int i = 0; int j = 0; for (; !i;) { for (; j != 10; ++j) continue; break; } j; }), "({ int i = 0; int j = 0; for (; !i;) { for (; j != 10; ++j) continue; break; } j; }),"); + assert(11, ({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } i; }), "({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } i; })"); + assert(5, ({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } j; }), "({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } j; })"); + assert(11, ({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; }), "({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; })"); + + printf("All tests are passed!\n"); + return 0; +} diff --git a/test/Tests/csrc/self/statements/for.c b/test/Tests/csrc/self/statements/for.c new file mode 100644 index 0000000..a414686 --- /dev/null +++ b/test/Tests/csrc/self/statements/for.c @@ -0,0 +1,45 @@ +// This is a c compiler test file. This comment itself is a line comment test. +/* + * This comment is also a block comment test. + */ + +int printf(); +int exit(); +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:statements/for test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:statements/for test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int main() +{ + printf(">>>> tests: statements/for\n"); + + test_num = 1; + assert(110, ({ int a = 0; int i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; a; }), "({ int a = 0; int i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; a; })"); + assert(12, ({ int i = 0; for (; i <= 10;) i = i + 2; i; }), "({ int i = 0; for (; i <= 10;) i = i + 2; i; })"); + assert(0, ({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; a; }), "({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; a; })"); + assert(0, ({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } a; }), "({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } a; })"); + assert(20, ({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; a; }), "({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; a; })"); + assert(6, ({ int s = 0; int i = 1; for (; i < 4; i = i + 1) s = s + i; s; }), "({ int s = 0; int i = 1; for (; i < 4; i = i + 1) s = s + i; return s; })"); + assert(3, ({ int a = 0; for(; a < 3; a = a + 1); a; }), "({ int a = 0; for(; a < 3; a = a + 1); a; })"); + assert(45, ({ int ar[10]; int i = 0; for (; i < 10; i = i + 1) { *(ar + i) = i; } int s = 0; for (i = 0; i < 10; i = i + 1) { s = s + *(ar + i); } s; }), "({ int ar[10]; int i = 0; for (; i < 10; i = i + 1) { *(ar + i) = i; } int s = 0; for (i = 0; i < 10; i = i + 1) { s = s + *(ar + i); } s; })"); + assert(9, ({ int ar[2][3]; int s = 0; int i = 0; for (; i < 2; i = i + 1) { int j = 0; for (; j < 3; j = j + 1) { *(*(ar + i) + j) = i + j; s = s + *(*(ar + i) + j); } } s; }), "({ int ar[2][3]; int s = 0; int i = 0; for (; i < 2; i = i + 1) { int j = 0; for (; j < 3; j = j + 1) { *(*(ar + i) + j) = i + j; s = s + *(*(ar + i) + j); } } s; })"); + assert(0, ({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[0]; }), "({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[0]; })"); + assert(1, ({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[1]; }), "({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[1]; })"); + assert(2, ({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[2]; }), "({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[2]; })"); + assert(42, ({ int i = 42; for (int i = 0; i < 10; ++i); i; }), "({ int i = 42; for (int i = 0; i < 10; ++i); i; })"); + assert(42, ({ int i = 42; for (auto int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; }), "for (int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; })"); + + printf("All tests are passed!\n"); + + return 0; +} diff --git a/test/Tests/csrc/self/statements/while.c b/test/Tests/csrc/self/statements/while.c new file mode 100644 index 0000000..ff67526 --- /dev/null +++ b/test/Tests/csrc/self/statements/while.c @@ -0,0 +1,35 @@ +// This is a c compiler test file. This comment itself is a line comment test. +/* + * This comment is also a block comment test. + */ + +int printf(); +int exit(); + +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:statements/while test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:statements/while test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int main() +{ + printf(">>>> tests: statements/while\n"); + + test_num = 1; + assert(10, ({ int a = 1; while (a < 10) a = a + 1; a; }), "({{ int a = 1; while (a < 10) a = a + 1; a; })"); + assert(31, ({ int a = 1; while (a < 10) a = a + 1; int b = 1; while (b < 20) b = b + 2; a + b; }), "({ int a = 1; while (a < 10) a = a + 1; int b = 1; while (b < 20) b = b + 2; a + b; })"); + assert(0, ({ int a = 0; while (a); 0; }), "({ int a = 0; while (a); 0; })"); + + printf("All tests are passed!\n"); + + return 0; +} diff --git a/test/Tests/csrc/test_core.c b/test/Tests/csrc/self/test_core.c similarity index 82% rename from test/Tests/csrc/test_core.c rename to test/Tests/csrc/self/test_core.c index 0fa495b..8555d02 100644 --- a/test/Tests/csrc/test_core.c +++ b/test/Tests/csrc/self/test_core.c @@ -48,25 +48,6 @@ int param_decay(int ar[]) { return ar[0]; }*/ int main() { test_num = 1; - assert(42, 42, "42"); - assert(7, 1 + 2 + 4, "1 + 2 + 4"); - assert(6, 10 - 7 + 3, "10 - 7 + 3"); - assert(35, 42 + 23 - 30, "42 + 23 - 30"); - assert(18, 42 / 2 + 2 - 5, "42 / 2 + 2 - 5"); - assert(4, (3 + 5) / 2, "(3 + 5) / 2"); - assert(21, (4 - 2) * 8 + 20 / 4, "(4 - 2) * 8 + 20 / 4"); - assert(15, -(-3 * +5), "-(-3 * +5)"); - assert(5, -25 + 30, "-25 + 30"); - assert(1, 42 == 42, "42 == 42"); - assert(1, 42 != 53, "42 != 53"); - assert(1, 42 < 53, "42 < 53"); - assert(1, 53 > 42, "53 > 42"); - assert(1, 42 <= 42, "42 <= 42"); - assert(1, 32 <= 42, "32 <= 42"); - assert(1, 42 >= 42, "42 >= 42"); - assert(1, 53 >= 42, "53 >= 42"); - assert(1, (1 + 1) == 2, "(1 + 1) == 2"); - assert(1, (2 * 3) != 2, "(2 * 3) != 2"); assert(42, ({ int a = 42; a; }), "({ int a = 42; a; })"); assert(42, ( { int a = 42; a; } ), "( { int a = 42; a; } )"); assert(44, ({ int a = 42; int b = 2; a + b; }), "({ int a = 42; int b = 2; a + b; })"); @@ -93,16 +74,6 @@ int main() assert(1, ({ int a = 1; int b = 1; a & b; }), "({ int a = 1; int b = 1; return a & b; })"); assert(1, ({ int a = 42; int b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) a = 1; else a = 0; a; }), "({ int a = 42; int b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) a = 1; else a = 0; a; })"); assert(1, 1 | 0, "1 | 0"); - assert(1, ({ int a = 1; int b = 0; a & b ^ a | b; }), "({ int a = 1; int b = 0; a & b ^ a | b; })"); // Xor swap - assert(20, ({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; a; }), "({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (i % 2 == 0) a = a + i; a; })"); - assert(1, !0, "!0"); - assert(0, !42, "!42"); - assert(1, !!!0, "!!!0"); - assert(41, ~(-42), "~(-42)"); - assert(42, ~~~~42, "~~~~42"); - assert(1, (2 * 4) == (2 << 2), "(2 * 4) == (2 << 2)"); - assert(1, (8 / 4) == (8 >> 2), "(8 / 4) == (8 >> 2)"); - assert(1, ({ int a = 2 << 4; (a & (a - 1)) == 0; }), "({ int a = 2 << 4; (a & (a - 1)) == 0; })"); // Determining if an integer is a power of 2 assert(3, ({ 1; {2;} 3; }), "({ 1; {2;} 3; })"); assert(42, f(), "f()"); assert(45, f() + 3, "f() + 3"); @@ -167,19 +138,6 @@ int main() assert(1, ({ char x; sizeof x; }), "({ char x; sizeof x; })"); assert(10, ({ char ar[10]; sizeof ar; }), "({ char ar[10]; return sizeof ar; })"); assert(1, sub3(7, 3, 3), "sub3(7, 3, 3)"); - assert(97, "abc"[0], "\"abc\"[0]"); - assert(98, "abc"[1], "\"abc\"[1];"); - assert(99, "abc"[2], "\"abc\"[2];"); - assert(0, "abc"[3], "\"abc\"[3];"); - assert(99, ({ char* p = "abc"; p[2]; }), "({ char* p = \"abc\"; p[2]; })"); - assert(7, "\a"[0], "\"\\a\"[0]"); - assert(8, "\b"[0], "\"\\b\"[0]"); - assert(9, "\t"[0], "\"\\t\"[0]"); - assert(10, "\n"[0], "\"\\n\"[0]"); - assert(11, "\v"[0], "\"\\v\"[0]"); - assert(12, "\f"[0], "\"\\f\"[0]"); - assert(13, "\r"[0], "\"\\r\"[0]"); - assert(0, "\0"[0], "\\0[0]"); assert(92, "\\"[0], "a"); assert(42, ({ int a = 42; { int a = 32; } a; }), "({ int a = 42; { int a = 32; } a; })"); assert(32, ({ int a = 42; { a = 32; } a; }), "({ int a = 42; { a = 32; } a; })"); @@ -301,56 +259,7 @@ int main() assert(4, ({ enum t { zero, one, two }; enum t y; sizeof y; }), "enum t { zero, one, two }; enum t y; sizeof y;"); assert(0, ({ typedef enum { zero } e; e y = zero; y; }), " ({ typedef enum { zero } e; e y = zero; y; })"); assert(42, (1, 2, 42), "(1, 2, 42)");*/ - assert(42, ({ int a = 41; ++a; }), "({ int a = 41; ++a; })"); - assert(42, ({ int a = 43; --a; }), "({ int a = 43; --a; })"); - assert(42, ({ int a = 42; a++; }), "({ int a = 41; a++; })"); - assert(42, ({ int a = 42; a--; }), "({ int a = 43; a--; })"); - assert(42, ({ int a = 41; a++; a; }), "({ int a = 41; a++; a; })"); - assert(42, ({ int a = 43; a--; a; }), "({ int a = 43; a--; a; })"); - assert(1, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; })"); - assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; ++*p++; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; })"); - assert(1, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p--; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; })"); - assert(0, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; --*p; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; --*p; })"); - assert(0, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; ar[0]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; *p++; ar[0]; })"); - assert(0, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[1]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[1]; })"); - assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[2]; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; ar[2]; })"); - assert(2, ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; }), " ({ int ar[3]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; (*p++)--; *p; })"); - assert(42, ({ int a = 2; a += 40; a; }), "int a = 2; a += 40; a;"); - assert(42, ({ int a = 2; a += 40; }), "int a = 2; a += 40;"); - assert(42, ({ int a = 44; a -= 2; a; }), "int a = 44; a -= 2; a;"); - assert(42, ({ int a = 44; a -= 2; }), "int a = 44; a -= 2;"); - assert(42, ({ int a = 21; a *= 2; a; }), "int a = 21; a *= 2; a;"); - assert(42, ({ int a = 21; a *= 2; }), "int a = 21; a *= 2;"); - assert(42, ({ int a = 84; a /= 2; a; }), "int a = 84; a /= 2; a;"); - assert(42, ({ int a = 84; a /= 2; }), "int a = 84; a /= 2;"); - assert(1, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar; p += 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar; p += 1; *p; })"); - assert(0, ({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; }), "({ int ar[2]; int i = 0; for (; i < sizeof ar / sizeof *ar; ++i) ar[i] = i; int* p = ar + 1; p -= 1; *p; })"); - assert(1, 1 || 0, "1 || 0"); - assert(1, (1 + 1) || 0 || 0, "(1 + 1) || 0 || 0"); - assert(0, 0 || 0, "0 || 0"); - assert(0, 0 || (1 - 1), "0 || (1 - 1)"); - assert(1, 1 && 2, "1 && 2"); - assert(0, 2 && 3 && 4 && 0, "2 && 3 && 4 && 0"); - assert(2, ({ int a = 6; a &= 3; a; }), "({ int a = 6; a &= 3; a; })"); - assert(2, ({ int a = 6; a &= 3; }), "({ int a = 6; a &= 3; })"); - assert(7, ({ int a = 6; a |= 3; a; }), "({ int a = 6; a |= 3; a; })"); - assert(7, ({ int a = 6; a |= 3; }), "({ int a = 6; a |= 3; })"); - assert(10, ({ int a = 15; a ^= 5; a; }), "({ int a = 15; a ^= 5; a; })"); - assert(10, ({ int a = 15; a ^= 5; }), "({ int a = 15; a ^= 5; })"); - assert(2, ({ int a = 1; a <<= 1; a; }), "({ int a = 1; a <<= 1; a; })"); - assert(2, ({ int a = 1; a <<= 1; }), "({ int a = 1; a <<= 1; })"); - assert(2, ({ int a = 4; a >>= 1; a; }), "({ int a = 4; a >>= 1; a; })"); - assert(2, ({ int a = 4; a >>= 1; }), "({ int a = 4; a >>= 1; })"); - assert(-1, ({ int a = -1; a >>= 1; }), "({ int a = -1; a >>= 1; })"); - assert(42, 1 ? 42 : 0, "1 ? 42 : 0"); - assert(42, 0 ? 0 : 42, "0 ? 0 : 42"); - assert(42, ({ int a = 1; int b = 0; a || b ? 42 : 0; }), "({ int a = 1; int b = 0; a || b ? 42 : 0; })"); - assert(42, ({ int a = 1; int b = 0; a && b ? 0 : 42; }), "({ int a = 1; int b = 0; a && b ? 0 : 42; })"); - assert(42, ({ 42 ?: 0; }), "({ 42 ?: 0; })"); - assert(42, ({ int a = 42; a++ ?: 0; }), "({ int a = 42; a++ ?: 0; })"); - assert(42, ({ sub3(2, 1, 1) ?: 42; }), "({ sub3(2, 1, 1) ?: 42; })"); //assert(43, ({ enum { a = 14 + 14 + 14, b }; b; }), "({ enum { a = 14 + 14 + 14, b }; b; })"); - assert(10, ({ int ar[2 ? 5 * 2 : 5]; sizeof ar / sizeof *ar; }), "({ int ar[2 ? 5 * 2 : 5]; sizeof ar / sizeof *ar; })"); /* assert(1, sizeof(signed char), "sizeof(signed char)"); assert(1, sizeof(char signed), "sizeof(char signed)"); assert(4, sizeof(signed int), "sizeof(signed int)"); @@ -406,12 +315,6 @@ int main() assert(3, ({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; }), "({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; })"); assert(4, ({ int i = 0; while (1) { if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { if (i++ == 3) break; } i; })"); assert(4, ({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; })"); - assert(10, ({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } i; }), "({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } i; })"); - assert(6, ({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } j; }), "({ int i = 0; int j = 0; for (; i < 10; ++i) { if (i > 5) continue; ++j; } j; })"); - assert(10, ({ int i = 0; int j = 0; for (; !i;) { for (; j != 10; ++j) continue; break; } j; }), "({ int i = 0; int j = 0; for (; !i;) { for (; j != 10; ++j) continue; break; } j; }),"); - assert(11, ({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } i; }), "({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } i; })"); - assert(5, ({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } j; }), "({ int i = 0; int j = 0; while (i++ < 10) { if (i > 5) continue; ++j; } j; })"); - assert(11, ({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; }), "({ int i = 0; int j = 0; while (!i) { while (j++ != 10) continue; break; } j; })"); assert(3, ({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; }), "({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; })"); assert(2, ({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; }), "({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; })"); assert(1, ({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; }), "({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; })"); @@ -425,7 +328,7 @@ int main() assert(0, ({ int i = 0; switch (3) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; }), "({ int i = 0; switch (3) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; })"); assert(42, ({ int i = 40; switch (0) { case 0: ++i; case 1: ++i; } i; }), "({ int i = 40; switch (0) { case 0: ++i; case 1: ++i; } i; })"); assert(41, ({ int i = 40; switch (i) { case 20 * 2: ++i; } i; }), "({ int i = 40; switch (i) { case 20 * 2: ++i; } i; })"); - assert(0, ({ int ar[]; 0; }), "({ int ar[]; 0; })"); + //assert(0, ({ int ar[]; 0; }), "({ int ar[]; 0; })"); assert(42, ({ int ar[1] = { 42 }; ar[0]; }), "({ int ar[1] = { 42 }; ar[0]; })"); assert(1, ({ int ar[3] = { 1, 2, 3 }; ar[0]; }), "({ int ar[3] = { 1, 2, 3 }; ar[0]; })"); assert(2, ({ int ar[3] = { 1, 2, 3 }; ar[1]; }), "({ int ar[3] = { 1, 2, 3 }; ar[1]; })"); From d6addc120a2a3ed39ca87ba9c6e14f5b0bf54982 Mon Sep 17 00:00:00 2001 From: roki Date: Mon, 11 Jan 2021 03:28:23 +0900 Subject: [PATCH 40/51] Allow array initialization with strings --- src/Htcc/Parser/Combinators/Core.hs | 5 +- src/Htcc/Parser/Combinators/Program.hs | 17 ++-- src/Htcc/Parser/Combinators/Var.hs | 121 +++++++++++++++---------- test/Spec.hs | 1 - test/Tests/csrc/self/array/string.c | 58 ++++++++++++ test/Tests/csrc/self/test_core.c | 14 --- 6 files changed, 143 insertions(+), 73 deletions(-) create mode 100644 test/Tests/csrc/self/array/string.c diff --git a/src/Htcc/Parser/Combinators/Core.hs b/src/Htcc/Parser/Combinators/Core.hs index 92b36c0..d625f49 100644 --- a/src/Htcc/Parser/Combinators/Core.hs +++ b/src/Htcc/Parser/Combinators/Core.hs @@ -12,6 +12,7 @@ C language lexer {-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, TupleSections #-} module Htcc.Parser.Combinators.Core ( runParser + , ConstructionDataState , Parser , spaceConsumer , lexeme @@ -97,10 +98,10 @@ symbol :: Ord e => T.Text -> M.ParsecT e T.Text m T.Text symbol = ML.symbol spaceConsumer charLiteral :: Ord e => M.ParsecT e T.Text m Char -charLiteral = M.between (MC.char '\'') (MC.char '\'') ML.charLiteral +charLiteral = M.between (MC.char '\'') (MC.char '\'') ML.charLiteral <* spaceConsumer stringLiteral :: Ord e => M.ParsecT e T.Text m String -stringLiteral = MC.char '\"' *> ((<> "\0") <$> M.manyTill ML.charLiteral (MC.char '\"')) +stringLiteral = MC.char '\"' *> ((<> "\0") <$> M.manyTill ML.charLiteral (MC.char '\"')) <* spaceConsumer hexadecimal, octal, decimal, natural, integer :: (Ord e, Num i) => M.ParsecT e T.Text m i hexadecimal = MC.char '0' >> MC.char' 'x' >> ML.hexadecimal diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index e5a4e26..6a843e4 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -7,7 +7,7 @@ Maintainer : falgon53@yahoo.co.jp Stability : experimental Portability : POSIX -C language lexer +C language Program parser -} {-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings, TupleSections #-} module Htcc.Parser.Combinators.Program ( @@ -29,8 +29,7 @@ import qualified Data.ByteString.UTF8 as BSU import Data.Char (ord) import Data.Either (rights) import Data.Functor ((<&>)) -import Data.Maybe (fromJust, - fromMaybe) +import Data.Maybe (fromJust) import qualified Data.Text as T import Data.Tuple.Extra (dupe, first) import qualified Htcc.CRules.Types as CT @@ -107,7 +106,7 @@ declIdentFuncArg sep = do Right . (,ident) <$> M.option ty (narrowPtr <$> arraySuffix ty) <* sep narrowPtr ty - | CT.isCTArray ty = fromMaybe ty $ CT.mapTypeKind CT.CTPtr <$> CT.deref ty + | CT.isCTArray ty = maybe ty (CT.mapTypeKind CT.CTPtr) $ CT.deref ty | CT.isIncompleteArray ty = CT.mapTypeKind (\(CT.CTIncomplete (CT.IncompleteArray t')) -> CT.CTPtr t') ty | otherwise = ty @@ -152,7 +151,7 @@ function = do ] where takeParameters = - M.manyTill (M.try (declIdentFuncArg comma) M.<|> (declIdentFuncArg $ M.lookAhead rparen)) rparen + M.manyTill (M.try (declIdentFuncArg comma) M.<|> declIdentFuncArg (M.lookAhead rparen)) rparen declaration ty ident = void semi @@ -310,7 +309,7 @@ expr = assign assign = do nd <- conditional - M.option nd $ choice $ map (`id` nd) $ + M.option nd $ choice $ map (`id` nd) [ assignOp ATAssign "=" , assignOp ATMulAssign "*=" , assignOp ATDivAssign "/=" @@ -329,7 +328,7 @@ conditional = do nd <- logicalOr ifM (M.option False (True <$ M.lookAhead question)) (GNU.condOmitted nd M.<|> condOp nd) $ pure nd where - condOp nd = uncurry (flip atConditional nd) . first atype . dupe + condOp nd = uncurry (`atConditional` nd) . first atype . dupe <$> (question *> expr <* colon) <*> conditional @@ -435,7 +434,7 @@ factor = choice strLiteral = do s <- stringLiteral lit <- lift $ gets $ - addLiteral (CT.SCAuto $ CT.CTArray (fromIntegral $ length s) CT.CTChar) $ + addLiteral (CT.SCAuto $ CT.CTArray (fromIntegral $ length s) CT.CTChar) (HT.TokenLCNums 1 1, HT.TKString $ BSU.fromString s) case lit of Left err -> fail $ T.unpack $ fst err @@ -448,7 +447,7 @@ factor = choice , variable ident ] where - variable ident = do + variable ident = lift (gets $ lookupVar ident) >>= \case FoundGVar (PV.GVar t _) -> return $ atGVar t ident diff --git a/src/Htcc/Parser/Combinators/Var.hs b/src/Htcc/Parser/Combinators/Var.hs index a4d0482..2ebec0e 100644 --- a/src/Htcc/Parser/Combinators/Var.hs +++ b/src/Htcc/Parser/Combinators/Var.hs @@ -17,11 +17,14 @@ import Control.Monad (foldM, forM, void, (>=>)) import Control.Monad.Extra (andM) import Control.Monad.Fix (fix) import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT) import Control.Monad.Trans.State (gets) import Data.Bits (Bits) import Data.Bool (bool) +import Data.Char (ord) import Data.Foldable (toList) import Data.Functor ((<&>)) +import Data.List (sortBy) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Sequence as SQ import qualified Data.Text as T @@ -36,9 +39,16 @@ import Htcc.Parser.Combinators.Utils (bracket, maybeToParser, import Htcc.Parser.ConstructionData (incomplete, lookupLVar) import Htcc.Utils (tshow) import qualified Text.Megaparsec as M - import Text.Megaparsec.Debug (dbg) +type DesignatorParser i r = ReaderT (T.Text, Parser i (ATree i)) (Parser i) r + +runDesignator :: (SQ.Seq (ATree i) -> SQ.Seq (CT.Desg i) -> DesignatorParser i r) + -> T.Text + -> Parser i (ATree i) + -> Parser i r +runDesignator p ident assignParser = runReaderT (p SQ.empty SQ.empty) (ident, assignParser) + fromValidAssignAST :: Eq i => ATree i -> Parser i (ATree i) fromValidAssignAST at@(ATNode _ ty _ _) | CT.toTypeKind ty == CT.CTVoid = fail "void value not ignored as it ought to be" @@ -86,99 +96,116 @@ lengthArrayBrace = braces (arrayBrace 0) ] desgNode :: (Num i, Ord i, Show i) - => T.Text - -> ATree i + => ATree i -> SQ.Seq (CT.Desg i) - -> Parser i (ATree i) -desgNode ident nd desg = fmap (atExprStmt . flip atAssign nd) $ - flip (`foldr` (treealize <$> (maybeToParser' =<< lift (gets $ lookupLVar ident)))) desg $ \idx acc -> case idx of + -> DesignatorParser i (ATree i) +desgNode nd desg = fmap (atExprStmt . flip atAssign nd) $ + flip (`foldr` facc) desg $ \idx acc -> case idx of CT.DesgIdx idx' -> do - at <- acc - nd' <- maybeToParser' $ addKind at $ atNumLit idx' + nd' <- maybeToParser' . (`addKind` atNumLit idx') =<< acc flip (atUnary ATDeref) nd' <$> maybeToParser' (CT.deref (atype nd')) CT.DesgMem mem -> atMemberAcc mem <$> acc where - maybeToParser' = maybeToParser "invalid initializer-list" + facc = asks fst + >>= lift . lift . gets . lookupLVar + >>= maybeToParser' + <&> treealize + maybeToParser' = lift . maybeToParser "invalid initializer-list" initLoop :: (Integral i, Bits i, Read i, Show i) - => Parser i (ATree i) - -> CT.StorageClass i - -> T.Text + => CT.StorageClass i -> SQ.Seq (ATree i) -> SQ.Seq (CT.Desg i) - -> Parser i (SQ.Seq (ATree i), i) -initLoop p ty ident ai desg = initLoop' ai <* rbrace + -> DesignatorParser i (SQ.Seq (ATree i), i) +initLoop ty ai desg = initLoop' ai <* lift rbrace where initLoop' ai' = case CT.toTypeKind ty of CT.CTArray _ _ -> ($ (0, ai')) . fix $ \f (idx, rl) -> do - rs <- desgInit p (fromJust $ CT.deref ty) ident rl (CT.DesgIdx idx SQ.<| desg) + rs <- desgInit (fromJust $ CT.deref ty) rl (CT.DesgIdx idx SQ.<| desg) M.choice - [ (rs, succ idx) <$ M.lookAhead rbrace - , comma *> f (succ idx, rs) + [ (rs, succ idx) <$ lift (M.lookAhead rbrace) + , lift comma *> f (succ idx, rs) ] _ -> fail "internal compiler error" initZero :: (Num i, Ord i, Show i, Enum i) => CT.TypeKind i - -> T.Text -> SQ.Seq (CT.Desg i) - -> Parser i (SQ.Seq (ATree i)) -initZero (CT.CTArray n ty) ident desg = + -> DesignatorParser i (SQ.Seq (ATree i)) +initZero (CT.CTArray n ty) desg = foldM - (\acc idx -> (SQ.>< acc) <$> initZero ty ident (CT.DesgIdx idx SQ.<| desg)) + (\acc idx -> (SQ.>< acc) <$> initZero ty (CT.DesgIdx idx SQ.<| desg)) SQ.empty [0..fromIntegral (pred n)] -initZero _ ident desg = SQ.singleton <$> desgNode ident (atNumLit 0) desg +initZero _ desg = SQ.singleton <$> desgNode (atNumLit 0) desg + +arType :: (CT.CType (a j), CT.TypeKindBase a, Integral i) => a j -> i -> a j +arType ty len = snd (CT.dctorArray ty) $ + CT.mapTypeKind (CT.CTArray (fromIntegral len) . fromJust . CT.fromIncompleteArray) ty + +initializerString :: (Integral i, Bits i, Read i, Show i) + => CT.StorageClass i + -> SQ.Seq (ATree i) + -> SQ.Seq (CT.Desg i) + -> DesignatorParser i (SQ.Seq (ATree i)) +initializerString ty ai desg + | CT.isIncompleteArray ty = do + newt <- lift $ bracket M.getInput M.setInput (const $ arType ty . length <$> stringLiteral) + asks fst >>= lift . registerLVar newt >> desgInit newt ai desg + | otherwise = case CT.toTypeKind ty of + CT.CTArray n _ -> do + s <- lift stringLiteral + let s' = s <> replicate (fromIntegral n - pred (length s)) (toEnum 0) + inds = sortBy (flip (.) reverse . compare . reverse) $ CT.accessibleIndices $ CT.toTypeKind ty + fmap ((ai SQ.><) . SQ.fromList) + $ mapM (uncurry desgNode) + $ zipWith (flip (.) ((SQ.>< desg) . SQ.fromList) . (,) . atNumLit . fromIntegral . ord) s' inds + _ -> fail "internal compiler error" initializerList :: (Integral i, Bits i, Read i, Show i) - => Parser i (ATree i) - -> CT.StorageClass i - -> T.Text + => CT.StorageClass i -> SQ.Seq (ATree i) -> SQ.Seq (CT.Desg i) - -> Parser i (SQ.Seq (ATree i)) -initializerList p ty ident ai desg = M.choice + -> DesignatorParser i (SQ.Seq (ATree i)) +initializerList ty ai desg = M.choice [ allZeroInit , withInitElements ] where allZeroInit = do - void $ M.try (lbrace *> rbrace) + void $ lift $ M.try (lbrace *> rbrace) (ai SQ.><) . SQ.fromList <$> forM (CT.accessibleIndices $ CT.toTypeKind ty) - (desgNode ident (atNumLit 0) . (SQ.>< desg) . SQ.fromList) + (desgNode (atNumLit 0) . (SQ.>< desg) . SQ.fromList) withInitElements | CT.isIncompleteArray ty = do - newt <- bracket M.getInput M.setInput (const $ arType <$> lengthArrayBrace) - registerLVar newt ident *> desgInit p newt ident ai desg + newt <- lift $ bracket M.getInput M.setInput (const $ arType ty <$> lengthArrayBrace) + asks fst + >>= lift . registerLVar newt + >> desgInit newt ai desg | otherwise = do - void lbrace + void $ lift lbrace case CT.toTypeKind ty of CT.CTArray n bt -> do - (ast, idx) <- initLoop p ty ident ai desg + (ast, idx) <- initLoop ty ai desg (ai SQ.><) . (ast SQ.><) <$> foldM - (\acc idx' -> (SQ.>< acc) <$> initZero bt ident (CT.DesgIdx idx' SQ.<| desg)) + (\acc idx' -> (SQ.>< acc) <$> initZero bt (CT.DesgIdx idx' SQ.<| desg)) SQ.empty [fromIntegral idx..pred (fromIntegral n)] _ -> fail "internal compiler error" - where - arType len = snd (CT.dctorArray ty) $ - CT.mapTypeKind (CT.CTArray (fromIntegral len) . fromJust . CT.fromIncompleteArray) ty desgInit :: (Integral i, Bits i, Read i, Show i) - => Parser i (ATree i) - -> CT.StorageClass i - -> T.Text + => CT.StorageClass i -> SQ.Seq (ATree i) -> SQ.Seq (CT.Desg i) - -> Parser i (SQ.Seq (ATree i)) -desgInit p ty ident ai desg = M.choice - [ ai <$ lookInitializerString - , lookInitializerList *> initializerList p ty ident ai desg - , ai <$ lookStructInit - , p >>= (flip (desgNode ident) desg >=> pure . (SQ.|>) ai) + -> DesignatorParser i (SQ.Seq (ATree i)) +desgInit ty ai desg = M.choice + [ lift lookInitializerString *> initializerString ty ai desg + , lift lookInitializerList *> initializerList ty ai desg + , ai <$ lift lookStructInit + , asks snd >>= lift >>= (flip desgNode desg >=> pure . (SQ.|>) ai) ] where lookInitializerString = bool M.empty (pure ()) =<< andM @@ -196,7 +223,7 @@ varInit' :: (Integral i, Bits i, Read i, Show i) -> ATree i -> Parser i (ATree i) varInit' p ty ident lat - | CT.isArray ty || CT.isCTStruct ty = atBlock . toList <$> desgInit p ty ident SQ.empty SQ.empty + | CT.isArray ty || CT.isCTStruct ty = atBlock . toList <$> runDesignator (desgInit ty) ident p | otherwise = p >>= fromValidAssignAST <&> atExprStmt . ATNode ATAssign (atype lat) lat varInit :: (Integral i, Bits i, Read i, Show i) diff --git a/test/Spec.hs b/test/Spec.hs index 921a517..dcca475 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,7 +2,6 @@ module Main where import Codec.Binary.UTF8.String (decodeString) -import Control.Exception (finally) import Control.Monad (foldM) import Control.Monad.Extra (partitionM) import Control.Monad.Trans (lift) diff --git a/test/Tests/csrc/self/array/string.c b/test/Tests/csrc/self/array/string.c new file mode 100644 index 0000000..29abfba --- /dev/null +++ b/test/Tests/csrc/self/array/string.c @@ -0,0 +1,58 @@ +// The array of string tests + +int printf(); +int exit(); +int strcmp(char* p, char* q); +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:array/string test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:array/string test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int main() +{ + printf(">>>> tests: array/string\n"); + test_num = 1; + + assert('h', ({ char s[5] = "hoge"; s[0]; }), "({ char s[5] = \"hoge\"; s[0]; })"); + assert('o', ({ char s[5] = "hoge"; s[1]; }), "({ char s[5] = \"hoge\"; s[1]; })"); + assert('g', ({ char s[5] = "hoge"; s[2]; }), "({ char s[5] = \"hoge\"; s[2]; })"); + assert('e', ({ char s[5] = "hoge"; s[3]; }), "({ char s[5] = \"hoge\"; s[3]; })"); + assert(0, ({ char s[5] = "hoge"; s[4]; }), "({ char s[5] = \"hoge\"; s[4]; })"); + assert('h', ({ char s[] = "hoge"; s[0]; }), "({ char s[] = \"hoge\"; s[0]; })"); + assert('o', ({ char s[] = "hoge"; s[1]; }), "({ char s[] = \"hoge\"; s[1]; })"); + assert('g', ({ char s[] = "hoge"; s[2]; }), "({ char s[] = \"hoge\"; s[2]; })"); + assert('e', ({ char s[] = "hoge"; s[3]; }), "({ char s[] = \"hoge\"; s[3]; })"); + assert(0, ({ char s[] = "hoge"; s[4]; }), "({ char s[] = \"hoge\"; s[4]; })"); + assert(0, ({ char s1[] = "hoge"; char s2[] = "hoge"; strcmp(s1, s2); }), "({ char s1[] = \"hoge\"; char s2[] = \"hoge\"; strcmp(s1, s2); })"); + assert(1, ({ char s1[] = "a"; char s2[] = "b"; 0 < strcmp(s1, s2); }), "({ char s1[] = \"a\"; char s2[] = \"b\"; 0 < strcmp(s1, s2); })"); + assert(5, ({ char s[] = "hoge"; sizeof s; }), "({ char s[] = \"hoge\"; sizeof s; })"); + assert('a', ({ char str[2][4] = { "abc", "def" }; str[0][0]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][0]; })"); + assert('b', ({ char str[2][4] = { "abc", "def" }; str[0][1]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][1]; })"); + assert('c', ({ char str[2][4] = { "abc", "def" }; str[0][2]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][2]; })"); + assert(0, ({ char str[2][4] = { "abc", "def" }; str[0][3]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][3]; })"); + assert('d', ({ char str[2][4] = { "abc", "def" }; str[1][0]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][0]; })"); + assert('e', ({ char str[2][4] = { "abc", "def" }; str[1][1]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][1]; })"); + assert('f', ({ char str[2][4] = { "abc", "def" }; str[1][2]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][2]; })"); + assert(0, ({ char str[2][4] = { "abc", "def" }; str[1][3]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][3]; })"); + assert('a', ({ char str[][4] = { "abc", "def" }; str[0][0]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[0][0]; })"); + assert('b', ({ char str[][4] = { "abc", "def" }; str[0][1]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[0][1]; })"); + assert('c', ({ char str[][4] = { "abc", "def" }; str[0][2]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[0][2]; })"); + assert(0, ({ char str[][4] = { "abc", "def" }; str[0][3]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[0][3]; })"); + assert('d', ({ char str[][4] = { "abc", "def" }; str[1][0]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[1][0]; })"); + assert('e', ({ char str[][4] = { "abc", "def" }; str[1][1]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[1][1]; })"); + assert('f', ({ char str[][4] = { "abc", "def" }; str[1][2]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[1][2]; })"); + assert(0, ({ char str[][4] = { "abc", "def" }; str[1][3]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[1][3]; })"); + + printf("All tests are passed!\n"); + + return 0; +} diff --git a/test/Tests/csrc/self/test_core.c b/test/Tests/csrc/self/test_core.c index 8555d02..c21cdf2 100644 --- a/test/Tests/csrc/self/test_core.c +++ b/test/Tests/csrc/self/test_core.c @@ -369,22 +369,8 @@ int main() assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; })"); assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; })"); assert(0, ({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; }), "({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; })");/* - assert('a', ({ char str[4] = "abc"; str[0]; }), "({ int str[4] = \"abc\"; str[0]; })"); - assert('c', ({ char str[4] = "abc"; str[2]; }), "({ int str[4] = \"abc\"; str[2]; })"); - assert(0, ({ char str[4] = "abc"; str[3]; }), "({ int str[4] = \"abc\"; str[3]; })"); - assert('a', ({ char str[2][4] = { "abc", "def" }; str[0][0]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][0]; })"); - assert('b', ({ char str[2][4] = { "abc", "def" }; str[0][1]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][1]; })"); - assert('c', ({ char str[2][4] = { "abc", "def" }; str[0][2]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][2]; })"); - assert(0, ({ char str[2][4] = { "abc", "def" }; str[0][3]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][3]; })"); - assert('d', ({ char str[2][4] = { "abc", "def" }; str[1][0]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][0]; })"); - assert('e', ({ char str[2][4] = { "abc", "def" }; str[1][1]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][1]; })"); - assert('f', ({ char str[2][4] = { "abc", "def" }; str[1][2]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][2]; })"); - assert(0, ({ char str[2][4] = { "abc", "def" }; str[1][3]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][3]; })"); assert(3, ({ int ar[] = { 0, 1, 2, 3 }; ar[3]; }), "({ int ar[] = { 0, 1, 2, 3 }; ar[3]; })"); assert(16, ({ int ar[] = { 0, 1, 2, 3 }; sizeof ar; }), "({ int ar[] = { 0, 1, 2, 3 }; sizeof ar; })"); - assert(4, ({ char str[] = "foo"; sizeof str; }), "({ char str[] = \"foo\"; sizeof str; })"); - assert('d', ({ char str[] = "abcd"; str[3]; }), "({ char str[] = \"abcd\"; str[3]; })"); - assert(0, ({ char str[] = "abcd"; str[4]; }), "({ char str[] = \"abcd\"; str[4]; })"); assert(1, ({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.a; }), "({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.a; })"); assert(2, ({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.b; }), "({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.b; })"); assert(3, ({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.c; }), "({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.c; })"); From f584afc30eb2dfebf577b7e4b8bd58bbf765e958 Mon Sep 17 00:00:00 2001 From: roki Date: Tue, 12 Jan 2021 00:37:43 +0900 Subject: [PATCH 41/51] Allow void function --- src/Htcc/CRules/Types/TypeKind.hs | 2 +- src/Htcc/Parser/Combinators/Keywords.hs | 4 +-- src/Htcc/Parser/Combinators/Program.hs | 32 +++++++++++++---- .../ComponentsTests/Parser/Combinators.hs | 9 +++-- test/Tests/csrc/self/statements/func.c | 35 +++++++++++++++++++ test/Tests/csrc/self/test_core.c | 8 +---- 6 files changed, 68 insertions(+), 22 deletions(-) create mode 100644 test/Tests/csrc/self/statements/func.c diff --git a/src/Htcc/CRules/Types/TypeKind.hs b/src/Htcc/CRules/Types/TypeKind.hs index 5c18519..bd97a21 100644 --- a/src/Htcc/CRules/Types/TypeKind.hs +++ b/src/Htcc/CRules/Types/TypeKind.hs @@ -148,7 +148,7 @@ data TypeKind i = CTInt -- ^ The type @int@ as C language {-# INLINE fundamental #-} fundamental :: [TypeKind i] -fundamental = [CTChar, CTInt, CTShort CTUndef, CTLong CTUndef, CTSigned CTUndef] +fundamental = [CTChar, CTInt, CTShort CTUndef, CTLong CTUndef, CTSigned CTUndef, CTVoid] {-# INLINE isLongShortable #-} isLongShortable :: TypeKind i -> Bool diff --git a/src/Htcc/Parser/Combinators/Keywords.hs b/src/Htcc/Parser/Combinators/Keywords.hs index fc58415..634006f 100644 --- a/src/Htcc/Parser/Combinators/Keywords.hs +++ b/src/Htcc/Parser/Combinators/Keywords.hs @@ -28,7 +28,7 @@ import qualified Text.Megaparsec as M import qualified Text.Megaparsec.Char as MC pKeyword :: Ord e => T.Text -> M.ParsecT e T.Text m T.Text -pKeyword = flip notFollowedBy (M.takeWhile1P (Just "valid identifier") CR.isValidChar) . MC.string +pKeyword = flip notFollowedBy (M.takeWhile1P (Just "valid Keyword") CR.isValidChar) . MC.string kAuto, kBreak, kCase, kChar, kConst, kContinue, kDefault, kDo, kDouble, kElse, kEnum, kExtern, @@ -58,7 +58,7 @@ kInline = pKeyword "inline" kInt = pKeyword "int" kLong = pKeyword "long" kRegister = pKeyword "register" -kRestrict = "restrict" +kRestrict = pKeyword "restrict" kReturn = pKeyword "return" kShort = pKeyword "short" kSigned = pKeyword "signed" diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 6a843e4..78c06f9 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -29,12 +29,15 @@ import qualified Data.ByteString.UTF8 as BSU import Data.Char (ord) import Data.Either (rights) import Data.Functor ((<&>)) -import Data.Maybe (fromJust) +import Data.List (find) +import Data.Maybe (fromJust, isJust) import qualified Data.Text as T import Data.Tuple.Extra (dupe, first) import qualified Htcc.CRules.Types as CT import Htcc.Parser.AST (Treealizable (..), - addKind, subKind) + addKind, + isNonEmptyReturn, + subKind) import Htcc.Parser.AST.Core (ATKind (..), ATKindFor (..), ATree (..), @@ -89,7 +92,7 @@ import Text.Megaparsec.Debug (dbg) declIdent :: (Show i, Read i, Bits i, Integral i) => Parser i (CT.StorageClass i, T.Text) declIdent = do - ty <- cType + ty <- M.try cType ident <- identifier (,ident) <$> M.option ty (arraySuffix ty) @@ -97,7 +100,7 @@ declIdentFuncArg :: (Show i, Read i, Bits i, Integral i) => Parser i a -> Parser i (Either (CT.StorageClass i) (CT.StorageClass i, T.Text)) declIdentFuncArg sep = do - ty <- cType + ty <- M.try cType anonymousArg ty M.<|> namedArg ty where anonymousArg ty = Left <$> M.option ty (arraySuffix ty) <* sep @@ -167,8 +170,23 @@ function = do Right scp' -> do lift $ put scp' params' <- forM (rights params) $ uncurry registerLVar - atDefFunc ident (if null params' then Nothing else Just params') ty <$> stmt + stmt >>= fromValidFunc params' Left err -> fail $ T.unpack $ fst err + where + fromValidFunc params' st@(ATNode (ATBlock block) _ _ _) + | CT.toTypeKind ty == CT.CTVoid = + if isJust (find isNonEmptyReturn block) then + fail $ mconcat + [ "the return type of function '" + , T.unpack ident + , "' is void, but the statement returns a value" + ] + else + pure $ atDefFunc ident (if null params' then Nothing else Just params') ty st + | otherwise = + -- TODO: Warning when there is no return value when the function is not void + pure $ atDefFunc ident (if null params' then Nothing else Just params') ty st + fromValidFunc _ _ = fail "internal compiler error" gvar = do (ty, ident) <- declIdent @@ -245,8 +263,8 @@ stmt = choice ] where returnStmt = choice - [ atReturn (CT.SCUndef CT.CTUndef) <$> (M.try kReturn >> expr) <* semi - --, atReturn (CT.SCUndef CT.CTUndef) ATEmpty <$ (kReturn >> semi) + [ atReturn (CT.SCUndef CT.CTUndef) ATEmpty <$ M.try (kReturn *> semi) + , atReturn (CT.SCUndef CT.CTUndef) <$> (M.try kReturn *> expr) <* semi ] ifStmt = do diff --git a/test/Tests/ComponentsTests/Parser/Combinators.hs b/test/Tests/ComponentsTests/Parser/Combinators.hs index d988d82..9371727 100644 --- a/test/Tests/ComponentsTests/Parser/Combinators.hs +++ b/test/Tests/ComponentsTests/Parser/Combinators.hs @@ -8,17 +8,16 @@ import qualified Data.Text as T import Data.Void (Void) import qualified Htcc.CRules as CR import Htcc.Parser.Combinators.Core -import qualified Htcc.Tokenizer.Token as HTT import Htcc.Utils (tshow) import Test.HUnit (Test (..), (~:), (~?=)) import qualified Text.Megaparsec as M type TestParser = M.Parsec Void T.Text -charLiteralTest, - stringLiteralTest, - hexadecimalTest, - octalTest, +charLiteralTest, + stringLiteralTest, + hexadecimalTest, + octalTest, naturalTest, integerTest, identifierTest :: Test diff --git a/test/Tests/csrc/self/statements/func.c b/test/Tests/csrc/self/statements/func.c new file mode 100644 index 0000000..2bd461f --- /dev/null +++ b/test/Tests/csrc/self/statements/func.c @@ -0,0 +1,35 @@ +// function call test + +int printf(); +int exit(); +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:statements/func test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:statements/func test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +void swap(int* a, int* b) { *a ^= *b; *b ^= *a; *a ^= *b; } +void void_fn(int* a) { *a = 42; return; *a = 53; } +int param_decay(int ar[]) { return ar[0]; } + +int main() +{ + printf(">>>> tests: statements/func\n"); + + test_num = 1; + assert(0, ({ int ar[] = { 0 }; param_decay(ar); }), "({ int ar[] = { 0 }; param_decay(ar); })"); + assert(2, ({ int a = 1; int b = 2; swap(&a, &b); a; }), "({ int a = 1; int b = 2; swap(&a, &b); a; })"); + assert(1, ({ int a = 1; int b = 2; swap(&a, &b); b; }), "({ int a = 1; int b = 2; swap(&a, &b); b; })"); + assert(42, ({ int a = 1; void_fn(&a); a; }), "({ int a = 1; void_fn(&a); a; })"); + + printf("All tests are passed!\n"); + return 0; +} diff --git a/test/Tests/csrc/self/test_core.c b/test/Tests/csrc/self/test_core.c index c21cdf2..3cda104 100644 --- a/test/Tests/csrc/self/test_core.c +++ b/test/Tests/csrc/self/test_core.c @@ -41,9 +41,6 @@ int sub3_short(short a, short b, short c) { return a - b - c; } int sub3_long(long a, long b, long c) { return a - b - c; } /*int ptr2ar(int (*p)[3]) { int i = 0; for (; i < sizeof *p / sizeof **p; i = i + 1) p[0][i] = i + 1; return 0; } static int static_fun() { return 42; }*/ -/*void swap(int* a, int* b) { *a ^= *b; *b ^= *a; *a ^= *b; } -void void_fn(int* a) { *a = 42; return; *a = 53; } -int param_decay(int ar[]) { return ar[0]; }*/ int main() { @@ -306,10 +303,7 @@ int main() assert(42, 0B101010, "0B101010");*/ assert(49389, 0xc0ed, "0xc0ed"); assert(49389, 0xC0eD, "0xC0eD"); - /*assert(42, ({ int a = 53; int b = 42; swap(&a, &b); a; }), "({ int a = 53; int b = 42; swap(&a, &b); a; })"); - assert(42, ({ int a = 0; void_fn(&a); a; }), "({ int a = 53; int b = 42; swap(&a, &b); a; })"); - assert(42, ({ int ar[2]; ar[0] = 42; param_decay(ar); }), "({ int ar[2]; ar[0] = 0; param_decay(ar); })"); - assert(4, ({ struct X *a; struct X { int x; }; sizeof(struct X); }), " ({ struct X *a; struct X { int x; }; sizeof(struct X); })"); + /*assert(4, ({ struct X *a; struct X { int x; }; sizeof(struct X); }), " ({ struct X *a; struct X { int x; }; sizeof(struct X); })"); assert(42, ({ struct X { struct X* next; int x; } a; struct X b; b.x = 42; a.next = &b; a.next->x; }), "({ struct X { struct X* next; int x; } a; struct X b; b.x = 42; a.next = &b; a.next->x; })");*/ assert(3, ({ int i = 0; for (; i < 10; ++i) { if (i == 3) break; } i; }), "({ int i = 0; for (; i < 10; ++i) { if (i == 3) break; } i; })"); assert(3, ({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; }), "({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; })"); From 45f0bf0c73a60a6af414776838db9468b990c54e Mon Sep 17 00:00:00 2001 From: roki Date: Tue, 12 Jan 2021 02:39:07 +0900 Subject: [PATCH 42/51] refactoring unit tests --- test/Spec.hs | 32 ++-- test/Tests/csrc/self/array/basic.c | 17 -- test/Tests/csrc/self/array/string.c | 1 + test/Tests/csrc/self/expressions/literals.c | 44 +++++ test/Tests/csrc/self/expressions/operators.c | 3 + test/Tests/csrc/self/expressions/pointers.c | 33 ++++ test/Tests/csrc/self/statements/for.c | 3 + test/Tests/csrc/self/statements/func.c | 9 ++ test/Tests/csrc/self/statements/goto.c | 34 ++++ test/Tests/csrc/self/statements/if.c | 41 +++++ test/Tests/csrc/self/statements/switch.c | 41 +++++ test/Tests/csrc/self/statements/while.c | 2 + test/Tests/csrc/self/test_core.c | 161 +------------------ 13 files changed, 230 insertions(+), 191 deletions(-) create mode 100644 test/Tests/csrc/self/expressions/literals.c create mode 100644 test/Tests/csrc/self/expressions/pointers.c create mode 100644 test/Tests/csrc/self/statements/goto.c create mode 100644 test/Tests/csrc/self/statements/if.c create mode 100644 test/Tests/csrc/self/statements/switch.c diff --git a/test/Spec.hs b/test/Spec.hs index dcca475..b9fab68 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,7 +5,7 @@ import Codec.Binary.UTF8.String (decodeString) import Control.Monad (foldM) import Control.Monad.Extra (partitionM) import Control.Monad.Trans (lift) -import Control.Monad.Trans.State (StateT, evalStateT, get, modify, +import Control.Monad.Trans.State (StateT, evalStateT, gets, modify, put) import qualified Data.ByteString.Char8 as B import Data.List (isSuffixOf) @@ -19,6 +19,7 @@ import qualified Options.Applicative as OA import System.Directory (createDirectoryIfMissing) import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath (()) +import System.IO (hFlush, stdout) import System.Process (readCreateProcess, shell) import qualified Tests.ComponentsTests as ComponentsTests import qualified Tests.SubProcTests as SubProcTests @@ -85,21 +86,17 @@ genTestAsm' = lift (createDirectoryIfMissing False workDir *> createDirectoryIfM go s fname = do names <- lift $ map (fname ) <$> listDirectory fname (dirPaths, filePaths) <- lift $ partitionM doesDirectoryExist names - foldM (\fs f -> if ".c" `isSuffixOf` f then (:fs) <$> mkBin f else pure fs) s filePaths + foldM (\fs f -> if ".c" `isSuffixOf` f then (:fs) <$> mkBin (T.pack f) else pure fs) s filePaths >>= flip (foldM go) dirPaths mkBin fname = do - n <- get - lift $ execErrFin $ - mconcat - [ "stack exec htcc -- " - , T.pack fname - , " > " - , T.pack (asmDir "spec") - , tshow n - , ".s" - ] - mconcat [T.pack (asmDir "spec"), tshow n, ".s"] <$ modify succ + outAsmName <- gets (\n -> T.pack (asmDir "spec") <> tshow n <> ".s") + lift $ + T.putStr ("[compiling] " <> fname) + *> hFlush stdout + *> execErrFin ("stack exec htcc -- " <> fname <> " > " <> outAsmName) + *> T.putStrLn (" -> " <> outAsmName) + outAsmName <$ modify succ genTestAsm :: IO [T.Text] genTestAsm = evalStateT genTestAsm' 0 @@ -108,9 +105,12 @@ genTestBins' :: StateT Int IO [T.Text] genTestBins' = (genTestAsm' <* put 0) >>= mapM f where f fname = do - n <- get - let binName = mconcat [T.pack (workDir "spec"), tshow n, ".out"] - lift $ execErrFin ("gcc -xassembler -no-pie -o " <> binName <> " " <> fname) + binName <- gets (\n -> T.pack (workDir "spec") <> tshow n <> ".out") + lift $ + T.putStr ("[assembling] " <> fname) + *> hFlush stdout + *> execErrFin ("gcc -xassembler -no-pie -o " <> binName <> " " <> fname) + *> T.putStrLn (" -> " <> binName) binName <$ modify succ genTestBins :: IO [T.Text] diff --git a/test/Tests/csrc/self/array/basic.c b/test/Tests/csrc/self/array/basic.c index f4f14aa..1af483d 100644 --- a/test/Tests/csrc/self/array/basic.c +++ b/test/Tests/csrc/self/array/basic.c @@ -137,23 +137,6 @@ int main() assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; })"); assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; })"); assert(0, ({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; }), "({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; })"); - /* - assert('a', ({ char str[4] = "abc"; str[0]; }), "({ int str[4] = \"abc\"; str[0]; })"); - assert('c', ({ char str[4] = "abc"; str[2]; }), "({ int str[4] = \"abc\"; str[2]; })"); - assert(0, ({ char str[4] = "abc"; str[3]; }), "({ int str[4] = \"abc\"; str[3]; })"); - assert('a', ({ char str[2][4] = { "abc", "def" }; str[0][0]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][0]; })"); - assert('b', ({ char str[2][4] = { "abc", "def" }; str[0][1]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][1]; })"); - assert('c', ({ char str[2][4] = { "abc", "def" }; str[0][2]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][2]; })"); - assert(0, ({ char str[2][4] = { "abc", "def" }; str[0][3]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][3]; })"); - assert('d', ({ char str[2][4] = { "abc", "def" }; str[1][0]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][0]; })"); - assert('e', ({ char str[2][4] = { "abc", "def" }; str[1][1]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][1]; })"); - assert('f', ({ char str[2][4] = { "abc", "def" }; str[1][2]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][2]; })"); - assert(0, ({ char str[2][4] = { "abc", "def" }; str[1][3]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[1][3]; })"); - assert(3, ({ int ar[] = { 0, 1, 2, 3 }; ar[3]; }), "({ int ar[] = { 0, 1, 2, 3 }; ar[3]; })"); - assert(16, ({ int ar[] = { 0, 1, 2, 3 }; sizeof ar; }), "({ int ar[] = { 0, 1, 2, 3 }; sizeof ar; })"); - assert(4, ({ char str[] = "foo"; sizeof str; }), "({ char str[] = \"foo\"; sizeof str; })"); - assert('d', ({ char str[] = "abcd"; str[3]; }), "({ char str[] = \"abcd\"; str[3]; })"); - assert(0, ({ char str[] = "abcd"; str[4]; }), "({ char str[] = \"abcd\"; str[4]; })");*/ printf("All tests are passed!\n"); diff --git a/test/Tests/csrc/self/array/string.c b/test/Tests/csrc/self/array/string.c index 29abfba..629db25 100644 --- a/test/Tests/csrc/self/array/string.c +++ b/test/Tests/csrc/self/array/string.c @@ -51,6 +51,7 @@ int main() assert('e', ({ char str[][4] = { "abc", "def" }; str[1][1]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[1][1]; })"); assert('f', ({ char str[][4] = { "abc", "def" }; str[1][2]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[1][2]; })"); assert(0, ({ char str[][4] = { "abc", "def" }; str[1][3]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[1][3]; })"); + assert(92, "\\"[0], "\"\\\\\"[0]"); printf("All tests are passed!\n"); diff --git a/test/Tests/csrc/self/expressions/literals.c b/test/Tests/csrc/self/expressions/literals.c new file mode 100644 index 0000000..ea9ddb4 --- /dev/null +++ b/test/Tests/csrc/self/expressions/literals.c @@ -0,0 +1,44 @@ +// This is a c compiler test file. This comment itself is a line comment test. +/* + * This comment is also a block comment test. + */ + +int printf(); +int exit(); +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:expressions/literals test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:expressions/literals test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int main() +{ + printf(">>>> tests: expressions/literals\n"); + test_num = 1; + assert(511, 0777, "0777"); + assert(0, 0x0, "0x0"); + assert(10, 0xa, "0xa"); + assert(10, 0Xa, "0Xa"); + assert(48879, 0xbeef, "0xbeef"); + assert(48879, 0xBEEF, "0xBEEF"); + /*assert(0, 0b0, "0b0"); + assert(1, 0b1, "0b1"); + assert(42, 0b101010, "0b101010"); + assert(42, 0B101010, "0B101010");*/ + assert(49389, 0xc0ed, "0xc0ed"); + assert(49389, 0xC0eD, "0xC0eD"); + assert(97, 'a', "'a'"); + assert(10, '\n', "\'\\n\'"); + + printf("All tests are passed!\n"); + + return 0; +} diff --git a/test/Tests/csrc/self/expressions/operators.c b/test/Tests/csrc/self/expressions/operators.c index 5239fb6..8aecadf 100644 --- a/test/Tests/csrc/self/expressions/operators.c +++ b/test/Tests/csrc/self/expressions/operators.c @@ -99,6 +99,9 @@ int main() assert(42, ({ 42 ?: 0; }), "({ 42 ?: 0; })"); assert(42, ({ int a = 42; a++ ?: 0; }), "({ int a = 42; a++ ?: 0; })"); assert(42, ({ sub3(2, 1, 1) ?: 42; }), "({ sub3(2, 1, 1) ?: 42; })"); + assert(4, ({ int a; sizeof(a); }), "({ int a; sizeof(a); })"); + assert(4, ({ int a; sizeof a; }), "({ int a; sizeof a; })"); + assert(8, ({ int* p; sizeof p; }), "({ int* p; sizeof p; })"); printf("All tests are passed!\n"); diff --git a/test/Tests/csrc/self/expressions/pointers.c b/test/Tests/csrc/self/expressions/pointers.c new file mode 100644 index 0000000..48f8ebf --- /dev/null +++ b/test/Tests/csrc/self/expressions/pointers.c @@ -0,0 +1,33 @@ +// pointers test + +int printf(); +int exit(); +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:expressions/pointers test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:expressions/pointers test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int main() +{ + printf(">>>> tests: expressions/pointers\n"); + test_num = 1; + assert(42, ({ int a = 42; int* b = &a; *b; }), "({ int a = 42; int* b = &a; *b; })"); + assert(42, ({ int a = 42; *&a; }), "({ int a = 42; *&a; })"); + assert(42, ({ int a = 42; int* b = &a; int** c = &b; **c; }), "({ int a = 42; int* b = &a; int** c = &b; **c; })"); + assert(84, ({ int a = 42; int* b = &a; *b = a * 2; a; }), "({ int a = 42; int* b = &a; *b = a * 2; a; })"); + assert(42, ({ int a = 42; int b = 5; *(&b+1); }), "({ int a = 42; int b = 5; *(&b+1); })"); + assert(53, ({ int a = 42; int b = 5; *(&a-1) = 53; b; }), "({ int a = 42; int b = 5; *(&a-1) = 53; b; })"); + assert(53, ({ int a = 42; int b = 5; *(&b+1) = 53; a; }), "({ int a = 42; int b = 5; *(&b+1) = 53; a; })"); + + printf("All tests are passed!\n"); + return 0; +} diff --git a/test/Tests/csrc/self/statements/for.c b/test/Tests/csrc/self/statements/for.c index a414686..ea13409 100644 --- a/test/Tests/csrc/self/statements/for.c +++ b/test/Tests/csrc/self/statements/for.c @@ -38,6 +38,9 @@ int main() assert(2, ({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[2]; }), "({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[2]; })"); assert(42, ({ int i = 42; for (int i = 0; i < 10; ++i); i; }), "({ int i = 42; for (int i = 0; i < 10; ++i); i; })"); assert(42, ({ int i = 42; for (auto int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; }), "for (int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; })"); + assert(3, ({ int i = 0; for (; i < 10; ++i) { if (i == 3) break; } i; }), "({ int i = 0; for (; i < 10; ++i) { if (i == 3) break; } i; })"); + assert(3, ({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; }), "({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; })"); + assert(42, ({ int i = 42; for (int i = 0; i < 10; ++i); i; }), "({ int i = 42; for (int i = 0; i < 10; ++i); i; })"); printf("All tests are passed!\n"); diff --git a/test/Tests/csrc/self/statements/func.c b/test/Tests/csrc/self/statements/func.c index 2bd461f..26baa56 100644 --- a/test/Tests/csrc/self/statements/func.c +++ b/test/Tests/csrc/self/statements/func.c @@ -16,15 +16,24 @@ int assert(long expected, long actual, char* code) } } +int f() { return 42; } +int add(int x, int y) { return x + y; } void swap(int* a, int* b) { *a ^= *b; *b ^= *a; *a ^= *b; } void void_fn(int* a) { *a = 42; return; *a = 53; } int param_decay(int ar[]) { return ar[0]; } +int rec(int a) { if (a == 0) return 42; return rec(a - 1); } +int fib(int n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } int main() { printf(">>>> tests: statements/func\n"); test_num = 1; + assert(42, f(), "f()"); + assert(45, f() + 3, "f() + 3"); + assert(3, add(1, 2), "add(1, 2)"); + assert(44, ({ int b = rec(2); b + 2; }), "({ int b = rec(2); b + 2; })"); + assert(8, fib(5), "fib(5)"); // fibonacci number assert(0, ({ int ar[] = { 0 }; param_decay(ar); }), "({ int ar[] = { 0 }; param_decay(ar); })"); assert(2, ({ int a = 1; int b = 2; swap(&a, &b); a; }), "({ int a = 1; int b = 2; swap(&a, &b); a; })"); assert(1, ({ int a = 1; int b = 2; swap(&a, &b); b; }), "({ int a = 1; int b = 2; swap(&a, &b); b; })"); diff --git a/test/Tests/csrc/self/statements/goto.c b/test/Tests/csrc/self/statements/goto.c new file mode 100644 index 0000000..332596b --- /dev/null +++ b/test/Tests/csrc/self/statements/goto.c @@ -0,0 +1,34 @@ +// This is a c compiler test file. This comment itself is a line comment test. +/* + * This comment is also a block comment test. + */ + +int printf(); +int exit(); +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:statements/goto test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:statements/goto test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int main() +{ + printf(">>>> tests: statements/goto\n"); + test_num = 1; + + assert(3, ({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; }), "({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; })"); + assert(2, ({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; }), "({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; })"); + assert(1, ({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; }), "({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; })"); + + printf("All tests are passed!\n"); + + return 0; +} diff --git a/test/Tests/csrc/self/statements/if.c b/test/Tests/csrc/self/statements/if.c new file mode 100644 index 0000000..53a0360 --- /dev/null +++ b/test/Tests/csrc/self/statements/if.c @@ -0,0 +1,41 @@ +// This is a c compiler test file. This comment itself is a line comment test. +/* + * This comment is also a block comment test. + */ + +int printf(); +int exit(); +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:statements/if test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:statements/if test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int main() +{ + printf(">>>> tests: statements/if\n"); + test_num = 1; + + assert(42, ({ int a = 0; if (1) { a = 42; } else { a = 53; } a; }), "({ int a = 0; if (1) { a = 42; } else { a = 53; } a; })"); + assert(53, ({ int a = 0; if (20*3-60) a = 42; else a = 53; a; }), "({ int a = 0; if (20*3-60) a = 42; else a = 53; a; })"); + assert(2, ({ int a = 1; int b = 2; if (a) a = b; else a = 42; a; }), "({ int a = 1; int b = 2; if (a) a = b; else a = 42; a; })"); + assert(53, ({ int a = 0; if (0) a = 42; else a = 53; a; }), "({ int a = 0; if (0) a = 42; else a = 53; a; })"); + assert(4, ({ int a = 0; int b = 2; if (a) a = b; else a = b * 2; a; }), "({ int a = 0; int b = 2; if (a) a = b; else a = b * 2; a; })"); + assert(1, ({ int a = 1; int b = 0; if (b) a = 42; if (0) a = 42; a; }), "({ int a = 1; int b = 0; if (b) a = 42; if (0) a = 42; a; })"); + assert(2, ({ int a = 1; int b = 2; if (a) if (b) a = b; else a = 53; else a = 24; a; }), "({ int a = 1; int b = 2; if (a) if (b) a = b; else a = 53; else a = 24; a; })"); + assert(2, ({ int a = 0; if (1) if (1) if (1) if (1) if (1) if (0) a = 1; else a = 2; else a = 3; else a = 4; else a = 5; else a = 6; else a = 7; a; }), "({ int a = 0; if (1) if (1) if (1) if (1) if (1) if (0) a = 1; else a = 2; else a = 3; else a = 4; else a = 5; else a = 6; else a = 7; a; })"); + assert(42, ({ int a = 0; if(1) if(1) a = 42; else a = 53; a; }), "({ int a = 0; if(1) if(1) a = 42; else a = 53; a; })"); + assert(0, ({ if(0); 0; }), "({ if(0); 0; })"); + + printf("All tests are passed!\n"); + + return 0; +} diff --git a/test/Tests/csrc/self/statements/switch.c b/test/Tests/csrc/self/statements/switch.c new file mode 100644 index 0000000..17dc392 --- /dev/null +++ b/test/Tests/csrc/self/statements/switch.c @@ -0,0 +1,41 @@ +// This is a c compiler test file. This comment itself is a line comment test. +/* + * This comment is also a block comment test. + */ + +int printf(); +int exit(); +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:statements/switch test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:statements/switch test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int main() +{ + printf(">>>> tests: statements/switch\n"); + test_num = 1; + + assert(42, ({ int i = 0; switch (0) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (0) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); + assert(43, ({ int i = 0; switch (1) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (1) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); + assert(44, ({ int i = 0; switch (2) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (2) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); + assert(42, ({ int i = 42; switch (3) { case 0: i = 5; break; case 1: i = 6; break; case 2: i = 7; break; } i; }), "({ int i = 42; switch (3) { case 0: i = 5; break; case 1: i = 6; break; case 2: i = 7; break; } i; })"); + assert(42, ({ int i = 0; switch (0) { case 0: i = 42; break; default: i = 43; } i; }), "({ int i = 0; switch (0) { case 0: i = 42; break; default: i = 43; } i; })"); + assert(43, ({ int i = 0; switch (1) { case 0: i = 42; break; default: i = 43; } i; }), "({ int i = 0; switch (0) { case 0: i = 42; break; default: i = 43; } i; })"); + assert(42, ({ int i = 0; switch (1) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; }), "({ int i = 0; switch (1) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; })"); + assert(0, ({ int i = 0; switch (3) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; }), "({ int i = 0; switch (3) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; })"); + assert(42, ({ int i = 40; switch (0) { case 0: ++i; case 1: ++i; } i; }), "({ int i = 40; switch (0) { case 0: ++i; case 1: ++i; } i; })"); + assert(41, ({ int i = 40; switch (i) { case 20 * 2: ++i; } i; }), "({ int i = 40; switch (i) { case 20 * 2: ++i; } i; })"); + + printf("All tests are passed!\n"); + + return 0; +} diff --git a/test/Tests/csrc/self/statements/while.c b/test/Tests/csrc/self/statements/while.c index ff67526..e7841ed 100644 --- a/test/Tests/csrc/self/statements/while.c +++ b/test/Tests/csrc/self/statements/while.c @@ -28,6 +28,8 @@ int main() assert(10, ({ int a = 1; while (a < 10) a = a + 1; a; }), "({{ int a = 1; while (a < 10) a = a + 1; a; })"); assert(31, ({ int a = 1; while (a < 10) a = a + 1; int b = 1; while (b < 20) b = b + 2; a + b; }), "({ int a = 1; while (a < 10) a = a + 1; int b = 1; while (b < 20) b = b + 2; a + b; })"); assert(0, ({ int a = 0; while (a); 0; }), "({ int a = 0; while (a); 0; })"); + assert(4, ({ int i = 0; while (1) { if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { if (i++ == 3) break; } i; })"); + assert(4, ({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; })"); printf("All tests are passed!\n"); diff --git a/test/Tests/csrc/self/test_core.c b/test/Tests/csrc/self/test_core.c index 3cda104..d27eec5 100644 --- a/test/Tests/csrc/self/test_core.c +++ b/test/Tests/csrc/self/test_core.c @@ -30,10 +30,7 @@ int assert(long expected, long actual, char* code) } } -int f() { return 42; } int add(int x, int y) { return x + y; } -int rec(int a) { if (a == 0) return 42; return rec(a - 1); } -int fib(int n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } int gg(int* p) { *p = 42; return 0; } int sum(int* p, int n) { int s = 0; for (int i = 0; i < n; i = i + 1) s = s + *(p + i); return s; } int sub3(int a, int b, int c) { return a - b - c; } @@ -45,85 +42,9 @@ static int static_fun() { return 42; }*/ int main() { test_num = 1; - assert(42, ({ int a = 42; a; }), "({ int a = 42; a; })"); - assert(42, ( { int a = 42; a; } ), "( { int a = 42; a; } )"); - assert(44, ({ int a = 42; int b = 2; a + b; }), "({ int a = 42; int b = 2; a + b; })"); - assert(20, ({ int a = 42; int b = 20; int c = 32; (a - c) * b / 10; }), "({ int a = 42; int b = 20; int c = 32; (a - c) * b / 10; })"); - assert(22, ({ int hoge = 42; int foo = 20; hoge - foo; }), "({ int hoge = 42; int foo = 20; hoge - foo; })"); - assert(14, ({ int a = 3; int b = 5 * 6 - 8; a + b / 2; }), "({ int a = 3; int b = 5 * 6 - 8; a + b / 2; })"); - assert(42, ({ int a = 0; if (1) { a = 42; } else { a = 53; } a; }), "({ int a = 0; if (1) { a = 42; } else { a = 53; } a; })"); - assert(53, ({ int a = 0; if (20*3-60) a = 42; else a = 53; a; }), "({ int a = 0; if (20*3-60) a = 42; else a = 53; a; })"); - assert(2, ({ int a = 1; int b = 2; if (a) a = b; else a = 42; a; }), "({ int a = 1; int b = 2; if (a) a = b; else a = 42; a; })"); - assert(53, ({ int a = 0; if (0) a = 42; else a = 53; a; }), "({ int a = 0; if (0) a = 42; else a = 53; a; })"); - assert(4, ({ int a = 0; int b = 2; if (a) a = b; else a = b * 2; a; }), "({ int a = 0; int b = 2; if (a) a = b; else a = b * 2; a; })"); - assert(1, ({ int a = 1; int b = 0; if (b) a = 42; if (0) a = 42; a; }), "({ int a = 1; int b = 0; if (b) a = 42; if (0) a = 42; a; })"); - assert(2, ({ int a = 1; int b = 2; if (a) if (b) a = b; else a = 53; else a = 24; a; }), "({ int a = 1; int b = 2; if (a) if (b) a = b; else a = 53; else a = 24; a; })"); - assert(2, ({ int a = 0; if (1) if (1) if (1) if (1) if (1) if (0) a = 1; else a = 2; else a = 3; else a = 4; else a = 5; else a = 6; else a = 7; a; }), "({ int a = 0; if (1) if (1) if (1) if (1) if (1) if (0) a = 1; else a = 2; else a = 3; else a = 4; else a = 5; else a = 6; else a = 7; a; })"); - assert(42, ({ int a = 0; if(1) if(1) a = 42; else a = 53; a; }), "({ int a = 0; if(1) if(1) a = 42; else a = 53; a; })"); - assert(0, ({ if(0); 0; }), "({ if(0); 0; })"); - assert(10, ({ int a = 1; while (a < 10) a = a + 1; a; }), "({{ int a = 1; while (a < 10) a = a + 1; a; })"); - assert(31, ({ int a = 1; while (a < 10) a = a + 1; int b = 1; while (b < 20) b = b + 2; a + b; }), "({ int a = 1; while (a < 10) a = a + 1; int b = 1; while (b < 20) b = b + 2; a + b; })"); - assert(0, ({ int a = 0; while (a); 0; }), "({ int a = 0; while (a); 0; })"); - assert(110, ({ int a = 0; int i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; a; }), "({ int a = 0; int i = 0; for (i = 1; i <= 10; i = i + 1) a = a + i * 2; a; })"); - assert(12, ({ int i = 0; for (; i <= 10;) i = i + 2; i; }), "({ int i = 0; for (; i <= 10;) i = i + 2; i; })"); - assert(0, ({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; a; }), "({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) if (a) a = 0; else a = 1; a; })"); - assert(0, ({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } a; }), "({ int a = 0; int i = 0; for (i = 0; i < 10; i = i + 1) { a = a + i; a = a - i; } a; })"); - assert(1, ({ int a = 1; int b = 1; a & b; }), "({ int a = 1; int b = 1; return a & b; })"); - assert(1, ({ int a = 42; int b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) a = 1; else a = 0; a; }), "({ int a = 42; int b = 53; a = a ^ b; b = b ^ a; a = a ^ b; if (a == 53) if (b == 42) a = 1; else a = 0; a; })"); - assert(1, 1 | 0, "1 | 0"); assert(3, ({ 1; {2;} 3; }), "({ 1; {2;} 3; })"); - assert(42, f(), "f()"); - assert(45, f() + 3, "f() + 3"); - assert(3, add(1, 2), "add(1, 2)"); - assert(44, ({ int b = rec(2); b + 2; }), "({ int b = rec(2); b + 2; })"); - assert(8, fib(5), "fib(5)"); // fibonacci number - assert(42, ({ int a = 42; int* b = &a; *b; }), "({ int a = 42; int* b = &a; *b; })"); - assert(42, ({ int a = 42; *&a; }), "({ int a = 42; *&a; })"); - assert(42, ({ int a = 42; int* b = &a; int** c = &b; **c; }), "({ int a = 42; int* b = &a; int** c = &b; **c; })"); - assert(84, ({ int a = 42; int* b = &a; *b = a * 2; a; }), "({ int a = 42; int* b = &a; *b = a * 2; a; })"); - assert(42, ({ int a = 42; int b = 5; *(&b+1); }), "({ int a = 42; int b = 5; *(&b+1); })"); - assert(53, ({ int a = 42; int b = 5; *(&a-1) = 53; b; }), "({ int a = 42; int b = 5; *(&a-1) = 53; b; })"); - assert(53, ({ int a = 42; int b = 5; *(&b+1) = 53; a; }), "({ int a = 42; int b = 5; *(&b+1) = 53; a; })"); assert(6, ({ int s = 0; int i = 1; for (; i < 4; i = i + 1) s = s + i; s; }), "({ int s = 0; int i = 1; for (; i < 4; i = i + 1) s = s + i; return s; })"); assert(3, ({ int a = 0; for(; a < 3; a = a + 1); a; }), "({ int a = 0; for(; a < 3; a = a + 1); a; })"); - assert(3, ({ int ar[2]; int* p = ar; *p = 3; *ar; }), "({ int ar[2]; int* p = ar; *p = 3; *ar; })"); - assert(3, ({ int ar[2]; int* p = ar; *(p + 1) = 3; *(ar + 1); }), "({ int ar[2]; int* p = ar; *(p + 1) = 3; *(ar + 1); })"); - assert(5, ({ int ar[2]; int* p = ar; *p = 2; *(p + 1) = 3; *ar + *(ar + 1); }), "({ int ar[2]; int* p = ar; *p = 2; *(p + 1) = 3; *ar + *(ar + 1); })"); - assert(1, ({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *ar; }), "({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *ar; })"); - assert(2, ({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *(ar + 1); }), "({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *(ar + 1); })"); - assert(3, ({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *(ar + 2); }), "({ int ar[3]; *ar = 1; *(ar + 1) = 2; *(ar + 2) = 3; *(ar + 2); })"); - assert(42, ({ int a = 0; gg(&a); a; }), "({ int a = 0; gg(&a); a; })"); - assert(45, ({ int ar[10]; int i = 0; for (; i < 10; i = i + 1) { *(ar + i) = i; } int s = 0; for (i = 0; i < 10; i = i + 1) { s = s + *(ar + i); } s; }), "({ int ar[10]; int i = 0; for (; i < 10; i = i + 1) { *(ar + i) = i; } int s = 0; for (i = 0; i < 10; i = i + 1) { s = s + *(ar + i); } s; })"); - assert(45, ({ int ar[10]; int i = 0; for (; i < 10; i = i + 1) *(ar + i) = i; sum(ar, 10); }), "({ int ar[10]; int i = 0; for (; i < 10; i = i + 1) *(ar + i) = i; sum(ar, 10); })"); - assert(9, ({ int ar[2][3]; int s = 0; int i = 0; for (; i < 2; i = i + 1) { int j = 0; for (; j < 3; j = j + 1) { *(*(ar + i) + j) = i + j; s = s + *(*(ar + i) + j); } } s; }), "({ int ar[2][3]; int s = 0; int i = 0; for (; i < 2; i = i + 1) { int j = 0; for (; j < 3; j = j + 1) { *(*(ar + i) + j) = i + j; s = s + *(*(ar + i) + j); } } s; })"); - assert(42, ({ int ar[2][3]; int* p = ar; *p = 42; **ar; }), "({ int ar[2][3]; int* p = ar; *p = 42; **ar; }"); - assert(42, ({ int ar[2][3]; int* p = ar; *(p + 1) = 42; *(*ar + 1); }), "({ int ar[2][3]; int* p = ar; *(p + 1) = 42; *(*ar + 1); })"); - assert(42, ({ int ar[2][3]; int* p = ar; *(p + 2) = 42; *(*ar + 2); }), "({ int ar[2][3]; int* p = ar; *(p + 2) = 42; *(*ar + 2); })"); - assert(42, ({ int ar[2][3]; int* p = ar; *(p + 3) = 42; **(ar + 1); }), "({ int ar[2][3]; int* p = ar; *(p + 3) = 42; **(ar + 1); })"); - assert(42, ({ int ar[2][3]; int* p = ar; *(p + 4) = 42; *(*(ar + 1) + 1); }), "({ int ar[2][3]; int* p = ar; *(p + 4) = 42; *(*(ar + 1) + 1); })"); - assert(42, ({ int ar[2][3]; int* p = ar; *(p + 5) = 42; *(*(ar + 1) + 2); }), "({ int ar[2][3]; int* p = ar; *(p + 5) = 42; *(*(ar + 1) + 2); })"); - assert(42, ({ int ar[2][3]; int* p = ar; *(p + 6) = 42; **(ar + 2); }), "({ int ar[2][3]; int* p = ar; *(p + 6) = 42; **(ar + 2); })"); - assert(0, ({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[0]; }), "({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[0]; })"); - assert(1, ({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[1]; }), "({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[1]; })"); - assert(2, ({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[2]; }), "({ int ar[3]; int i = 0; for (; i < 3; i = i + 1) ar[i] = i; ar[2]; })"); - assert(42, ({ int ar[2][3]; int* p = ar; p[0] = 42; ar[0][0]; }), "({ int ar[2][3]; int* p = ar; p[0] = 42; ar[0][0]; })"); - assert(42, ({ int ar[2][3]; int* p = ar; p[1] = 42; ar[0][1]; }), "({ int ar[2][3]; int* p = ar; p[1] = 42; ar[0][1]; })"); - assert(42, ({ int ar[2][3]; int* p = ar; p[2] = 42; ar[0][2]; }), "({ int ar[2][3]; int* p = ar; p[2] = 42; ar[0][2]; })"); - assert(42, ({ int ar[2][3]; int* p = ar; p[3] = 42; ar[1][0]; }), "({ int ar[2][3]; int* p = ar; p[3] = 42; ar[1][0]; })"); - assert(42, ({ int ar[2][3]; int* p = ar; p[4] = 42; ar[1][1]; }), "({ int ar[2][3]; int* p = ar; p[4] = 42; ar[1][1]; })"); - assert(42, ({ int ar[2][3]; int* p = ar; p[5] = 42; ar[1][2]; }), "({ int ar[2][3]; int* p = ar; p[5] = 42; ar[1][2]; })"); - assert(42, ({ int ar[2][3]; int* p = ar; p[6] = 42; ar[2][0]; }), "({ int ar[2][3]; int* p = ar; p[6] = 42; ar[2][0]; })"); - assert(4, ({ int a; sizeof(a); }), "({ int a; sizeof(a); })"); - assert(4, ({ int a; sizeof a; }), "({ int a; sizeof a; })"); - assert(8, ({ int* p; sizeof p; }), "({ int* p; sizeof p; })"); - assert(3 * 4, ({ int ar[3]; sizeof ar; }), "({ int ar[3]; sizeof ar; })"); - assert(3 * 5 * 4, ({int ar[3][5]; sizeof ar; }), "({int ar[3][5]; return sizeof ar; })"); - assert(5 * 4, ({ int ar[3][5]; sizeof *ar; }), "({ int ar[3][5]; sizeof *ar; })"); - assert(4, ({ int ar[3][5]; sizeof **ar; }), "({ int ar[3][5]; sizeof **ar; })"); - assert(4 + 1, ({ int ar[3][5]; sizeof(**ar) + 1; }), "({ int ar[3][5]; sizeof(**ar) + 1; })"); - assert(4 + 1, ({ int ar[3][5]; sizeof **ar + 1; }), "({ int ar[3][5]; return sizeof **ar + 1; })"); - assert(8, ({ int ar[3][5]; sizeof(**ar + 1); }), "({ int ar[3][5]; sizeof(**ar + 1); })"); - assert(42, ({ int ar[2]; 2[ar] = 42; ar[2]; }), "({ int ar[2]; 2[ar] = 42; ar[2]; })"); assert(0, g, "g"); assert(42, ({ g = 42; g; }), "({ g = 42; g; })"); assert(1, ({ int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; gr[0]; }), "({ int i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; gr[0]; })"); @@ -133,12 +54,9 @@ int main() assert(1, ({ char c1 = 1; char c2 = 2; c1; }), "({ char c1 = 1; char c2 = 2; c1; })"); assert(2, ({ char c1 = 1; char c2 = 2; c2; }), "({ char c1 = 1; char c2 = 2; c2; })"); assert(1, ({ char x; sizeof x; }), "({ char x; sizeof x; })"); - assert(10, ({ char ar[10]; sizeof ar; }), "({ char ar[10]; return sizeof ar; })"); assert(1, sub3(7, 3, 3), "sub3(7, 3, 3)"); - assert(92, "\\"[0], "a"); assert(42, ({ int a = 42; { int a = 32; } a; }), "({ int a = 42; { int a = 32; } a; })"); assert(32, ({ int a = 42; { a = 32; } a; }), "({ int a = 42; { a = 32; } a; })"); - assert(2, ({ int ar[5]; int* p = ar + 2; p - ar; }), "({ int ar[5]; int* p = ar + 2; p - ar; })"); /*assert(1, ({ struct { int a; int b; } x; x.a = 1; x.b = 2; x.a; }), "({ struct { int a; int b; } x; x.a = 1; x.b = 2; x.a; })"); assert(2, ({ struct { int a; int b; } x; x.a = 1; x.b = 2; x.b; }), "({ struct { int a; int b; } x; x.a = 1; x.b = 2; x.b; })"); assert(1, ({ struct { char a; int b; char c; } x; x.a = 1; x.b = 2; x.c = 3; x.a; }), "({ struct { char a; int b; char c; } x; x.a = 1; x.b = 2; x.c = 3; x.a; })"); @@ -241,9 +159,7 @@ int main() assert(0, (long)&*(int *)0, "(long)&*(int *)0"); assert(42, ({ int a = 42 ; long b = (long)&a; *(int*)b; }), "int a = 42; long b = (long)&a; *(int*)b"); assert(2147483648, ({ int a = 2147483647; long b = a + 1; b; }), " ({ int a = 2147483647; long b = a + 1; b; })");*/ - assert(97, 'a', "'a'"); - assert(10, '\n', "\'\\n\'");/* - assert(0, ({ enum { zero, one, two }; zero; }), "enum { zero, one, two }; zero;"); + /*assert(0, ({ enum { zero, one, two }; zero; }), "enum { zero, one, two }; zero;"); assert(1, ({ enum { zero, one, two }; one; }), "enum { zero, one, two }; one;"); assert(2, ({ enum { zero, one, two }; two; }), "enum { zero, one, two }; two;"); assert(5, ({ enum { five = 5, six, seven }; five; }), "enum { five = 5, six, seven }; five;"); @@ -288,84 +204,13 @@ int main() assert(42, ({ register struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; }), "({ register struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; })"); assert(42, ({ auto struct { int x; } x; x.x = 42; x.x; }), "({ auto struct { int x; } x; x.x = 42; x.x; })"); assert(42, ({ auto struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; }), "({ register struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; })");*/ - assert(42, ({ int i = 42; for (int i = 0; i < 10; ++i); i; }), "({ int i = 42; for (int i = 0; i < 10; ++i); i; })"); /*assert(42, ({ int i = 42; for (auto int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; }), "for (int i = ({ int i = 0; for (; i < 10; ++i); i; }); i > 0; --i); i; })"); assert(42, ({ for (struct { int x; } x; 0;); 42; }), "({ for (struct { int x; } x; 0;); 42; })");*/ - assert(511, 0777, "0777"); - assert(0, 0x0, "0x0"); - assert(10, 0xa, "0xa"); - assert(10, 0Xa, "0Xa"); - assert(48879, 0xbeef, "0xbeef"); - assert(48879, 0xBEEF, "0xBEEF"); - /*assert(0, 0b0, "0b0"); - assert(1, 0b1, "0b1"); - assert(42, 0b101010, "0b101010"); - assert(42, 0B101010, "0B101010");*/ - assert(49389, 0xc0ed, "0xc0ed"); - assert(49389, 0xC0eD, "0xC0eD"); + /*assert(4, ({ struct X *a; struct X { int x; }; sizeof(struct X); }), " ({ struct X *a; struct X { int x; }; sizeof(struct X); })"); assert(42, ({ struct X { struct X* next; int x; } a; struct X b; b.x = 42; a.next = &b; a.next->x; }), "({ struct X { struct X* next; int x; } a; struct X b; b.x = 42; a.next = &b; a.next->x; })");*/ - assert(3, ({ int i = 0; for (; i < 10; ++i) { if (i == 3) break; } i; }), "({ int i = 0; for (; i < 10; ++i) { if (i == 3) break; } i; })"); - assert(3, ({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; }), "({ int i = 0; for (; i < 10; ++i) { for (;;) break; if (i == 3) break; } i; })"); - assert(4, ({ int i = 0; while (1) { if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { if (i++ == 3) break; } i; })"); - assert(4, ({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; }), "({ int i = 0; while (1) { for (;;) break; if (i++ == 3) break; } i; })"); - assert(3, ({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; }), "({ int i = 0; goto a; a: ++i; b: ++i; c: ++i; i; })"); - assert(2, ({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; }), "({ int i = 0; goto e; d: ++i; e: ++i; f: ++i; i; })"); - assert(1, ({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; }), "({ int i = 0; goto i; g: ++i; h: ++i; i: ++i; i; })"); - assert(42, ({ int i = 0; switch (0) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (0) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); - assert(43, ({ int i = 0; switch (1) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (1) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); - assert(44, ({ int i = 0; switch (2) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; }), "({ int i = 0; switch (2) { case 0: i = 42; break; case 1: i = 43; break; case 2: i = 44; break; } i; })"); - assert(42, ({ int i = 42; switch (3) { case 0: i = 5; break; case 1: i = 6; break; case 2: i = 7; break; } i; }), "({ int i = 42; switch (3) { case 0: i = 5; break; case 1: i = 6; break; case 2: i = 7; break; } i; })"); - assert(42, ({ int i = 0; switch (0) { case 0: i = 42; break; default: i = 43; } i; }), "({ int i = 0; switch (0) { case 0: i = 42; break; default: i = 43; } i; })"); - assert(43, ({ int i = 0; switch (1) { case 0: i = 42; break; default: i = 43; } i; }), "({ int i = 0; switch (0) { case 0: i = 42; break; default: i = 43; } i; })"); - assert(42, ({ int i = 0; switch (1) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; }), "({ int i = 0; switch (1) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; })"); - assert(0, ({ int i = 0; switch (3) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; }), "({ int i = 0; switch (3) { case 0: 0; case 1: 0; case 2: 0; i = 42; } i; })"); - assert(42, ({ int i = 40; switch (0) { case 0: ++i; case 1: ++i; } i; }), "({ int i = 40; switch (0) { case 0: ++i; case 1: ++i; } i; })"); - assert(41, ({ int i = 40; switch (i) { case 20 * 2: ++i; } i; }), "({ int i = 40; switch (i) { case 20 * 2: ++i; } i; })"); //assert(0, ({ int ar[]; 0; }), "({ int ar[]; 0; })"); - assert(42, ({ int ar[1] = { 42 }; ar[0]; }), "({ int ar[1] = { 42 }; ar[0]; })"); - assert(1, ({ int ar[3] = { 1, 2, 3 }; ar[0]; }), "({ int ar[3] = { 1, 2, 3 }; ar[0]; })"); - assert(2, ({ int ar[3] = { 1, 2, 3 }; ar[1]; }), "({ int ar[3] = { 1, 2, 3 }; ar[1]; })"); - assert(3, ({ int ar[3] = { 1, 2, 3 }; ar[2]; }), "({ int ar[3] = { 1, 2, 3 }; ar[2]; })"); - assert(2, ({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[0][1]; }), "({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[0][1]; })"); - assert(4, ({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][0]; }), "({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][0]; })"); - assert(6, ({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][2]; }), "({ int ar[2][3] = { { 1, 2, 3 }, { 4, 5, 6 }}; ar[1][2]; })"); - assert(1, ({ int a = 0; int ar[2] = { a = 1 }; ar[0]; }), "({ int a = 0; int ar[2] = { a = 1 }; ar[0]; })"); - assert(1, ({ int a = 0; int ar[2] = { a = 1 }; a; }), "({ int a = 0; int ar[2] = { a = 1 }; a; })"); - assert(0, ({ int ar[3] = {}; ar[0]; }), "({ int ar[3] = {}; ar[0]; })"); - assert(0, ({ int ar[3] = {}; ar[1]; }), "({ int ar[3] = {}; ar[1]; })"); - assert(0, ({ int ar[3] = {}; ar[2]; }), "({ int ar[3] = {}; ar[2]; })"); - assert(0, ({ int ar[3][2] = {}; ar[0][0]; }), "({ int ar[3][2] = {}; ar[0][0]; })"); - assert(0, ({ int ar[3][2] = {}; ar[0][1]; }), "({ int ar[3][2] = {}; ar[0][1]; })"); - assert(0, ({ int ar[3][2] = {}; ar[1][0]; }), "({ int ar[3][2] = {}; ar[1][0]; })"); - assert(0, ({ int ar[3][2] = {}; ar[1][1]; }), "({ int ar[3][2] = {}; ar[1][1]; })"); - assert(0, ({ int ar[3][2] = {}; ar[2][0]; }), "({ int ar[3][2] = {}; ar[2][0]; })"); - assert(0, ({ int ar[3][2] = {}; ar[2][1]; }), "({ int ar[3][2] = {}; ar[2][1]; })"); - assert(2, ({ int ar[2][3] = { { 42, 2 } }; ar[0][1]; }), "({ int ar[2][3] = { { 42, 2 } }; ar[0][1]; })"); - assert(0, ({ int ar[2][3] = { { 42, 2 } }; ar[1][0]; }), "({ int ar[2][3] = { { 42, 2 } }; ar[1][0]; })"); - assert(0, ({ int ar[2][3] = { { 42, 2 } }; ar[1][2]; }), "({ int ar[2][3] = { { 42, 2 } }; ar[1][2]; })"); - assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[0][0]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[0][0]; })"); - assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[0][1]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[0][1]; })"); - assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[1][0]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[1][0]; })"); - assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[1][1]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[1][1]; })"); - assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[2][0]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[2][0]; })"); - assert(0, ({ int ar[3][2] = { {}, {}, {} }; ar[2][1]; }), "({ int ar[3][2] = { {}, {}, {} }; ar[2][1]; })"); - assert(0, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][0]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][0]; })"); - assert(0, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][1]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[0][1]; })"); - assert(0, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[1][0]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[1][0]; })"); - assert(0, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[1][1]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[1][1]; })"); - assert(1, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[2][0]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[2][0]; })"); - assert(2, ({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[2][1]; }), "({ int ar[3][2] = { {}, {}, { 1, 2 } }; ar[2][1]; })"); - assert(1, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][0]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][0]; })"); - assert(2, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][1]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][1]; })"); - assert(3, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][2]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[0][2]; })"); - assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][0]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][0]; })"); - assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; })"); - assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; })"); - assert(0, ({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; }), "({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; })");/* - assert(3, ({ int ar[] = { 0, 1, 2, 3 }; ar[3]; }), "({ int ar[] = { 0, 1, 2, 3 }; ar[3]; })"); - assert(16, ({ int ar[] = { 0, 1, 2, 3 }; sizeof ar; }), "({ int ar[] = { 0, 1, 2, 3 }; sizeof ar; })"); - assert(1, ({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.a; }), "({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.a; })"); + /*assert(1, ({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.a; }), "({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.a; })"); assert(2, ({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.b; }), "({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.b; })"); assert(3, ({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.c; }), "({ struct { int a; int b; int c; } x = { 1, 2, 3 }; x.c; })"); assert(1, ({ struct { int a; int b; int c; } x = { 1 }; x.a; }), "({ struct { int a; int b; int c; } x = { 1 }; x.a; })"); From 25041d18a7d0bd687d6e0c7501eae79fdc605673 Mon Sep 17 00:00:00 2001 From: roki Date: Wed, 13 Jan 2021 04:29:01 +0900 Subject: [PATCH 43/51] Add warning text management --- app/Main.hs | 12 +- htcc.cabal | 14 +- src/Htcc/Asm/Generate.hs | 90 +--- src/Htcc/Asm/Generate/Core.hs | 45 +- src/Htcc/CRules/Types/TypeKind.hs | 8 +- src/Htcc/Parser.hs | 4 +- src/Htcc/Parser/AST.hs | 2 - src/Htcc/Parser/AST/Type.hs | 6 +- src/Htcc/Parser/AST/Var.hs | 16 - src/Htcc/Parser/AST/Var/Init.hs | 182 -------- src/Htcc/Parser/Combinators.hs | 4 +- src/Htcc/Parser/Combinators/Core.hs | 31 +- src/Htcc/Parser/Combinators/ParserType.hs | 42 ++ .../Parser/Combinators/ParserType.hs-boot | 21 + src/Htcc/Parser/Combinators/Program.hs | 94 ++-- src/Htcc/Parser/Combinators/Type.hs | 32 +- src/Htcc/Parser/Combinators/Utils.hs | 32 +- src/Htcc/Parser/Combinators/Var.hs | 53 +-- src/Htcc/Parser/ConstructionData.hs | 16 - src/Htcc/Parser/ConstructionData/Core.hs | 25 +- src/Htcc/Parser/ConstructionData/Core.hs-boot | 16 + src/Htcc/Parser/Parsing.hs | 16 - src/Htcc/Parser/Parsing/Core.hs | 435 ------------------ src/Htcc/Parser/Parsing/Core.hs-boot | 12 - src/Htcc/Parser/Parsing/Global.hs | 40 -- src/Htcc/Parser/Parsing/Global.hs-boot | 8 - src/Htcc/Parser/Parsing/Global/Function.hs | 80 ---- src/Htcc/Parser/Parsing/Global/Var.hs | 68 --- src/Htcc/Parser/Parsing/StmtExpr.hs | 54 --- src/Htcc/Parser/Parsing/Type.hs | 278 ----------- src/Htcc/Parser/Parsing/Typedef.hs | 44 -- .../ComponentsTests/Parser/Combinators.hs | 1 - 32 files changed, 290 insertions(+), 1491 deletions(-) delete mode 100644 src/Htcc/Parser/AST/Var.hs delete mode 100644 src/Htcc/Parser/AST/Var/Init.hs create mode 100644 src/Htcc/Parser/Combinators/ParserType.hs create mode 100644 src/Htcc/Parser/Combinators/ParserType.hs-boot delete mode 100644 src/Htcc/Parser/ConstructionData.hs create mode 100644 src/Htcc/Parser/ConstructionData/Core.hs-boot delete mode 100644 src/Htcc/Parser/Parsing.hs delete mode 100644 src/Htcc/Parser/Parsing/Core.hs delete mode 100644 src/Htcc/Parser/Parsing/Core.hs-boot delete mode 100644 src/Htcc/Parser/Parsing/Global.hs delete mode 100644 src/Htcc/Parser/Parsing/Global.hs-boot delete mode 100644 src/Htcc/Parser/Parsing/Global/Function.hs delete mode 100644 src/Htcc/Parser/Parsing/Global/Var.hs delete mode 100644 src/Htcc/Parser/Parsing/StmtExpr.hs delete mode 100644 src/Htcc/Parser/Parsing/Type.hs delete mode 100644 src/Htcc/Parser/Parsing/Typedef.hs diff --git a/app/Main.hs b/app/Main.hs index bde4ec3..2953cb6 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,6 +2,7 @@ module Main where import Control.Monad (forM_) +import Data.Foldable (toList) import qualified Data.Text.IO as T import Data.Version (showVersion) import Development.GitRev (gitHash) @@ -10,13 +11,14 @@ import qualified Paths_htcc as P import qualified Data.Text as T import Data.Void -import Htcc.Asm.Generate (casm') +import Htcc.Asm (casm') import qualified Htcc.Asm.Intrinsic.Structure.Internal as SI import Htcc.Parser (ASTs) import Htcc.Parser.Combinators (parser, runParser) -import Htcc.Parser.ConstructionData (Warnings) +import Htcc.Parser.ConstructionData.Core (Warnings) import Htcc.Parser.ConstructionData.Scope.Var (GlobalVars, Literals) import Htcc.Utils +import System.IO (hPutStr, stderr) import qualified Text.Megaparsec as M data Opts = Opts @@ -90,8 +92,10 @@ main = do forM_ (optInput opts) $ \fname -> do txt <- T.readFile fname case runParser parser fname txt - :: Either (M.ParseErrorBundle T.Text Void) (Warnings Integer, ASTs Integer, GlobalVars Integer, Literals Integer) of + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer) of Left x -> print x -- putStr $ M.errorBundlePretty x - Right r -> runAsm' $ casm' (snd4 r) (thd4 r) (fou4 r) + Right r -> do + mapM_ (hPutStr stderr . M.errorBundlePretty) $ toList $ fst4 r + runAsm' $ casm' (snd4 r) (thd4 r) (fou4 r) where runAsm' = SI.runAsm :: SI.Asm SI.AsmCodeCtx Integer a -> IO a diff --git a/htcc.cabal b/htcc.cabal index cc1b7e6..e3c07d2 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 2eed65682adb7b03154ede97ff35806be8a937984b5dfcb70a644b23832bf2a2 +-- hash: 000a21d18c160392985148fd3a5bec6cce2c82a00c364037c73e8a677952aa01 name: htcc version: 0.0.0.1 @@ -68,18 +68,16 @@ library Htcc.Parser.AST.Core Htcc.Parser.AST.DeduceKind Htcc.Parser.AST.Type - Htcc.Parser.AST.Var - Htcc.Parser.AST.Var.Init Htcc.Parser.Combinators Htcc.Parser.Combinators.BasicOperator Htcc.Parser.Combinators.Core Htcc.Parser.Combinators.GNUExtensions Htcc.Parser.Combinators.Keywords + Htcc.Parser.Combinators.ParserType Htcc.Parser.Combinators.Program Htcc.Parser.Combinators.Type Htcc.Parser.Combinators.Utils Htcc.Parser.Combinators.Var - Htcc.Parser.ConstructionData Htcc.Parser.ConstructionData.Core Htcc.Parser.ConstructionData.Scope Htcc.Parser.ConstructionData.Scope.Enumerator @@ -89,14 +87,6 @@ library Htcc.Parser.ConstructionData.Scope.Typedef Htcc.Parser.ConstructionData.Scope.Utils Htcc.Parser.ConstructionData.Scope.Var - Htcc.Parser.Parsing - Htcc.Parser.Parsing.Core - Htcc.Parser.Parsing.Global - Htcc.Parser.Parsing.Global.Function - Htcc.Parser.Parsing.Global.Var - Htcc.Parser.Parsing.StmtExpr - Htcc.Parser.Parsing.Type - Htcc.Parser.Parsing.Typedef Htcc.Parser.Utils Htcc.Parser.Utils.Core Htcc.Tokenizer diff --git a/src/Htcc/Asm/Generate.hs b/src/Htcc/Asm/Generate.hs index d73a5b4..404d3d3 100644 --- a/src/Htcc/Asm/Generate.hs +++ b/src/Htcc/Asm/Generate.hs @@ -13,41 +13,17 @@ The executable module for compilation module Htcc.Asm.Generate ( InputCCode, -- * Generator - casm', - buildAST, - execAST + casm' ) where -import Control.Monad (unless, (>=>)) -import Data.Bits (Bits) -import Data.Foldable (toList) -import qualified Data.Sequence as S -import qualified Data.Text as T -import System.Exit (exitFailure) -import Text.PrettyPrint.ANSI.Leijen (Doc, blue, - bold, char, - empty, - magenta, red, - text, (<+>)) - -import Htcc.Parser (ASTResult, - ASTs, parse) -import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) -import Htcc.Parser.ConstructionData.Scope.Var (GlobalVars, - Literals) -import qualified Htcc.Tokenizer as HT - +import qualified Data.Text as T import Htcc.Asm.Generate.Core import Htcc.Asm.Intrinsic.Operand -import qualified Htcc.Asm.Intrinsic.Structure as SI -import qualified Htcc.Asm.Intrinsic.Structure.Section.Text as IT - -import Htcc.Utils (dropFst4, - putDocErr, - putDocLnErr, - putStrErr, - putStrLnErr, - toInts, tshow) +import qualified Htcc.Asm.Intrinsic.Structure as SI +import qualified Htcc.Asm.Intrinsic.Structure.Section.Text as IT +import Htcc.Parser (ASTs) +import Htcc.Parser.ConstructionData.Scope.Var (GlobalVars, + Literals) -- | input string, C source code type InputCCode = T.Text @@ -59,54 +35,12 @@ instance Show MessageType where show ErrorMessage = "error" show WarningMessage = "warning" -{-# INLINE messageColor #-} -messageColor :: MessageType -> Doc -> Doc -messageColor ErrorMessage = red -messageColor WarningMessage = magenta - -{-# INLINE repSpace #-} -repSpace :: Integral i => i -> MessageType -> IO () -repSpace i mest = do - mapM_ (putStrErr . T.pack . flip replicate ' ' . pred) $ toInts i - putDocErr $ messageColor mest $ char '^' - -{-# INLINE format #-} -format :: T.Text -> Int -> InputCCode -> IO () -format errMesPre e xs = do - putDocErr $ blue (text $ T.unpack errMesPre) <+> blue (char '|') <+> empty - putStrLnErr (T.lines xs !! max 0 (fromIntegral e)) - putStrErr $ T.replicate (T.length errMesPre) " " - putDocErr $ empty <+> blue (char '|') <+> empty - -parsedMessage :: (Integral i, Show i) => MessageType -> FilePath -> InputCCode -> ASTError i -> IO () -parsedMessage mest fpath xs (s, (i, etk)) = do - putDocLnErr $ - bold (text fpath) <> bold (char ':') <> - bold (text (show i)) <> bold (char ':') <+> - messageColor mest (text $ show mest) <> messageColor mest (char ':') <+> - text (T.unpack s) - format (T.replicate 4 " " <> tshow (HT.tkLn i)) (pred $ fromIntegral $ HT.tkLn i) xs - repSpace (HT.tkCn i) mest - putDocLnErr $ messageColor mest (text $ replicate (pred $ HT.length etk) '~') - --- | the function to output error message -parsedErrExit :: (Integral i, Show i) => FilePath -> InputCCode -> ASTError i -> IO () -parsedErrExit fpath ccode err = parsedMessage ErrorMessage fpath ccode err >> exitFailure - --- | the function to output warning message -parsedWarn :: (Integral i, Show i) => FilePath -> InputCCode -> S.Seq (ASTError i) -> IO () -parsedWarn fpath xs warns = mapM_ (parsedMessage WarningMessage fpath xs) (toList warns) - -- | Executor that receives information about the constructed AST, -- global variables, and literals and composes assembly code -casm' :: (Integral e, Show e, Integral i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) => ASTs i -> GlobalVars i -> Literals i -> SI.Asm SI.AsmCodeCtx e () +casm' :: (Integral e, Show e, Integral i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) + => ASTs i + -> GlobalVars i + -> Literals i + -> SI.Asm SI.AsmCodeCtx e () casm' atl gvars lits = dataSection gvars lits >> textSection atl --- | Build AST from string of C source code -buildAST :: (Integral i, Read i, Show i, Bits i) => InputCCode -> ASTResult i -buildAST = HT.tokenize >=> parse - --- | Print warning or error message if building AST from string of C source code has some problems -execAST :: (Integral i, Read i, Show i, Bits i) => Bool -> FilePath -> InputCCode -> IO (Maybe (ASTs i, GlobalVars i, Literals i)) -execAST supWarns fpath ccode = flip (either ((<$) Nothing . parsedErrExit fpath ccode)) (buildAST ccode) $ \xs@(warns, _, _, _) -> - Just (dropFst4 xs) <$ unless supWarns (parsedWarn fpath ccode warns) diff --git a/src/Htcc/Asm/Generate/Core.hs b/src/Htcc/Asm/Generate/Core.hs index c453a12..e0f5752 100644 --- a/src/Htcc/Asm/Generate/Core.hs +++ b/src/Htcc/Asm/Generate/Core.hs @@ -9,23 +9,33 @@ Portability : POSIX The modules of intrinsic (x86_64) assembly -} -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-} module Htcc.Asm.Generate.Core ( dataSection, textSection, ) where -import Control.Monad (forM_, unless, when, zipWithM_) +import Control.Monad (forM_, unless, when, + zipWithM_) import Control.Monad.Finally (MonadFinally (..)) -import Prelude hiding (truncate) import Data.Int (Int32) import Data.IORef (readIORef) import Data.List (find) import qualified Data.Map as M import Data.Maybe (fromJust, isJust) +import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.IO as T +import Prelude hiding (truncate) +import Data.List (foldl') +import Data.Tuple.Extra (dupe, first, second) +import Htcc.Asm.Intrinsic.Operand +import Htcc.Asm.Intrinsic.Register +import qualified Htcc.Asm.Intrinsic.Structure as SI +import qualified Htcc.Asm.Intrinsic.Structure.Section.Data as ID +import qualified Htcc.Asm.Intrinsic.Structure.Section.Text as IT +import qualified Htcc.CRules.Types as CR import Htcc.Parser (ATKind (..), ATree (..), fromATKindFor, @@ -33,16 +43,27 @@ import Htcc.Parser (ATKind (..), isATForIncr, isATForInit, isATForStmt, - isComplexAssign, - stackSize) + isComplexAssign) import Htcc.Parser.ConstructionData.Scope.Var as PV -import Htcc.Asm.Intrinsic.Operand -import Htcc.Asm.Intrinsic.Register -import qualified Htcc.Asm.Intrinsic.Structure as SI -import qualified Htcc.Asm.Intrinsic.Structure.Section.Data as ID -import qualified Htcc.Asm.Intrinsic.Structure.Section.Text as IT -import Htcc.Utils (err, maybe', splitAtLen, tshow) -import qualified Htcc.CRules.Types as CR +import Htcc.Utils (err, maybe', + splitAtLen, + toNatural, tshow) +import Numeric.Natural + +stackSize :: (Show i, Integral i) => ATree i -> Natural +stackSize (ATNode (ATDefFunc _ args) _ body _) = let ms = f body $ maybe S.empty (foldr (\(ATNode (ATLVar t x) _ _ _) acc -> S.insert (t, x) acc) S.empty) args in + if S.size ms == 1 then toNatural $ flip CR.alignas 8 $ toInteger $ CR.sizeof $ fst $ head (S.toList ms) else toNatural $ flip CR.alignas 8 $ uncurry (+) $ + first (toInteger . CR.sizeof . fst) $ second (fromIntegral . snd) $ dupe $ foldl' (\acc x -> if snd acc < snd x then x else acc) (CR.SCUndef CR.CTUndef, 0) $ S.toList ms + where + f ATEmpty !s = s + f (ATNode (ATCallFunc _ (Just arg)) t l r) !s = f (ATNode (ATBlock arg) t l r) s + f (ATNode (ATLVar t x) _ l r) !s = let i = S.insert (t, x) s in f l i `S.union` f r i + f (ATNode (ATBlock xs) _ l r) !s = let i = foldr (S.union . (`f` s)) s xs in f l i `S.union` f r i + f (ATNode (ATStmtExpr xs) t l r) !s = f (ATNode (ATBlock xs) t l r) s + f (ATNode (ATFor xs) _ l r) !s = let i = foldr (S.union . flip f s . fromATKindFor) S.empty xs in f l i `S.union` f r i + f (ATNode (ATNull x) _ _ _) !s = f x s + f (ATNode _ _ l r) !s = f l s `S.union` f r s +stackSize _ = 0 {-# INLINE prologue #-} prologue :: Integral i => i -> SI.Asm IT.TextLabelCtx e () diff --git a/src/Htcc/CRules/Types/TypeKind.hs b/src/Htcc/CRules/Types/TypeKind.hs index bd97a21..8260364 100644 --- a/src/Htcc/CRules/Types/TypeKind.hs +++ b/src/Htcc/CRules/Types/TypeKind.hs @@ -391,11 +391,11 @@ instance TypeKindBase TypeKind where isArray = lor [isCTArray, isIncompleteArray] {-# INLINE isIntegral #-} - isIntegral CTInt = True + isIntegral CTInt = True isIntegral (CTSigned x) = isIntegral x - isIntegral (CTLong x) = isIntegral x - isIntegral (CTShort x) = isIntegral x - isIntegral _ = False + isIntegral (CTLong x) = isIntegral x + isIntegral (CTShort x) = isIntegral x + isIntegral _ = False {-# INLINE isCTStruct #-} isCTStruct (CTStruct _) = True diff --git a/src/Htcc/Parser.hs b/src/Htcc/Parser.hs index 970f480..5204b44 100644 --- a/src/Htcc/Parser.hs +++ b/src/Htcc/Parser.hs @@ -10,9 +10,7 @@ Portability : POSIX Parsing and constructing AST from string -} module Htcc.Parser ( - module Htcc.Parser.AST, - module Htcc.Parser.Parsing + module Htcc.Parser.AST ) where import Htcc.Parser.AST -import Htcc.Parser.Parsing diff --git a/src/Htcc/Parser/AST.hs b/src/Htcc/Parser/AST.hs index 6d6ee15..febf3d3 100644 --- a/src/Htcc/Parser/AST.hs +++ b/src/Htcc/Parser/AST.hs @@ -13,10 +13,8 @@ module Htcc.Parser.AST ( module Htcc.Parser.AST.Core, module Htcc.Parser.AST.Type, module Htcc.Parser.AST.DeduceKind, - module Htcc.Parser.AST.Var ) where import Htcc.Parser.AST.Core import Htcc.Parser.AST.DeduceKind import Htcc.Parser.AST.Type -import Htcc.Parser.AST.Var diff --git a/src/Htcc/Parser/AST/Type.hs b/src/Htcc/Parser/AST/Type.hs index 5abaf0c..da81377 100644 --- a/src/Htcc/Parser/AST/Type.hs +++ b/src/Htcc/Parser/AST/Type.hs @@ -18,8 +18,8 @@ module Htcc.Parser.AST.Type ( ) where import Htcc.Parser.AST.Core (ATree (..)) -import Htcc.Parser.ConstructionData.Core (ConstructionData, - Warnings) +import {-# SOURCE #-} Htcc.Parser.ConstructionData.Core (ConstructionData, + Warnings) import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) import qualified Htcc.Parser.ConstructionData.Scope.Var as PV import qualified Htcc.Tokenizer as HT @@ -35,7 +35,7 @@ type ASTConstruction i = Either (ASTError i) (ASTSuccess i) type ASTs i = [ATree i] -- | A type that represents the result after AST construction. Quadraple of warning list, constructed abstract syntax tree list, global variable map, literal list. -type ASTResult i = Either (ASTError i) (Warnings i, ASTs i, PV.GlobalVars i, PV.Literals i) +type ASTResult i = Either (ASTError i) (Warnings, ASTs i, PV.GlobalVars i, PV.Literals i) -- | The type synonym of ASTState type ASTState i r = CompilationState (ConstructionData i) [HT.TokenLC i] i r diff --git a/src/Htcc/Parser/AST/Var.hs b/src/Htcc/Parser/AST/Var.hs deleted file mode 100644 index ba98174..0000000 --- a/src/Htcc/Parser/AST/Var.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-| -Module : Htcc.Parser.AST.Var -Description : Data types and type synonyms used during AST construction -Copyright : (c) roki, 2019 -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -Data types and type synonyms used during AST construction --} -module Htcc.Parser.AST.Var ( - module Htcc.Parser.AST.Var.Init -) where - -import Htcc.Parser.AST.Var.Init diff --git a/src/Htcc/Parser/AST/Var/Init.hs b/src/Htcc/Parser/AST/Var/Init.hs deleted file mode 100644 index b4855fe..0000000 --- a/src/Htcc/Parser/AST/Var/Init.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings, TupleSections #-} -{-| -Module : Htcc.Parser.AST.Var.Init -Description : The C languge parser and AST constructor -Copyright : (c) roki, 2019 -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -The C languge parser and AST constructor --} -module Htcc.Parser.AST.Var.Init ( - Assign, - validAssign, - varInit -) where - -import Control.Conditional (ifM) -import Control.Monad (forM) -import Control.Monad.Fix (fix) -import Control.Monad.State (gets, put) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.State (evalStateT) -import Data.Bits (Bits) -import qualified Data.ByteString as B -import Data.Foldable (Foldable (..)) -import Data.List (isPrefixOf, - sortBy) -import qualified Data.Map.Strict as M -import Data.Maybe (fromJust, - fromMaybe, - isNothing) -import qualified Data.Sequence as SQ -import Data.Tuple.Extra (dupe, first, - second, snd3) -import Prelude hiding - (toInteger) -import Safe (headMay) - -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST.Core (ATKind (..), - ATree (..), - Treealizable (..), - atAssign, - atExprStmt, - atMemberAcc, - atNumLit, - atUnary) -import Htcc.Parser.AST.DeduceKind -import Htcc.Parser.AST.Type (ASTConstruction, - ASTState) -import Htcc.Parser.ConstructionData -import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) -import Htcc.Parser.ConstructionData.Scope.Utils (internalCE) -import Htcc.Parser.Utils -import qualified Htcc.Tokenizer as HT -import Htcc.Utils (dropSnd3, - fou4, fst4, - maybeToRight, - second3, snd4, - swap, thd4, - tshow) -import Htcc.Utils.CompilationState (isSatisfied, - itemCWhen) - -{-# INLINE validAssign #-} --- | Check for valid substitutions -validAssign :: Eq i => HT.TokenLC i -> ATree i -> Either (ASTError i) (ATree i) -validAssign errPlaceholder x@(ATNode _ t _ _) - | CT.toTypeKind t == CT.CTVoid = Left ("void value not ignored as it ought to be", errPlaceholder) - | otherwise = Right x -validAssign errPlaceholder _ = Left ("Expected to assign", errPlaceholder) - -desgNode :: (Num i, Ord i, Show i) => HT.TokenLC i -> ATree i -> [CT.Desg i]-> ConstructionData i -> Either (ASTError i) (ATree i) -desgNode ident rhs desg sc = fmap (atExprStmt . flip atAssign rhs) $ flip (`foldr` ntRightLVarTree) desg $ \idx acc -> case idx of - CT.DesgIdx idx' -> do - at <- acc - nd <- ntRightInvalidInitList $ addKind at $ atNumLit idx' - flip (atUnary ATDeref) nd <$> ntRightInvalidInitList (CT.deref (atype nd)) - CT.DesgMem mem -> atMemberAcc mem <$> acc - where - ntRightInvalidInitList = maybeToRight ("invalid initializer-list", HT.emptyToken) - ntRightLVarTree = treealize <$> maybeToRight (internalCE, HT.emptyToken) (lookupLVar (tshow $ snd ident) sc) - -initZero :: (Num i, Ord i, Show i, Enum i) => CT.TypeKind i -> HT.TokenLC i -> [CT.Desg i] -> ConstructionData i -> Either (ASTError i) [ATree i] -initZero (CT.CTArray n t) ident desg sc = fmap concat $ forM [0..fromIntegral (pred n)] $ flip (initZero t ident) sc . (:desg) . CT.DesgIdx -initZero _ ident desg sc = (:[]) <$> desgNode ident (atNumLit 0) desg sc - --- | needs parameters for Assign -type Assign i = [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i - --- Designator initialization processing loop --- Returns the consumed token list, the constructed tree, ConstructionData and the number of elements specified in designator -initLoop :: (Bits i, Integral i, Read i, Show i) => - Assign i -> CT.StorageClass i -> HT.TokenLC i -> [CT.Desg i] -> SQ.Seq (ATree i) -> HT.TokenLC i -> ASTState i ([HT.TokenLC i], SQ.Seq (ATree i), ConstructionData i, i) -initLoop callback t' ident desg ai c = do - rs <- initLoop' ai - itemCWhen const ((==HT.TKReserved "}") . snd) >>= maybe (lift $ Left ("expected '}' token for '{'", c)) (const $ retCur (snd4 rs) (fou4 rs)) - where - isEnd = uncurry (||) . first (isPrefixOf [HT.TKReserved "}"]) . second (isPrefixOf [HT.TKReserved ",", HT.TKReserved "}"]) . dupe . map snd - - retCur :: SQ.Seq (ATree i) -> i -> ASTState i ([HT.TokenLC i], SQ.Seq (ATree i), ConstructionData i, i) - retCur ai' n = uncurry (,ai',,n) <$> gets swap - - initLoop' ai' = case CT.toTypeKind t' of - CT.CTArray _ _ -> ($ (0, ai')) . fix $ \f (!idx, rl) -> do - rs <- uncurry (desgInit callback ident rl (CT.DesgIdx idx:desg) $ fromJust $ CT.deref t') <$> gets swap - flip (either (lift . Left)) rs $ \rs' -> do - put (swap $ dropSnd3 rs') - ifM ((||) <$> isSatisfied isEnd <*> (isNothing <$> itemCWhen const ((==HT.TKReserved ",") . snd))) (retCur (snd3 rs') $ succ idx) $ f (succ idx, snd3 rs') - CT.CTStruct mems -> ($ (M.elems mems, ai', 0)) . fix $ \f (mems', rl, len) -> if null mems' then retCur ai' len else do - rs <- uncurry (desgInit callback ident rl (CT.DesgMem (head mems'):desg) $ CT.SCAuto $ CT.smType (head mems')) <$> gets swap - flip (either (lift . Left)) rs $ \rs' -> do - put (swap $ dropSnd3 rs') - ifM ((||) <$> isSatisfied isEnd <*> (isNothing <$> itemCWhen const ((==HT.TKReserved ",") . snd))) (retCur (snd3 rs') $ succ len) $ f (tail mems', snd3 rs', succ len) - _ -> lift $ Left (internalCE, HT.emptyToken) - --- For initializer-list. --- For example, the declaration @int x[2][2] = { { 1, 2 }, { 3, 4 } };@ is converted to @x[2][2]; x[0][0] = 1; x[0][1] = 2; x[1][0] = 3; x[1][1] = 4;@. -desgInit :: (Bits i, Integral i, Read i, Show i) => - Assign i -> HT.TokenLC i -> SQ.Seq (ATree i) -> [CT.Desg i] -> CT.StorageClass i -> [HT.TokenLC i] -> ConstructionData i -> - Either (ASTError i) ([HT.TokenLC i], SQ.Seq (ATree i), ConstructionData i) -desgInit callback ident ai desg t' xs' scp - -- initializer-string - | CT.isArray t' && maybe False ((==CT.CTChar) . CT.toTypeKind) (CT.deref t') && maybe False (HT.isTKString . snd) (headMay xs') = if CT.isIncompleteArray t' then - case snd (head xs') of - (HT.TKString s) -> let newt = arTypeFromLen (B.length s) in addLVar newt ident scp >>= desgInit callback ident ai desg newt xs' . snd - _ -> Left (internalCE, HT.emptyToken) -- should not reach here - else case (snd (head xs'), CT.toTypeKind t') of - (HT.TKString s, CT.CTArray n _) -> let s' = s `B.append` B.pack (replicate (fromIntegral n - pred (B.length s)) $ toEnum 0) in - fmap ((tail xs',, if fromIntegral n < pred (B.length s) then pushWarn "initializer-string for char array is too long" (head xs') scp else scp) . - (ai SQ.><) . SQ.fromList) $ mapM (flip id scp . uncurry (desgNode ident)) $ zipWith (flip (.) (++desg) . (,) . atNumLit . fromIntegral) (B.unpack s') $ - sortBy (flip (.) reverse . compare . reverse) $ CT.accessibleIndices $ CT.toTypeKind t' - _ -> Left (internalCE, HT.emptyToken) -- should not reach here - -- Non-string initializer-list - | CT.isArray t' = case xs' of -- incomplete dattara takeExps de kazeru - -- Zero initialization - (_, HT.TKReserved "{"):(_, HT.TKReserved "}"):ds -> fmap ((ds,, scp) . (ai SQ.><) . SQ.fromList) $ - mapM (flip (desgNode ident $ atNumLit 0) scp . (++desg)) $ CT.accessibleIndices $ CT.toTypeKind t' - -- The specified initializer-list of initialization elements - c@(_, HT.TKReserved "{"):ds - | CT.isIncompleteArray t' -> toComplete (c:ds) >>= \newt -> addLVar newt ident scp >>= desgInit callback ident ai desg newt xs' . snd - | otherwise -> case CT.toTypeKind t' of - CT.CTArray n bt -> do - rs <- evalStateT (initLoop callback t' ident desg ai c) (scp, ds) - zeroResult rs $ forM [fromIntegral (fou4 rs)..pred $ fromIntegral n] $ \idx -> initZero bt ident (CT.DesgIdx idx:desg) (thd4 rs) - _ -> Left (internalCE, HT.emptyToken) - _ -> Left ("expected { initializer-list } or { initializer-list , }", if not (null xs') then head xs' else HT.emptyToken) - -- struct initializer - | CT.isCTStruct t' = case (xs', CT.toTypeKind t') of - ((_, HT.TKReserved "{"):(_, HT.TKReserved "}"):ds, CT.CTStruct mems) -> fmap ((ds,,scp) . (ai SQ.><) . SQ.fromList . concat) $ forM (M.elems mems) $ \mem -> - initZero (CT.smType mem) ident (CT.DesgMem mem:desg) scp - (c@(_, HT.TKReserved "{"):ds, CT.CTStruct mems) -> do - rs <- evalStateT (initLoop callback t' ident desg ai c) (scp, ds) - zeroResult rs $ forM (drop (fromIntegral $ fou4 rs) (M.elems mems)) $ \mem -> initZero (CT.smType mem) ident (CT.DesgMem mem:desg) (thd4 rs) - _ -> Left ("expected { initializer-list } or { initializer-list , }", if not (null xs') then head xs' else HT.emptyToken) - -- For a element - | otherwise = callback xs' ATEmpty scp >>= \(ds, at, scp''') -> (ds,,scp''') . (ai SQ.|>) <$> desgNode ident at desg scp''' - where - {-# INLINE zeroResult #-} - zeroResult rs = fmap ((fst4 rs,,thd4 rs) . (ai SQ.><) . (snd4 rs SQ.><) . SQ.fromList . concat) - - {-# INLINE toComplete #-} - toComplete ds' = (>>=) - (maybeToRight ("expected { initializer-list } or { initializer-list , }", if not (null xs') then head xs' else HT.emptyToken) (takeBrace "{" "}" ds')) $ - either (Left . ("expected { initializer-list } or { initializer-list , }",)) $ \(br, _) -> arTypeFromLen . length <$> - maybeToRight (internalCE, HT.emptyToken) (takeExps $ [(HT.TokenLCNums 0 0, HT.TKReserved "(")] ++ init (tail br) ++ [(HT.TokenLCNums 0 0, HT.TKReserved ")")]) - - {-# INLINE arTypeFromLen #-} - arTypeFromLen len = snd (CT.dctorArray t') $ CT.mapTypeKind (CT.CTArray (fromIntegral len) . fromJust . CT.fromIncompleteArray) t' - -varInit' :: (Read i, Show i, Integral i, Bits i) => Assign i -> CT.StorageClass i -> HT.TokenLC i -> [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -varInit' callback t ident xs lat scp' - | CT.isArray t || CT.isCTStruct t = second3 (\st -> ATNode (ATBlock $ toList st) (CT.SCUndef CT.CTUndef) ATEmpty ATEmpty) <$> desgInit callback ident SQ.empty [] t xs scp' - | otherwise = do - (ert, erat, ervar) <- callback xs ATEmpty scp' - flip fmap (validAssign (HT.altEmptyToken ert) erat) $ \erat' -> (ert, atExprStmt (ATNode ATAssign (atype lat) lat erat'), ervar) - --- | Initializing local variables -varInit :: (Read i, Show i, Integral i, Bits i) => Assign i -> CT.StorageClass i -> HT.TokenLC i -> [HT.TokenLC i] -> ConstructionData i -> ASTConstruction i -varInit callback t ident token scp = addLVar (fromMaybe t $ incomplete t scp) ident scp >>= uncurry (varInit' callback t ident token) diff --git a/src/Htcc/Parser/Combinators.hs b/src/Htcc/Parser/Combinators.hs index ea60113..69c907f 100644 --- a/src/Htcc/Parser/Combinators.hs +++ b/src/Htcc/Parser/Combinators.hs @@ -14,5 +14,5 @@ module Htcc.Parser.Combinators ( , module Htcc.Parser.Combinators.Program ) where -import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Program +import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.Program diff --git a/src/Htcc/Parser/Combinators/Core.hs b/src/Htcc/Parser/Combinators/Core.hs index d625f49..d42388f 100644 --- a/src/Htcc/Parser/Combinators/Core.hs +++ b/src/Htcc/Parser/Combinators/Core.hs @@ -55,25 +55,18 @@ module Htcc.Parser.Combinators.Core ( , notFollowedBy ) where -import Control.Applicative (Alternative (..)) -import Control.Monad.Combinators (between) -import Control.Monad.Trans.State.Lazy -import Data.Char (isAlpha) -import Data.Functor.Identity -import qualified Data.Text as T -import Data.Void -import qualified Htcc.CRules as CR -import Htcc.Parser.AST.Type (ASTs) -import Htcc.Parser.ConstructionData (ConstructionData (..), - Warnings, - initConstructionData) -import qualified Htcc.Parser.ConstructionData.Scope as PS -import qualified Htcc.Parser.ConstructionData.Scope.Var as PSV -import Htcc.Utils (lor) -import qualified Text.Megaparsec as M -import qualified Text.Megaparsec.Char as MC -import qualified Text.Megaparsec.Char.Lexer as ML +import Htcc.Parser.Combinators.ParserType +import Control.Applicative (Alternative (..)) +import Control.Monad.Combinators (between) +import Data.Char (isAlpha) +import qualified Data.Text as T +import qualified Htcc.CRules as CR +import Htcc.Utils (lor) +import qualified Text.Megaparsec as M +import qualified Text.Megaparsec.Char as MC +import qualified Text.Megaparsec.Char.Lexer as ML +{- type ConstructionDataState i = StateT (ConstructionData i) Identity type Parser i = M.ParsecT Void T.Text (ConstructionDataState i) @@ -87,7 +80,7 @@ runParser p fp input = <$> fst result where result = runIdentity $ runStateT (M.runParserT p fp input) initConstructionData - +-} spaceConsumer :: Ord e => M.ParsecT e T.Text m () spaceConsumer = ML.space MC.space1 (ML.skipLineComment "//") (ML.skipBlockComment "/*" "*/") diff --git a/src/Htcc/Parser/Combinators/ParserType.hs b/src/Htcc/Parser/Combinators/ParserType.hs new file mode 100644 index 0000000..0bb7e7f --- /dev/null +++ b/src/Htcc/Parser/Combinators/ParserType.hs @@ -0,0 +1,42 @@ +{-| +Module : Htcc.Parser.Combinators.ParserType +Description : C language parser type +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser type +-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, TupleSections #-} +module Htcc.Parser.Combinators.ParserType ( + runParser + , ConstructionDataState + , Parser +) where + +import Control.Monad.Trans.State.Lazy (StateT, runStateT) +import Data.Functor.Identity +import qualified Data.Text as T +import Data.Void +import Htcc.Parser.AST.Type (ASTs) +import {-# SOURCE #-} Htcc.Parser.ConstructionData.Core +import qualified Htcc.Parser.ConstructionData.Scope as PS +import qualified Htcc.Parser.ConstructionData.Scope.Var as PSV +import qualified Text.Megaparsec as M + +type ConstructionDataState i = StateT (ConstructionData i) Identity +type Parser i = M.ParsecT Void T.Text (ConstructionDataState i) + +runParser :: + Parser i (ASTs i) + -> FilePath + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs i, PSV.GlobalVars i, PSV.Literals i) +runParser p fp input = + (warns (snd result),, PSV.globals $ PS.vars $ scope $ snd result, PSV.literals $ PS.vars $ scope $ snd result) + <$> fst result + where + result = runIdentity $ runStateT (M.runParserT p fp input) initConstructionData + diff --git a/src/Htcc/Parser/Combinators/ParserType.hs-boot b/src/Htcc/Parser/Combinators/ParserType.hs-boot new file mode 100644 index 0000000..a7ddb22 --- /dev/null +++ b/src/Htcc/Parser/Combinators/ParserType.hs-boot @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, TupleSections #-} +module Htcc.Parser.Combinators.ParserType where + +import Control.Monad.Trans.State.Lazy (StateT (..)) +import Data.Functor.Identity +import qualified Data.Text as T +import Data.Void +import Htcc.Parser.AST.Type (ASTs) +import {-# SOURCE #-} Htcc.Parser.ConstructionData.Core (ConstructionData, + Warnings) +import qualified Htcc.Parser.ConstructionData.Scope.Var as PSV +import qualified Text.Megaparsec as M + +type ConstructionDataState i = StateT (ConstructionData i) Identity +type Parser i = M.ParsecT Void T.Text (ConstructionDataState i) + +runParser :: + Parser i (ASTs i) + -> FilePath + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs i, PSV.GlobalVars i, PSV.Literals i) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 78c06f9..c643f79 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -16,14 +16,15 @@ module Htcc.Parser.Combinators.Program ( , compoundStmt ) where -import Control.Monad (forM, void, (>=>)) +import Control.Monad (forM, void, when, + (>=>)) import Control.Monad.Combinators (choice, some) import Control.Monad.Extra (ifM) +import Control.Monad.State (get, gets, modify, + put) import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Control.Monad.Trans.State (get, gets, modify, - put) import Data.Bits (Bits) import qualified Data.ByteString.UTF8 as BSU import Data.Char (ord) @@ -36,6 +37,7 @@ import Data.Tuple.Extra (dupe, first) import qualified Htcc.CRules.Types as CT import Htcc.Parser.AST (Treealizable (..), addKind, + isEmptyReturn, isNonEmptyReturn, subKind) import Htcc.Parser.AST.Core (ATKind (..), @@ -66,11 +68,12 @@ import Htcc.Parser.Combinators.Type (arraySuffix, cType, constantExp) import Htcc.Parser.Combinators.Utils (bracket, + getPosState, maybeToParser, registerLVar, tmpTKIdent) import Htcc.Parser.Combinators.Var (varInit) -import Htcc.Parser.ConstructionData (addFunction, +import Htcc.Parser.ConstructionData.Core (addFunction, addGVar, addGVarWith, addLiteral, @@ -79,6 +82,7 @@ import Htcc.Parser.ConstructionData (addFunction, isSwitchStmt, lookupFunction, lookupVar, + pushWarn, resetLocal, succNest) import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) @@ -145,12 +149,13 @@ global = choice ] function = do + pos <- getPosState (ty, ident) <- M.try (declIdent <* lparen) params <- takeParameters - lift $ modify resetLocal + modify resetLocal choice [ declaration ty ident - , definition ty ident params + , definition ty ident params pos ] where takeParameters = @@ -158,17 +163,17 @@ function = do declaration ty ident = void semi - >> lift (gets $ addFunction False ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) + >> gets (addFunction False ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) >>= \case - Right scp' -> ATEmpty <$ lift (put scp') + Right scp' -> ATEmpty <$ put scp' Left err -> fail $ T.unpack $ fst err - definition ty ident params = + definition ty ident params pos = void (M.lookAhead lbrace) - >> lift (gets $ addFunction True ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) + >> gets (addFunction True ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) >>= \case Right scp' -> do - lift $ put scp' + put scp' params' <- forM (rights params) $ uncurry registerLVar stmt >>= fromValidFunc params' Left err -> fail $ T.unpack $ fst err @@ -183,9 +188,16 @@ function = do ] else pure $ atDefFunc ident (if null params' then Nothing else Just params') ty st - | otherwise = - -- TODO: Warning when there is no return value when the function is not void - pure $ atDefFunc ident (if null params' then Nothing else Just params') ty st + | otherwise = do + when (isJust (find isEmptyReturn block)) $ + pushWarn pos $ mconcat + [ "the return type of function '" + , T.unpack ident + , "' is " + , show (CT.toTypeKind ty) + , ", but the statement returns no value" + ] + pure $ atDefFunc ident (if null params' then Nothing else Just params') ty st fromValidFunc _ _ = fail "internal compiler error" gvar = do @@ -197,15 +209,15 @@ gvar = do where nonInit ty ident = do void semi - ty' <- maybeToParser "defining global variables with a incomplete type" =<< lift (gets $ incomplete ty) - lift (gets (addGVar ty' (tmpTKIdent ident))) + ty' <- maybeToParser "defining global variables with a incomplete type" =<< gets (incomplete ty) + gets (addGVar ty' (tmpTKIdent ident)) >>= \case Left err -> fail $ T.unpack $ fst err - Right (_, scp) -> ATEmpty <$ lift (put scp) + Right (_, scp) -> ATEmpty <$ put scp withInit ty ident = do void equal - ty' <- maybeToParser "defining global variables with a incomplete type" =<< lift (gets $ incomplete ty) + ty' <- maybeToParser "defining global variables with a incomplete type" =<< gets (incomplete ty) gvarInit ty' ident <* semi gvarInit ty ident = choice @@ -216,16 +228,16 @@ gvar = do fromOG = do ast <- conditional case (atkind ast, atkind (atL ast)) of - (ATAddr, ATGVar _ name) -> lift (gets (gvarInitWithOG ty name)) + (ATAddr, ATGVar _ name) -> gets (gvarInitWithOG ty name) >>= \case Left err -> fail $ T.unpack $ fst err - Right (_, scp) -> ATEmpty <$ lift (put scp) + Right (_, scp) -> ATEmpty <$ put scp (ATAddr, _) -> fail "invalid initializer in global variable" (ATGVar t name, _) - | CT.isCTArray t -> lift (gets (gvarInitWithOG ty name)) + | CT.isCTArray t -> gets (gvarInitWithOG ty name) >>= \case Left err -> fail $ T.unpack $ fst err - Right (_, scp) -> ATEmpty <$ lift (put scp) + Right (_, scp) -> ATEmpty <$ put scp -- TODO: support initializing from other global variables | otherwise -> fail "initializer element is not constant" _ -> fail "initializer element is not constant" @@ -235,14 +247,14 @@ gvar = do fromConstant = do cval <- constantExp - lift (gets (gvarInitWithVal ty cval)) + gets (gvarInitWithVal ty cval) >>= \case Left err -> fail $ T.unpack $ fst err - Right (_, scp) -> ATEmpty <$ lift (put scp) + Right (_, scp) -> ATEmpty <$ put scp compoundStmt :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i [ATree i] -compoundStmt = bracket (lift get) (lift . modify . fallBack) $ const $ - braces (lift (modify succNest) *> M.many stmt) +compoundStmt = bracket get (modify . fallBack) $ const $ + braces (modify succNest *> M.many stmt) stmt = choice [ returnStmt @@ -275,9 +287,9 @@ stmt = choice whileStmt = atWhile <$> (M.try kWhile >> parens expr) <*> stmt - forStmt = (>>) (M.try kFor) $ bracket (lift get) (lift . modify . fallBack) $ const $ do + forStmt = (>>) (M.try kFor) $ bracket get (modify . fallBack) $ const $ do es <- parens $ do - lift $ modify succNest + modify succNest initSect <- ATForInit <$> choice [ATEmpty <$ semi, M.try (atExprStmt <$> expr <* semi), lvarStmt] condSect <- ATForCond @@ -301,15 +313,15 @@ stmt = choice ATNode (ATBlock ats) ty _ _ -> pure $ atSwitch cond ats ty _ -> fail "expected compound statement after the token ')'" where - putSwitchState b = lift $ modify $ \scp -> scp { isSwitchStmt = b } + putSwitchState b = modify $ \scp -> scp { isSwitchStmt = b } caseStmt = M.try kCase - *> ifM (lift $ gets isSwitchStmt) + *> ifM (gets isSwitchStmt) ((atCase 0 <$> constantExp <* colon) <*> stmt) (fail "stray 'case'") defaultStmt = (M.try kDefault <* colon) - *> ifM (lift $ gets isSwitchStmt) + *> ifM (gets isSwitchStmt) (atDefault 0 <$> stmt) (fail "stray 'default'") @@ -416,7 +428,7 @@ unary = choice idx <- brackets expr kt <- maybeToParser "invalid operands" (addKind fac idx) ty <- maybeToParser "subscripted value is neither array nor pointer nor vector" $ CT.deref $ atype kt - ty' <- maybeToParser "incomplete value dereference" =<< lift (gets $ incomplete ty) + ty' <- maybeToParser "incomplete value dereference" =<< gets (incomplete ty) allAcc $ atUnary ATDeref ty' kt postInc fac = allAcc =<< atUnary ATPostInc (atype fac) fac <$ symbol "++" @@ -443,7 +455,7 @@ factor = choice ] where sizeof = kSizeof >> choice - [ incomplete <$> M.try (parens cType) <*> lift get + [ incomplete <$> M.try (parens cType) <*> get >>= fmap (atNumLit . fromIntegral . CT.sizeof) . maybeToParser "invalid application of 'sizeof' to incomplete type" , atNumLit . fromIntegral . CT.sizeof . atype <$> unary @@ -451,33 +463,35 @@ factor = choice strLiteral = do s <- stringLiteral - lit <- lift $ gets $ + lit <- gets $ addLiteral (CT.SCAuto $ CT.CTArray (fromIntegral $ length s) CT.CTChar) (HT.TokenLCNums 1 1, HT.TKString $ BSU.fromString s) case lit of Left err -> fail $ T.unpack $ fst err - Right (nd, scp) -> nd <$ lift (put scp) + Right (nd, scp) -> nd <$ put scp identifier' = do + pos <- getPosState ident <- identifier choice - [ fnCall ident + [ fnCall ident pos , variable ident ] where variable ident = - lift (gets $ lookupVar ident) + gets (lookupVar ident) >>= \case FoundGVar (PV.GVar t _) -> return $ atGVar t ident FoundLVar sct -> return $ treealize sct FoundEnum sct -> return $ treealize sct NotFound -> fail $ "The '" <> T.unpack ident <> "' is not defined identifier" - fnCall ident = do + fnCall ident pos = do params <- lparen *> M.manyTill (M.try (expr <* comma) M.<|> expr) rparen let params' = if null params then Nothing else Just params - lift (gets $ lookupFunction ident) <&> \case + gets (lookupFunction ident) >>= \case -- TODO: set warning message -- TODO: Infer the return type of a function Nothing -> atNoLeaf (ATCallFunc ident params') (CT.SCAuto CT.CTInt) - Just fn -> atNoLeaf (ATCallFunc ident params') (PSF.fntype fn) + <$ pushWarn pos ("the function '" <> T.unpack ident <> "' is not declared.") + Just fn -> pure $ atNoLeaf (ATCallFunc ident params') (PSF.fntype fn) diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs index dcba38f..5566a31 100644 --- a/src/Htcc/Parser/Combinators/Type.hs +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -15,24 +15,24 @@ module Htcc.Parser.Combinators.Type ( , cType , arraySuffix ) where -import Control.Monad (mfilter) -import Control.Monad.Combinators (choice) -import Control.Monad.Trans (MonadTrans (..)) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Control.Monad.Trans.State (gets) -import Data.Bits (Bits (..)) -import Data.Bool (bool) -import Data.Maybe (fromJust) -import qualified Data.Text as T -import Data.Tuple.Extra (dupe, first) -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST.Core (ATKind (..), ATree (..)) +import Control.Monad (mfilter) +import Control.Monad.Combinators (choice) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Control.Monad.Trans.State (gets) +import Data.Bits (Bits (..)) +import Data.Bool (bool) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Data.Tuple.Extra (dupe, first) +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATKind (..), ATree (..)) import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords -import {-# SOURCE #-} Htcc.Parser.Combinators.Program (conditional) -import Htcc.Parser.ConstructionData (incomplete) -import Htcc.Utils (toNatural) -import qualified Text.Megaparsec as M +import {-# SOURCE #-} Htcc.Parser.Combinators.Program (conditional) +import Htcc.Parser.ConstructionData.Core (incomplete) +import Htcc.Utils (toNatural) +import qualified Text.Megaparsec as M constantExp :: (Bits i, Integral i, Show i, Read i) => Parser i i constantExp = conditional >>= constantExp' diff --git a/src/Htcc/Parser/Combinators/Utils.hs b/src/Htcc/Parser/Combinators/Utils.hs index 58ac1d7..707f434 100644 --- a/src/Htcc/Parser/Combinators/Utils.hs +++ b/src/Htcc/Parser/Combinators/Utils.hs @@ -15,32 +15,38 @@ module Htcc.Parser.Combinators.Utils ( , registerLVar , bracket , tmpTKIdent + , getPosState ) where -import Control.Monad.Trans (MonadTrans (..)) -import Control.Monad.Trans.State (gets, put) -import Control.Natural (type (~>)) -import Data.Bits (Bits (..)) -import qualified Data.Text as T -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST.Core (ATree (..)) +import Control.Monad.State (gets, put) +import Control.Natural (type (~>)) +import Data.Bits (Bits (..)) +import qualified Data.Text as T +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATree (..)) import Htcc.Parser.Combinators.Core -import Htcc.Parser.ConstructionData (addLVar) -import qualified Htcc.Tokenizer.Token as HT -import qualified Text.Megaparsec as M +import Htcc.Parser.ConstructionData.Core (addLVar) +import qualified Htcc.Tokenizer.Token as HT +import qualified Text.Megaparsec as M maybeToParser :: String -> Maybe ~> Parser i maybeToParser s = maybe (fail s) pure registerLVar :: (Bits i, Integral i) => CT.StorageClass i -> T.Text -> Parser i (ATree i) -registerLVar ty ident = lift (gets $ addLVar ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) +registerLVar ty ident = gets (addLVar ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) >>= \case - Right (lat, scp') -> lift (lat <$ put scp') + Right (lat, scp') -> lat <$ put scp' Left err -> fail $ T.unpack $ fst err bracket :: Parser i a -> (a -> Parser i b) -> (a -> Parser i c) -> Parser i c bracket beg end m = do b <- beg M.withRecovery (\err -> end b *> M.parseError err) (m b) <* end b - + tmpTKIdent :: Num i => T.Text -> HT.TokenLC i tmpTKIdent ident = (HT.TokenLCNums 1 1, HT.TKIdent ident) + +getPosState :: Parser i (M.PosState T.Text) +getPosState = do + statePos <- M.statePosState <$> M.getParserState + srcPos <- M.getSourcePos + pure $ statePos { M.pstateSourcePos = srcPos } diff --git a/src/Htcc/Parser/Combinators/Var.hs b/src/Htcc/Parser/Combinators/Var.hs index 2ebec0e..2098b1d 100644 --- a/src/Htcc/Parser/Combinators/Var.hs +++ b/src/Htcc/Parser/Combinators/Var.hs @@ -13,33 +13,34 @@ C language parser Combinators module Htcc.Parser.Combinators.Var ( varInit ) where -import Control.Monad (foldM, forM, void, (>=>)) -import Control.Monad.Extra (andM) -import Control.Monad.Fix (fix) -import Control.Monad.Trans (MonadTrans (..)) -import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT) -import Control.Monad.Trans.State (gets) -import Data.Bits (Bits) -import Data.Bool (bool) -import Data.Char (ord) -import Data.Foldable (toList) -import Data.Functor ((<&>)) -import Data.List (sortBy) -import Data.Maybe (fromJust, fromMaybe) -import qualified Data.Sequence as SQ -import qualified Data.Text as T -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST (ATKind (..), ATree (..), - addKind, atAssign, atBlock, - atExprStmt, atMemberAcc, - atNumLit, atUnary, treealize) +import Control.Monad (foldM, forM, void, (>=>)) +import Control.Monad.Extra (andM) +import Control.Monad.Fix (fix) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT) +import Control.Monad.Trans.State (gets) +import Data.Bits (Bits) +import Data.Bool (bool) +import Data.Char (ord) +import Data.Foldable (toList) +import Data.Functor ((<&>)) +import Data.List (sortBy) +import Data.Maybe (fromJust, fromMaybe) +import qualified Data.Sequence as SQ +import qualified Data.Text as T +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.AST (ATKind (..), ATree (..), + addKind, atAssign, atBlock, + atExprStmt, atMemberAcc, + atNumLit, atUnary, + treealize) import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Utils (bracket, maybeToParser, - registerLVar) -import Htcc.Parser.ConstructionData (incomplete, lookupLVar) -import Htcc.Utils (tshow) -import qualified Text.Megaparsec as M -import Text.Megaparsec.Debug (dbg) +import Htcc.Parser.Combinators.Utils (bracket, maybeToParser, + registerLVar) +import Htcc.Parser.ConstructionData.Core (incomplete, lookupLVar) +import Htcc.Utils (tshow) +import qualified Text.Megaparsec as M +import Text.Megaparsec.Debug (dbg) type DesignatorParser i r = ReaderT (T.Text, Parser i (ATree i)) (Parser i) r diff --git a/src/Htcc/Parser/ConstructionData.hs b/src/Htcc/Parser/ConstructionData.hs deleted file mode 100644 index 687d9eb..0000000 --- a/src/Htcc/Parser/ConstructionData.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-| -Module : Htcc.Parser.ConstructionData.hs -Description : Data types and type synonyms used during AST construction -Copyright : (c) roki, 2019 -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -Data types and type synonyms used during AST construction --} -module Htcc.Parser.ConstructionData ( - module Htcc.Parser.ConstructionData.Core -) where - -import Htcc.Parser.ConstructionData.Core diff --git a/src/Htcc/Parser/ConstructionData/Core.hs b/src/Htcc/Parser/ConstructionData/Core.hs index 407afb7..41d1fb5 100644 --- a/src/Htcc/Parser/ConstructionData/Core.hs +++ b/src/Htcc/Parser/ConstructionData/Core.hs @@ -41,7 +41,7 @@ module Htcc.Parser.ConstructionData.Core ( import Data.Bits (Bits (..)) import Data.Maybe (fromJust) -import qualified Data.Sequence as S +import qualified Data.Sequence as SQ import qualified Data.Text as T import Data.Tuple.Extra (second) @@ -55,17 +55,23 @@ import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) import qualified Htcc.Parser.ConstructionData.Scope.Tag as PS import qualified Htcc.Parser.ConstructionData.Scope.Typedef as PT import qualified Htcc.Parser.ConstructionData.Scope.Var as PV -import Htcc.Tokenizer.Token (TokenLC) import qualified Htcc.Tokenizer.Token as HT +import Control.Monad.State (modify) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Set as S +import Data.Void +import {-# SOURCE #-} Htcc.Parser.Combinators.ParserType +import qualified Text.Megaparsec as M + -- | The warning messages type -type Warnings i = S.Seq (T.Text, TokenLC i) +type Warnings = SQ.Seq (M.ParseErrorBundle T.Text Void) -- | `ConstructionData` is a set of "things" used during the construction of the AST. -- Contains error messages and scope information. data ConstructionData i = ConstructionData -- ^ The constructor of ConstructionData { - warns :: Warnings i, -- ^ The warning messages + warns :: Warnings, -- ^ The warning messages scope :: AS.Scoped i, -- ^ Scope type isSwitchStmt :: Bool -- ^ When the statement is @switch@, this flag will be `True`, otherwise will be `False`. } deriving Show @@ -202,7 +208,7 @@ addEnumerator ty tkn n cd = (\x -> cd { scope = x }) <$> AS.addEnumerator ty tkn -- | Shortcut to the initial state of `ConstructionData`. {-# INLINE initConstructionData #-} initConstructionData :: ConstructionData i -initConstructionData = ConstructionData S.empty AS.initScope False +initConstructionData = ConstructionData SQ.empty AS.initScope False -- | Shortcut to function `Htcc.Parser.AST.Scope.resetLocal` for variable @x@ of type `ConstructionData`. -- This function is equivalent to @@ -212,8 +218,13 @@ resetLocal :: ConstructionData i -> ConstructionData i resetLocal cd = cd { scope = AS.resetLocal (scope cd) } -- | Function to add warning text. -pushWarn :: T.Text -> TokenLC i -> ConstructionData i -> ConstructionData i -pushWarn t tkn cd = cd { warns = warns cd S.|> (t, tkn) } +pushWarn :: M.PosState T.Text -> String -> Parser i () +pushWarn posState warnMsg = do + let peb = M.ParseErrorBundle { + M.bundleErrors = M.FancyError 0 (S.singleton $ M.ErrorFail $ "warning: " <> warnMsg) :| [] + , M.bundlePosState = posState + } + modify (\s -> s { warns = warns s SQ.|> peb }) -- | Returns `Nothing` if incomplete, otherwise `Htcc.CRules.Types.StorageClass`. {-# INLINE incomplete #-} diff --git a/src/Htcc/Parser/ConstructionData/Core.hs-boot b/src/Htcc/Parser/ConstructionData/Core.hs-boot new file mode 100644 index 0000000..27f2660 --- /dev/null +++ b/src/Htcc/Parser/ConstructionData/Core.hs-boot @@ -0,0 +1,16 @@ +module Htcc.Parser.ConstructionData.Core where + +import qualified Data.Sequence as SQ +import qualified Data.Text as T +import Data.Void +import qualified Htcc.Parser.ConstructionData.Scope as AS +import qualified Text.Megaparsec as M + +type Warnings = SQ.Seq (M.ParseErrorBundle T.Text Void) + +data ConstructionData i = ConstructionData + { + warns :: Warnings, + scope :: AS.Scoped i, + isSwitchStmt :: Bool + } diff --git a/src/Htcc/Parser/Parsing.hs b/src/Htcc/Parser/Parsing.hs deleted file mode 100644 index 059cb3f..0000000 --- a/src/Htcc/Parser/Parsing.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-| -Module : Htcc.Parser.Parsing -Description : The main routines for parsing -Copyright : (c) roki, 2019 -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -The main routines for parsing --} -module Htcc.Parser.Parsing ( - module Htcc.Parser.Parsing.Core -) where - -import Htcc.Parser.Parsing.Core diff --git a/src/Htcc/Parser/Parsing/Core.hs b/src/Htcc/Parser/Parsing/Core.hs deleted file mode 100644 index 47aa884..0000000 --- a/src/Htcc/Parser/Parsing/Core.hs +++ /dev/null @@ -1,435 +0,0 @@ -{-# LANGUAGE BangPatterns, LambdaCase, OverloadedStrings, ScopedTypeVariables, - TupleSections #-} -{-| -Module : Htcc.Parser.Parsing.Core -Description : The C languge parser and AST constructor -Copyright : (c) roki, 2019 -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -The C languge parser and AST constructor --} -module Htcc.Parser.Parsing.Core ( - -- * Recursive descent implementation functions - program, - globalDef, - stmt, - inners, - logicalOr, - logicalAnd, - bitwiseOr, - bitwiseXor, - bitwiseAnd, - shift, - add, - term, - cast, - unary, - factor, - relational, - equality, - conditional, - assign, - expr, - -- * Parser - parse, - -- * Types and synonyms - ASTs, - ASTSuccess, - ASTConstruction, - ASTResult, - -- * Utilities - stackSize -) where - -import Control.Monad (forM) -import Control.Monad.Loops (unfoldrM) -import Control.Monad.ST (runST) -import Data.Bits hiding (shift) -import qualified Data.ByteString as B -import Data.Either (isLeft, lefts, - rights) -import Data.Foldable (Foldable (..)) -import Data.List (find) -import Data.Maybe (fromJust, - fromMaybe) -import qualified Data.Set as S -import Data.STRef (newSTRef, - readSTRef, - writeSTRef) -import qualified Data.Text as T -import Data.Tuple.Extra (dupe, first, - second, snd3, - uncurry3) -import Numeric.Natural -import Prelude hiding - (toInteger) - -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST -import Htcc.Parser.ConstructionData -import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..), - Scoped (..)) -import qualified Htcc.Parser.ConstructionData.Scope.Function as PSF -import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) -import Htcc.Parser.ConstructionData.Scope.Utils (internalCE) -import qualified Htcc.Parser.ConstructionData.Scope.Var as PV -import Htcc.Parser.Parsing.Global -import Htcc.Parser.Parsing.StmtExpr -import Htcc.Parser.Parsing.Type -import Htcc.Parser.Parsing.Typedef -import Htcc.Parser.Utils -import qualified Htcc.Tokenizer as HT -import Htcc.Utils (first3, - first4, - maybe', - maybeToRight, - second3, - third3, - toInteger, - toNatural, - tshow) - -{-# INLINE varDecl #-} -varDecl :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ConstructionData i -> ASTConstruction i -varDecl tk scp = takeType tk scp >>= validDecl (HT.altEmptyToken tk) >>= varDecl' - where - varDecl' (_, Nothing, (_, HT.TKReserved ";"):ds, scp') = Right (ds, ATEmpty, scp') - varDecl' (t, Just ident, (_, HT.TKReserved ";"):ds, scp') = maybeToRight ("declaration with incomplete type", ident) (incomplete t scp) >>= \t' -> - addLVar t' ident scp' >>= \(lat, scp'') -> Right (ds, atNull lat, scp'') - varDecl' (t, Just ident, (_, HT.TKReserved "="):ds, scp') = (>>=) (varInit assign t ident ds scp') $ \case - ((_, HT.TKReserved ";"):ds', at, sc) -> Right (ds', at, sc) - _ -> Left ("expected ';' token, the subject iteration statement starts here:", head tk) - varDecl' (_, _, ds, _) = Left $ if null ds then ("expected unqualified-id", head tk) else ("expected unqualified-id before '" <> tshow (snd (head ds)) <> T.singleton '\'', head ds) - validDecl _ tnt@(t, Just ident, _, scp') = maybe' (Right tnt) (incomplete t scp') $ \t' -> if CT.toTypeKind t == CT.CTVoid then - Left ("variable or field '" <> tshow (snd ident) <> "' declarated void", ident) else Right $ first4 (const t') tnt - validDecl errPlaceholder tnt@(t, _, _, scp') = maybe' (Right tnt) (incomplete t scp') $ \t' -> if CT.toTypeKind t == CT.CTVoid then - Left ("declarations of type void is invalid in this context", errPlaceholder) else Right $ first4 (const t') tnt - --- | `program` indicates \(\eqref{eq:eigth}\) among the comments of `inners`. -program :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ConstructionData i -> Either (ASTError i) (ASTs i, ConstructionData i) -program [] !scp = Right ([], scp) -program xs !scp = either Left (\(ys, atn, !scp') -> first (atn:) <$> program ys scp') $ globalDef xs ATEmpty scp - --- | `stmt` indicates \(\eqref{eq:nineth}\) among the comments of `inners`. -stmt :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -stmt ((_, HT.TKReturn):(_, HT.TKReserved ";"):xs) _ scp = Right (xs, atReturn (CT.SCUndef CT.CTUndef) ATEmpty, scp) -- for @return;@ -stmt (cur@(_, HT.TKReturn):xs) atn !scp = (>>=) (expr xs atn scp) $ \(ert, erat, erscp) -> case ert of -- for @return@ - (_, HT.TKReserved ";"):ys -> Right (ys, atReturn (CT.SCUndef CT.CTUndef) erat, erscp) - ert' -> Left $ expectedMessage ";" cur ert' -stmt (cur@(_, HT.TKIf):(_, HT.TKReserved "("):xs) atn !scp = (>>=) (expr xs atn scp) $ \(ert, erat, erscp) -> case ert of -- for @if@ - (_, HT.TKReserved ")"):ys -> (>>=) (stmt ys erat erscp) $ \x -> case second3 (atIf erat) x of - ((_, HT.TKElse):zs, eerat, eerscp) -> second3 (atElse eerat) <$> stmt zs eerat eerscp -- for @else@ - zs -> Right zs - ert' -> Left $ expectedMessage ")" cur ert' -stmt (cur@(_, HT.TKWhile):(_, HT.TKReserved "("):xs) atn !scp = (>>=) (expr xs atn scp) $ \(ert, erat, erscp) -> case ert of -- for @while@ - (_, HT.TKReserved ")"):ys -> second3 (atWhile erat) <$> stmt ys erat erscp - ert' -> Left $ expectedMessage ")" cur ert' -stmt xxs@(cur@(_, HT.TKFor):(_, HT.TKReserved "("):_) _ !scp = (>>=) (maybeToRight (internalCE, cur) (takeBrace "(" ")" (tail xxs))) $ -- for @for@ - either (Left . ("expected ')' token. The subject iteration statement starts here:",)) $ \(forSt, ds) -> (>>=) (initSect (tail (init forSt)) $ succNest scp) $ \(fxs, finit, fscp') -> - (>>=) (condSect fxs fscp') $ \(fxs', fcond, fscp'') -> (>>=) (incrSect fxs' fscp'') $ \case - ([], fincr, fscp''') -> - let fnd = filter (\x' -> case fromATKindFor x' of ATEmpty -> False; x'' -> not $ isEmptyExprStmt x'') [ATForInit finit, ATForCond fcond, ATForIncr fincr] - mkk = maybe (ATForCond (atNumLit 1) : fnd) (const fnd) $ find isATForCond fnd in case ds of - ((_, HT.TKReserved ";"):ys) -> Right (ys, atFor mkk, fallBack scp fscp''') - _ -> third3 (fallBack scp) . second3 (atFor . (mkk ++) . (:[]) . ATForStmt) <$> stmt ds ATEmpty fscp''' - _ -> Left ("unexpected end of for statement", cur) - where - initSect [] _ = Left ("the iteration statement for must be `for (expression_opt; expression_opt; expression_opt) statement`. See section 6.8.5.", cur) - initSect ((_, HT.TKReserved ";"):ds) fsc = Right (ds, ATEmpty, fsc) - initSect forSect fsc - | isTypeName (head forSect) fsc = varDecl forSect fsc - | otherwise = (>>=) (expr forSect ATEmpty fsc) $ \(x, y, z) -> case x of - (_, HT.TKReserved ";"):ds -> Right (ds, atExprStmt y, z) - _ -> if null x then Left ("expected ';' token", HT.emptyToken) else Left ("expected ';' token after '" <> tshow (snd $ head x) <> "'", head x) - condSect [] _ = Left ("the iteration statement for must be `for (expression_opt; expression_opt; expression_opt) statement`. See section 6.8.5.", cur) - condSect ((_, HT.TKReserved ";"):ds) fsc = Right (ds, ATEmpty, fsc) - condSect forSect fsc = (>>=) (expr forSect ATEmpty fsc) $ \case - ((_, HT.TKReserved ";"):ds, y, z) -> Right (ds, y, z) - (x, _, _) -> if null x then Left ("expected ';' token", HT.emptyToken) else Left ("expected ';' token after '" <> tshow (snd $ head x) <> "'", head x) - incrSect [] fsc = Right ([], ATEmpty, fsc) - incrSect forSect fsc = second3 atExprStmt <$> expr forSect ATEmpty fsc -stmt xxs@(cur@(_, HT.TKReserved "{"):_) _ !scp = (>>=) (maybeToRight (internalCE, cur) (takeBrace "{" "}" xxs)) $ -- for compound statement - either (Left . ("the compound statement is not closed",)) $ \(sctk, ds) -> runST $ do - eri <- newSTRef Nothing - v <- newSTRef $ succNest scp - mk <- flip unfoldrM (init $ tail sctk) $ \ert -> if null ert then return Nothing else do - erscp <- readSTRef v - either (\err -> Nothing <$ writeSTRef eri (Just err)) (\(ert', erat', erscp') -> Just (erat', ert') <$ writeSTRef v erscp') $ stmt ert ATEmpty erscp - (>>=) (readSTRef eri) $ flip maybe (return . Left) $ Right . (ds, atBlock mk,) . fallBack scp <$> readSTRef v -stmt ((_, HT.TKReserved ";"):xs) atn !scp = Right (xs, atn, scp) -- for only @;@ -stmt (cur@(_, HT.TKBreak):xs) _ scp = case xs of -- for @break@ - (_, HT.TKReserved ";"):ds -> Right (ds, atBreak, scp) - _ -> Left ("expected ';' token after 'break' token", cur) -stmt (cur@(_, HT.TKContinue):xs) _ scp = case xs of -- for @continue@ - (_, HT.TKReserved ";"):ds -> Right (ds, atContinue, scp) - _ -> Left ("expected ';' token after 'continue' token", cur) -stmt (cur@(_, HT.TKSwitch):xs) atn scp = case xs of -- for @switch@ - (_, HT.TKReserved "("):xs' -> (>>=) (expr xs' atn scp) $ \case - (cur1@(_, HT.TKReserved ")"):xs'', cond, scp') -> - (>>=) (stmt xs'' ATEmpty (scp' { isSwitchStmt = True })) $ \case - (xs''', ATNode (ATBlock ats) t _ _, scp'') -> Right (xs''', atSwitch cond ats t, scp'' { isSwitchStmt = False }) - _ -> Left ("expected compound statement after the token ')'", cur1) - (xs'', _, _) -> Left $ if not (null xs'') then ("expected token ')' before '" <> tshow (snd $ head xs') <> "' token", head xs') else ("expected ')' token", HT.emptyToken) - _ -> Left ("expected token '(' after the token 'switch'", cur) -stmt (cur@(_, HT.TKCase):xs) atn scp -- for @case@ - | isSwitchStmt scp = flip (either (Left . fromMaybe ("expected constant expression after 'case' token", cur))) (constantExp xs scp) $ \case - ((_, HT.TKReserved ":"):ds, val) -> second3 (atCase 0 val) <$> stmt ds atn scp - (ds, _) -> Left $ if not (null ds) then ("expected ':' token before '" <> tshow (snd $ head ds) <> "'", head ds) else ("expected ':' token", head ds) - | otherwise = Left ("stray 'case'", cur) -stmt (cur@(_, HT.TKDefault):(_, HT.TKReserved ":"):xs) atn scp -- for @default@ - | isSwitchStmt scp = second3 (atDefault 0) <$> stmt xs atn scp - | otherwise = Left ("stray 'default'", cur) -stmt (cur@(_, HT.TKGoto):xs) _ scp = case xs of -- for @goto@ - (_, HT.TKIdent ident):(_, HT.TKReserved ";"):ds -> Right (ds, atGoto ident, scp) - (_, HT.TKIdent ident):_ -> Left ("expected ';' token after the identifier '" <> ident <> "'", cur) - _ -> Left ("expected identifier after the 'goto' token", cur) -stmt ((_, HT.TKIdent ident):(_, HT.TKReserved ":"):xs) _ scp = Right (xs, atLabel ident, scp) -- for local label -stmt xs@((_, HT.TKTypedef):_) _ scp = typedef xs scp -- for local @typedef@ -stmt tk atn !scp - | not (null tk) && isTypeName (head tk) scp = varDecl tk scp -- for a local variable declaration - | otherwise = (>>=) (expr tk atn scp) $ \(ert, erat, erscp) -> case ert of -- for stmt; - (_, HT.TKReserved ";"):ys -> Right (ys, atExprStmt erat, erscp) - ert' -> Left $ expectedMessage ";" (if null tk then HT.emptyToken else last tk) ert' - -{-# INLINE expr #-} --- | \({\rm expr} = {\rm assign}\left("," {\rm assign}\right)\ast\) -expr :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -expr tk at cd = assign tk at cd >>= uncurry3 f - where - f ((_, HT.TKReserved ","):xs) at' cd' = assign xs at' cd' >>= uncurry3 f . second3 (\x -> atComma (atype x) (atExprStmt at') x) - f tk' at' cd' = Right (tk', at', cd') - --- | `assign` indicates \(\eqref{eq:seventh}\) among the comments of `inners`. -assign :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -assign xs atn scp = (>>=) (conditional xs atn scp) $ \(ert, erat, erscp) -> case ert of - (_, HT.TKReserved "="):ys -> nextNode ATAssign ys erat erscp - (_, HT.TKReserved "*="):ys -> nextNode ATMulAssign ys erat erscp - (_, HT.TKReserved "/="):ys -> nextNode ATDivAssign ys erat erscp - (_, HT.TKReserved "&="):ys -> nextNode ATAndAssign ys erat erscp - (_, HT.TKReserved "|="):ys -> nextNode ATOrAssign ys erat erscp - (_, HT.TKReserved "^="):ys -> nextNode ATXorAssign ys erat erscp - (_, HT.TKReserved "<<="):ys -> nextNode ATShlAssign ys erat erscp - (_, HT.TKReserved ">>="):ys -> nextNode ATShrAssign ys erat erscp - (_, HT.TKReserved "+="):ys -> nextNode (maybe ATAddAssign (const ATAddPtrAssign) $ CT.deref (atype erat)) ys erat erscp - (_, HT.TKReserved "-="):ys -> nextNode (maybe ATSubAssign (const ATSubPtrAssign) $ CT.deref (atype erat)) ys erat erscp - _ -> Right (ert, erat, erscp) - where - nextNode atk ys erat erscp = (>>=) (assign ys erat erscp) $ \(zs, erat', erscp') -> - (>>=) (validAssign (if not (null zs) then head zs else if not (null ys) then head ys else if not (null xs) then head xs else HT.emptyToken) erat') $ \erat'' -> - Right (zs, ATNode atk (atype erat) erat erat'', erscp') - --- | `conditional` indicates \(\eqref{eq:seventeenth}\) among the comments of `inners`. -conditional :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -conditional xs atn scp = (>>=) (logicalOr xs atn scp) $ \(ert, cond, erscp) -> case ert of - -- GNU extension (Conditionals with Omitted Operands, see also: https://gcc.gnu.org/onlinedocs/gcc/Conditionals.html) - (_, HT.TKReserved "?"):(_, HT.TKReserved ":"):ds -> second3 (atConditional (atype cond) cond ATEmpty) <$> conditional ds cond erscp - cur@(_, HT.TKReserved "?"):ds -> (>>=) (expr ds cond erscp) $ \(ert', thn, erscp') -> case ert' of - (_, HT.TKReserved ":"):ds' -> second3 (atConditional (atype thn) cond thn) <$> conditional ds' thn erscp' - ds' -> if null ds' then Left ("expected ':' token for this '?'", cur) else Left ("expected ':' before '" <> tshow (snd (head ds')) <> "' token", head ds') - _ -> Right (ert, cond, erscp) - --- | `inners` is a general function for creating `equality`, `relational`, `add` and `term` in the following syntax (EBNF) of \({\rm LL}\left(k\right)\) where \(k\in\mathbb{N}\). --- --- \[ --- \begin{eqnarray} --- {\rm program} &=& \text{global-def*}\label{eq:eigth}\tag{1}\\ --- {\rm stmt} &=& \begin{array}{l} --- {\rm expr}?\ {\rm ";"}\\ --- \mid\ {\rm "\{"\ stmt}^\ast\ {\rm "\}"}\\ --- \mid\ {\rm "return"}\ {\rm expr}\ ";"\\ --- \mid\ "{\rm if}"\ "("\ {\rm expr}\ ")"\ {\rm stmt}\ ("{\rm else}"\ {\rm stmt})?\\ --- \mid\ {\rm "while"\ "("\ expr\ ")"\ stmt}\\ --- \mid\ {\rm "for"\ "("\ expr?\ ";" expr?\ ";"\ expr?\ ")"\ stmt? ";"} --- \end{array}\label{eq:nineth}\tag{2}\\ --- {\rm expr} &=& {\rm assign}\\ --- {\rm assign} &=& {\rm conditional} \left(\left("="\ \mid\ "+="\ \mid\ "-="\ \mid\ "*="\ \mid\ "/="\right)\ {\rm assign}\right)?\label{eq:seventh}\tag{3}\\ --- {\rm conditional} &=& {\rm logicalOr} \left("?"\ {\rm expr}\ ":"\ {\rm conditional}\right)?\label{eq:seventeenth}\tag{4}\\ --- {\rm logicalOr} &=& {\rm logicalAnd}\ \left("||"\ {\rm logicalAnd}\right)^\ast\label{eq:fifteenth}\tag{5}\\ --- {\rm logicalAnd} &=& {\rm bitwiseOr}\ \left("|"\ {\rm bitwiseOr}\right)^\ast\label{eq:sixteenth}\tag{6}\\ --- {\rm bitwiseOr} &=& {\rm bitwiseXor}\ \left("|"\ {\rm bitwiseXor}\right)^\ast\label{eq:tenth}\tag{7}\\ --- {\rm bitwiseXor} &=& {\rm bitwiseAnd}\ \left("\hat{}"\ {\rm bitwiseAnd}\right)^\ast\label{eq:eleventh}\tag{8}\\ --- {\rm bitwiseAnd} &=& {\rm equality}\ \left("\&"\ {\rm equality}\right)^\ast\label{eq:twelveth}\tag{9}\\ --- {\rm equality} &=& {\rm relational}\ \left("=="\ {\rm relational}\ \mid\ "!="\ {\rm relational}\right)^\ast\label{eq:fifth}\tag{10}\\ --- {\rm relational} &=& {\rm shift}\ \left("\lt"\ {\rm shift}\mid\ "\lt ="\ {\rm shift}\mid\ "\gt"\ {\rm shift}\mid\ "\gt ="\ {\rm shift}\right)^\ast\label{eq:sixth}\tag{11}\\ --- {\rm shift} &=& {\rm add}\ \left("\lt\lt"\ {\rm add}\mid\ "\gt\gt"\ {\rm add}\right)^\ast\label{eq:thirteenth}\tag{12}\\ --- {\rm add} &=& {\rm term}\ \left("+"\ {\rm term}\ \mid\ "-"\ {\rm term}\right)^\ast\label{eq:first}\tag{13} \\ --- {\rm term} &=& {\rm factor}\ \left("\ast"\ {\rm factor}\ \mid\ "/"\ {\rm factor}\right)^\ast\label{eq:second}\tag{14} \\ --- {\rm cast} &=& "(" {\rm type-name} ")"\ {\rm cast}\ \mid\ {\rm unary}\label{eq:fourteenth}\tag{15} \\ --- {\rm unary} &=& \left(\text{"+"}\ \mid\ \text{"-"}\ \mid\ \text{"*"}\ \mid\ \text{"&"}\ \mid\ \text{"!"}\ \mid\ \text{"-"}\right)\text{?}\ \text{cast}\ \mid\ \left(\text{"++"}\ \mid\ \text{"--"}\right)\ \text{unary}\ \mid\ \text{primary} \left(\text{"["}\ \text{expr}\ \text{"]"}\ \mid\ \text{"."}\ \text{ident}\ \mid\ \text{"->"}\ \text{ident}\ \mid\ \text{"++"}\ \mid\ \text{"--"}\right)\ast\label{eq:fourth}\tag{16} \\ --- {\rm factor} &=& {\rm num} \mid\ {\rm ident}\ \left({\rm "(" \left(expr\ \left(\left(","\ expr\right)^\ast\right)?\right)? ")"}\right)?\ \mid\ "(" {\rm expr} ")"\ \mid \text{string}\ \mid\ \text{"sizeof"}\ \text{"("}\ \text{type}\ \text{")"}\ \mid\ \text{"sizeof"}\ \text{unary}\ \mid\ \text{stmt-expr}\label{eq:third}\tag{17} --- \end{eqnarray} --- \] -inners :: ([HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i) -> [(T.Text, ATKind i)] -> [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -inners _ _ [] atn scp = Right ([], atn, scp) -inners f cs xs atn scp = either Left (uncurry3 (inners' f cs)) $ f xs atn scp - where - inners' _ _ [] at ars = Right ([], at, ars) - inners' g ds ys at ars = maybe' (Right (ys, at, ars)) (find (\(c, _) -> case snd (head ys) of HT.TKReserved cc -> cc == c; _ -> False) ds) $ \(_, k) -> - either Left (uncurry3 id . first3 (inners' f cs) . second3 (ATNode k (CT.SCAuto CT.CTInt) at)) $ g (tail ys) at ars - --- | `logicalOr` indicates \(\eqref{eq:fifteenth}\) among the comments of `inners`. -logicalOr :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -logicalOr = inners logicalAnd [("||", ATLOr)] - --- | `logicalAnd` indicates \(\eqref{eq:sixteenth}\) among the comments of `inners`. -logicalAnd :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -logicalAnd = inners bitwiseOr [("&&", ATLAnd)] - --- | `bitwiseOr` indicates \(\eqref{eq:tenth}\) among the comments of `inners`. -bitwiseOr :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -bitwiseOr = inners bitwiseXor [("|", ATOr)] - --- | `bitwiseXor` indicates \(\eqref{eq:eleventh}\) amont the comments of `inners`. -bitwiseXor :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -bitwiseXor = inners bitwiseAnd [("^", ATXor)] - --- | `bitwiseAnd` indicates \(\eqref{eq:twelveth}\) among the comments of `inners`. -bitwiseAnd :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -bitwiseAnd = inners equality [("&", ATAnd)] - --- | `equality` indicates \(\eqref{eq:fifth}\) among the comments of `inners`. --- This is equivalent to the following code: --- --- --- > equality :: [HT.TokenLC i] -> ATree i -> [LVar i] -> Either (ASTError i) ([HT.TokenLC i], ATree i) --- > equality xs atn scp = (>>=) (relational xs atn scp) $ uncurry3 equality' --- > where --- > equality' ((_, HT.TKReserved "=="):ys) era ars = either Left (uncurry3 id . first3 equality' . second3 (ATNode ATEQ era)) $ relational ys era ars --- > equality' ((_, HT.TKReserved "!="):ys) era ars = either Left (uncurry3 id . first3 equality' . second3 (ATNode ATNEQ era)) $ relational ys era ars --- > equality' ert era ars = Right (ert, era, ars) -equality :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -equality = inners relational [("==", ATEQ), ("!=", ATNEQ)] - --- | `relational` indicates \(\eqref{eq:sixth}\) among the comments of `inners`. -relational :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -relational = inners shift [("<", ATLT), ("<=", ATLEQ), (">", ATGT), (">=", ATGEQ)] - --- | `shift` indicates \(\eqref{eq:thirteenth}\\) among the comments of `inners`. -shift :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -shift = inners add [("<<", ATShl), (">>", ATShr)] - --- | `add` indicates \(\eqref{eq:first}\) among the comments of `inners`. -add :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -add xs atn scp = (>>=) (term xs atn scp) $ uncurry3 add' - where - add' (cur@(_, HT.TKReserved "+"):ys) era ars = (>>=) (term ys era ars) $ \zz -> - maybeToRight ("invalid operands", cur) (addKind era $ snd3 zz) >>= \nat -> uncurry3 id $ first3 add' $ second3 (const nat) zz - add' (cur@(_, HT.TKReserved "-"):ys) era ars = (>>=) (term ys era ars) $ \zz -> - maybeToRight ("invalid operands", cur) (subKind era $ snd3 zz) >>= \nat -> uncurry3 id $ first3 add' $ second3 (const nat) zz - add' ert erat ars = Right (ert, erat, ars) - --- | `term` indicates \(\eqref{eq:second}\) amont the comments of `inners`. -term :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -term = inners cast [("*", ATMul), ("/", ATDiv), ("%", ATMod)] - --- | `cast` indicates \(\eqref{eq:fourteenth}\) amont the comments of `inners`. -cast :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -cast (cur@(_, HT.TKReserved "("):xs) at scp = flip (either (const $ unary (cur:xs) at scp)) (takeTypeName xs scp) $ \case - (t, (_, HT.TKReserved ")"):xs') -> second3 (atCast t) <$> cast xs' at scp - _ -> Left ("The token ')' corresponding to '(' is expected", cur) -cast xs at scp = unary xs at scp - --- | `unary` indicates \(\eqref{eq:fourth}\) amount the comments of `inners`. -unary :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -unary ((_, HT.TKReserved "+"):xs) at scp = cast xs at scp -unary ((_, HT.TKReserved "-"):xs) at scp = second3 (ATNode ATSub (CT.SCAuto CT.CTInt) (atNumLit 0)) <$> cast xs at scp -unary ((_, HT.TKReserved "!"):xs) at scp = second3 (flip (ATNode ATNot $ CT.SCAuto CT.CTInt) ATEmpty) <$> cast xs at scp -unary ((_, HT.TKReserved "~"):xs) at scp = second3 (flip (ATNode ATBitNot $ CT.SCAuto CT.CTInt) ATEmpty) <$> cast xs at scp -unary ((_, HT.TKReserved "&"):xs) at scp = flip fmap (cast xs at scp) $ second3 $ \x -> let ty = if CT.isCTArray (atype x) then fromJust $ CT.deref (atype x) else atype x in - atUnary ATAddr (CT.mapTypeKind CT.CTPtr ty) x -unary (cur@(_, HT.TKReserved "*"):xs) at !scp = (>>=) (cast xs at scp) $ \(ert, erat, erscp) -> - maybeToRight ("invalid pointer dereference", cur) (CT.deref $ atype erat) >>= \y -> case CT.toTypeKind y of - CT.CTVoid -> Left ("void value not ignored as it ought to be", cur) - _ -> (\ty' -> (ert, atUnary ATDeref ty' erat, erscp)) <$> maybeToRight ("incomplete value dereference", cur) (incomplete y scp) -unary ((_, HT.TKReserved "++"):xs) at scp = second3 (\x -> ATNode ATPreInc (atype x) x ATEmpty) <$> unary xs at scp -unary ((_, HT.TKReserved "--"):xs) at scp = second3 (\x -> ATNode ATPreDec (atype x) x ATEmpty) <$> unary xs at scp -unary xs at scp = either Left (uncurry3 f) $ factor xs at scp - where - f (cur@(_, HT.TKReserved "["):xs') erat !erscp = (>>=) (expr xs' erat erscp) $ \(ert', erat', erscp') -> case ert' of - (_, HT.TKReserved "]"):xs'' -> maybeToRight ("invalid operands", cur) (addKind erat erat') >>= \erat'' -> - maybeToRight ("subscripted value is neither array nor pointer nor vector", HT.altEmptyToken xs) (CT.deref $ atype erat'') >>= \t -> - maybeToRight ("incomplete value dereference", cur) (incomplete t erscp') >>= \t' -> f xs'' (atUnary ATDeref t' erat'') erscp' - _ -> Left $ if null ert' then ("expected expression after '[' token", cur) else ("expected expression before '" <> tshow (snd (head ert')) <> "' token", head ert') - f (cur@(_, HT.TKReserved "."):xs') erat !erscp - | CT.isCTStruct (atype erat) || CT.isIncompleteStruct (atype erat) = if null xs' then Left ("expected identifier at end of input", cur) else case head xs' of - (_, HT.TKIdent ident) -> maybeToRight ("incomplete type '" <> tshow (atype erat) <> "'", cur) (incomplete (atype erat) erscp) >>= \t -> - maybeToRight ("no such member", cur) (CT.lookupMember ident (CT.toTypeKind t)) >>= \mem -> - f (tail xs') (atMemberAcc mem erat) erscp - _ -> Left ("expected identifier after '.' token", cur) - | otherwise = Left ("request for a member in something not a structure or union", cur) - f (cur@(_, HT.TKReserved "->"):xs') erat !erscp - | maybe False CT.isCTStruct (CT.deref $ atype erat) || maybe False CT.isIncompleteStruct (CT.deref $ atype erat) = if null xs' then Left ("expected identifier at end of input", cur) else - case head xs' of - (_, HT.TKIdent ident) -> maybeToRight ("incomplete type '" <> tshow (atype erat) <> "'", cur) (incomplete (fromJust (CT.deref $ atype erat)) erscp) >>= \t -> - maybeToRight ("no such member", cur) (CT.lookupMember ident (CT.toTypeKind t)) >>= \mem -> - f (tail xs') (atMemberAcc mem (atUnary ATDeref (CT.SCAuto $ CT.smType mem) erat)) erscp - _ -> Left ("expected identifier after '->' token", cur) - | otherwise = Left ("invalid type argument of '->'" <> if CT.isCTUndef (atype erat) then "" else " (have '" <> tshow (atype erat) <> "')", cur) - f ((_, HT.TKReserved "++"):xs') erat !erscp = f xs' (atUnary ATPostInc (atype erat) erat) erscp - f ((_, HT.TKReserved "--"):xs') erat !erscp = f xs' (atUnary ATPostDec (atype erat) erat) erscp - f ert erat !erscp = Right (ert, erat, erscp) - --- | `factor` indicates \(\eqref{eq:third}\) amount the comments of `inners`. -factor :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -factor [] atn !scp = Right ([], atn, scp) -factor tk@((_, HT.TKReserved "("):((_, HT.TKReserved "{"):_)) at !scp = stmtExpr tk at scp -factor (cur@(_, HT.TKReserved "("):xs) atn !scp = (>>=) (expr xs atn scp) $ \(ert, erat, erscp) -> case ert of -- for (expr) - (_, HT.TKReserved ")"):ys -> Right (ys, erat, erscp) - ert' -> Left $ expectedMessage ")" cur ert' -factor ((_, HT.TKNum n):xs) _ !scp = Right (xs, atNumLit n, scp) -- for numbers -factor (cur@(_, HT.TKIdent v):(_, HT.TKReserved "("):(_, HT.TKReserved ")"):xs) _ !scp = case lookupFunction v scp of -- for no arguments function call - Nothing -> Right (xs, atNoLeaf (ATCallFunc v Nothing) (CT.SCAuto CT.CTInt), pushWarn ("the function '" <> v <> "' is not declared.") cur scp) - Just fn -> Right (xs, atNoLeaf (ATCallFunc v Nothing) (PSF.fntype fn), scp) -factor (cur1@(_, HT.TKIdent v):cur2@(_, HT.TKReserved "("):xs) _ scp = (>>=) (maybeToRight (internalCE, cur1) (takeBrace "(" ")" (cur2:xs))) $ -- for some argumets function call - either (Left . ("invalid function call",)) $ \(fsec, ds) -> case lookupFunction v scp of - Nothing -> f fsec ds (pushWarn ("The function '" <> tshow (snd cur1) <> "' is not declared.") cur1 scp) $ CT.SCAuto CT.CTInt - Just fn -> f fsec ds scp (PSF.fntype fn) - where - f fsec ds scp' t = maybeToRight ("invalid function call", cur1) (takeExps fsec) >>= \exps -> runST $ do - mk <- newSTRef scp' - expl <- forM exps $ \etk -> readSTRef mk >>= either (return . Left) (\(_, erat, ervar) -> Right erat <$ writeSTRef mk ervar) . expr etk ATEmpty - if any isLeft expl then return $ Left $ head $ lefts expl else do - scp'' <- readSTRef mk - return $ Right (ds, atNoLeaf (ATCallFunc v (Just $ rights expl)) t, scp'') -factor (cur0@(_, HT.TKSizeof):cur@(_, HT.TKReserved "("):xs) atn scp = case takeTypeName xs scp of - Left _ -> second3 (atNumLit . fromIntegral . CT.sizeof . atype) <$> unary (cur:xs) atn scp -- for `sizeof(variable)` - Right (t, (_, HT.TKReserved ")"):ds) -> (ds, , scp) . atNumLit . fromIntegral . CT.sizeof <$> - maybeToRight ("invalid application of 'sizeof' to incomplete type '" <> tshow (CT.toTypeKind t) <> "'", cur0) (incomplete t scp) - Right _ -> Left ("The token ')' corresponding to '(' is expected", cur) -factor ((_, HT.TKSizeof):xs) atn !scp = second3 (atNumLit . fromIntegral . CT.sizeof . atype) <$> unary xs atn scp -- for `sizeof variable` -- TODO: the type of sizeof must be @size_t@ -factor (cur@(_, HT.TKAlignof):xs) atn !scp = (>>=) (unary xs atn scp) $ \(ert, erat, erscp) -> - if CT.isCTUndef (atype erat) then Left ("_Alignof must be an expression or type", cur) else Right (ert, atNumLit $ fromIntegral $ CT.alignof $ atype erat, erscp) -- Note: Using alignof for expressions is a non-standard feature of C11 -factor (cur@(_, HT.TKString slit):xs) _ !scp = uncurry (xs,,) <$> addLiteral (CT.SCAuto $ CT.CTArray (fromIntegral $ B.length slit) CT.CTChar) cur scp -- for literals -factor (cur@(_, HT.TKIdent ident):xs) _ !scp = case lookupVar ident scp of - FoundGVar (PV.GVar t _) -> Right (xs, atGVar t ident, scp) -- for declared global variable - FoundLVar sct -> Right (xs, treealize sct, scp) -- for declared local variable - FoundEnum sct -> Right (xs, treealize sct, scp) -- for declared enumerator - NotFound -> Left ("The '" <> ident <> "' is not defined variable", cur) -factor ert _ _ = Left (if null ert then "unexpected token in program" else "unexpected token '" <> tshow (snd (head ert)) <> "' in program", HT.altEmptyToken ert) - -{-# INLINE parse #-} --- | Constructs the abstract syntax tree based on the list of token strings. --- if construction fails, `parse` returns the error message and the token at the error location. --- Otherwise, `parse` returns a list of abstract syntax trees, a set of global variables, and a list of literals. -parse :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ASTResult i -parse = fmap (\(ast, sc) -> (warns sc, ast, PV.globals $ vars $ scope sc, PV.literals $ vars $ scope sc)) . flip program initConstructionData - --- | `stackSize` returns the stack size of variable per function. -stackSize :: (Show i, Integral i) => ATree i -> Natural -stackSize (ATNode (ATDefFunc _ args) _ body _) = let ms = f body $ maybe S.empty (foldr (\(ATNode (ATLVar t x) _ _ _) acc -> S.insert (t, x) acc) S.empty) args in - if S.size ms == 1 then toNatural $ flip CT.alignas 8 $ toInteger $ CT.sizeof $ fst $ head (S.toList ms) else toNatural $ flip CT.alignas 8 $ uncurry (+) $ - first (toInteger . CT.sizeof . fst) $ second (fromIntegral . snd) $ dupe $ foldl' (\acc x -> if snd acc < snd x then x else acc) (CT.SCUndef CT.CTUndef, 0) $ S.toList ms - where - f ATEmpty !s = s - f (ATNode (ATCallFunc _ (Just arg)) t l r) !s = f (ATNode (ATBlock arg) t l r) s - f (ATNode (ATLVar t x) _ l r) !s = let i = S.insert (t, x) s in f l i `S.union` f r i - f (ATNode (ATBlock xs) _ l r) !s = let i = foldr (S.union . (`f` s)) s xs in f l i `S.union` f r i - f (ATNode (ATStmtExpr xs) t l r) !s = f (ATNode (ATBlock xs) t l r) s - f (ATNode (ATFor xs) _ l r) !s = let i = foldr (S.union . flip f s . fromATKindFor) S.empty xs in f l i `S.union` f r i - f (ATNode (ATNull x) _ _ _) !s = f x s - f (ATNode _ _ l r) !s = f l s `S.union` f r s -stackSize _ = 0 - diff --git a/src/Htcc/Parser/Parsing/Core.hs-boot b/src/Htcc/Parser/Parsing/Core.hs-boot deleted file mode 100644 index a56fa51..0000000 --- a/src/Htcc/Parser/Parsing/Core.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module Htcc.Parser.Parsing.Core where - -import Data.Bits (Bits) -import Htcc.Tokenizer (TokenLC) -import Htcc.Parser.ConstructionData (ConstructionData) -import Htcc.Parser.AST (ATree, ASTConstruction) -import qualified Htcc.Tokenizer as HT - -stmt :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i - -conditional :: (Show i, Read i, Integral i, Bits i) => [TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i - diff --git a/src/Htcc/Parser/Parsing/Global.hs b/src/Htcc/Parser/Parsing/Global.hs deleted file mode 100644 index 702e32d..0000000 --- a/src/Htcc/Parser/Parsing/Global.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE BangPatterns, LambdaCase, OverloadedStrings #-} -{-| -Module : Htcc.Parser.Parsing.Global -Description : The C languge parser and AST constructor -Copyright : (c) roki, 2019 -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -The module of the globals --} -module Htcc.Parser.Parsing.Global ( - globalDef -) where - -import Data.Bits - -import Htcc.Parser.AST -import Htcc.Parser.ConstructionData -import Htcc.Parser.Parsing.Global.Function -import Htcc.Parser.Parsing.Global.Var -import Htcc.Parser.Parsing.Type (takeType) -import Htcc.Parser.Parsing.Typedef -import qualified Htcc.Tokenizer as HT -import Htcc.Utils (uncurry4) - --- | `globalDef` parses global definitions (include functions and global variables) --- \[ --- \text{global-def}=\left(\text{global-var}\ \mid\ \text{function}\right)\text{*} --- \] -globalDef :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -globalDef (cur@(_, HT.TKReserved "register"):_) _ _ = Left ("illegal storage class on file-scoped identifier", cur) -globalDef (cur@(_, HT.TKReserved "auto"):_) _ _ = Left ("illegal storage class on file-scoped identifier", cur) -globalDef xs@((_, HT.TKTypedef):_) _ sc = typedef xs sc -- for global @typedef@ -globalDef tks at !va = (>>=) (takeType tks va) $ \case - (_, Nothing, (_, HT.TKReserved ";"):ds', scp) -> Right (ds', ATEmpty, scp) -- e.g., @int;@ is legal in C11 (See N1570/section 6.7 Declarations) - (funcType, ident@(Just (_, HT.TKIdent _)), tk@((_, HT.TKReserved "("):_), !sc) -> function funcType ident tk at sc - p@(_, Just (_, HT.TKIdent _), _, _) -> uncurry4 var p - _ -> Left ("invalid definition of global identifier", HT.altEmptyToken tks) diff --git a/src/Htcc/Parser/Parsing/Global.hs-boot b/src/Htcc/Parser/Parsing/Global.hs-boot deleted file mode 100644 index 2c26ff2..0000000 --- a/src/Htcc/Parser/Parsing/Global.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -module Htcc.Parser.Parsing.Global where - -import Data.Bits -import Htcc.Parser.AST -import Htcc.Parser.ConstructionData -import qualified Htcc.Tokenizer as HT - -globalDef :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i diff --git a/src/Htcc/Parser/Parsing/Global/Function.hs b/src/Htcc/Parser/Parsing/Global/Function.hs deleted file mode 100644 index 7980e49..0000000 --- a/src/Htcc/Parser/Parsing/Global/Function.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE BangPatterns, LambdaCase, OverloadedStrings, ScopedTypeVariables, - TupleSections #-} -{-| -Module : Htcc.Parser.Parsing.Global.Function -Description : The C languge parser and AST constructor -Copyright : (c) roki, 2019 -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -The function declaration --} -module Htcc.Parser.Parsing.Global.Function ( - function -) where - -import Control.Monad.Loops (unfoldrM) -import Control.Monad.ST (runST) -import Data.Bits hiding (shift) -import Data.List (find) -import Data.List.Split (linesBy) -import Data.Maybe (fromMaybe, isJust) -import Data.STRef (newSTRef, readSTRef, - writeSTRef) -import Prelude hiding (toInteger) - -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST -import Htcc.Parser.ConstructionData -import Htcc.Parser.ConstructionData.Scope.Utils (internalCE) -import {-# SOURCE #-} Htcc.Parser.Parsing.Core (stmt) -import {-# SOURCE #-} Htcc.Parser.Parsing.Global (globalDef) -import Htcc.Parser.Parsing.Type -import Htcc.Parser.Utils -import qualified Htcc.Tokenizer as HT -import Htcc.Utils (maybe', maybeToRight, - tshow) - --- | --- \[ --- \begin{array}{ccc} --- \text{function}&=&\text{pre-type}\ \text{declaration}\ \text{"("}\ \text{params?}\ \text{")"}\ \left(\text{"\{"}\ \text{stmt*}\ \text{"\}"}\ \mid\ \text{";"}\right)\\ --- \text{params}&=&\text{params}\left(\text{","}\ \text{param}\right)\text{*}\\ --- \text{param}&=&\text{pre-type}\ \text{declaration}\ \text{array-decl-suffix} --- \end{array} --- \] -function :: (Show i, Read i, Integral i, Bits i) => CT.StorageClass i -> Maybe (HT.TokenLC i) -> [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -function funcType (Just cur@(_, HT.TKIdent fname)) tk@((_, HT.TKReserved "("):_) at !sc = let scp = resetLocal sc in - (>>=) (maybeToRight (internalCE, cur) (takeBrace "(" ")" $ tail (cur:tk))) $ - either (Left . ("invalid function declaration/definition",)) $ \(fndec, st) -> case st of - ((_, HT.TKReserved ";"):ds'') -> addFunction False funcType cur scp >>= globalDef ds'' at -- for a function declaration -- TODO: read types of parameters and register them - ((_, HT.TKReserved "{"):_) -> (>>=) (addFunction True funcType cur scp) $ \scp' -> checkErr fndec scp' $ \args -> runST $ do -- for a function definition - eri <- newSTRef Nothing - v <- newSTRef scp' - mk <- flip unfoldrM args $ \args' -> if null args' then return Nothing else let arg = head args' in do - -- About @t'@: - -- An array of type T is equivalent to a pointer of type T in the context of function parameters. - m <- flip fmap (readSTRef v) $ \scp'' -> let (t, mident, _, _) = arg; t' = fromMaybe t $ aboutArray t in case mident of - Nothing -> Left ("anonymouse variable is not implemented yet", cur) -- TODO - Just ident -> addLVar t' ident scp'' - flip (either ((<$) Nothing . writeSTRef eri . Just)) m $ \(vat, scp'') -> Just (vat, tail args') <$ writeSTRef v scp'' - (>>=) (readSTRef eri) $ flip maybe (return . Left) $ flip fmap (readSTRef v) $ \v' -> (>>=) (stmt st at v') $ \case -- Forbid void to return a value in a return type function. - (ert, erat@(ATNode (ATBlock block) _ _ _), erscp) - | CT.toTypeKind funcType == CT.CTVoid -> if isJust (find isNonEmptyReturn block) then - Left ("The return type of function '" <> fname <> "' is void, but the statement returns a value", cur) else - Right (ert, atDefFunc fname (if null mk then Nothing else Just mk) funcType erat, erscp) - | otherwise -> let fnode = atDefFunc fname (if null mk then Nothing else Just mk) funcType erat in - maybe' (Right (ert, fnode, erscp)) (find isEmptyReturn block) $ const $ - Right (ert, fnode, pushWarn ("The return type of function '" <> fname <> "' is " <> tshow (CT.toTypeKind funcType) <> ", but the statement returns no value") cur erscp) - _ -> Left (internalCE, HT.emptyToken) - _ -> stmt tk at scp - where - checkErr ar !scp' f = let ar' = init $ tail ar in if not (null ar') && snd (head ar') == HT.TKReserved "," then Left ("unexpected ',' token", head ar') else - let args = linesBy ((==HT.TKReserved ",") . snd) ar' in mapM (`takeType` scp') args >>= f - aboutArray t - | CT.isCTArray t = CT.mapTypeKind CT.CTPtr <$> CT.deref t - | CT.isIncompleteArray t = Just $ CT.mapTypeKind (\(CT.CTIncomplete (CT.IncompleteArray t')) -> CT.CTPtr t') t - | otherwise = Nothing -function _ _ xs _ _ = Left (internalCE, HT.altEmptyToken xs) diff --git a/src/Htcc/Parser/Parsing/Global/Var.hs b/src/Htcc/Parser/Parsing/Global/Var.hs deleted file mode 100644 index ae419a2..0000000 --- a/src/Htcc/Parser/Parsing/Global/Var.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, - TupleSections #-} -{-| -Module : Htcc.Parser.Parsing.Global.Var -Description : The C languge parser and AST constructor -Copyright : (c) roki, 2019 -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -The Global variable declaration --} -module Htcc.Parser.Parsing.Global.Var ( - var -) where - -import Data.Bits hiding (shift) -import Prelude hiding - (toInteger) - -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST -import Htcc.Parser.ConstructionData -import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) -import Htcc.Parser.ConstructionData.Scope.Utils (internalCE) -import qualified Htcc.Parser.ConstructionData.Scope.Var as PV -import {-# SOURCE #-} Htcc.Parser.Parsing.Core (conditional) -import Htcc.Parser.Parsing.Type -import qualified Htcc.Tokenizer as HT -import Htcc.Utils (maybeToRight, - tshow) - -gvarInit :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> CT.StorageClass i -> HT.TokenLC i -> ConstructionData i -> Either (ASTError i) ([HT.TokenLC i], ConstructionData i) -gvarInit xs ty ident sc = do - (ds, ast, sc') <- conditional xs ATEmpty sc - case (atkind ast, atkind (atL ast)) of - (ATAddr, ATGVar _ name) -> (ds,) . snd <$> gvarInitWithOG ty ident name sc' - (ATAddr, _) -> Left ("invalid initializer in global variable", HT.altEmptyToken ds) - (ATGVar t name, _) - | CT.isCTArray t -> (ds,) . snd <$> gvarInitWithOG ty ident name sc' - | otherwise -> gvarInitWithVal ds sc' - _ -> gvarInitWithVal ds sc' - where - gvarInitWithOG ty' from to = addGVarWith ty' from (PV.GVarInitWithOG to) - gvarInitWithVal ds sc' = do - (ds', cval) <- either (maybe (Left ("initializer element is not constant", HT.altEmptyToken ds)) Left) Right $ constantExp xs sc' - (ds',) . snd <$> addGVarWith ty ident (PV.GVarInitWithVal cval) sc' - --- | \[ --- \text{global-var} = \text{pre-type}\ \text{declaration}\ \text{array-decl-suffix}\ \text{";"} --- \] -var :: (Show i, Read i, Integral i, Bits i) => CT.StorageClass i -> Maybe (HT.TokenLC i) -> [HT.TokenLC i] -> ConstructionData i -> ASTConstruction i -var ty (Just cur@(_, HT.TKIdent _)) xs !scp = case xs of - (_, HT.TKReserved "="):ds -> do -- for initializing - ty' <- maybeToRight ("defining global variables with a incomplete type", cur) (incomplete ty scp) - (ds', nsc) <- gvarInit ds ty' cur scp - case ds' of - (_, HT.TKReserved ";"):ds'' -> return (ds'', ATEmpty, nsc) - _ -> Left $ if null ds' then - ("expected ';' token after '" <> tshow (snd cur) <> "' token", HT.altEmptyToken ds') else - ("expected ';' token" <> (if null ds' then "" else " before '" <> tshow (snd $ head ds') <> "' token"), HT.altEmptyToken ds') - (_, HT.TKReserved ";"):ds -> do -- for non initializing - ty' <- maybeToRight ("defining global variables with a incomplete type", cur) (incomplete ty scp) - (ds, ATEmpty,) . snd <$> addGVar ty' cur scp - _ -> Left ("expected ';' token after '" <> tshow (snd cur) <> "' token", cur) -var _ _ xs _ = Left (internalCE, HT.altEmptyToken xs) - diff --git a/src/Htcc/Parser/Parsing/StmtExpr.hs b/src/Htcc/Parser/Parsing/StmtExpr.hs deleted file mode 100644 index 14317b3..0000000 --- a/src/Htcc/Parser/Parsing/StmtExpr.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE BangPatterns, LambdaCase, OverloadedStrings, ScopedTypeVariables, - TupleSections #-} -{-| -Module : Htcc.Parser.Parsing.StmtExpr -Description : The C languge parser and AST constructor -Copyright : (c) roki, 2019 -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -The module of the statement expression (GNU extension: ) --} -module Htcc.Parser.Parsing.StmtExpr ( - stmtExpr -) where - -import Control.Monad (when) -import Control.Monad.Loops (unfoldrM) -import Control.Monad.ST (runST) -import Data.Bits hiding (shift) -import Data.STRef (newSTRef, readSTRef, - writeSTRef) -import Prelude hiding (toInteger) - -import Htcc.Parser.AST -import Htcc.Parser.ConstructionData -import Htcc.Parser.ConstructionData.Scope.Utils (internalCE) -import {-# SOURCE #-} Htcc.Parser.Parsing.Core (stmt) -import Htcc.Parser.Utils -import qualified Htcc.Tokenizer as HT -import Htcc.Utils (maybeToRight, tshow) - --- | statement expression (GNU extension: ) --- \[\text{stmt-expr}=\text{"("}\ \text{"\{"}\ \text{stmt}\ \text{stmt*}\ \text{"\}"}\ \text{")"}\] -stmtExpr :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i -stmtExpr ((_, HT.TKReserved "("):xs@((_, HT.TKReserved "{"):_)) _ !scp = (>>=) (maybeToRight (internalCE, head xs) (takeBrace "{" "}" xs)) $ - either (Left . ("the statement expression is not closed",)) $ \(sctk, ds) -> case ds of - (_, HT.TKReserved ")"):ds' -> runST $ do - eri <- newSTRef Nothing - v <- newSTRef $ succNest scp - lastA <- newSTRef ATEmpty - mk <- flip unfoldrM (init $ tail sctk) $ \ert -> if null ert then return Nothing else do - erscp <- readSTRef v - flip (either $ \err -> Nothing <$ writeSTRef eri (Just err)) (stmt ert ATEmpty erscp) $ \(ert', erat', erscp') -> - Just (erat', ert') <$ (writeSTRef v erscp' >> when (case erat' of ATEmpty -> False; _ -> True) (writeSTRef lastA erat')) - (>>=) (readSTRef eri) $ flip maybe (return . Left) $ do - v' <- readSTRef v - flip fmap (readSTRef lastA) $ \case - (ATNode ATExprStmt _ lhs _) -> Right (ds', atNoLeaf (ATStmtExpr (init mk ++ [lhs])) (atype lhs), fallBack scp v') - _ -> Left ("void value not ignored as it ought to be. the statement expression starts here:", head xs) - _ -> Left $ if null sctk then ("expected ')' token. the statement expression starts here: ", head xs) else - ("expected ')' token after '" <> tshow (snd $ last sctk) <> "' token", last sctk) -stmtExpr xs _ _ = Left (internalCE, HT.altEmptyToken xs) diff --git a/src/Htcc/Parser/Parsing/Type.hs b/src/Htcc/Parser/Parsing/Type.hs deleted file mode 100644 index bced49a..0000000 --- a/src/Htcc/Parser/Parsing/Type.hs +++ /dev/null @@ -1,278 +0,0 @@ -{-# LANGUAGE BangPatterns, LambdaCase, OverloadedStrings, ScopedTypeVariables, - TupleSections #-} -{-| -Module : Htcc.Parser.Parsing.Type -Description : The C languge parser and AST constructor -Copyright : (c) roki, 2019 -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -The module of the Type parsing --} -module Htcc.Parser.Parsing.Type ( - -- * Constant - ConstantResult, - constantExp, - -- * Utilities - isTypeName, - -- * Structure and Enum - takeStructFields, - takeEnumFiels, - -- * Declarations - arrayDeclSuffix, - absDeclaration, - declaration, - -- * Type - takePreType, - takeType, - takeTypeName -) where - -import Data.Bits hiding (shift) -import Data.Bool (bool) -import qualified Data.Map.Strict as M -import Data.Maybe (fromJust, - fromMaybe, - isJust) -import qualified Data.Text as T -import Data.Tuple.Extra (dupe, first, - uncurry3) -import Prelude hiding - (toInteger) - -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST -import Htcc.Parser.ConstructionData -import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) -import qualified Htcc.Parser.ConstructionData.Scope.Tag as PST -import qualified Htcc.Parser.ConstructionData.Scope.Typedef as PSD -import Htcc.Parser.ConstructionData.Scope.Utils (internalCE) -import {-# SOURCE #-} Htcc.Parser.Parsing.Core (conditional) -import Htcc.Parser.Utils -import qualified Htcc.Tokenizer as HT -import Htcc.Utils (dropFst3, - dropFst4, - dropSnd3, - first3, - maybe', - maybeToRight, - spanLen, - toInteger, - toNatural, - tshow) - --- | \[ --- \begin{array}{ccc} --- \text{struct-decl}&=&\text{"struct"}\ \text{ident?}\ \left(\text{"\{"}\ \text{struct-member}\ \text{"\}"}\right)\text{?}\\ --- \text{struct-member}&=&\text{pre-type}\ \text{declaration}\ \text{array-decl-suffix}\ \text{";"} --- \end{array} --- \] -takeStructFields :: (Integral i, Show i, Read i, Bits i) => [HT.TokenLC i] -> ConstructionData i -> Either (ASTError i) (M.Map T.Text (CT.StructMember i), ConstructionData i) -takeStructFields tk sc = takeStructFields' tk sc 0 - where - takeStructFields' [] scp' _ = Right (M.empty, scp') - takeStructFields' fs scp' !n = (>>=) (takeType fs scp' >>= validDecl (HT.altEmptyToken tk)) $ \case - (ty@(CT.SCAuto _), Just (_, HT.TKIdent ident), (_, HT.TKReserved ";"):ds, scp'') -> let ofs = toNatural $ CT.alignas (toInteger n) $ toInteger $ CT.alignof ty in - first (M.insert ident (CT.StructMember (CT.toTypeKind ty) ofs)) <$> takeStructFields' ds scp'' (ofs + fromIntegral (CT.sizeof ty)) - (_, Just _, _, _) -> Left ("invalid storage-class specifier", head fs) - _ -> Left ("expected member name or ';' after declaration specifiers", HT.altEmptyToken fs) - validDecl _ (t, Just ident, tks, scp) = maybeToRight ("declaration with incomplete type", ident) (incomplete t scp) >>= \t' -> if CT.toTypeKind t == CT.CTVoid then - Left ("variable or field '" <> tshow (snd ident) <> "' declarated void", ident) else Right (t', Just ident, tks, scp) - validDecl errPlaceholder (t, noth, tks, scp) = maybeToRight ("declaration with incomplete type", errPlaceholder) (incomplete t scp) >>= \t' -> if CT.toTypeKind t == CT.CTVoid then - Left ("declarations of type void is invalid in this context", errPlaceholder) else Right (t', noth, tks, scp) - --- | \[ --- \begin{array}{ccc} --- \text{enum-specifier}&=&\text{"enum"}\ \text{ident}\ \mid\ \text{"enum"}\ \text{ident?}\ \text{"\{"}\ \text{enum-list?}\ \text{"\}"}\\ --- \text{enum-list}&=&\text{enum-elem}\ \left(\text{","}\ \text{enum-elem}\right)\ast\ \text{","?}\\ --- \text{enum-elem}&=&\text{ident}\ \left(\text{"="}\ \text{const-expr}\right)\text{?} --- \end{array} --- \] -takeEnumFiels :: (Integral i, Show i, Read i, Bits i) => CT.StorageClass i -> [HT.TokenLC i] -> ConstructionData i -> Either (ASTError i) (M.Map T.Text i, ConstructionData i) -takeEnumFiels = takeEnumFiels' 0 - where - takeEnumFiels' !n ty [cur@(_, HT.TKIdent ident)] scp = (M.singleton ident n,) <$> addEnumerator ty cur n scp - takeEnumFiels' !n ty (cur@(_, HT.TKIdent ident):(_, HT.TKReserved ","):xs) scp = (>>=) (takeEnumFiels' (succ n) ty xs scp) $ \(m, scp') -> - (M.insert ident n m,) <$> addEnumerator ty cur n scp' - takeEnumFiels' _ ty (cur@(_, HT.TKIdent ident):(_, HT.TKReserved "="):xs) scp = case constantExp xs scp of - Left (Just err) -> Left err - Left Nothing -> Left ("The enumerator value for '" <> tshow (snd cur) <> "' is not an integer constant", cur) - Right ((_, HT.TKReserved ","):ds, val) -> (>>=) (takeEnumFiels' (succ val) ty ds scp) $ \(m, scp') -> - (M.insert ident val m,) <$> addEnumerator ty cur val scp' - Right (ds, val) -> (>>=) (takeEnumFiels' (succ val) ty ds scp) $ \(m, scp') -> - (M.insert ident val m,) <$> addEnumerator ty cur val scp' - takeEnumFiels' _ _ ds _ = let lst = if null ds then HT.emptyToken else last ds in - Left ("expected enum identifier_opt { enumerator-list } or enum identifier_opt { enumerator-list , }", lst) - -{-# INLINE takeCtorPtr #-} -takeCtorPtr :: Integral i => [HT.TokenLC i] -> (CT.StorageClass i -> CT.StorageClass i, [HT.TokenLC i]) -takeCtorPtr = first (CT.ctorPtr . toNatural) . dropSnd3 . spanLen ((==HT.TKReserved "*") . snd) - --- | It is obtained by parsing the front part of the type from the token string. --- e.g. @int (*)[4]@ applied to this function yields @int@. --- --- \[\begin{array}{ccc} --- \text{pre-type}&=&\text{builtin-type}\ \mid\ \text{struct-decl}\ \mid\ \text{typedef-name}\ \mid\ \text{enum-specifier}\\ --- \text{builtin-type}&=&\text{"void"}\ \mid\ \text{"_Bool"}\ \mid\ \text{"char"}\ \mid\ \text{"short"}\ \mid\ \text{"int"}\ \mid\ \text{"long"}\ \mid\ \text{"long "long"} --- \end{array} --- \] -takePreType :: (Integral i, Show i, Read i, Bits i) => [HT.TokenLC i] -> ConstructionData i -> Either (ASTError i) (CT.StorageClass i, [HT.TokenLC i], ConstructionData i) -takePreType ((_, HT.TKType ty1):y@(iy, HT.TKType ty2):xs) scp = maybeToRight (T.singleton '\'' <> tshow ty1 <> " " <> tshow ty2 <> "' is invalid.", y) (CT.qualify ty1 ty2) >>= \ty -> -- for a complex type - takePreType ((iy, HT.TKType ty):xs) scp -takePreType ((_, HT.TKType ty):xs) scp = Right (CT.SCAuto $ CT.toTypeKind $ CT.implicitInt ty, xs, scp) -- for fundamental type -takePreType ((_, HT.TKStruct):cur@(_, HT.TKReserved "{"):xs) scp = maybeToRight (internalCE, cur) (takeBrace "{" "}" (cur:xs)) >>= -- for @struct@ definition - either (Left . ("expected '}' token to match this '{'",)) (\(field, ds) -> uncurry (,ds,) . first (CT.SCAuto . CT.CTStruct) <$> takeStructFields (tail $ init field) scp) -takePreType ((_, HT.TKStruct):cur1@(_, HT.TKIdent ident):cur2@(_, HT.TKReserved "{"):xs) scp = (>>=) (maybeToRight (internalCE, cur1) (takeBrace "{" "}" (cur2:xs))) $ -- for @struct@ definition with tag - either (Left . ("expected '}' token to match this '{'",)) $ \(field, ds) -> (>>=) (addTag (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteStruct ident) cur1 scp) $ \scp' -> - (>>=) (takeStructFields (tail $ init field) scp') $ \(mem, scp'') -> let ty = CT.SCAuto $ CT.CTStruct mem in addTag ty cur1 scp'' >>= Right . (ty, ds,) -takePreType ((_, HT.TKStruct):cur1@(_, HT.TKIdent ident):xs) scp = case lookupTag ident scp of -- for variable declaration with @struct@ tag - Nothing -> let ty = CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteStruct ident in (>>=) (addTag ty cur1 scp) $ \scp' -> Right (ty, xs, scp') - Just ty -> Right (PST.sttype ty, xs, scp) -takePreType (cur@(_, HT.TKIdent ident):xs) scp = (, xs, scp) . PSD.tdtype <$> maybeToRight (T.singleton '\'' <> tshow (snd cur) <> "' is not a type or also a typedef identifier", cur) (lookupTypedef ident scp) -- for declaration variable with @typedef@ -takePreType ((_, HT.TKEnum):cur@(_, HT.TKReserved "{"):xs) scp = (>>=) (maybeToRight (internalCE, cur) (takeBrace "{" "}" (cur:xs))) $ -- for @enum@ - either (Left . ("expected '}' token to match this '{'",)) $ \(field, ds) -> uncurry (,ds,) . first (CT.SCAuto . CT.CTEnum CT.CTInt) <$> takeEnumFiels (CT.SCAuto CT.CTInt) (tail $ init field) scp -takePreType ((_, HT.TKEnum):cur1@(_, HT.TKIdent _):cur2@(_, HT.TKReserved "{"):xs) scp = (>>=) (maybeToRight (internalCE, cur1) (takeBrace "{" "}" (cur2:xs))) $ -- for @enum@ with tag - either (Left . ("expected '}' token to match this '{'",)) $ \(field, ds) -> (>>=) (takeEnumFiels (CT.SCAuto CT.CTInt) (tail $ init field) scp) $ \(mem, scp') -> let ty = CT.SCAuto $ CT.CTEnum CT.CTInt mem in - addTag ty cur1 scp' >>= Right . (ty, ds,) -takePreType ((_, HT.TKEnum):cur1@(_, HT.TKIdent ident):xs) scp = (, xs, scp) . PST.sttype <$> maybeToRight ("storage size of '" <> ident <> "' isn't known", cur1) (lookupTag ident scp) -- declaration for @enum@ -takePreType ((_, HT.TKReserved _):cur@(_, HT.TKReserved _):_) _ = Left ("cannot combine with previous '" <> tshow (snd cur) <> "' declaration specifier", cur) -takePreType ((_, HT.TKReserved "static"):xs) scp = first3 (CT.SCStatic . CT.toTypeKind) <$> takePreType xs scp -takePreType ((_, HT.TKReserved "register"):xs) scp = first3 (CT.SCRegister . CT.toTypeKind) <$> takePreType xs scp -takePreType ((_, HT.TKReserved "auto"):xs) scp = takePreType xs scp -takePreType (x:_) _ = Left ("ISO C forbids declaration with no type", x) -takePreType _ _ = Left ("ISO C forbids declaration with no type", HT.emptyToken) - -{-# INLINE declaration #-} --- | \[ --- \text{declaration} = \text{"*"*}\ \left(\text{"("}\ \text{declaration}\ \text{")"}\ \mid\ \text{ident}\right)\ \text{array-decl-suffix} --- \] -declaration :: (Integral i, Bits i, Show i, Read i) => CT.StorageClass i -> [HT.TokenLC i] -> ConstructionData i -> Either (ASTError i) (CT.StorageClass i, Maybe (HT.TokenLC i), [HT.TokenLC i]) -declaration ty xs scp = case takeCtorPtr xs of - (fn, xs'@((_, HT.TKReserved "("):_)) -> dropFst4 <$> declaration' id (fn ty) xs' scp - (fn, ident@(_, HT.TKIdent _):ds') -> case arrayDeclSuffix (fn ty) ds' scp of - Nothing -> Right (fn ty, Just ident, ds') - Just rs -> uncurry (,Just ident,) <$> rs - (fn, es) -> Right (fn ty, Nothing, es) - where - declaration' fn ty' xs' scp' = case takeCtorPtr xs' of - (ptrf, cur@(_, HT.TKReserved "("):ds') -> (>>=) (declaration' (fn . ptrf) ty' ds' scp') $ \case - (ptrf', ty'', ident, (_, HT.TKReserved ")"):ds'') -> case arrayDeclSuffix ty'' ds'' scp' of - Nothing -> Right (id, ptrf' ty', ident, ds'') - Just rs -> uncurry (id,,ident,) . first ptrf' <$> rs - _ -> Left ("expected ')' token for this '('", cur) - (ptrf, ident@(_, HT.TKIdent _):ds') -> case arrayDeclSuffix ty' ds' scp' of - Nothing -> Right (ptrf, ty', Just ident, ds') - Just rs -> uncurry (ptrf,,Just ident,) <$> rs - _ -> Left ("expected some identifier", HT.emptyToken) - --- | `takeType` returns a pair of type (including pointer and array type) and the remaining tokens wrapped in --- `Just` only if the token starts with `HT.TKType`, `HT.TKStruct` or identifier that is declarated by @typedef@. --- Otherwise `Nothing` is returned. --- --- \[ --- \text{type}=\text{pre-type}\ \text{declaration} --- \] -takeType :: (Integral i, Show i, Read i, Bits i) => [HT.TokenLC i] -> ConstructionData i -> Either (ASTError i) (CT.StorageClass i, Maybe (HT.TokenLC i), [HT.TokenLC i], ConstructionData i) -takeType tk scp = takePreType tk scp >>= (\(x, y, z) -> uncurry3 (,,, z) <$> declaration x y z) - - --- | `absDeclaration` parses abstract type declarations: --- --- \[ --- \text{abs-declaration} = \text{"*"*}\ \left(\text{"("}\ \text{abs-declaration}\ \text{")"}\right)\text{?}\ \text{array-decl-suffix} --- \] -absDeclaration :: (Integral i, Bits i, Show i, Read i) => CT.StorageClass i -> [HT.TokenLC i] -> ConstructionData i -> Either (ASTError i) (CT.StorageClass i, [HT.TokenLC i]) -absDeclaration ty xs scp = case takeCtorPtr xs of - (fn, xs'@((_, HT.TKReserved "("):_)) -> dropFst3 <$> absDeclarator' id (fn ty) xs' scp - (fn, ds) -> fromMaybe (Right (fn ty, ds)) $ arrayDeclSuffix (fn ty) ds scp - where - absDeclarator' fn ty' xs' scp' = case takeCtorPtr xs' of - (ptrf, cur@(_, HT.TKReserved "("):ds') -> (>>=) (absDeclarator' (fn . ptrf) ty' ds' scp') $ \case - (ptrf', ty'', (_, HT.TKReserved ")"):ds'') -> maybe (Right (id, ptrf' ty'', ds'')) (fmap (uncurry (id,,) . first ptrf')) $ arrayDeclSuffix ty'' ds'' scp' - _ -> Left ("expected ')' token for this '('", cur) - (p, ds) -> Right (p, ty', ds) - --- | `takeTypeName` is used to parse type names used for sizeof etc. Version without `takeType`s identifier. -takeTypeName :: (Integral i, Show i, Read i, Bits i) => [HT.TokenLC i] -> ConstructionData i -> Either (ASTError i) (CT.StorageClass i, [HT.TokenLC i]) -takeTypeName tk scp = (>>=) (takePreType tk scp) $ \(x, y, z) -> if CT.isSCStatic x then Left ("storage-class specifier is not allowed", head tk) else absDeclaration x y z -- ! - --- | @HT.TKReserved "[", n, HT.TKReserved "]"@ from the beginning of the token sequence. --- `arrayDeclSuffix` constructs an array type of the given type @t@ based on --- the token sequence if \(k\leq 1\), wraps it in `Right` and `Just` and returns it with the rest of the token sequence. --- If the token @HT.TKReserved "["@ exists at the beginning of the token sequence, --- but the subsequent token sequence is invalid as an array declaration in C programming language, --- an error mesage and the token at the error location are returned wrapped in --- `Left` and `Just`. When \(k=0\), `Nothing` is returned. --- --- \[ --- \text{array-decl-suffix}=\left(\text{"["}\ \text{const-expr?}\ \text{"]"}\ \text{array-decl-suffix}\right)\text{?} --- \] -arrayDeclSuffix :: forall i. (Integral i, Bits i, Show i, Read i) => CT.StorageClass i -> [HT.TokenLC i] -> ConstructionData i -> Maybe (Either (ASTError i) (CT.StorageClass i, [HT.TokenLC i])) -arrayDeclSuffix t (cur@(_, HT.TKReserved "["):(_, HT.TKReserved "]"):xs) scp = case arrayDeclSuffix t xs scp of - Nothing -> Just ((,xs) . CT.mapTypeKind (CT.CTIncomplete . CT.IncompleteArray) <$> maybeToRight (errSt t) (incomplete t scp)) - Just rs -> Just . (>>=) rs $ \(t', ds) -> (,ds) . CT.mapTypeKind (uncurry ((.) fromJust . CT.concatCTArray) . first (CT.CTIncomplete . CT.IncompleteArray . CT.removeAllExtents) . dupe) <$> - maybeToRight (errSt t') (incomplete t' scp) - where - errSt t' = ("array type has incomplete element type '" <> tshow t' <> "'", cur) -arrayDeclSuffix t (cur@(_, HT.TKReserved "["):xs) scp = case constantExp xs scp of - Left (Just err) -> Just $ Left err - Left Nothing -> Just $ Left $ if null xs then ("The expression is not constant-expression", cur) else ("The expression '" <> tshow (snd $ head xs) <> "' is not constant-expression", head xs) - Right ((_, HT.TKReserved "]"):ds, val) -> Just $ maybe' (Right (CT.mapTypeKind (CT.CTArray (toNatural val)) t, ds)) (arrayDeclSuffix t ds scp) $ - either Left $ \(t', ds') -> maybe' (errSt t') (CT.concatCTArray (CT.mapTypeKind (CT.CTArray (toNatural val)) t) t') $ \ty -> if CT.isValidIncomplete ty then Right (ty, ds') else errSt t' - _ -> Just $ Left ("expected storage size after '[' token", cur) - where - errSt t' = Left ("array type has incomplete element type '" <> tshow t' <> "'", cur) -arrayDeclSuffix _ _ _ = Nothing - -{-# INLINE isTypeName #-} --- | `isTypeName` returns @True@ if the token is a type name, @False@ otherwise. -isTypeName :: HT.TokenLC i -> ConstructionData i -> Bool -isTypeName (_, HT.TKType _) _ = True -isTypeName (_, HT.TKStruct) _ = True -isTypeName (_, HT.TKEnum) _ = True -isTypeName (_, HT.TKReserved "static") _ = True -isTypeName (_, HT.TKReserved "auto") _ = True -isTypeName (_, HT.TKReserved "register") _ = True -isTypeName (_, HT.TKIdent ident) scp = isJust $ lookupTypedef ident scp -isTypeName _ _ = False - --- | The `Just` represents an error during construction of the syntax tree, and the `Nothing` represents no valid constant expression. -type ConstantResult i = Maybe (ASTError i) - --- | `constantExp` evaluates to a constant expression from token list. -constantExp :: forall i. (Bits i, Integral i, Show i, Read i) => [HT.TokenLC i] -> ConstructionData i -> Either (ConstantResult i) ([HT.TokenLC i], i) -constantExp tk scp = flip (either (Left . Just)) (conditional tk ATEmpty scp) $ \(ds, at, _) -> - maybe (Left Nothing) (Right . (ds, )) $ evalConstantExp at - where - evalConstantExp :: ATree i -> Maybe i - evalConstantExp (ATNode k _ lhs rhs) = let fromBool = fromIntegral . fromEnum :: Bool -> i in case k of - ATAdd -> binop (+) - ATSub -> binop (-) - ATMul -> binop (*) - ATDiv -> binop div - ATAnd -> binop (.&.) - ATXor -> binop xor - ATOr -> binop (.|.) - ATShl -> binop (flip (.) fromIntegral . shiftL) - ATShr -> binop (flip (.) fromIntegral . shiftR) - ATEQ -> binop ((.) fromBool . (==)) - ATNEQ -> binop ((.) fromBool . (/=)) - ATLT -> binop ((.) fromBool . (<)) - ATGT -> binop ((.) fromBool . (>)) - ATLEQ -> binop ((.) fromBool . (<=)) - ATGEQ -> binop ((.) fromBool . (>=)) - ATConditional cn th el -> evalConstantExp cn >>= bool (evalConstantExp el) (evalConstantExp th) . castBool - ATComma -> evalConstantExp rhs - ATNot -> fromIntegral . fromEnum . not . castBool <$> evalConstantExp lhs - ATBitNot -> complement <$> evalConstantExp lhs - ATLAnd -> binop ((.) fromBool . flip (.) castBool . (&&) . castBool) - ATLOr -> binop ((.) fromBool . flip (.) castBool . (||) . castBool) - ATNum v -> Just v - _ -> Nothing - where - binop f = (>>=) (evalConstantExp lhs) $ \lhs' -> fromIntegral . f lhs' <$> evalConstantExp rhs - castBool x | x == 0 = False | otherwise = True - evalConstantExp ATEmpty = Nothing - diff --git a/src/Htcc/Parser/Parsing/Typedef.hs b/src/Htcc/Parser/Parsing/Typedef.hs deleted file mode 100644 index e9c3e05..0000000 --- a/src/Htcc/Parser/Parsing/Typedef.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, - TupleSections #-} -{-| -Module : Htcc.Parser.Parsing.Typedef -Description : The C languge parser and AST constructor -Copyright : (c) roki, 2019 -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -Perspective on @typedef@ declaration --} -module Htcc.Parser.Parsing.Typedef ( - typedef -) where - -import Data.Bits (Bits) - -import Htcc.Parser.AST -import Htcc.Parser.ConstructionData -import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) -import Htcc.Parser.ConstructionData.Scope.Utils (internalCE) -import Htcc.Parser.Parsing.Type -import qualified Htcc.Tokenizer as HT -import Htcc.Utils (maybeToRight, - tshow) - --- | Perform type definition from token string starting from @typedef@ token. --- \[\text{typedef-name}=\text{ident}\] -typedef :: (Integral i, Show i, Read i, Bits i) => [(HT.TokenLCNums i, HT.Token i)] -> ConstructionData i -> Either (ASTError i) ([HT.TokenLC i], ATree a, ConstructionData i) -typedef ((_, HT.TKTypedef):cur@(_, HT.TKReserved _):_) _ = Left ("storage-class specifier is not allowed in this context", cur) -typedef (cur@(_, HT.TKTypedef):xs) !scp = case takeType xs scp of - Left er -> Left er - Right (ty, Just ident, ds, scp') -> case ds of - (_, HT.TKReserved ";"):ds' -> do - ty' <- maybeToRight ("incomplete type typedef", ident) (incomplete ty scp') - (ds', ATEmpty,) <$> addTypedef ty' ident scp' - _ -> Left ("expected ';' token after '" <> tshow (snd ident) <> "'", ident) - Right (_, Nothing, ds, scp') -> case ds of - (_, HT.TKReserved ";"):ds' -> Right (ds', ATEmpty, pushWarn "useless type name in empty declaration" cur scp') - _ -> Left $ if not (null ds) then ("expected ';' token after '" <> tshow (snd $ head ds) <> "'", head ds) else ("expected ';' token", HT.emptyToken) -typedef _ _ = Left (internalCE, HT.emptyToken) - diff --git a/test/Tests/ComponentsTests/Parser/Combinators.hs b/test/Tests/ComponentsTests/Parser/Combinators.hs index 9371727..e3cf430 100644 --- a/test/Tests/ComponentsTests/Parser/Combinators.hs +++ b/test/Tests/ComponentsTests/Parser/Combinators.hs @@ -8,7 +8,6 @@ import qualified Data.Text as T import Data.Void (Void) import qualified Htcc.CRules as CR import Htcc.Parser.Combinators.Core -import Htcc.Utils (tshow) import Test.HUnit (Test (..), (~:), (~?=)) import qualified Text.Megaparsec as M From 8348d2012b5ba5218b0da6409b59da839dacf5d7 Mon Sep 17 00:00:00 2001 From: roki Date: Fri, 15 Jan 2021 01:57:06 +0900 Subject: [PATCH 44/51] Add _Alignof --- src/Htcc/Parser/Combinators/Core.hs | 14 -------------- src/Htcc/Parser/Combinators/Program.hs | 6 ++++++ test/Tests/csrc/self/expressions/operators.c | 10 ++++++---- 3 files changed, 12 insertions(+), 18 deletions(-) diff --git a/src/Htcc/Parser/Combinators/Core.hs b/src/Htcc/Parser/Combinators/Core.hs index d42388f..098e1aa 100644 --- a/src/Htcc/Parser/Combinators/Core.hs +++ b/src/Htcc/Parser/Combinators/Core.hs @@ -66,21 +66,7 @@ import Htcc.Utils (lor) import qualified Text.Megaparsec as M import qualified Text.Megaparsec.Char as MC import qualified Text.Megaparsec.Char.Lexer as ML -{- -type ConstructionDataState i = StateT (ConstructionData i) Identity -type Parser i = M.ParsecT Void T.Text (ConstructionDataState i) -runParser :: - Parser i (ASTs i) - -> FilePath - -> T.Text - -> Either (M.ParseErrorBundle T.Text Void) (Warnings i, ASTs i, PSV.GlobalVars i, PSV.Literals i) -runParser p fp input = - (warns (snd result),, PSV.globals $ PS.vars $ scope $ snd result, PSV.literals $ PS.vars $ scope $ snd result) - <$> fst result - where - result = runIdentity $ runStateT (M.runParserT p fp input) initConstructionData --} spaceConsumer :: Ord e => M.ParsecT e T.Text m () spaceConsumer = ML.space MC.space1 (ML.skipLineComment "//") (ML.skipBlockComment "/*" "*/") diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index c643f79..45ae53c 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -447,6 +447,7 @@ factor = choice [ atNumLit <$> natural , atNumLit . fromIntegral . ord <$> charLiteral , sizeof + , alignof , strLiteral , identifier' , M.try (parens expr) @@ -461,6 +462,11 @@ factor = choice , atNumLit . fromIntegral . CT.sizeof . atype <$> unary ] + alignof = do + at <- k_Alignof *> unary + if CT.isCTUndef (atype at) then fail "_Alignof must be an expression or type" else + pure $ atNumLit $ fromIntegral $ CT.alignof $ atype at + strLiteral = do s <- stringLiteral lit <- gets $ diff --git a/test/Tests/csrc/self/expressions/operators.c b/test/Tests/csrc/self/expressions/operators.c index 8aecadf..63003f1 100644 --- a/test/Tests/csrc/self/expressions/operators.c +++ b/test/Tests/csrc/self/expressions/operators.c @@ -57,10 +57,6 @@ int main() assert(1, (2 * 4) == (2 << 2), "(2 * 4) == (2 << 2)"); assert(1, (8 / 4) == (8 >> 2), "(8 / 4) == (8 >> 2)"); assert(1, ({ int a = 2 << 4; (a & (a - 1)) == 0; }), "({ int a = 2 << 4; (a & (a - 1)) == 0; })"); // Determining if an integer is a power of 2 - assert(3, ({ 1; {2;} 3; }), "({ 1; {2;} 3; })"); - assert(4, ({ int a; sizeof(a); }), "({ int a; sizeof(a); })"); - assert(4, ({ int a; sizeof a; }), "({ int a; sizeof a; })"); - assert(8, ({ int* p; sizeof p; }), "({ int* p; sizeof p; })"); assert(42, ({ int a = 41; ++a; }), "({ int a = 41; ++a; })"); assert(42, ({ int a = 43; --a; }), "({ int a = 43; --a; })"); assert(42, ({ int a = 42; a++; }), "({ int a = 41; a++; })"); @@ -102,6 +98,12 @@ int main() assert(4, ({ int a; sizeof(a); }), "({ int a; sizeof(a); })"); assert(4, ({ int a; sizeof a; }), "({ int a; sizeof a; })"); assert(8, ({ int* p; sizeof p; }), "({ int* p; sizeof p; })"); + //assert(4, sizeof(int), "sizeof(int)"); + //assert(8, sizeof(int*), "sizeof(int*)"); + assert(4, ({ int a; _Alignof(a); }), "({ int a; _Alignof(a); })"); + assert(8, ({ int* a; _Alignof(a); }), "({ int* a; _Alignof(a); })"); + //assert(4, _Alignof(int), "_Alignof(int)"); + //assert(8, _Alignof(int*), "_Alignof(int*)"); printf("All tests are passed!\n"); From 7a9c0ec238b139654ce8f41d00b385efd9bf1d42 Mon Sep 17 00:00:00 2001 From: roki Date: Sat, 16 Jan 2021 19:10:56 +0900 Subject: [PATCH 45/51] Add abstract declarators --- htcc.cabal | 4 +- src/Htcc/Parser/Combinators/Program.hs | 30 +++-- src/Htcc/Parser/Combinators/Type.hs | 118 +---------------- src/Htcc/Parser/Combinators/Type/AbsDecl.hs | 41 ++++++ src/Htcc/Parser/Combinators/Type/Core.hs | 129 +++++++++++++++++++ test/Tests/csrc/self/expressions/operators.c | 33 ++++- test/Tests/csrc/self/test_core.c | 1 - 7 files changed, 224 insertions(+), 132 deletions(-) create mode 100644 src/Htcc/Parser/Combinators/Type/AbsDecl.hs create mode 100644 src/Htcc/Parser/Combinators/Type/Core.hs diff --git a/htcc.cabal b/htcc.cabal index e3c07d2..7e759ed 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 000a21d18c160392985148fd3a5bec6cce2c82a00c364037c73e8a677952aa01 +-- hash: c4a47b7564fcba08e1190069308a7cdd94c8b5edc4759f9253edef4d35dce598 name: htcc version: 0.0.0.1 @@ -76,6 +76,8 @@ library Htcc.Parser.Combinators.ParserType Htcc.Parser.Combinators.Program Htcc.Parser.Combinators.Type + Htcc.Parser.Combinators.Type.AbsDecl + Htcc.Parser.Combinators.Type.Core Htcc.Parser.Combinators.Utils Htcc.Parser.Combinators.Var Htcc.Parser.ConstructionData.Core diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 45ae53c..7aeaca7 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -64,7 +64,8 @@ import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.Core import qualified Htcc.Parser.Combinators.GNUExtensions as GNU import Htcc.Parser.Combinators.Keywords -import Htcc.Parser.Combinators.Type (arraySuffix, +import Htcc.Parser.Combinators.Type (absDeclType, + arraySuffix, cType, constantExp) import Htcc.Parser.Combinators.Utils (bracket, @@ -455,17 +456,24 @@ factor = choice , ATEmpty <$ M.eof ] where - sizeof = kSizeof >> choice - [ incomplete <$> M.try (parens cType) <*> get - >>= fmap (atNumLit . fromIntegral . CT.sizeof) - . maybeToParser "invalid application of 'sizeof' to incomplete type" - , atNumLit . fromIntegral . CT.sizeof . atype <$> unary + memOp p op opS = p *> choice + [ memOpType + , memOpUnary ] - - alignof = do - at <- k_Alignof *> unary - if CT.isCTUndef (atype at) then fail "_Alignof must be an expression or type" else - pure $ atNumLit $ fromIntegral $ CT.alignof $ atype at + where + memOpType = incomplete <$> M.try (parens absDeclType) <*> get + >>= fmap (atNumLit . fromIntegral . op) + . maybeToParser ("invalid application of '" <> opS <> "' to incomplete type") + + memOpUnary = do + u <- unary + if CT.isCTUndef (atype u) then + fail $ opS <> " must be an expression or type" + else + pure $ atNumLit $ fromIntegral $ op $ atype u + + sizeof = memOp kSizeof CT.sizeof "sizeof" + alignof = memOp k_Alignof CT.alignof "alignof" strLiteral = do s <- stringLiteral diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs index 5566a31..ffe49ed 100644 --- a/src/Htcc/Parser/Combinators/Type.hs +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -9,120 +9,10 @@ Portability : POSIX C language parser Combinators -} -{-# LANGUAGE LambdaCase, OverloadedStrings #-} module Htcc.Parser.Combinators.Type ( - constantExp - , cType - , arraySuffix + module Htcc.Parser.Combinators.Type.Core + , module Htcc.Parser.Combinators.Type.AbsDecl ) where -import Control.Monad (mfilter) -import Control.Monad.Combinators (choice) -import Control.Monad.Trans (MonadTrans (..)) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Control.Monad.Trans.State (gets) -import Data.Bits (Bits (..)) -import Data.Bool (bool) -import Data.Maybe (fromJust) -import qualified Data.Text as T -import Data.Tuple.Extra (dupe, first) -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST.Core (ATKind (..), ATree (..)) -import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Keywords -import {-# SOURCE #-} Htcc.Parser.Combinators.Program (conditional) -import Htcc.Parser.ConstructionData.Core (incomplete) -import Htcc.Utils (toNatural) -import qualified Text.Megaparsec as M -constantExp :: (Bits i, Integral i, Show i, Read i) => Parser i i -constantExp = conditional >>= constantExp' - where - fromBool = fromIntegral . fromEnum :: Num i => Bool -> i - toBool x | x == 0 = False | otherwise = True - - constantExp' (ATNode k _ lhs rhs) = case k of - ATAdd -> binop (+) - ATSub -> binop (-) - ATMul -> binop (*) - ATDiv -> binop div - ATAnd -> binop (.&.) - ATXor -> binop xor - ATOr -> binop (.|.) - ATShl -> binop (flip (.) fromIntegral . shiftL) - ATShr -> binop (flip (.) fromIntegral . shiftR) - ATEQ -> binop ((.) fromBool . (==)) - ATNEQ -> binop ((.) fromBool . (/=)) - ATLT -> binop ((.) fromBool . (<)) - ATGT -> binop ((.) fromBool . (>)) - ATLEQ -> binop ((.) fromBool . (<=)) - ATGEQ -> binop ((.) fromBool . (>=)) - ATConditional cn th el -> constantExp' cn - >>= bool (constantExp' el) (constantExp' th) . toBool - ATComma -> constantExp' rhs - ATNot -> fromIntegral . fromEnum . not . toBool <$> constantExp' lhs - ATBitNot -> complement <$> constantExp' lhs - ATLAnd -> binop ((.) fromBool . flip (.) toBool . (&&) . toBool) - ATLOr -> binop ((.) fromBool . flip (.) toBool . (||) . toBool) - ATNum v -> pure v - _ -> fail "The expression is not constant-expression" - where - binop f = constantExp' lhs - >>= \lhs' -> fromIntegral . f lhs' <$> constantExp' rhs - constantExp' ATEmpty = fail "The expression is not constant-expression" - -arraySuffix :: (Show i, Read i, Bits i, Integral i) - => CT.StorageClass i - -> Parser i (CT.StorageClass i) -arraySuffix ty = choice - [ withConstantExp - , nonConstantExp - ] - where - failWithTypeMaybe ty' = maybe (fail $ show ty') pure - - withConstantExp = do - arty <- flip id ty . CT.mapTypeKind . CT.CTArray . toNatural <$> M.try (brackets constantExp) - M.option Nothing (Just <$> arraySuffix ty) - >>= \case - Nothing -> pure arty - Just ty' -> - runMaybeT (mfilter CT.isValidIncomplete $ MaybeT $ pure $ CT.concatCTArray arty ty') - >>= failWithTypeMaybe ty' - - nonConstantExp = let mtIncomplete ty' = MaybeT $ lift $ gets $ incomplete ty' in - symbol "[" - *> symbol "]" - *> M.option Nothing (Just <$> arraySuffix ty) - >>= \case - Nothing -> - runMaybeT (CT.mapTypeKind (CT.CTIncomplete . CT.IncompleteArray) <$> mtIncomplete ty) - >>= failWithTypeMaybe ty - Just ty' -> - runMaybeT (multiple <$> mtIncomplete ty') - >>= failWithTypeMaybe ty' - where - multiple = CT.mapTypeKind $ - uncurry ((.) fromJust . CT.concatCTArray) - . first (CT.CTIncomplete . CT.IncompleteArray . CT.removeAllExtents) - . dupe - -preType, - cType :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) - -preType = choice - [ kStatic >> (CT.SCStatic . CT.toTypeKind <$> preType) - , kRegister >> (CT.SCRegister . CT.toTypeKind <$> preType) - , kAuto >> preType - , CT.SCAuto . CT.toTypeKind . CT.implicitInt . read' . T.unpack - <$> choice kBasicTypes - ] - where - read' :: (Show i, Read i, Integral i) - => String - -> CT.TypeKind i - read' = read - -cType = do - pt <- preType - fn <- CT.ctorPtr . toNatural . length <$> M.many (symbol "*") - pure $ fn pt +import Htcc.Parser.Combinators.Type.Core +import Htcc.Parser.Combinators.Type.AbsDecl diff --git a/src/Htcc/Parser/Combinators/Type/AbsDecl.hs b/src/Htcc/Parser/Combinators/Type/AbsDecl.hs new file mode 100644 index 0000000..a2be1a8 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Type/AbsDecl.hs @@ -0,0 +1,41 @@ +{-| +Module : Htcc.Parser.Combinators.Type.AbsDecl +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +{-# LANGUAGE TupleSections #-} +module Htcc.Parser.Combinators.Type.AbsDecl ( + absDeclType +) where + +import Data.Bits (Bits (..)) +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.Type.Core (arraySuffix, preType) +import Htcc.Utils (toNatural) +import qualified Text.Megaparsec as M + +-- TODO: Allow the function pointer type +absDeclType :: (Integral i, Show i, Read i, Bits i) => Parser i (CT.StorageClass i) +absDeclType = do + ty <- preType + if CT.isSCStatic ty {- TODO: or register -} then fail "storage-class specifier is not allowed" else do + ty' <- flip id ty <$> ctorPtr + M.choice + [ arraySuffix ty' + , snd <$> absDeclType' id ty' + ] + where + ctorPtr = CT.ctorPtr . toNatural . length <$> M.many star + + absDeclType' fn ty = do + cpfn <- ctorPtr + M.option (cpfn, ty) $ do + (cpfn', ty') <- parens $ absDeclType' (fn . cpfn) ty + M.option (id, cpfn' ty') ((id,) . cpfn' <$> arraySuffix ty') diff --git a/src/Htcc/Parser/Combinators/Type/Core.hs b/src/Htcc/Parser/Combinators/Type/Core.hs new file mode 100644 index 0000000..12d219e --- /dev/null +++ b/src/Htcc/Parser/Combinators/Type/Core.hs @@ -0,0 +1,129 @@ +{-| +Module : Htcc.Parser.Combinators.Type.Core +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +{-# LANGUAGE LambdaCase, OverloadedStrings #-} +module Htcc.Parser.Combinators.Type.Core ( + constantExp + , arraySuffix + , preType + , cType +) where +import Control.Monad (mfilter) +import Control.Monad.Combinators (choice) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Control.Monad.Trans.State (gets) +import Data.Bits (Bits (..)) +import Data.Bool (bool) +import Data.Functor ((<&>)) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Data.Tuple.Extra (dupe, first) +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATKind (..), ATree (..)) +import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.Keywords +import {-# SOURCE #-} Htcc.Parser.Combinators.Program (conditional) +import Htcc.Parser.ConstructionData.Core (incomplete) +import Htcc.Utils (toNatural) +import qualified Text.Megaparsec as M + +constantExp :: (Bits i, Integral i, Show i, Read i) => Parser i i +constantExp = conditional >>= constantExp' + where + fromBool = fromIntegral . fromEnum :: Num i => Bool -> i + toBool x | x == 0 = False | otherwise = True + + constantExp' (ATNode k _ lhs rhs) = case k of + ATAdd -> binop (+) + ATSub -> binop (-) + ATMul -> binop (*) + ATDiv -> binop div + ATAnd -> binop (.&.) + ATXor -> binop xor + ATOr -> binop (.|.) + ATShl -> binop (flip (.) fromIntegral . shiftL) + ATShr -> binop (flip (.) fromIntegral . shiftR) + ATEQ -> binop ((.) fromBool . (==)) + ATNEQ -> binop ((.) fromBool . (/=)) + ATLT -> binop ((.) fromBool . (<)) + ATGT -> binop ((.) fromBool . (>)) + ATLEQ -> binop ((.) fromBool . (<=)) + ATGEQ -> binop ((.) fromBool . (>=)) + ATConditional cn th el -> constantExp' cn + >>= bool (constantExp' el) (constantExp' th) . toBool + ATComma -> constantExp' rhs + ATNot -> fromIntegral . fromEnum . not . toBool <$> constantExp' lhs + ATBitNot -> complement <$> constantExp' lhs + ATLAnd -> binop ((.) fromBool . flip (.) toBool . (&&) . toBool) + ATLOr -> binop ((.) fromBool . flip (.) toBool . (||) . toBool) + ATNum v -> pure v + _ -> fail "The expression is not constant-expression" + where + binop f = constantExp' lhs + >>= \lhs' -> fromIntegral . f lhs' <$> constantExp' rhs + constantExp' ATEmpty = fail "The expression is not constant-expression" + +arraySuffix :: (Show i, Read i, Bits i, Integral i) + => CT.StorageClass i + -> Parser i (CT.StorageClass i) +arraySuffix ty = choice + [ withConstantExp + , nonConstantExp + ] + where + failWithTypeMaybe ty' = maybe (fail $ show ty') pure + + withConstantExp = do + arty <- flip id ty . CT.mapTypeKind . CT.CTArray . toNatural <$> M.try (brackets constantExp) + M.option Nothing (Just <$> arraySuffix ty) + >>= \case + Nothing -> pure arty + Just ty' -> + runMaybeT (mfilter CT.isValidIncomplete $ MaybeT $ pure $ CT.concatCTArray arty ty') + >>= failWithTypeMaybe ty' + + nonConstantExp = let mtIncomplete ty' = MaybeT $ lift $ gets $ incomplete ty' in + symbol "[" + *> symbol "]" + *> M.option Nothing (Just <$> arraySuffix ty) + >>= \case + Nothing -> + runMaybeT (CT.mapTypeKind (CT.CTIncomplete . CT.IncompleteArray) <$> mtIncomplete ty) + >>= failWithTypeMaybe ty + Just ty' -> + runMaybeT (multiple <$> mtIncomplete ty') + >>= failWithTypeMaybe ty' + where + multiple = CT.mapTypeKind $ + uncurry ((.) fromJust . CT.concatCTArray) + . first (CT.CTIncomplete . CT.IncompleteArray . CT.removeAllExtents) + . dupe + +preType, + cType :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) + +preType = choice + [ kStatic *> (CT.SCStatic . CT.toTypeKind <$> preType) + , kRegister *> (CT.SCRegister . CT.toTypeKind <$> preType) + , kAuto *> preType + , choice kBasicTypes <&> CT.SCAuto . CT.toTypeKind . CT.implicitInt . read' . T.unpack + ] + where + read' :: (Show i, Read i, Integral i) + => String + -> CT.TypeKind i + read' = read + +cType = do + pt <- preType + fn <- CT.ctorPtr . toNatural . length <$> M.many star + pure $ fn pt diff --git a/test/Tests/csrc/self/expressions/operators.c b/test/Tests/csrc/self/expressions/operators.c index 63003f1..de8a0ee 100644 --- a/test/Tests/csrc/self/expressions/operators.c +++ b/test/Tests/csrc/self/expressions/operators.c @@ -98,13 +98,36 @@ int main() assert(4, ({ int a; sizeof(a); }), "({ int a; sizeof(a); })"); assert(4, ({ int a; sizeof a; }), "({ int a; sizeof a; })"); assert(8, ({ int* p; sizeof p; }), "({ int* p; sizeof p; })"); - //assert(4, sizeof(int), "sizeof(int)"); - //assert(8, sizeof(int*), "sizeof(int*)"); + assert(4, sizeof(int), "sizeof(int)"); + assert(8, sizeof(int*), "sizeof(int*)"); + assert(80, sizeof(int*[10]), "sizeof(int*[10])"); + assert(8, sizeof(int (*)[10]), "sizeof(int (*)[10])"); + assert(40, sizeof(int[10]), "sizeof(int[10])"); + assert(1, ({ char a; sizeof(a); }), "({ char a; sizeof(a); })"); + assert(1, ({ char a; sizeof a; }), "({ char a; sizeof a; })"); + assert(8, ({ char* a; sizeof a; }), "({ char* a; sizeof a; })"); + assert(1, sizeof(char), "sizeof(char)"); + assert(8, sizeof(char*), "sizeof(char*)"); + assert(80, sizeof(char*[10]), "sizeof(char*[10])"); + assert(8, sizeof(char (*)[10]), "sizeof(char (*)[10])"); + assert(10, sizeof(char[10]), "sizeof(char[10])"); assert(4, ({ int a; _Alignof(a); }), "({ int a; _Alignof(a); })"); - assert(8, ({ int* a; _Alignof(a); }), "({ int* a; _Alignof(a); })"); - //assert(4, _Alignof(int), "_Alignof(int)"); - //assert(8, _Alignof(int*), "_Alignof(int*)"); + assert(4, ({ int a; _Alignof a; }), "({ int a; _Alignof a; })"); + assert(8, ({ int* a; _Alignof a; }), "({ int* a; _Alignof a; })"); + assert(4, _Alignof(int), "_Alignof(int)"); + assert(8, _Alignof(int*), "_Alignof(int*)"); + assert(8, _Alignof(int*[10]), "_Alignof(int*[10])"); + assert(8, _Alignof(int(*)[10]), "_Alignof(int(*)[10])"); + assert(4, _Alignof(int[10]), "_Alignof(int[10])"); + assert(1, ({ char a; _Alignof(a); }), "({ char a; _Alignof(a); })"); + assert(1, ({ char a; _Alignof a; }), "({ char a; _Alignof a; })"); + assert(8, ({ char* a; _Alignof a; }), "({ char* a; _Alignof a; })"); + assert(1, _Alignof(char), "_Alignof(char)"); + assert(8, _Alignof(char*), "_Alignof(char*)"); + assert(8, _Alignof(char*[10]), "_Alignof(char*[10])"); + assert(8, _Alignof(char(*)[10]), "_Alignof(char(*)[10])"); + assert(1, _Alignof(char[10]), "_Alignof(char[10])"); printf("All tests are passed!\n"); return 0; diff --git a/test/Tests/csrc/self/test_core.c b/test/Tests/csrc/self/test_core.c index d27eec5..756038e 100644 --- a/test/Tests/csrc/self/test_core.c +++ b/test/Tests/csrc/self/test_core.c @@ -199,7 +199,6 @@ int main() assert(8, sizeof(signed int long long), "sizeof(signed int long long)"); assert(42, static_fun(), "static_fun()"); assert(42, ({ register int x = 42; x; }), "({ register int x = 42; x; })"); - assert(42, ({ auto int x = 42; x; }), "({ auto int x = 42; x; })"); assert(42, ({ register struct { int x; } x; x.x = 42; x.x; }), "({ register struct { int x; } x; x.x = 42; x.x; })"); assert(42, ({ register struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; }), "({ register struct X { int x; }* p; struct X x; p = &x; p->x = 42; x.x; })"); assert(42, ({ auto struct { int x; } x; x.x = 42; x.x; }), "({ auto struct { int x; } x; x.x = 42; x.x; })"); From edd70e2bc8e9378092a16a03064a2278c8aa2cbe Mon Sep 17 00:00:00 2001 From: roki Date: Sat, 16 Jan 2021 19:29:57 +0900 Subject: [PATCH 46/51] Add cast --- src/Htcc/Parser/Combinators/Program.hs | 16 ++++++++---- test/Tests/csrc/self/expressions/cast.c | 34 +++++++++++++++++++++++++ 2 files changed, 45 insertions(+), 5 deletions(-) create mode 100644 test/Tests/csrc/self/expressions/cast.c diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 7aeaca7..ad20a8b 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -44,7 +44,7 @@ import Htcc.Parser.AST.Core (ATKind (..), ATKindFor (..), ATree (..), atBlock, atBreak, - atCase, + atCase, atCast, atConditional, atContinue, atDefFunc, @@ -140,6 +140,7 @@ global, shift, add, term, + cast, unary, factor :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) @@ -395,12 +396,17 @@ add = binaryOperator term , (symbol "-", \l r -> maybeToParser "invalid operands" $ subKind l r) ] -term = binaryOperator unary +term = binaryOperator cast [ (star, binOpCon ATMul) , (slash, binOpCon ATDiv) , (percent, binOpCon ATMod) ] +cast = choice + [ atCast <$> M.try (parens absDeclType) <*> cast + , unary + ] + unary = choice [ symbol "++" *> unary <&> \n -> ATNode ATPreInc (atype n) n ATEmpty , symbol "--" *> unary <&> \n -> ATNode ATPreDec (atype n) n ATEmpty @@ -462,12 +468,12 @@ factor = choice ] where memOpType = incomplete <$> M.try (parens absDeclType) <*> get - >>= fmap (atNumLit . fromIntegral . op) + >>= fmap (atNumLit . fromIntegral . op) . maybeToParser ("invalid application of '" <> opS <> "' to incomplete type") memOpUnary = do - u <- unary - if CT.isCTUndef (atype u) then + u <- unary + if CT.isCTUndef (atype u) then fail $ opS <> " must be an expression or type" else pure $ atNumLit $ fromIntegral $ op $ atype u diff --git a/test/Tests/csrc/self/expressions/cast.c b/test/Tests/csrc/self/expressions/cast.c new file mode 100644 index 0000000..a5f22d3 --- /dev/null +++ b/test/Tests/csrc/self/expressions/cast.c @@ -0,0 +1,34 @@ +// This is a c compiler test file. This comment itself is a line comment test. +/* + * This comment is also a block comment test. + */ + +int printf(); +int exit(); +int test_num; + +int assert(long expected, long actual, char* code) +{ + if (expected == actual) { + printf("[OK]:expressions/cast test #%ld: \'%s\' => %d\n", test_num, code, actual); + test_num = test_num + 1; + return 0; + } else { + printf("[Failed]:expressions/cast test #%ld: \'%s\' => %d, but expected %d\n", test_num, code, actual, expected); + exit(1); + } +} + +int main() +{ + printf(">>>> tests: expressions/cast\n"); + test_num = 1; + + assert(4, sizeof((int)'a')); + assert(1, sizeof((char)42)); + assert(8, sizeof((int*)42)); + assert(8, sizeof((char*)42)); + + printf("All tests are passed!\n"); + return 0; +} From d09c968953bf8fdc52713216a1cdcf8c13662a92 Mon Sep 17 00:00:00 2001 From: roki Date: Wed, 27 Jan 2021 04:56:13 +0900 Subject: [PATCH 47/51] Partially supported sizeof function --- htcc.cabal | 5 +- src/Htcc/CRules/Types/StorageClass.hs | 8 +- src/Htcc/CRules/Types/TypeKind.hs | 7 + src/Htcc/Parser/AST/Core.hs | 1 + src/Htcc/Parser/Combinators/ConstExpr.hs | 58 ++++++++ src/Htcc/Parser/Combinators/Program.hs | 88 +++++------- src/Htcc/Parser/Combinators/Type/AbsDecl.hs | 12 +- src/Htcc/Parser/Combinators/Type/Core.hs | 134 +++++++++--------- .../Parser/Combinators/Type/NestedDecl.hs | 50 +++++++ .../Combinators/Type/NestedDecl.hs-boot | 21 +++ src/Htcc/Parser/Combinators/Type/Utils.hs | 23 +++ src/Htcc/Parser/ConstructionData/Scope.hs | 5 +- .../Parser/ConstructionData/Scope/Function.hs | 5 + test/Tests/csrc/self/array/basic.c | 3 + test/Tests/csrc/self/expressions/operators.c | 17 ++- 15 files changed, 302 insertions(+), 135 deletions(-) create mode 100644 src/Htcc/Parser/Combinators/ConstExpr.hs create mode 100644 src/Htcc/Parser/Combinators/Type/NestedDecl.hs create mode 100644 src/Htcc/Parser/Combinators/Type/NestedDecl.hs-boot create mode 100644 src/Htcc/Parser/Combinators/Type/Utils.hs diff --git a/htcc.cabal b/htcc.cabal index 7e759ed..5f14cac 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: c4a47b7564fcba08e1190069308a7cdd94c8b5edc4759f9253edef4d35dce598 +-- hash: adf27582692559fb937928c96b4a6efb3c7d2441e4dc93f9fc88a84730d74c70 name: htcc version: 0.0.0.1 @@ -70,6 +70,7 @@ library Htcc.Parser.AST.Type Htcc.Parser.Combinators Htcc.Parser.Combinators.BasicOperator + Htcc.Parser.Combinators.ConstExpr Htcc.Parser.Combinators.Core Htcc.Parser.Combinators.GNUExtensions Htcc.Parser.Combinators.Keywords @@ -78,6 +79,8 @@ library Htcc.Parser.Combinators.Type Htcc.Parser.Combinators.Type.AbsDecl Htcc.Parser.Combinators.Type.Core + Htcc.Parser.Combinators.Type.NestedDecl + Htcc.Parser.Combinators.Type.Utils Htcc.Parser.Combinators.Utils Htcc.Parser.Combinators.Var Htcc.Parser.ConstructionData.Core diff --git a/src/Htcc/CRules/Types/StorageClass.hs b/src/Htcc/CRules/Types/StorageClass.hs index c8052d1..578e954 100644 --- a/src/Htcc/CRules/Types/StorageClass.hs +++ b/src/Htcc/CRules/Types/StorageClass.hs @@ -12,8 +12,9 @@ The storage-class of C language {-# LANGUAGE DeriveGeneric #-} module Htcc.CRules.Types.StorageClass ( -- * StorageClass data type and class - StorageClass (..), - StorageClassBase (..) + StorageClass (..) + , StorageClassBase (..) + , wrapCTFunc ) where import Control.DeepSeq (NFData (..)) @@ -137,3 +138,6 @@ instance StorageClassBase StorageClass where isSCStatic _ = False instance NFData i => NFData (StorageClass i) + +wrapCTFunc :: StorageClass i -> [StorageClass i] -> StorageClass i +wrapCTFunc ty params = picksc ty $ CTFunc (toTypeKind ty) $ map fromsc params diff --git a/src/Htcc/CRules/Types/TypeKind.hs b/src/Htcc/CRules/Types/TypeKind.hs index 8260364..a508bd6 100644 --- a/src/Htcc/CRules/Types/TypeKind.hs +++ b/src/Htcc/CRules/Types/TypeKind.hs @@ -138,6 +138,7 @@ data TypeKind i = CTInt -- ^ The type @int@ as C language | CTLong (TypeKind i) -- ^ The type @long@ as C language | CTBool -- ^ The type @_Bool@ as C language | CTVoid -- ^ The type @void@ as C language + | CTFunc (TypeKind i) [TypeKind i] -- ^ The type of function as C language | CTPtr (TypeKind i) -- ^ The pointer type of `TypeKind` | CTArray Natural (TypeKind i) -- ^ The array type | CTEnum (TypeKind i) (M.Map T.Text i) -- ^ The enum, has its underlying type and a map @@ -248,6 +249,9 @@ instance Eq i => Eq (TypeKind i) where (==) CTChar CTChar = True (==) CTBool CTBool = True (==) CTVoid CTVoid = True + (==) (CTFunc lty lparams) (CTFunc rty rparams) = lty == rty && lparams == rparams + (==) (CTFunc lty _) rhs = lty == rhs -- function and otherwise + (==) lhs (CTFunc rty _) = lhs == rty -- function and otherwise (==) (CTEnum ut1 m1) (CTEnum ut2 m2) = ut1 == ut2 && m1 == m2 (==) (CTArray v1 t1) (CTArray v2 t2) = v1 == v2 && t1 == t2 (==) (CTStruct m1) (CTStruct m2) = m1 == m2 @@ -270,6 +274,7 @@ instance Show i => Show (TypeKind i) where show (CTLong t) = "long " ++ show t show CTBool = "_Bool" show CTVoid = "void" + show (CTFunc ty param) = show ty ++ "(" ++ intercalate ", " (map show param) ++ ")" show (CTPtr x) = show x ++ "*" show (CTArray v t) = show t ++ "[" ++ show v ++ "]" show (CTEnum _ m) = "enum { " ++ intercalate ", " (map T.unpack $ M.keys m) ++ " }" @@ -314,6 +319,7 @@ instance Ord i => CType (TypeKind i) where sizeof (CTLong x) = sizeof x sizeof CTBool = 1 sizeof CTVoid = 1 -- Non standard + sizeof (CTFunc _ _) = 1 -- Non standard sizeof (CTPtr _) = 8 sizeof (CTArray v t) = v * sizeof t sizeof (CTEnum t _) = sizeof t @@ -335,6 +341,7 @@ instance Ord i => CType (TypeKind i) where alignof (CTLong x) = alignof x alignof CTBool = 1 alignof CTVoid = 1 -- Non standard + alignof (CTFunc _ _) = 1 -- Non standard alignof (CTPtr _) = 8 alignof (CTArray _ t) = alignof $ removeAllExtents t alignof (CTEnum t _) = alignof t diff --git a/src/Htcc/Parser/AST/Core.hs b/src/Htcc/Parser/AST/Core.hs index d0a6175..2a82661 100644 --- a/src/Htcc/Parser/AST/Core.hs +++ b/src/Htcc/Parser/AST/Core.hs @@ -148,6 +148,7 @@ data ATKind a = ATAdd -- ^ \(x+y\): @x + y@ | ATGVar (CT.StorageClass a) T.Text -- ^ the global variable. It has a type information (as `CT.StorageClass`) and an name | ATDefFunc T.Text (Maybe [ATree a]) -- ^ the function definition | ATCallFunc T.Text (Maybe [ATree a]) -- ^ the function call. It has a offset value and arguments (`Maybe`) + | ATFuncPtr -- ^ the function pointer. | ATExprStmt -- ^ the expression of a statement | ATStmtExpr [ATree a] -- ^ the statement of a expression (GNU extension) | ATNull (ATree a) -- ^ indicates nothing to do diff --git a/src/Htcc/Parser/Combinators/ConstExpr.hs b/src/Htcc/Parser/Combinators/ConstExpr.hs new file mode 100644 index 0000000..ec02030 --- /dev/null +++ b/src/Htcc/Parser/Combinators/ConstExpr.hs @@ -0,0 +1,58 @@ +{-| +Module : Htcc.Parser.Combinators.ConstExpr +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +{-# LANGUAGE LambdaCase, OverloadedStrings #-} +module Htcc.Parser.Combinators.ConstExpr ( + evalConstexpr +) where +import Data.Bits (Bits (..)) +import Data.Bool (bool) +import Htcc.Parser.AST.Core (ATKind (..), + ATree (..)) +import Htcc.Parser.Combinators.Core +import {-# SOURCE #-} Htcc.Parser.Combinators.Program (conditional) + +evalConstexpr :: (Bits i, Integral i, Show i, Read i) => Parser i i +evalConstexpr = conditional >>= constantExp' + where + fromBool = fromIntegral . fromEnum :: Num i => Bool -> i + toBool x | x == 0 = False | otherwise = True + + constantExp' (ATNode k _ lhs rhs) = case k of + ATAdd -> binop (+) + ATSub -> binop (-) + ATMul -> binop (*) + ATDiv -> binop div + ATAnd -> binop (.&.) + ATXor -> binop xor + ATOr -> binop (.|.) + ATShl -> binop (flip (.) fromIntegral . shiftL) + ATShr -> binop (flip (.) fromIntegral . shiftR) + ATEQ -> binop ((.) fromBool . (==)) + ATNEQ -> binop ((.) fromBool . (/=)) + ATLT -> binop ((.) fromBool . (<)) + ATGT -> binop ((.) fromBool . (>)) + ATLEQ -> binop ((.) fromBool . (<=)) + ATGEQ -> binop ((.) fromBool . (>=)) + ATConditional cn th el -> constantExp' cn + >>= bool (constantExp' el) (constantExp' th) . toBool + ATComma -> constantExp' rhs + ATNot -> fromIntegral . fromEnum . not . toBool <$> constantExp' lhs + ATBitNot -> complement <$> constantExp' lhs + ATLAnd -> binop ((.) fromBool . flip (.) toBool . (&&) . toBool) + ATLOr -> binop ((.) fromBool . flip (.) toBool . (||) . toBool) + ATNum v -> pure v + _ -> fail "The expression is not constant-expression" + where + binop f = constantExp' lhs + >>= \lhs' -> fromIntegral . f lhs' <$> constantExp' rhs + constantExp' ATEmpty = fail "The expression is not constant-expression" + diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index ad20a8b..54c796c 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -28,7 +28,6 @@ import Control.Monad.Trans.Maybe (MaybeT (..), import Data.Bits (Bits) import qualified Data.ByteString.UTF8 as BSU import Data.Char (ord) -import Data.Either (rights) import Data.Functor ((<&>)) import Data.List (find) import Data.Maybe (fromJust, isJust) @@ -61,13 +60,13 @@ import Htcc.Parser.AST.Core (ATKind (..), isEmptyExprStmt) import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator +import Htcc.Parser.Combinators.ConstExpr (evalConstexpr) import Htcc.Parser.Combinators.Core import qualified Htcc.Parser.Combinators.GNUExtensions as GNU import Htcc.Parser.Combinators.Keywords import Htcc.Parser.Combinators.Type (absDeclType, - arraySuffix, - cType, - constantExp) + declIdent, + funcParams) import Htcc.Parser.Combinators.Utils (bracket, getPosState, maybeToParser, @@ -95,30 +94,6 @@ import qualified Text.Megaparsec.Char as MC import Text.Megaparsec.Debug (dbg) -declIdent :: (Show i, Read i, Bits i, Integral i) => Parser i (CT.StorageClass i, T.Text) -declIdent = do - ty <- M.try cType - ident <- identifier - (,ident) <$> M.option ty (arraySuffix ty) - -declIdentFuncArg :: (Show i, Read i, Bits i, Integral i) - => Parser i a - -> Parser i (Either (CT.StorageClass i) (CT.StorageClass i, T.Text)) -declIdentFuncArg sep = do - ty <- M.try cType - anonymousArg ty M.<|> namedArg ty - where - anonymousArg ty = Left <$> M.option ty (arraySuffix ty) <* sep - namedArg ty = do - ident <- identifier - Right . (,ident) <$> M.option ty (narrowPtr <$> arraySuffix ty) <* sep - - narrowPtr ty - | CT.isCTArray ty = maybe ty (CT.mapTypeKind CT.CTPtr) $ CT.deref ty - | CT.isIncompleteArray ty = - CT.mapTypeKind (\(CT.CTIncomplete (CT.IncompleteArray t')) -> CT.CTPtr t') ty - | otherwise = ty - parser, program :: (Integral i, Bits i, Read i, Show i) => Parser i (ASTs i) parser = (spaceConsumer >> program) <* M.eof program = some global @@ -145,38 +120,36 @@ global, factor :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) global = choice - [ ATEmpty <$ M.try (cType >> semi) - , function + [ function , gvar ] function = do pos <- getPosState - (ty, ident) <- M.try (declIdent <* lparen) - params <- takeParameters - modify resetLocal - choice - [ declaration ty ident - , definition ty ident params pos - ] + M.try (declIdent <* lparen) >>= \case + (_, Nothing) -> fail "expected unqualified-id" + (ty, Just ident) -> do + (ty', params) <- funcParams ty + modify resetLocal + choice + [ declaration ty' ident + , definition ty' ident params pos + ] where - takeParameters = - M.manyTill (M.try (declIdentFuncArg comma) M.<|> declIdentFuncArg (M.lookAhead rparen)) rparen - - declaration ty ident = + declaration ty ident = void semi - >> gets (addFunction False ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) + >> gets (addFunction False ty (tmpTKIdent ident)) >>= \case Right scp' -> ATEmpty <$ put scp' Left err -> fail $ T.unpack $ fst err - definition ty ident params pos = + definition ty ident params pos = void (M.lookAhead lbrace) - >> gets (addFunction True ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) + >> gets (addFunction True ty (tmpTKIdent ident)) >>= \case Right scp' -> do put scp' - params' <- forM (rights params) $ uncurry registerLVar + params' <- forM params $ uncurry registerLVar stmt >>= fromValidFunc params' Left err -> fail $ T.unpack $ fst err where @@ -202,9 +175,9 @@ function = do pure $ atDefFunc ident (if null params' then Nothing else Just params') ty st fromValidFunc _ _ = fail "internal compiler error" -gvar = do - (ty, ident) <- declIdent - choice +gvar = declIdent >>= \case + (_, Nothing) -> ATEmpty <$ semi + (ty, Just ident) -> choice [ nonInit ty ident , withInit ty ident ] @@ -248,7 +221,7 @@ gvar = do gvarInitWithVal ty' to = addGVarWith ty' (tmpTKIdent ident) (PV.GVarInitWithVal to) fromConstant = do - cval <- constantExp + cval <- evalConstexpr gets (gvarInitWithVal ty cval) >>= \case Left err -> fail $ T.unpack $ fst err @@ -319,7 +292,7 @@ stmt = choice caseStmt = M.try kCase *> ifM (gets isSwitchStmt) - ((atCase 0 <$> constantExp <* colon) <*> stmt) + ((atCase 0 <$> evalConstexpr <* colon) <*> stmt) (fail "stray 'case'") defaultStmt = (M.try kDefault <* colon) @@ -331,11 +304,15 @@ stmt = choice labelStmt = atLabel <$> M.try (identifier <* colon) - lvarStmt = choice - [ ATEmpty <$ M.try (cType <* semi) - , M.try (declIdent <* semi) >>= fmap atNull . uncurry registerLVar - , (declIdent <* equal >>= uncurry (varInit assign)) <* semi - ] + lvarStmt = declIdent >>= \case + (_, Nothing) -> ATEmpty <$ semi + (ty, Just ident) -> choice + [ nonInit ty ident + , withInit ty ident + ] + where + nonInit ty ident = semi >> atNull <$> registerLVar ty ident + withInit ty ident = equal *> varInit assign ty ident <* semi expr = assign @@ -504,6 +481,7 @@ factor = choice FoundGVar (PV.GVar t _) -> return $ atGVar t ident FoundLVar sct -> return $ treealize sct FoundEnum sct -> return $ treealize sct + FoundFunc sct -> return $ treealize sct NotFound -> fail $ "The '" <> T.unpack ident <> "' is not defined identifier" fnCall ident pos = do diff --git a/src/Htcc/Parser/Combinators/Type/AbsDecl.hs b/src/Htcc/Parser/Combinators/Type/AbsDecl.hs index a2be1a8..b0edebe 100644 --- a/src/Htcc/Parser/Combinators/Type/AbsDecl.hs +++ b/src/Htcc/Parser/Combinators/Type/AbsDecl.hs @@ -17,25 +17,23 @@ module Htcc.Parser.Combinators.Type.AbsDecl ( import Data.Bits (Bits (..)) import qualified Htcc.CRules.Types as CT import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Type.Core (arraySuffix, preType) -import Htcc.Utils (toNatural) +import Htcc.Parser.Combinators.Type.Core (arraySuffix, declspec) +import Htcc.Parser.Combinators.Type.Utils (takeCtorPtr) import qualified Text.Megaparsec as M -- TODO: Allow the function pointer type absDeclType :: (Integral i, Show i, Read i, Bits i) => Parser i (CT.StorageClass i) absDeclType = do - ty <- preType + ty <- declspec if CT.isSCStatic ty {- TODO: or register -} then fail "storage-class specifier is not allowed" else do - ty' <- flip id ty <$> ctorPtr + ty' <- flip id ty <$> takeCtorPtr M.choice [ arraySuffix ty' , snd <$> absDeclType' id ty' ] where - ctorPtr = CT.ctorPtr . toNatural . length <$> M.many star - absDeclType' fn ty = do - cpfn <- ctorPtr + cpfn <- takeCtorPtr M.option (cpfn, ty) $ do (cpfn', ty') <- parens $ absDeclType' (fn . cpfn) ty M.option (id, cpfn' ty') ((id,) . cpfn' <$> arraySuffix ty') diff --git a/src/Htcc/Parser/Combinators/Type/Core.hs b/src/Htcc/Parser/Combinators/Type/Core.hs index 12d219e..39a89ba 100644 --- a/src/Htcc/Parser/Combinators/Type/Core.hs +++ b/src/Htcc/Parser/Combinators/Type/Core.hs @@ -9,68 +9,33 @@ Portability : POSIX C language parser Combinators -} -{-# LANGUAGE LambdaCase, OverloadedStrings #-} +{-# LANGUAGE LambdaCase, OverloadedStrings, TupleSections #-} module Htcc.Parser.Combinators.Type.Core ( - constantExp - , arraySuffix - , preType - , cType + arraySuffix + , funcParams + , declspec + , declIdent ) where -import Control.Monad (mfilter) -import Control.Monad.Combinators (choice) -import Control.Monad.Trans (MonadTrans (..)) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Control.Monad.Trans.State (gets) -import Data.Bits (Bits (..)) -import Data.Bool (bool) -import Data.Functor ((<&>)) -import Data.Maybe (fromJust) -import qualified Data.Text as T -import Data.Tuple.Extra (dupe, first) -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST.Core (ATKind (..), ATree (..)) +import Control.Monad (mfilter) +import Control.Monad.Combinators (choice) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.Maybe (MaybeT (..), + runMaybeT) +import Control.Monad.Trans.State (gets) +import Data.Bits (Bits (..)) +import Data.Either (rights) +import Data.Functor ((<&>)) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Data.Tuple.Extra (dupe, first) +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.Combinators.ConstExpr (evalConstexpr) import Htcc.Parser.Combinators.Core import Htcc.Parser.Combinators.Keywords -import {-# SOURCE #-} Htcc.Parser.Combinators.Program (conditional) -import Htcc.Parser.ConstructionData.Core (incomplete) -import Htcc.Utils (toNatural) -import qualified Text.Megaparsec as M - -constantExp :: (Bits i, Integral i, Show i, Read i) => Parser i i -constantExp = conditional >>= constantExp' - where - fromBool = fromIntegral . fromEnum :: Num i => Bool -> i - toBool x | x == 0 = False | otherwise = True - - constantExp' (ATNode k _ lhs rhs) = case k of - ATAdd -> binop (+) - ATSub -> binop (-) - ATMul -> binop (*) - ATDiv -> binop div - ATAnd -> binop (.&.) - ATXor -> binop xor - ATOr -> binop (.|.) - ATShl -> binop (flip (.) fromIntegral . shiftL) - ATShr -> binop (flip (.) fromIntegral . shiftR) - ATEQ -> binop ((.) fromBool . (==)) - ATNEQ -> binop ((.) fromBool . (/=)) - ATLT -> binop ((.) fromBool . (<)) - ATGT -> binop ((.) fromBool . (>)) - ATLEQ -> binop ((.) fromBool . (<=)) - ATGEQ -> binop ((.) fromBool . (>=)) - ATConditional cn th el -> constantExp' cn - >>= bool (constantExp' el) (constantExp' th) . toBool - ATComma -> constantExp' rhs - ATNot -> fromIntegral . fromEnum . not . toBool <$> constantExp' lhs - ATBitNot -> complement <$> constantExp' lhs - ATLAnd -> binop ((.) fromBool . flip (.) toBool . (&&) . toBool) - ATLOr -> binop ((.) fromBool . flip (.) toBool . (||) . toBool) - ATNum v -> pure v - _ -> fail "The expression is not constant-expression" - where - binop f = constantExp' lhs - >>= \lhs' -> fromIntegral . f lhs' <$> constantExp' rhs - constantExp' ATEmpty = fail "The expression is not constant-expression" +import {-# SOURCE #-} Htcc.Parser.Combinators.Type.NestedDecl +import Htcc.Parser.ConstructionData.Core (incomplete) +import Htcc.Utils (toNatural) +import qualified Text.Megaparsec as M arraySuffix :: (Show i, Read i, Bits i, Integral i) => CT.StorageClass i @@ -83,7 +48,7 @@ arraySuffix ty = choice failWithTypeMaybe ty' = maybe (fail $ show ty') pure withConstantExp = do - arty <- flip id ty . CT.mapTypeKind . CT.CTArray . toNatural <$> M.try (brackets constantExp) + arty <- flip id ty . CT.mapTypeKind . CT.CTArray . toNatural <$> M.try (brackets evalConstexpr) M.option Nothing (Just <$> arraySuffix ty) >>= \case Nothing -> pure arty @@ -108,13 +73,45 @@ arraySuffix ty = choice . first (CT.CTIncomplete . CT.IncompleteArray . CT.removeAllExtents) . dupe -preType, - cType :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) +funcParams :: (Show i, Read i, Integral i, Bits i) + => CT.StorageClass i + -> Parser i (CT.StorageClass i, [(CT.StorageClass i, T.Text)]) +funcParams ty = choice + [ (CT.wrapCTFunc ty [], []) <$ (symbol "void" *> rparen) + , withParams <&> \p -> (CT.wrapCTFunc ty $ map (either id fst) p, rights p) + ] + where + withParams = M.manyTill + (M.try (declIdentFuncParam comma) M.<|> declIdentFuncParam (M.lookAhead rparen)) + rparen -preType = choice - [ kStatic *> (CT.SCStatic . CT.toTypeKind <$> preType) - , kRegister *> (CT.SCRegister . CT.toTypeKind <$> preType) - , kAuto *> preType + declIdentFuncParam sep = declIdent >>= \case + (ty', Nothing) -> Left ty' <$ sep + (ty', Just ident) -> Right (narrowPtr ty', ident) <$ sep + where + narrowPtr ty' + | CT.isCTArray ty' = maybe ty' (CT.mapTypeKind CT.CTPtr) $ CT.deref ty' + | CT.isIncompleteArray ty' = flip CT.mapTypeKind ty' $ + \(CT.CTIncomplete (CT.IncompleteArray ty'')) -> CT.CTPtr ty'' + | otherwise = ty' +{- +typeSuffix :: (Show i, Read i, Bits i, Integral i) + => CT.StorageClass i + -> Parser i (CT.StorageClass i) +typeSuffix ty = M.option ty $ choice + [ arraySuffix ty + , lparen *> funcParams ty <&> fst + ] +-} + +declspec', + declspec :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) + +declspec' = choice + [ kStatic *> (CT.SCStatic . CT.toTypeKind <$> declspec') + , kRegister *> (CT.SCRegister . CT.toTypeKind <$> declspec') + , kAuto *> declspec' + -- , struct , choice kBasicTypes <&> CT.SCAuto . CT.toTypeKind . CT.implicitInt . read' . T.unpack ] where @@ -123,7 +120,10 @@ preType = choice -> CT.TypeKind i read' = read -cType = do - pt <- preType +declspec = do + pt <- declspec' fn <- CT.ctorPtr . toNatural . length <$> M.many star pure $ fn pt + +declIdent :: (Show i, Read i, Bits i, Integral i) => Parser i (CT.StorageClass i, Maybe T.Text) +declIdent = M.try declspec >>= nestedDeclType diff --git a/src/Htcc/Parser/Combinators/Type/NestedDecl.hs b/src/Htcc/Parser/Combinators/Type/NestedDecl.hs new file mode 100644 index 0000000..a8d8942 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Type/NestedDecl.hs @@ -0,0 +1,50 @@ +{-| +Module : Htcc.Parser.Combinators.Type.NestedDecl +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +{-# LANGUAGE TupleSections #-} +module Htcc.Parser.Combinators.Type.NestedDecl ( + nestedDeclType +) where + +import Data.Bits (Bits (..)) +import qualified Data.Text as T +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.Type.Core (arraySuffix) +import Htcc.Parser.Combinators.Type.Utils +import Htcc.Utils (dropFst3, swap) +import qualified Text.Megaparsec as M + +-- TODO: Allow the function pointer type +nestedDeclType :: (Integral i, Show i, Read i, Bits i) + => CT.StorageClass i + -> Parser i (CT.StorageClass i, Maybe T.Text) +nestedDeclType ty = do + ty' <- flip id ty <$> takeCtorPtr + M.option (ty', Nothing) $ M.choice + [ M.lookAhead lparen *> (swap . dropFst3 <$> nestedDeclType' id ty') + , swap <$> ((,) <$> (Just <$> identifier) <*> M.option ty' (arraySuffix ty')) + ] + where + nestedDeclType' fn ty' = do + ptrf <- takeCtorPtr + M.choice + [ nested ptrf + , nonNested ptrf + ] + where + nested ptrf = do + (ptrf', ident, ty'') <- parens $ nestedDeclType' (fn . ptrf) ty' + M.option (id, ident, ptrf' ty'') ((id, ident,) . ptrf' <$> arraySuffix ty'') + + nonNested ptrf = (ptrf,,) + <$> (Just <$> identifier) + <*> M.option ty' (arraySuffix ty') diff --git a/src/Htcc/Parser/Combinators/Type/NestedDecl.hs-boot b/src/Htcc/Parser/Combinators/Type/NestedDecl.hs-boot new file mode 100644 index 0000000..910a604 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Type/NestedDecl.hs-boot @@ -0,0 +1,21 @@ +{-| +Module : Htcc.Parser.Combinators.Type.NestedDecl +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +module Htcc.Parser.Combinators.Type.NestedDecl where + +import Data.Bits (Bits (..)) +import qualified Data.Text as T +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.Combinators.Core (Parser) + +nestedDeclType :: (Integral i, Show i, Read i, Bits i) + => CT.StorageClass i + -> Parser i (CT.StorageClass i, Maybe T.Text) diff --git a/src/Htcc/Parser/Combinators/Type/Utils.hs b/src/Htcc/Parser/Combinators/Type/Utils.hs new file mode 100644 index 0000000..affa72f --- /dev/null +++ b/src/Htcc/Parser/Combinators/Type/Utils.hs @@ -0,0 +1,23 @@ +{-| +Module : Htcc.Parser.Combinators.Type.Utils +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +{-# LANGUAGE TupleSections #-} +module Htcc.Parser.Combinators.Type.Utils ( + takeCtorPtr +) where + +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.Combinators.Core (Parser, star) +import Htcc.Utils (toNatural) +import qualified Text.Megaparsec as M + +takeCtorPtr :: Ord i => Parser i (CT.StorageClass i -> CT.StorageClass i) +takeCtorPtr = CT.ctorPtr . toNatural . length <$> M.many star diff --git a/src/Htcc/Parser/ConstructionData/Scope.hs b/src/Htcc/Parser/ConstructionData/Scope.hs index 944133c..08b0b78 100644 --- a/src/Htcc/Parser/ConstructionData/Scope.hs +++ b/src/Htcc/Parser/ConstructionData/Scope.hs @@ -71,6 +71,7 @@ instance NFData i => NFData (Scoped i) data LookupVarResult i = FoundGVar (PV.GVar i) -- ^ A type constructor indicating that a global variable has been found | FoundLVar (PV.LVar i) -- ^ A type constructor indicating that a local variable has been found | FoundEnum (SE.Enumerator i) -- ^ A type constructor indicating that a enumerator has been found + | FoundFunc (PF.Function i) -- ^ A type constructor indicating that a function has been found | NotFound -- ^ A type constructor indicating that it was not found deriving (Show, Eq) @@ -140,7 +141,9 @@ lookupVar ident scp = case lookupLVar ident scp of Just local -> FoundLVar local _ -> case lookupEnumerator ident scp of Just enum -> FoundEnum enum - _ -> maybe NotFound FoundGVar $ lookupGVar ident scp + _ -> case lookupGVar ident scp of + Just gvar -> FoundGVar gvar + _ -> maybe NotFound FoundFunc $ lookupFunction ident scp -- | `lookupTag` has a scoped type argument and is the same function as `PS.lookupTag` internally. {-# INLINE lookupTag #-} diff --git a/src/Htcc/Parser/ConstructionData/Scope/Function.hs b/src/Htcc/Parser/ConstructionData/Scope/Function.hs index 6a2ed36..338ff04 100644 --- a/src/Htcc/Parser/ConstructionData/Scope/Function.hs +++ b/src/Htcc/Parser/ConstructionData/Scope/Function.hs @@ -21,6 +21,7 @@ import qualified Data.Map as M import qualified Data.Text as T import GHC.Generics (Generic (..)) +import Htcc.Parser.AST.Core (Treealizable (..), ATree (..), ATKind (..), atUnary) import qualified Htcc.CRules.Types as CT import Htcc.Parser.ConstructionData.Scope.ManagedScope import Htcc.Parser.ConstructionData.Scope.Utils (internalCE) @@ -40,6 +41,10 @@ instance ManagedScope (Function i) where fallBack = flip const initial = M.empty +-- TODO: allow function pointer +instance Treealizable Function where + treealize (Function ftype _) = atUnary ATFuncPtr ftype ATEmpty + -- | The typedefs data typedefs type Functions i = M.Map T.Text (Function i) diff --git a/test/Tests/csrc/self/array/basic.c b/test/Tests/csrc/self/array/basic.c index 1af483d..acad61c 100644 --- a/test/Tests/csrc/self/array/basic.c +++ b/test/Tests/csrc/self/array/basic.c @@ -7,6 +7,7 @@ int printf(); int exit(); int strcmp(char* p, char* q); int test_num; +int; int gr[3]; //int (*gpa)[3]; @@ -137,6 +138,8 @@ int main() assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][1]; })"); assert(0, ({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; }), "({ int ar[2][3] = { { 1, 2, 3 }, {} }; ar[1][2]; })"); assert(0, ({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; }), "({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; })"); + assert(3, ({ char* x[3]; char y; x[0] = &y; y = 3; x[0][0]; }), "({ char* x[3]; char y; x[0] = &y; y = 3; x[0][0]; })"); + assert(4, ({ char x[3]; char (*y)[3] = x; y[0][0] = 4; y[0][0]; }), "({ char x[3]; char (*y)[3] = x; y[0] = 4; y[0][0]; }"); printf("All tests are passed!\n"); diff --git a/test/Tests/csrc/self/expressions/operators.c b/test/Tests/csrc/self/expressions/operators.c index de8a0ee..5d4bc3c 100644 --- a/test/Tests/csrc/self/expressions/operators.c +++ b/test/Tests/csrc/self/expressions/operators.c @@ -111,6 +111,18 @@ int main() assert(80, sizeof(char*[10]), "sizeof(char*[10])"); assert(8, sizeof(char (*)[10]), "sizeof(char (*)[10])"); assert(10, sizeof(char[10]), "sizeof(char[10])"); + assert(4, ({ int a = 1; sizeof(a = 2); }), "({ int a = 1; sizeof(a = 2); })"); + assert(1, ({ int a = 1; sizeof(a = 2); a; }), "({ int a = 1; sizeof(a = 2); a; })"); + assert(24, ({ char* x[3]; sizeof x; }), "({ char* x[3]; sizeof x; })"); + assert(8, ({ char (*x)[3]; sizeof x; }), "({ char (*x)[3]; sizeof x; })"); + assert(1, sizeof main, "sizeof main"); + assert(1, sizeof assert, "sizeof assert"); + //assert(1, ({ char (x); sizeof x; }), "({ char (x); sizeof x; })"); + //assert(3, ({ char (x)[3]; sizeof x; }), "({ char (x)[3]; sizeof x; })"); + //assert(3, ({ char (x)[3]; sizeof x; }), + assert(12, ({ char (x[3])[4]; sizeof x; }), "({ char (x[3])[4]; sizeof x; })"); + assert(4, ({ char (x[3])[4]; sizeof x[0]; }), "({ char (x[3])[4]; sizeof x[0]; })"); + assert(4, ({ int a; _Alignof(a); }), "({ int a; _Alignof(a); })"); assert(4, ({ int a; _Alignof a; }), "({ int a; _Alignof a; })"); assert(8, ({ int* a; _Alignof a; }), "({ int* a; _Alignof a; })"); @@ -119,7 +131,6 @@ int main() assert(8, _Alignof(int*[10]), "_Alignof(int*[10])"); assert(8, _Alignof(int(*)[10]), "_Alignof(int(*)[10])"); assert(4, _Alignof(int[10]), "_Alignof(int[10])"); - assert(1, ({ char a; _Alignof(a); }), "({ char a; _Alignof(a); })"); assert(1, ({ char a; _Alignof a; }), "({ char a; _Alignof a; })"); assert(8, ({ char* a; _Alignof a; }), "({ char* a; _Alignof a; })"); @@ -128,7 +139,9 @@ int main() assert(8, _Alignof(char*[10]), "_Alignof(char*[10])"); assert(8, _Alignof(char(*)[10]), "_Alignof(char(*)[10])"); assert(1, _Alignof(char[10]), "_Alignof(char[10])"); - printf("All tests are passed!\n"); + assert(4, ({ int a = 1; _Alignof(a = 2); }), "({ int a = 1; _Alignof(a = 2); })"); + assert(1, ({ int a = 1; _Alignof(a = 2); a; }), "({ int a = 1; _Alignof(a = 2); a; })"); + printf("All tests are passed!\n"); return 0; } From 7fe7783daac80eb8c9fadd63b8ccc7f74ee5c30d Mon Sep 17 00:00:00 2001 From: roki Date: Mon, 8 Feb 2021 05:41:32 +0900 Subject: [PATCH 48/51] Allow sizeof for function (GNU extension) --- htcc.cabal | 8 +- src/Htcc/CRules/Types/StorageClass.hs | 5 +- src/Htcc/CRules/Types/TypeKind.hs | 4 +- src/Htcc/Parser/Combinators/Decl.hs | 20 +++ .../AbsDecl.hs => Decl/AbstractDeclarator.hs} | 19 +-- .../Parser/Combinators/Decl/Declarator.hs | 48 ++++++ .../Declarator.hs-boot} | 6 +- src/Htcc/Parser/Combinators/Decl/Spec.hs | 40 +++++ src/Htcc/Parser/Combinators/Program.hs | 151 ++++++++---------- src/Htcc/Parser/Combinators/Type.hs | 2 - src/Htcc/Parser/Combinators/Type/Core.hs | 78 ++++----- .../Parser/Combinators/Type/NestedDecl.hs | 50 ------ src/Htcc/Parser/Combinators/Type/Utils.hs | 10 +- src/Htcc/Parser/Combinators/Utils.hs | 88 ++++++++-- test/Tests/csrc/self/expressions/operators.c | 6 +- 15 files changed, 314 insertions(+), 221 deletions(-) create mode 100644 src/Htcc/Parser/Combinators/Decl.hs rename src/Htcc/Parser/Combinators/{Type/AbsDecl.hs => Decl/AbstractDeclarator.hs} (61%) create mode 100644 src/Htcc/Parser/Combinators/Decl/Declarator.hs rename src/Htcc/Parser/Combinators/{Type/NestedDecl.hs-boot => Decl/Declarator.hs-boot} (75%) create mode 100644 src/Htcc/Parser/Combinators/Decl/Spec.hs delete mode 100644 src/Htcc/Parser/Combinators/Type/NestedDecl.hs diff --git a/htcc.cabal b/htcc.cabal index 5f14cac..5206156 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: adf27582692559fb937928c96b4a6efb3c7d2441e4dc93f9fc88a84730d74c70 +-- hash: c76bad766ef4b8408c8ebd5f51183ab0da218376e837f6a97ac568d53ff52ea1 name: htcc version: 0.0.0.1 @@ -72,14 +72,16 @@ library Htcc.Parser.Combinators.BasicOperator Htcc.Parser.Combinators.ConstExpr Htcc.Parser.Combinators.Core + Htcc.Parser.Combinators.Decl + Htcc.Parser.Combinators.Decl.AbstractDeclarator + Htcc.Parser.Combinators.Decl.Declarator + Htcc.Parser.Combinators.Decl.Spec Htcc.Parser.Combinators.GNUExtensions Htcc.Parser.Combinators.Keywords Htcc.Parser.Combinators.ParserType Htcc.Parser.Combinators.Program Htcc.Parser.Combinators.Type - Htcc.Parser.Combinators.Type.AbsDecl Htcc.Parser.Combinators.Type.Core - Htcc.Parser.Combinators.Type.NestedDecl Htcc.Parser.Combinators.Type.Utils Htcc.Parser.Combinators.Utils Htcc.Parser.Combinators.Var diff --git a/src/Htcc/CRules/Types/StorageClass.hs b/src/Htcc/CRules/Types/StorageClass.hs index 578e954..018c432 100644 --- a/src/Htcc/CRules/Types/StorageClass.hs +++ b/src/Htcc/CRules/Types/StorageClass.hs @@ -23,6 +23,7 @@ import GHC.Generics (Generic) import Htcc.CRules.Types.CType import Htcc.CRules.Types.TypeKind +import qualified Data.Text as T -- | The data type representing `StorageClass` data StorageClass i = SCAuto (TypeKind i) -- ^ The @auto@ keyword @@ -139,5 +140,5 @@ instance StorageClassBase StorageClass where instance NFData i => NFData (StorageClass i) -wrapCTFunc :: StorageClass i -> [StorageClass i] -> StorageClass i -wrapCTFunc ty params = picksc ty $ CTFunc (toTypeKind ty) $ map fromsc params +wrapCTFunc :: StorageClass i -> [(StorageClass i, Maybe T.Text)] -> StorageClass i +wrapCTFunc ty params = picksc ty $ CTFunc (toTypeKind ty) $ map (first fromsc) params diff --git a/src/Htcc/CRules/Types/TypeKind.hs b/src/Htcc/CRules/Types/TypeKind.hs index a508bd6..61ce08a 100644 --- a/src/Htcc/CRules/Types/TypeKind.hs +++ b/src/Htcc/CRules/Types/TypeKind.hs @@ -138,7 +138,7 @@ data TypeKind i = CTInt -- ^ The type @int@ as C language | CTLong (TypeKind i) -- ^ The type @long@ as C language | CTBool -- ^ The type @_Bool@ as C language | CTVoid -- ^ The type @void@ as C language - | CTFunc (TypeKind i) [TypeKind i] -- ^ The type of function as C language + | CTFunc (TypeKind i) [(TypeKind i, Maybe T.Text)] -- ^ The type of function as C language | CTPtr (TypeKind i) -- ^ The pointer type of `TypeKind` | CTArray Natural (TypeKind i) -- ^ The array type | CTEnum (TypeKind i) (M.Map T.Text i) -- ^ The enum, has its underlying type and a map @@ -249,7 +249,7 @@ instance Eq i => Eq (TypeKind i) where (==) CTChar CTChar = True (==) CTBool CTBool = True (==) CTVoid CTVoid = True - (==) (CTFunc lty lparams) (CTFunc rty rparams) = lty == rty && lparams == rparams + (==) (CTFunc lty lparams) (CTFunc rty rparams) = lty == rty && map fst lparams == map fst rparams (==) (CTFunc lty _) rhs = lty == rhs -- function and otherwise (==) lhs (CTFunc rty _) = lhs == rty -- function and otherwise (==) (CTEnum ut1 m1) (CTEnum ut2 m2) = ut1 == ut2 && m1 == m2 diff --git a/src/Htcc/Parser/Combinators/Decl.hs b/src/Htcc/Parser/Combinators/Decl.hs new file mode 100644 index 0000000..727f884 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Decl.hs @@ -0,0 +1,20 @@ +{-| +Module : Htcc.Parser.Combinators.Decl +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +module Htcc.Parser.Combinators.Decl ( + module Htcc.Parser.Combinators.Decl.AbstractDeclarator + , module Htcc.Parser.Combinators.Decl.Spec + , module Htcc.Parser.Combinators.Decl.Declarator +) where + +import Htcc.Parser.Combinators.Decl.AbstractDeclarator +import Htcc.Parser.Combinators.Decl.Declarator +import Htcc.Parser.Combinators.Decl.Spec diff --git a/src/Htcc/Parser/Combinators/Type/AbsDecl.hs b/src/Htcc/Parser/Combinators/Decl/AbstractDeclarator.hs similarity index 61% rename from src/Htcc/Parser/Combinators/Type/AbsDecl.hs rename to src/Htcc/Parser/Combinators/Decl/AbstractDeclarator.hs index b0edebe..eb080ce 100644 --- a/src/Htcc/Parser/Combinators/Type/AbsDecl.hs +++ b/src/Htcc/Parser/Combinators/Decl/AbstractDeclarator.hs @@ -1,5 +1,5 @@ {-| -Module : Htcc.Parser.Combinators.Type.AbsDecl +Module : Htcc.Parser.Combinators.Decl.AbstractDeclarator Description : C language parser Combinators Copyright : (c) roki, 2020~ License : MIT @@ -10,30 +10,31 @@ Portability : POSIX C language parser Combinators -} {-# LANGUAGE TupleSections #-} -module Htcc.Parser.Combinators.Type.AbsDecl ( +module Htcc.Parser.Combinators.Decl.AbstractDeclarator ( absDeclType ) where -import Data.Bits (Bits (..)) -import qualified Htcc.CRules.Types as CT +import Data.Bits (Bits (..)) +import qualified Htcc.CRules.Types as CT import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Type.Core (arraySuffix, declspec) -import Htcc.Parser.Combinators.Type.Utils (takeCtorPtr) -import qualified Text.Megaparsec as M +import Htcc.Parser.Combinators.Decl.Spec (declspec) +import Htcc.Parser.Combinators.Type.Core (arraySuffix) +import Htcc.Parser.Combinators.Type.Utils (starsToPtr, starsToPtrCtor) +import qualified Text.Megaparsec as M -- TODO: Allow the function pointer type absDeclType :: (Integral i, Show i, Read i, Bits i) => Parser i (CT.StorageClass i) absDeclType = do ty <- declspec if CT.isSCStatic ty {- TODO: or register -} then fail "storage-class specifier is not allowed" else do - ty' <- flip id ty <$> takeCtorPtr + ty' <- starsToPtr ty M.choice [ arraySuffix ty' , snd <$> absDeclType' id ty' ] where absDeclType' fn ty = do - cpfn <- takeCtorPtr + cpfn <- starsToPtrCtor M.option (cpfn, ty) $ do (cpfn', ty') <- parens $ absDeclType' (fn . cpfn) ty M.option (id, cpfn' ty') ((id,) . cpfn' <$> arraySuffix ty') diff --git a/src/Htcc/Parser/Combinators/Decl/Declarator.hs b/src/Htcc/Parser/Combinators/Decl/Declarator.hs new file mode 100644 index 0000000..7dd8645 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Decl/Declarator.hs @@ -0,0 +1,48 @@ +{-| +Module : Htcc.Parser.Combinators.Decl.Declarator +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +{-# LANGUAGE TupleSections #-} +module Htcc.Parser.Combinators.Decl.Declarator ( + declarator +) where + +import Control.Monad.Fix (fix) +import Data.Bits (Bits (..)) +import qualified Data.Text as T +import Data.Tuple.Extra (uncurry3) +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.Type.Core (typeSuffix) +import Htcc.Parser.Combinators.Type.Utils +import Htcc.Utils (dropFst3, swap) +import qualified Text.Megaparsec as M + +declarator :: (Integral i, Show i, Read i, Bits i) + => CT.StorageClass i + -> Parser i (CT.StorageClass i, Maybe T.Text) +declarator ty = do + ty' <- starsToPtr ty + M.option (ty', Nothing) $ M.choice + [ nested ty' + , swap <$> ((,) <$> M.option Nothing (Just <$> identifier) <*> typeSuffix ty') + ] + where + nested ty' = fmap (swap . dropFst3) + $ ($ (id, ty')) + $ fix $ \f (fn, ty'') -> do + ptrf <- (fn .) <$> starsToPtrCtor + M.choice + [ parens (f (ptrf, ty'')) >>= uncurry3 nested' + , (ptrf,,) <$> (Just <$> identifier) <*> M.option ty'' (typeSuffix ty'') + ] + where + nested' ptrf ident t = + M.option (id, ident, ptrf t) ((id, ident,) . ptrf <$> typeSuffix t) diff --git a/src/Htcc/Parser/Combinators/Type/NestedDecl.hs-boot b/src/Htcc/Parser/Combinators/Decl/Declarator.hs-boot similarity index 75% rename from src/Htcc/Parser/Combinators/Type/NestedDecl.hs-boot rename to src/Htcc/Parser/Combinators/Decl/Declarator.hs-boot index 910a604..eb576bc 100644 --- a/src/Htcc/Parser/Combinators/Type/NestedDecl.hs-boot +++ b/src/Htcc/Parser/Combinators/Decl/Declarator.hs-boot @@ -1,5 +1,5 @@ {-| -Module : Htcc.Parser.Combinators.Type.NestedDecl +Module : Htcc.Parser.Combinators.Decl.Declarator Description : C language parser Combinators Copyright : (c) roki, 2020~ License : MIT @@ -9,13 +9,13 @@ Portability : POSIX C language parser Combinators -} -module Htcc.Parser.Combinators.Type.NestedDecl where +module Htcc.Parser.Combinators.Decl.Declarator where import Data.Bits (Bits (..)) import qualified Data.Text as T import qualified Htcc.CRules.Types as CT import Htcc.Parser.Combinators.Core (Parser) -nestedDeclType :: (Integral i, Show i, Read i, Bits i) +declarator :: (Integral i, Show i, Read i, Bits i) => CT.StorageClass i -> Parser i (CT.StorageClass i, Maybe T.Text) diff --git a/src/Htcc/Parser/Combinators/Decl/Spec.hs b/src/Htcc/Parser/Combinators/Decl/Spec.hs new file mode 100644 index 0000000..e3a96c7 --- /dev/null +++ b/src/Htcc/Parser/Combinators/Decl/Spec.hs @@ -0,0 +1,40 @@ +{-| +Module : Htcc.Parser.Combinators.Decl.Spec +Description : C language parser Combinators +Copyright : (c) roki, 2020~ +License : MIT +Maintainer : falgon53@yahoo.co.jp +Stability : experimental +Portability : POSIX + +C language parser Combinators +-} +module Htcc.Parser.Combinators.Decl.Spec ( + declspec +) where + +import Data.Functor ((<&>)) +import qualified Data.Text as T +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.Keywords +import Htcc.Parser.Combinators.Type.Utils +import qualified Text.Megaparsec as M + +declspec', + declspec :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) + +declspec' = M.choice + [ kStatic *> (CT.SCStatic . CT.toTypeKind <$> declspec') + , kRegister *> (CT.SCRegister . CT.toTypeKind <$> declspec') + , kAuto *> declspec' + -- , struct + , M.choice kBasicTypes <&> CT.SCAuto . CT.toTypeKind . CT.implicitInt . read' . T.unpack + ] + where + read' :: (Show i, Read i, Integral i) + => String + -> CT.TypeKind i + read' = read + +declspec = declspec' >>= starsToPtr diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 54c796c..08bbfa7 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -16,17 +16,14 @@ module Htcc.Parser.Combinators.Program ( , compoundStmt ) where -import Control.Monad (forM, void, when, - (>=>)) +import Control.Monad (void, when, (>=>)) import Control.Monad.Combinators (choice, some) import Control.Monad.Extra (ifM) -import Control.Monad.State (get, gets, modify, - put) +import Control.Monad.State (get, gets, modify) import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Bits (Bits) -import qualified Data.ByteString.UTF8 as BSU import Data.Char (ord) import Data.Functor ((<&>)) import Data.List (find) @@ -62,22 +59,22 @@ import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.ConstExpr (evalConstexpr) import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.Decl (absDeclType) +import Htcc.Parser.Combinators.Decl.Declarator (declarator) +import Htcc.Parser.Combinators.Decl.Spec (declspec) import qualified Htcc.Parser.Combinators.GNUExtensions as GNU import Htcc.Parser.Combinators.Keywords -import Htcc.Parser.Combinators.Type (absDeclType, - declIdent, - funcParams) +import Htcc.Parser.Combinators.Type (toNamedParams) import Htcc.Parser.Combinators.Utils (bracket, getPosState, maybeToParser, + registerFunc, + registerGVar, + registerGVarWith, registerLVar, - tmpTKIdent) + registerStringLiteral) import Htcc.Parser.Combinators.Var (varInit) -import Htcc.Parser.ConstructionData.Core (addFunction, - addGVar, - addGVarWith, - addLiteral, - fallBack, +import Htcc.Parser.ConstructionData.Core (fallBack, incomplete, isSwitchStmt, lookupFunction, @@ -88,14 +85,13 @@ import Htcc.Parser.ConstructionData.Core (addFunction, import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) import qualified Htcc.Parser.ConstructionData.Scope.Function as PSF import qualified Htcc.Parser.ConstructionData.Scope.Var as PV -import qualified Htcc.Tokenizer.Token as HT import qualified Text.Megaparsec as M import qualified Text.Megaparsec.Char as MC import Text.Megaparsec.Debug (dbg) parser, program :: (Integral i, Bits i, Read i, Show i) => Parser i (ASTs i) -parser = (spaceConsumer >> program) <* M.eof +parser = spaceConsumer *> program <* M.eof program = some global global, @@ -120,38 +116,27 @@ global, factor :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) global = choice - [ function + [ M.try function , gvar ] function = do pos <- getPosState - M.try (declIdent <* lparen) >>= \case - (_, Nothing) -> fail "expected unqualified-id" - (ty, Just ident) -> do - (ty', params) <- funcParams ty - modify resetLocal - choice - [ declaration ty' ident - , definition ty' ident params pos + declspec >>= declarator >>= \case + (_, Nothing) -> fail "function name omitted, expected unqualified-id" + (ty@(CT.SCAuto (CT.CTFunc _ _)), Just ident) -> modify resetLocal + *> choice + [ declaration ty ident + , definition ty ident pos ] + _ -> fail "expected function" -- TODO: currentry, ignore storage class where - declaration ty ident = - void semi - >> gets (addFunction False ty (tmpTKIdent ident)) - >>= \case - Right scp' -> ATEmpty <$ put scp' - Left err -> fail $ T.unpack $ fst err + declaration ty ident = ATEmpty <$ (semi *> registerFunc False ty ident) - definition ty ident params pos = - void (M.lookAhead lbrace) - >> gets (addFunction True ty (tmpTKIdent ident)) - >>= \case - Right scp' -> do - put scp' - params' <- forM params $ uncurry registerLVar - stmt >>= fromValidFunc params' - Left err -> fail $ T.unpack $ fst err + definition ty ident pos = do + registerFunc True ty ident + params <- mapM (uncurry registerLVar) =<< toNamedParams ty + stmt >>= fromValidFunc params where fromValidFunc params' st@(ATNode (ATBlock block) _ _ _) | CT.toTypeKind ty == CT.CTVoid = @@ -175,20 +160,25 @@ function = do pure $ atDefFunc ident (if null params' then Nothing else Just params') ty st fromValidFunc _ _ = fail "internal compiler error" -gvar = declIdent >>= \case - (_, Nothing) -> ATEmpty <$ semi - (ty, Just ident) -> choice - [ nonInit ty ident - , withInit ty ident +gvar = do + ty <- declspec + M.choice + [ ATEmpty <$ semi + , declGVar ty ] where - nonInit ty ident = do - void semi - ty' <- maybeToParser "defining global variables with a incomplete type" =<< gets (incomplete ty) - gets (addGVar ty' (tmpTKIdent ident)) - >>= \case - Left err -> fail $ T.unpack $ fst err - Right (_, scp) -> ATEmpty <$ put scp + declGVar ty = declarator ty >>= \case + (_, Nothing) -> fail "variable name omitted, expected unqualified-id" + (ty', Just ident) -> choice + [ nonInit ty' ident + , withInit ty' ident + ] + + nonInit ty ident = semi + >> gets (incomplete ty) + >>= maybeToParser "defining global variables with a incomplete type" + >>= flip registerGVar ident + >> pure ATEmpty withInit ty ident = do void equal @@ -196,37 +186,24 @@ gvar = declIdent >>= \case gvarInit ty' ident <* semi gvarInit ty ident = choice - [ M.try fromConstant - , fromOG - ] + [ M.try fromConstant + , fromOG + ] where + fromConstant = evalConstexpr + >>= registerGVarWith ty ident . PV.GVarInitWithVal + fromOG = do ast <- conditional case (atkind ast, atkind (atL ast)) of - (ATAddr, ATGVar _ name) -> gets (gvarInitWithOG ty name) - >>= \case - Left err -> fail $ T.unpack $ fst err - Right (_, scp) -> ATEmpty <$ put scp + (ATAddr, ATGVar _ name) -> registerGVarWith ty ident (PV.GVarInitWithOG name) (ATAddr, _) -> fail "invalid initializer in global variable" (ATGVar t name, _) - | CT.isCTArray t -> gets (gvarInitWithOG ty name) - >>= \case - Left err -> fail $ T.unpack $ fst err - Right (_, scp) -> ATEmpty <$ put scp + | CT.isCTArray t -> registerGVarWith ty ident (PV.GVarInitWithOG name) -- TODO: support initializing from other global variables | otherwise -> fail "initializer element is not constant" _ -> fail "initializer element is not constant" - gvarInitWithOG ty' to = addGVarWith ty' (tmpTKIdent ident) (PV.GVarInitWithOG to) - gvarInitWithVal ty' to = addGVarWith ty' (tmpTKIdent ident) (PV.GVarInitWithVal to) - - fromConstant = do - cval <- evalConstexpr - gets (gvarInitWithVal ty cval) - >>= \case - Left err -> fail $ T.unpack $ fst err - Right (_, scp) -> ATEmpty <$ put scp - compoundStmt :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i [ATree i] compoundStmt = bracket get (modify . fallBack) $ const $ braces (modify succNest *> M.many stmt) @@ -304,14 +281,21 @@ stmt = choice labelStmt = atLabel <$> M.try (identifier <* colon) - lvarStmt = declIdent >>= \case - (_, Nothing) -> ATEmpty <$ semi - (ty, Just ident) -> choice - [ nonInit ty ident - , withInit ty ident + lvarStmt = do + ty <- M.try declspec + M.choice + [ ATEmpty <$ semi + , declLVar ty ] where - nonInit ty ident = semi >> atNull <$> registerLVar ty ident + declLVar ty = declarator ty >>= \case + (_, Nothing) -> fail "variable name omitted, expected unqualified-id" + (ty', Just ident) -> M.choice + [ nonInit ty' ident + , withInit ty' ident + ] + + nonInit ty ident = semi *> registerLVar ty ident <&> atNull withInit ty ident = equal *> varInit assign ty ident <* semi expr = assign @@ -458,14 +442,7 @@ factor = choice sizeof = memOp kSizeof CT.sizeof "sizeof" alignof = memOp k_Alignof CT.alignof "alignof" - strLiteral = do - s <- stringLiteral - lit <- gets $ - addLiteral (CT.SCAuto $ CT.CTArray (fromIntegral $ length s) CT.CTChar) - (HT.TokenLCNums 1 1, HT.TKString $ BSU.fromString s) - case lit of - Left err -> fail $ T.unpack $ fst err - Right (nd, scp) -> nd <$ put scp + strLiteral = stringLiteral >>= registerStringLiteral identifier' = do pos <- getPosState diff --git a/src/Htcc/Parser/Combinators/Type.hs b/src/Htcc/Parser/Combinators/Type.hs index ffe49ed..20eda02 100644 --- a/src/Htcc/Parser/Combinators/Type.hs +++ b/src/Htcc/Parser/Combinators/Type.hs @@ -11,8 +11,6 @@ C language parser Combinators -} module Htcc.Parser.Combinators.Type ( module Htcc.Parser.Combinators.Type.Core - , module Htcc.Parser.Combinators.Type.AbsDecl ) where import Htcc.Parser.Combinators.Type.Core -import Htcc.Parser.Combinators.Type.AbsDecl diff --git a/src/Htcc/Parser/Combinators/Type/Core.hs b/src/Htcc/Parser/Combinators/Type/Core.hs index 39a89ba..f77edca 100644 --- a/src/Htcc/Parser/Combinators/Type/Core.hs +++ b/src/Htcc/Parser/Combinators/Type/Core.hs @@ -12,9 +12,9 @@ C language parser Combinators {-# LANGUAGE LambdaCase, OverloadedStrings, TupleSections #-} module Htcc.Parser.Combinators.Type.Core ( arraySuffix - , funcParams - , declspec - , declIdent + , typeSuffix + -- * Helper functions + , toNamedParams ) where import Control.Monad (mfilter) import Control.Monad.Combinators (choice) @@ -23,16 +23,15 @@ import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Control.Monad.Trans.State (gets) import Data.Bits (Bits (..)) -import Data.Either (rights) import Data.Functor ((<&>)) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, isJust) import qualified Data.Text as T -import Data.Tuple.Extra (dupe, first) +import Data.Tuple.Extra (dupe, first, second) import qualified Htcc.CRules.Types as CT import Htcc.Parser.Combinators.ConstExpr (evalConstexpr) import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Keywords -import {-# SOURCE #-} Htcc.Parser.Combinators.Type.NestedDecl +import {-# SOURCE #-} Htcc.Parser.Combinators.Decl.Declarator +import Htcc.Parser.Combinators.Decl.Spec (declspec) import Htcc.Parser.ConstructionData.Core (incomplete) import Htcc.Utils (toNatural) import qualified Text.Megaparsec as M @@ -75,55 +74,48 @@ arraySuffix ty = choice funcParams :: (Show i, Read i, Integral i, Bits i) => CT.StorageClass i - -> Parser i (CT.StorageClass i, [(CT.StorageClass i, T.Text)]) -funcParams ty = choice - [ (CT.wrapCTFunc ty [], []) <$ (symbol "void" *> rparen) - , withParams <&> \p -> (CT.wrapCTFunc ty $ map (either id fst) p, rights p) - ] + -> Parser i (CT.StorageClass i) +funcParams ty = lparen + *> choice + [ [] <$ (symbol "void" *> rparen) + , withParams + ] + <&> CT.wrapCTFunc ty where withParams = M.manyTill (M.try (declIdentFuncParam comma) M.<|> declIdentFuncParam (M.lookAhead rparen)) rparen - declIdentFuncParam sep = declIdent >>= \case - (ty', Nothing) -> Left ty' <$ sep - (ty', Just ident) -> Right (narrowPtr ty', ident) <$ sep + declIdentFuncParam sep = do + ty' <- M.try declspec + M.choice + [ (ty', Nothing) <$ sep + , declarator ty' >>= \case + (t, Nothing) -> (t, Nothing) <$ sep + (t, Just ident) -> (narrowPtr t, Just ident) <$ sep + ] where narrowPtr ty' | CT.isCTArray ty' = maybe ty' (CT.mapTypeKind CT.CTPtr) $ CT.deref ty' | CT.isIncompleteArray ty' = flip CT.mapTypeKind ty' $ \(CT.CTIncomplete (CT.IncompleteArray ty'')) -> CT.CTPtr ty'' | otherwise = ty' -{- + +toNamedParams :: (Show i, Read i, Integral i, Bits i) + => CT.StorageClass i + -> Parser i [(CT.StorageClass i, T.Text)] +toNamedParams ty = case CT.toTypeKind ty of + (CT.CTFunc _ params) -> pure + [ first CT.SCAuto $ second fromJust p + | p <- params + , isJust $ snd p + ] + _ -> fail "expected function parameters" + typeSuffix :: (Show i, Read i, Bits i, Integral i) => CT.StorageClass i -> Parser i (CT.StorageClass i) typeSuffix ty = M.option ty $ choice [ arraySuffix ty - , lparen *> funcParams ty <&> fst - ] --} - -declspec', - declspec :: (Show i, Read i, Integral i) => Parser i (CT.StorageClass i) - -declspec' = choice - [ kStatic *> (CT.SCStatic . CT.toTypeKind <$> declspec') - , kRegister *> (CT.SCRegister . CT.toTypeKind <$> declspec') - , kAuto *> declspec' - -- , struct - , choice kBasicTypes <&> CT.SCAuto . CT.toTypeKind . CT.implicitInt . read' . T.unpack + , funcParams ty ] - where - read' :: (Show i, Read i, Integral i) - => String - -> CT.TypeKind i - read' = read - -declspec = do - pt <- declspec' - fn <- CT.ctorPtr . toNatural . length <$> M.many star - pure $ fn pt - -declIdent :: (Show i, Read i, Bits i, Integral i) => Parser i (CT.StorageClass i, Maybe T.Text) -declIdent = M.try declspec >>= nestedDeclType diff --git a/src/Htcc/Parser/Combinators/Type/NestedDecl.hs b/src/Htcc/Parser/Combinators/Type/NestedDecl.hs deleted file mode 100644 index a8d8942..0000000 --- a/src/Htcc/Parser/Combinators/Type/NestedDecl.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-| -Module : Htcc.Parser.Combinators.Type.NestedDecl -Description : C language parser Combinators -Copyright : (c) roki, 2020~ -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -C language parser Combinators --} -{-# LANGUAGE TupleSections #-} -module Htcc.Parser.Combinators.Type.NestedDecl ( - nestedDeclType -) where - -import Data.Bits (Bits (..)) -import qualified Data.Text as T -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Type.Core (arraySuffix) -import Htcc.Parser.Combinators.Type.Utils -import Htcc.Utils (dropFst3, swap) -import qualified Text.Megaparsec as M - --- TODO: Allow the function pointer type -nestedDeclType :: (Integral i, Show i, Read i, Bits i) - => CT.StorageClass i - -> Parser i (CT.StorageClass i, Maybe T.Text) -nestedDeclType ty = do - ty' <- flip id ty <$> takeCtorPtr - M.option (ty', Nothing) $ M.choice - [ M.lookAhead lparen *> (swap . dropFst3 <$> nestedDeclType' id ty') - , swap <$> ((,) <$> (Just <$> identifier) <*> M.option ty' (arraySuffix ty')) - ] - where - nestedDeclType' fn ty' = do - ptrf <- takeCtorPtr - M.choice - [ nested ptrf - , nonNested ptrf - ] - where - nested ptrf = do - (ptrf', ident, ty'') <- parens $ nestedDeclType' (fn . ptrf) ty' - M.option (id, ident, ptrf' ty'') ((id, ident,) . ptrf' <$> arraySuffix ty'') - - nonNested ptrf = (ptrf,,) - <$> (Just <$> identifier) - <*> M.option ty' (arraySuffix ty') diff --git a/src/Htcc/Parser/Combinators/Type/Utils.hs b/src/Htcc/Parser/Combinators/Type/Utils.hs index affa72f..8d0a94a 100644 --- a/src/Htcc/Parser/Combinators/Type/Utils.hs +++ b/src/Htcc/Parser/Combinators/Type/Utils.hs @@ -11,7 +11,8 @@ C language parser Combinators -} {-# LANGUAGE TupleSections #-} module Htcc.Parser.Combinators.Type.Utils ( - takeCtorPtr + starsToPtrCtor + , starsToPtr ) where import qualified Htcc.CRules.Types as CT @@ -19,5 +20,8 @@ import Htcc.Parser.Combinators.Core (Parser, star) import Htcc.Utils (toNatural) import qualified Text.Megaparsec as M -takeCtorPtr :: Ord i => Parser i (CT.StorageClass i -> CT.StorageClass i) -takeCtorPtr = CT.ctorPtr . toNatural . length <$> M.many star +starsToPtrCtor :: Ord i => Parser i (CT.StorageClass i -> CT.StorageClass i) +starsToPtrCtor = CT.ctorPtr . toNatural . length <$> M.many star + +starsToPtr :: Ord i => CT.StorageClass i -> Parser i (CT.StorageClass i) +starsToPtr ty = starsToPtrCtor <*> pure ty diff --git a/src/Htcc/Parser/Combinators/Utils.hs b/src/Htcc/Parser/Combinators/Utils.hs index 707f434..55b49f4 100644 --- a/src/Htcc/Parser/Combinators/Utils.hs +++ b/src/Htcc/Parser/Combinators/Utils.hs @@ -13,29 +13,91 @@ C language parser Combinators module Htcc.Parser.Combinators.Utils ( maybeToParser , registerLVar + , registerGVar + , registerGVarWith + , registerStringLiteral + , registerFunc , bracket - , tmpTKIdent , getPosState ) where -import Control.Monad.State (gets, put) -import Control.Natural (type (~>)) -import Data.Bits (Bits (..)) -import qualified Data.Text as T -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST.Core (ATree (..)) +import qualified Data.ByteString.UTF8 as BSU +import Control.Monad.State (gets, put) +import Control.Natural (type (~>)) +import Data.Bits (Bits (..)) +import qualified Data.Text as T +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATree (..)) import Htcc.Parser.Combinators.Core -import Htcc.Parser.ConstructionData.Core (addLVar) -import qualified Htcc.Tokenizer.Token as HT -import qualified Text.Megaparsec as M +import Htcc.Parser.ConstructionData.Core (ConstructionData, + addGVar, + addGVarWith, + addLVar, + addLiteral, + addFunction) +import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) +import Htcc.Parser.ConstructionData.Scope.Var (GVarInitWith) +import qualified Htcc.Tokenizer.Token as HT +import qualified Text.Megaparsec as M maybeToParser :: String -> Maybe ~> Parser i maybeToParser s = maybe (fail s) pure -registerLVar :: (Bits i, Integral i) => CT.StorageClass i -> T.Text -> Parser i (ATree i) -registerLVar ty ident = gets (addLVar ty (HT.TokenLCNums 1 1, HT.TKIdent ident)) +type PureAdder i = CT.StorageClass i + -> HT.TokenLC i + -> ConstructionData i + -> Either (ASTError i) (ATree i, ConstructionData i) + +registerVar :: (Bits i, Integral i) + => PureAdder i + -> CT.StorageClass i + -> T.Text + -> Parser i (ATree i) +registerVar adder ty ident = gets (adder ty (tmpTKIdent ident)) >>= \case Right (lat, scp') -> lat <$ put scp' - Left err -> fail $ T.unpack $ fst err + Left err -> fail $ T.unpack $ fst err + +registerLVar :: (Bits i, Integral i) + => CT.StorageClass i + -> T.Text + -> Parser i (ATree i) +registerLVar = registerVar addLVar + +registerStringLiteral :: (Bits i, Integral i) + => String + -> Parser i (ATree i) +registerStringLiteral s = gets (addLiteral ty (HT.TokenLCNums 1 1, HT.TKString $ BSU.fromString s)) + >>= \case + Right (n, scp) -> n <$ put scp + Left err -> fail $ T.unpack $ fst err + where + ty = CT.SCAuto $ CT.CTArray (fromIntegral $ length s) CT.CTChar + +registerGVar :: (Bits i, Integral i) + => CT.StorageClass i + -> T.Text + -> Parser i (ATree i) +registerGVar = registerVar addGVar + +registerGVarWith :: (Bits i, Integral i) + => CT.StorageClass i + -> T.Text + -> GVarInitWith i + -> Parser i (ATree i) +registerGVarWith ty ident to = gets (addGVarWith ty (tmpTKIdent ident) to) + >>= \case + Right (_, scp) -> ATEmpty <$ put scp + Left err -> fail $ T.unpack $ fst err + +registerFunc :: (Bits i, Integral i) + => Bool + -> CT.StorageClass i + -> T.Text + -> Parser i () +registerFunc isDefined ty ident = gets (addFunction isDefined ty (tmpTKIdent ident)) + >>= \case + Right scp -> put scp + Left err -> fail $ T.unpack $ fst err bracket :: Parser i a -> (a -> Parser i b) -> (a -> Parser i c) -> Parser i c bracket beg end m = do diff --git a/test/Tests/csrc/self/expressions/operators.c b/test/Tests/csrc/self/expressions/operators.c index 5d4bc3c..154d359 100644 --- a/test/Tests/csrc/self/expressions/operators.c +++ b/test/Tests/csrc/self/expressions/operators.c @@ -117,12 +117,10 @@ int main() assert(8, ({ char (*x)[3]; sizeof x; }), "({ char (*x)[3]; sizeof x; })"); assert(1, sizeof main, "sizeof main"); assert(1, sizeof assert, "sizeof assert"); - //assert(1, ({ char (x); sizeof x; }), "({ char (x); sizeof x; })"); - //assert(3, ({ char (x)[3]; sizeof x; }), "({ char (x)[3]; sizeof x; })"); - //assert(3, ({ char (x)[3]; sizeof x; }), + assert(1, ({ char (x); sizeof x; }), "({ char (x); sizeof x; })"); + assert(3, ({ char (x)[3]; sizeof x; }), "({ char (x)[3]; sizeof x; })"); assert(12, ({ char (x[3])[4]; sizeof x; }), "({ char (x[3])[4]; sizeof x; })"); assert(4, ({ char (x[3])[4]; sizeof x[0]; }), "({ char (x[3])[4]; sizeof x[0]; })"); - assert(4, ({ int a; _Alignof(a); }), "({ int a; _Alignof(a); })"); assert(4, ({ int a; _Alignof a; }), "({ int a; _Alignof a; })"); assert(8, ({ int* a; _Alignof a; }), "({ int* a; _Alignof a; })"); From 7235a9c0517239d1a0ccbf2ce8d4a7291e68cf5c Mon Sep 17 00:00:00 2001 From: roki Date: Thu, 11 Feb 2021 18:50:12 +0900 Subject: [PATCH 49/51] Supports abstract declarator for functions --- htcc.cabal | 3 +- src/Htcc/Parser/Combinators/Decl.hs | 4 +- .../Combinators/Decl/AbstractDeclarator.hs | 40 ------------------- .../Parser/Combinators/Decl/Declarator.hs | 18 +++++++++ src/Htcc/Parser/Combinators/Program.hs | 8 ++-- src/Htcc/Parser/Combinators/Type/Core.hs | 3 +- src/Htcc/Visualizer/Core.hs | 1 + test/Tests/csrc/self/array/basic.c | 13 +++++- test/Tests/csrc/self/expressions/operators.c | 3 ++ test/Tests/csrc/self/statements/func.c | 11 ++++- test/Tests/csrc/self/test_core.c | 10 +---- 11 files changed, 50 insertions(+), 64 deletions(-) delete mode 100644 src/Htcc/Parser/Combinators/Decl/AbstractDeclarator.hs diff --git a/htcc.cabal b/htcc.cabal index 5206156..895fc6a 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: c76bad766ef4b8408c8ebd5f51183ab0da218376e837f6a97ac568d53ff52ea1 +-- hash: 850b9848b962537995097e4ec0c7bc1c88f136695936efa9068db58eece3242d name: htcc version: 0.0.0.1 @@ -73,7 +73,6 @@ library Htcc.Parser.Combinators.ConstExpr Htcc.Parser.Combinators.Core Htcc.Parser.Combinators.Decl - Htcc.Parser.Combinators.Decl.AbstractDeclarator Htcc.Parser.Combinators.Decl.Declarator Htcc.Parser.Combinators.Decl.Spec Htcc.Parser.Combinators.GNUExtensions diff --git a/src/Htcc/Parser/Combinators/Decl.hs b/src/Htcc/Parser/Combinators/Decl.hs index 727f884..57b2685 100644 --- a/src/Htcc/Parser/Combinators/Decl.hs +++ b/src/Htcc/Parser/Combinators/Decl.hs @@ -10,11 +10,9 @@ Portability : POSIX C language parser Combinators -} module Htcc.Parser.Combinators.Decl ( - module Htcc.Parser.Combinators.Decl.AbstractDeclarator - , module Htcc.Parser.Combinators.Decl.Spec + module Htcc.Parser.Combinators.Decl.Spec , module Htcc.Parser.Combinators.Decl.Declarator ) where -import Htcc.Parser.Combinators.Decl.AbstractDeclarator import Htcc.Parser.Combinators.Decl.Declarator import Htcc.Parser.Combinators.Decl.Spec diff --git a/src/Htcc/Parser/Combinators/Decl/AbstractDeclarator.hs b/src/Htcc/Parser/Combinators/Decl/AbstractDeclarator.hs deleted file mode 100644 index eb080ce..0000000 --- a/src/Htcc/Parser/Combinators/Decl/AbstractDeclarator.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-| -Module : Htcc.Parser.Combinators.Decl.AbstractDeclarator -Description : C language parser Combinators -Copyright : (c) roki, 2020~ -License : MIT -Maintainer : falgon53@yahoo.co.jp -Stability : experimental -Portability : POSIX - -C language parser Combinators --} -{-# LANGUAGE TupleSections #-} -module Htcc.Parser.Combinators.Decl.AbstractDeclarator ( - absDeclType -) where - -import Data.Bits (Bits (..)) -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Decl.Spec (declspec) -import Htcc.Parser.Combinators.Type.Core (arraySuffix) -import Htcc.Parser.Combinators.Type.Utils (starsToPtr, starsToPtrCtor) -import qualified Text.Megaparsec as M - --- TODO: Allow the function pointer type -absDeclType :: (Integral i, Show i, Read i, Bits i) => Parser i (CT.StorageClass i) -absDeclType = do - ty <- declspec - if CT.isSCStatic ty {- TODO: or register -} then fail "storage-class specifier is not allowed" else do - ty' <- starsToPtr ty - M.choice - [ arraySuffix ty' - , snd <$> absDeclType' id ty' - ] - where - absDeclType' fn ty = do - cpfn <- starsToPtrCtor - M.option (cpfn, ty) $ do - (cpfn', ty') <- parens $ absDeclType' (fn . cpfn) ty - M.option (id, cpfn' ty') ((id,) . cpfn' <$> arraySuffix ty') diff --git a/src/Htcc/Parser/Combinators/Decl/Declarator.hs b/src/Htcc/Parser/Combinators/Decl/Declarator.hs index 7dd8645..c0e7c34 100644 --- a/src/Htcc/Parser/Combinators/Decl/Declarator.hs +++ b/src/Htcc/Parser/Combinators/Decl/Declarator.hs @@ -12,6 +12,7 @@ C language parser Combinators {-# LANGUAGE TupleSections #-} module Htcc.Parser.Combinators.Decl.Declarator ( declarator + , absDeclarator ) where import Control.Monad.Fix (fix) @@ -20,6 +21,7 @@ import qualified Data.Text as T import Data.Tuple.Extra (uncurry3) import qualified Htcc.CRules.Types as CT import Htcc.Parser.Combinators.Core +import Htcc.Parser.Combinators.Decl.Spec (declspec) import Htcc.Parser.Combinators.Type.Core (typeSuffix) import Htcc.Parser.Combinators.Type.Utils import Htcc.Utils (dropFst3, swap) @@ -46,3 +48,19 @@ declarator ty = do where nested' ptrf ident t = M.option (id, ident, ptrf t) ((id, ident,) . ptrf <$> typeSuffix t) + +absDeclarator :: (Integral i, Show i, Read i, Bits i) => Parser i (CT.StorageClass i) +absDeclarator = do + ty <- declspec + if CT.isSCStatic ty {- TODO: or register -} then fail "storage-class specifier is not allowed" else do + ty' <- starsToPtr ty + M.choice + [ M.try $ typeSuffix ty' + , snd <$> absDeclType' id ty' + ] + where + absDeclType' fn ty = do + cpfn <- starsToPtrCtor + M.option (cpfn, ty) $ do + (cpfn', ty') <- parens $ absDeclType' (fn . cpfn) ty + M.option (id, cpfn' ty') ((id,) . cpfn' <$> typeSuffix ty') diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 08bbfa7..7bcc807 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -59,9 +59,7 @@ import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.ConstExpr (evalConstexpr) import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Decl (absDeclType) -import Htcc.Parser.Combinators.Decl.Declarator (declarator) -import Htcc.Parser.Combinators.Decl.Spec (declspec) +import Htcc.Parser.Combinators.Decl (absDeclarator, declarator, declspec) import qualified Htcc.Parser.Combinators.GNUExtensions as GNU import Htcc.Parser.Combinators.Keywords import Htcc.Parser.Combinators.Type (toNamedParams) @@ -364,7 +362,7 @@ term = binaryOperator cast ] cast = choice - [ atCast <$> M.try (parens absDeclType) <*> cast + [ atCast <$> M.try (parens absDeclarator) <*> cast , unary ] @@ -428,7 +426,7 @@ factor = choice , memOpUnary ] where - memOpType = incomplete <$> M.try (parens absDeclType) <*> get + memOpType = incomplete <$> M.try (parens absDeclarator) <*> get >>= fmap (atNumLit . fromIntegral . op) . maybeToParser ("invalid application of '" <> opS <> "' to incomplete type") diff --git a/src/Htcc/Parser/Combinators/Type/Core.hs b/src/Htcc/Parser/Combinators/Type/Core.hs index f77edca..540cedb 100644 --- a/src/Htcc/Parser/Combinators/Type/Core.hs +++ b/src/Htcc/Parser/Combinators/Type/Core.hs @@ -11,8 +11,7 @@ C language parser Combinators -} {-# LANGUAGE LambdaCase, OverloadedStrings, TupleSections #-} module Htcc.Parser.Combinators.Type.Core ( - arraySuffix - , typeSuffix + typeSuffix -- * Helper functions , toNamedParams ) where diff --git a/src/Htcc/Visualizer/Core.hs b/src/Htcc/Visualizer/Core.hs index 9ab88cb..a21e9cc 100644 --- a/src/Htcc/Visualizer/Core.hs +++ b/src/Htcc/Visualizer/Core.hs @@ -98,6 +98,7 @@ encodeTree (ATNode (ATCallFunc fname (Just args)) _ lhs rhs) = Node (T.unpack fn encodeTree (ATNode ATExprStmt _ lhs _) = encodeTree lhs encodeTree (ATNode (ATStmtExpr exps) _ lhs rhs) = Node "({})" $ map encodeTree exps ++ [encodeTree lhs, encodeTree rhs] encodeTree (ATNode (ATNull _) _ _ _) = Node "" [] +-- TODO: handle ATFunc renderNTree :: Tree String -> QDiagram SVG V2 Double Any renderNTree nt = renderTree diff --git a/test/Tests/csrc/self/array/basic.c b/test/Tests/csrc/self/array/basic.c index acad61c..c8f5ed8 100644 --- a/test/Tests/csrc/self/array/basic.c +++ b/test/Tests/csrc/self/array/basic.c @@ -10,7 +10,7 @@ int test_num; int; int gr[3]; -//int (*gpa)[3]; +int (*gpa)[3]; int assert(long expected, long actual, char* code) { @@ -26,6 +26,12 @@ int assert(long expected, long actual, char* code) int gg(int* p) { *p = 42; return 0; } int sum(int* p, int n) { int s = 0; for (int i = 0; i < n; i = i + 1) s = s + *(p + i); return s; } +void ptr2ar(int (*p)[3]) +{ + int i = 0; + for (; i < sizeof *p / sizeof **p; ++i) + p[0][i] = i + 1; +} int main() { @@ -140,6 +146,11 @@ int main() assert(0, ({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; }), "({ int ar[1][1][1] = {{{}}}; ar[0][0][0]; })"); assert(3, ({ char* x[3]; char y; x[0] = &y; y = 3; x[0][0]; }), "({ char* x[3]; char y; x[0] = &y; y = 3; x[0][0]; })"); assert(4, ({ char x[3]; char (*y)[3] = x; y[0][0] = 4; y[0][0]; }), "({ char x[3]; char (*y)[3] = x; y[0] = 4; y[0][0]; }"); + assert(1, ({ gpa = gr; (*gpa)[0]; }), "({ gpa = gr; (*gpa)[0]; })"); + assert(2, gpa[0][1], "gpa[0][1]"); + assert(3, gpa[0][2], "gpa[0][2]"); + assert(42, ({ int* ar[3]; int x; ar[0] = &x; x = 42; ar[0][0]; }), "({ int* ar[3]; int x; ar[0] = &x; x = 42; ar[0][0]; })"); + assert(6, ({ int ar[3]; ptr2ar(&ar); sum(ar, sizeof ar / sizeof *ar); }), "({ int ar[3]; ptr2ar(&ar); sum(ar, sizeof ar / sizeof *ar); })"); printf("All tests are passed!\n"); diff --git a/test/Tests/csrc/self/expressions/operators.c b/test/Tests/csrc/self/expressions/operators.c index 154d359..8ca2e0f 100644 --- a/test/Tests/csrc/self/expressions/operators.c +++ b/test/Tests/csrc/self/expressions/operators.c @@ -117,6 +117,9 @@ int main() assert(8, ({ char (*x)[3]; sizeof x; }), "({ char (*x)[3]; sizeof x; })"); assert(1, sizeof main, "sizeof main"); assert(1, sizeof assert, "sizeof assert"); + assert(8, sizeof(void (*)()), "sizeof(void (*)())"); + assert(8, sizeof(int (*)(void)), "sizeof(int (*)(void))"); + assert(8, sizeof(int (*)(int, int)), "sizeof(int (*)(int, int))"); assert(1, ({ char (x); sizeof x; }), "({ char (x); sizeof x; })"); assert(3, ({ char (x)[3]; sizeof x; }), "({ char (x)[3]; sizeof x; })"); assert(12, ({ char (x[3])[4]; sizeof x; }), "({ char (x[3])[4]; sizeof x; })"); diff --git a/test/Tests/csrc/self/statements/func.c b/test/Tests/csrc/self/statements/func.c index 26baa56..6390960 100644 --- a/test/Tests/csrc/self/statements/func.c +++ b/test/Tests/csrc/self/statements/func.c @@ -22,7 +22,13 @@ void swap(int* a, int* b) { *a ^= *b; *b ^= *a; *a ^= *b; } void void_fn(int* a) { *a = 42; return; *a = 53; } int param_decay(int ar[]) { return ar[0]; } int rec(int a) { if (a == 0) return 42; return rec(a - 1); } -int fib(int n) { if (n == 0) return 1; else if (n == 1) return 1; else if (n >= 2) return fib(n - 1) + fib(n - 2); else return 0; } +int fib(int n) // fibonacci number +{ + if (n == 0) return 1; + else if (n == 1) return 1; + else if (n >= 2) return fib(n - 1) + fib(n - 2); + else return 0; +} int main() { @@ -33,11 +39,12 @@ int main() assert(45, f() + 3, "f() + 3"); assert(3, add(1, 2), "add(1, 2)"); assert(44, ({ int b = rec(2); b + 2; }), "({ int b = rec(2); b + 2; })"); - assert(8, fib(5), "fib(5)"); // fibonacci number + assert(8, fib(5), "fib(5)"); assert(0, ({ int ar[] = { 0 }; param_decay(ar); }), "({ int ar[] = { 0 }; param_decay(ar); })"); assert(2, ({ int a = 1; int b = 2; swap(&a, &b); a; }), "({ int a = 1; int b = 2; swap(&a, &b); a; })"); assert(1, ({ int a = 1; int b = 2; swap(&a, &b); b; }), "({ int a = 1; int b = 2; swap(&a, &b); b; })"); assert(42, ({ int a = 1; void_fn(&a); a; }), "({ int a = 1; void_fn(&a); a; })"); + //assert(8, ({ int (*fibp)() = fib; fib(5); }), "({ int (*fibp)() = fib; fib(5); })"); printf("All tests are passed!\n"); return 0; diff --git a/test/Tests/csrc/self/test_core.c b/test/Tests/csrc/self/test_core.c index 756038e..86092e4 100644 --- a/test/Tests/csrc/self/test_core.c +++ b/test/Tests/csrc/self/test_core.c @@ -10,7 +10,6 @@ int test_num; int g; int gr[3]; -//int (*gpa)[3]; char gc = 1; short gsh = 2; int gi = 3; @@ -36,8 +35,7 @@ int sum(int* p, int n) { int s = 0; for (int i = 0; i < n; i = i + 1) s = s + *( int sub3(int a, int b, int c) { return a - b - c; } int sub3_short(short a, short b, short c) { return a - b - c; } int sub3_long(long a, long b, long c) { return a - b - c; } -/*int ptr2ar(int (*p)[3]) { int i = 0; for (; i < sizeof *p / sizeof **p; i = i + 1) p[0][i] = i + 1; return 0; } -static int static_fun() { return 42; }*/ +/*static int static_fun() { return 42; }*/ int main() { @@ -112,12 +110,6 @@ int main() assert(16, ({ long int a; int long b; sizeof a + sizeof b; }), "({ long int a; int long b; sizeof a + sizeof b; })"); assert(32, ({ typedef int* p[4]; p a; sizeof a; }), "({ typedef int* p[4]; sizeof p; })"); assert(8, ({ typedef int (*pp)[4]; pp a; sizeof a; }), "({ typedef int (*p)[4]; sizeof p; })"); - assert(1, ({ gpa = gr; (*gpa)[0]; }), "({ gpa = gr; (*gpa)[0]; })"); - assert(2, gpa[0][1], "(*gpa)[1]"); - assert(3, gpa[0][2], "(*gpa)[2]"); - assert(42, ({ int* ar[3]; int x; ar[0] = &x; x = 42; ar[0][0]; }), "({ int* ar[3]; int x; ar[0] = &x; x = 42; ar[0][0]; })"); - assert(42, ({ int ar[3]; int (*p)[3] = ar; p[0][0] = 42; ar[0]; }), "({ int ar[3]; int (*p)[3] = ar; p[0][0] = 42; ar[0]; })"); - assert(6, ({ int ar[3]; ptr2ar(&ar); sum(ar, sizeof ar / sizeof *ar); }), "({ int ar[3]; ptr2ar(&ar); sum(ar, sizeof ar / sizeof **ar); }"); assert(42, ({ struct { int (*p)[3]; } x; int ar[3]; x.p = &ar; (*x.p)[0] = 42; ar[0]; }), "({ struct { int (*p)[3]; } x; int ar[3]; x.p = &ar; (*x.p)[0] = 42; ar[0]; })"); { void* x; } assert(0, ({ _Bool x = 0; x; }), "({ _Bool x = 0; x; })"); From 3248a8c1bc19bc74c808f5f3bfcac36deb22e730 Mon Sep 17 00:00:00 2001 From: Hiroki Gomi Date: Thu, 26 Mar 2026 22:49:52 +0900 Subject: [PATCH 50/51] Replace Megaparsec with Parsec compatibility layer --- app/Main.hs | 2 +- htcc.cabal | 12 +- package.yaml | 2 +- src/Htcc/Parser/Combinators/Core.hs | 26 ++- src/Htcc/Parser/Combinators/Keywords.hs | 7 +- src/Text/Megaparsec.hs | 242 ++++++++++++++++++++++++ src/Text/Megaparsec/Char.hs | 25 +++ src/Text/Megaparsec/Char/Lexer.hs | 112 +++++++++++ src/Text/Megaparsec/Debug.hs | 6 + 9 files changed, 414 insertions(+), 20 deletions(-) create mode 100644 src/Text/Megaparsec.hs create mode 100644 src/Text/Megaparsec/Char.hs create mode 100644 src/Text/Megaparsec/Char/Lexer.hs create mode 100644 src/Text/Megaparsec/Debug.hs diff --git a/app/Main.hs b/app/Main.hs index 2953cb6..b2f13be 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -93,7 +93,7 @@ main = do txt <- T.readFile fname case runParser parser fname txt :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer) of - Left x -> print x -- putStr $ M.errorBundlePretty x + Left x -> putStr $ M.errorBundlePretty x Right r -> do mapM_ (hPutStr stderr . M.errorBundlePretty) $ toList $ fst4 r runAsm' $ casm' (snd4 r) (thd4 r) (fou4 r) diff --git a/htcc.cabal b/htcc.cabal index 895fc6a..f33f181 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -95,6 +95,10 @@ library Htcc.Parser.ConstructionData.Scope.Var Htcc.Parser.Utils Htcc.Parser.Utils.Core + Text.Megaparsec + Text.Megaparsec.Char + Text.Megaparsec.Char.Lexer + Text.Megaparsec.Debug Htcc.Tokenizer Htcc.Tokenizer.Core Htcc.Tokenizer.Token @@ -123,7 +127,7 @@ library , diagrams-lib , diagrams-svg , extra - , megaparsec + , parsec , monad-finally , monad-loops , mono-traversable @@ -159,7 +163,7 @@ executable htcc , extra , gitrev , htcc - , megaparsec + , parsec , monad-finally , monad-loops , mono-traversable @@ -210,7 +214,7 @@ test-suite htcc-test , hspec-contrib , hspec-core , htcc - , megaparsec + , parsec , monad-finally , monad-loops , mono-traversable @@ -247,7 +251,7 @@ benchmark criterion , diagrams-svg , extra , htcc - , megaparsec + , parsec , monad-finally , monad-loops , mono-traversable diff --git a/package.yaml b/package.yaml index 217031f..9aeb632 100644 --- a/package.yaml +++ b/package.yaml @@ -46,7 +46,7 @@ dependencies: - diagrams-lib - natural-transformation - optparse-applicative -- megaparsec +- parsec - parser-combinators - utf8-string diff --git a/src/Htcc/Parser/Combinators/Core.hs b/src/Htcc/Parser/Combinators/Core.hs index 098e1aa..c76792d 100644 --- a/src/Htcc/Parser/Combinators/Core.hs +++ b/src/Htcc/Parser/Combinators/Core.hs @@ -66,30 +66,36 @@ import Htcc.Utils (lor) import qualified Text.Megaparsec as M import qualified Text.Megaparsec.Char as MC import qualified Text.Megaparsec.Char.Lexer as ML +import qualified Text.Parsec as P -spaceConsumer :: Ord e => M.ParsecT e T.Text m () +spaceConsumer :: (Monad m, Ord e) => M.ParsecT e T.Text m () spaceConsumer = ML.space MC.space1 (ML.skipLineComment "//") (ML.skipBlockComment "/*" "*/") -lexeme :: Ord e => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m a +lexeme :: (Monad m, Ord e) => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m a lexeme = ML.lexeme spaceConsumer -symbol :: Ord e => T.Text -> M.ParsecT e T.Text m T.Text +symbol :: (Monad m, Ord e) => T.Text -> M.ParsecT e T.Text m T.Text symbol = ML.symbol spaceConsumer -charLiteral :: Ord e => M.ParsecT e T.Text m Char -charLiteral = M.between (MC.char '\'') (MC.char '\'') ML.charLiteral <* spaceConsumer +charLiteral :: (Monad m, Ord e) => M.ParsecT e T.Text m Char +charLiteral = M.between (MC.char '\'') (MC.char '\'') charBody <* spaceConsumer + where + -- Keep the historical single-quoted character behavior that the existing + -- component tests exercise, while `ML.charLiteral` remains strict enough + -- for string-literal parsing. + charBody = ML.charLiteral <|> M.ParsecT (P.noneOf ['\\']) -stringLiteral :: Ord e => M.ParsecT e T.Text m String +stringLiteral :: (Monad m, Ord e) => M.ParsecT e T.Text m String stringLiteral = MC.char '\"' *> ((<> "\0") <$> M.manyTill ML.charLiteral (MC.char '\"')) <* spaceConsumer -hexadecimal, octal, decimal, natural, integer :: (Ord e, Num i) => M.ParsecT e T.Text m i +hexadecimal, octal, decimal, natural, integer :: (Monad m, Ord e, Num i) => M.ParsecT e T.Text m i hexadecimal = MC.char '0' >> MC.char' 'x' >> ML.hexadecimal octal = MC.char '0' >> ML.octal decimal = ML.decimal natural = M.try (lexeme hexadecimal) <|> M.try (lexeme octal) <|> lexeme decimal integer = ML.signed spaceConsumer natural <|> natural -parens, braces, angles, brackets :: Ord e => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m a +parens, braces, angles, brackets :: (Monad m, Ord e) => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m a parens = between lparen rparen braces = between lbrace rbrace angles = between langle rangle @@ -118,7 +124,7 @@ identifier, hat, tilda, vertical, - percent :: Ord e => M.ParsecT e T.Text m T.Text + percent :: (Monad m, Ord e) => M.ParsecT e T.Text m T.Text identifier = mappend <$> M.takeWhile1P (Just "valid identifier") (lor [isAlpha, (=='_')]) @@ -148,7 +154,7 @@ tilda = symbol "~" vertical = symbol "|" percent = symbol "%" -notFollowedBy :: Ord e +notFollowedBy :: (Monad m, Ord e) => M.ParsecT e T.Text m a -> M.ParsecT e T.Text m b -> M.ParsecT e T.Text m a diff --git a/src/Htcc/Parser/Combinators/Keywords.hs b/src/Htcc/Parser/Combinators/Keywords.hs index 634006f..21727ae 100644 --- a/src/Htcc/Parser/Combinators/Keywords.hs +++ b/src/Htcc/Parser/Combinators/Keywords.hs @@ -27,7 +27,7 @@ import Htcc.Parser.Combinators.Core import qualified Text.Megaparsec as M import qualified Text.Megaparsec.Char as MC -pKeyword :: Ord e => T.Text -> M.ParsecT e T.Text m T.Text +pKeyword :: (Monad m, Ord e) => T.Text -> M.ParsecT e T.Text m T.Text pKeyword = flip notFollowedBy (M.takeWhile1P (Just "valid Keyword") CR.isValidChar) . MC.string kAuto, kBreak, kCase, kChar, kConst, kContinue, @@ -37,7 +37,7 @@ kAuto, kBreak, kCase, kChar, kConst, kContinue, kSizeof, kStatic, kStruct, kSwitch, kTypedef, kUnion, kUnsigned, kVoid, kVolatile, kWhile, k_Alignas, k_Alignof, k_Atomic, k_Bool, k_Complex, k_Generic, k_Imaginary, k_Noreturn, - k_Static_assert, k_Thread_local :: Ord e => M.ParsecT e T.Text m T.Text + k_Static_assert, k_Thread_local :: (Monad m, Ord e) => M.ParsecT e T.Text m T.Text kAuto = pKeyword "auto" kBreak = pKeyword "break" kCase = pKeyword "case" @@ -83,7 +83,7 @@ k_Noreturn = pKeyword "_Noreturn" k_Static_assert = pKeyword "_Static_assert" k_Thread_local = pKeyword "_Thread_local" -kBasicTypes :: Ord e => [M.ParsecT e T.Text m T.Text] +kBasicTypes :: (Monad m, Ord e) => [M.ParsecT e T.Text m T.Text] kBasicTypes = [ kChar , kDouble @@ -98,4 +98,3 @@ kBasicTypes = [ , k_Complex , k_Imaginary ] - diff --git a/src/Text/Megaparsec.hs b/src/Text/Megaparsec.hs new file mode 100644 index 0000000..5d2ef1d --- /dev/null +++ b/src/Text/Megaparsec.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, + LambdaCase, MultiParamTypeClasses, UndecidableInstances #-} +module Text.Megaparsec ( + Parsec, + ParsecT (..), + ParseErrorBundle (..), + ParseError (..), + ErrorFancy (..), + PosState (..), + ParserState (..), + runParser, + runParserT, + errorBundlePretty, + try, + lookAhead, + option, + choice, + many, + manyTill, + eof, + between, + takeWhileP, + takeWhile1P, + notFollowedBy, + getInput, + setInput, + getSourcePos, + getParserState, + withRecovery, + parseError, + empty, + (<|>) +) where + +import Control.Applicative (Alternative (..), many, (<|>)) +import Control.Monad (MonadPlus) +import qualified Control.Monad.State.Class as MS +import Control.Monad.Trans.Class (MonadTrans (..)) +import Data.Bool (bool) +import Data.Foldable (toList) +import Data.Functor.Identity (Identity, runIdentity) +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Text.Parsec as P +import qualified Text.Parsec.Error as PE +import qualified Text.Parsec.Pos as PP +import qualified Text.Parsec.Prim as PPri + +newtype ParsecT e s m a = ParsecT + { unParsecT :: P.ParsecT s s m a + } + deriving (Functor, Applicative, Monad, Alternative, MonadPlus, MonadFail) + +instance MonadTrans (ParsecT e s) where + lift = ParsecT . lift + +instance MS.MonadState st m => MS.MonadState st (ParsecT e s m) where + get = lift MS.get + put = lift . MS.put + state = lift . MS.state + +type Parsec e s = ParsecT e s Identity + +data ErrorFancy e + = ErrorFail String + deriving (Eq, Ord, Show) + +data ParseError s e + = ParsecError Bool PE.ParseError + | FancyError Int (S.Set (ErrorFancy e)) + deriving (Eq, Show) + +data PosState s = PosState + { pstateInput :: s + , pstateSourcePos :: PP.SourcePos + } + deriving (Eq, Show) + +data ParserState s = ParserState + { statePosState :: PosState s + } + deriving (Eq, Show) + +data ParseErrorBundle s e = ParseErrorBundle + { bundleErrors :: NonEmpty (ParseError s e) + , bundlePosState :: PosState s + } + deriving (Eq) + +instance Show (ParseErrorBundle T.Text e) where + show = errorBundlePretty + +runParser :: Parsec e T.Text a -> FilePath -> T.Text -> Either (ParseErrorBundle T.Text e) a +runParser p fp input = runIdentity $ runParserT p fp input + +runParserT :: Monad m => ParsecT e T.Text m a -> FilePath -> T.Text -> m (Either (ParseErrorBundle T.Text e) a) +runParserT (ParsecT p) fp input = + fmap (either (Left . toBundle input) Right) $ + P.runParserT p input fp input + where + toBundle source err = + ParseErrorBundle + { bundleErrors = ParsecError False err :| [] + , bundlePosState = PosState source (PE.errorPos err) + } + +errorBundlePretty :: ParseErrorBundle T.Text e -> String +errorBundlePretty bundle = + intercalate "\n\n" (fmap renderError $ toList $ bundleErrors bundle) <> "\n" + where + renderError = \case + ParsecError _ err -> + renderAt (PE.errorPos err) $ + lines $ + PE.showErrorMessages + "or" + "unknown parse error" + "expecting" + "unexpected" + "end of input" + (PE.errorMessages err) + FancyError _ fancyErrors -> + renderAt + (pstateSourcePos $ bundlePosState bundle) + [ msg + | ErrorFail msg <- S.toList fancyErrors + ] + + renderAt pos msgs = + intercalate "\n" $ + [ renderLoc pos ] + <> maybe [] (\(srcLn, caretCol) -> [srcLn, replicate (pred caretCol) ' ' <> "^"]) (sourceLineAt pos) + <> msgs + + renderLoc pos = + intercalate + ":" + [ PP.sourceName pos + , show $ PP.sourceLine pos + , show $ PP.sourceColumn pos + ] + + sourceLineAt pos = + let lineNo = fromIntegral (PP.sourceLine pos) - 1 + inputLines = T.splitOn (T.singleton '\n') $ pstateInput $ bundlePosState bundle + in if lineNo < 0 + then Nothing + else case drop lineNo inputLines of + srcLn : _ -> Just (T.unpack srcLn, fromIntegral $ PP.sourceColumn pos) + [] -> Nothing + +try :: ParsecT e T.Text m a -> ParsecT e T.Text m a +try = ParsecT . P.try . unParsecT + +lookAhead :: Monad m => ParsecT e T.Text m a -> ParsecT e T.Text m a +lookAhead = ParsecT . P.lookAhead . unParsecT + +option :: Monad m => a -> ParsecT e T.Text m a -> ParsecT e T.Text m a +option x = ParsecT . P.option x . unParsecT + +choice :: Alternative f => [f a] -> f a +choice = foldr (<|>) empty + +manyTill :: Monad m => ParsecT e T.Text m a -> ParsecT e T.Text m end -> ParsecT e T.Text m [a] +manyTill p end = ParsecT $ P.manyTill (unParsecT p) (unParsecT end) + +eof :: Monad m => ParsecT e T.Text m () +eof = ParsecT P.eof + +between :: Monad m => ParsecT e T.Text m open -> ParsecT e T.Text m close -> ParsecT e T.Text m a -> ParsecT e T.Text m a +between open close parser = ParsecT $ + P.between (unParsecT open) (unParsecT close) (unParsecT parser) + +takeWhileP :: Monad m => Maybe String -> (Char -> Bool) -> ParsecT e T.Text m T.Text +takeWhileP _ predicate = ParsecT $ T.pack <$> P.many (P.satisfy predicate) + +takeWhile1P :: Monad m => Maybe String -> (Char -> Bool) -> ParsecT e T.Text m T.Text +takeWhile1P _ predicate = ParsecT $ T.pack <$> P.many1 (P.satisfy predicate) + +notFollowedBy :: Monad m => ParsecT e T.Text m a -> ParsecT e T.Text m () +notFollowedBy parser = ParsecT $ + P.optionMaybe (P.try $ P.lookAhead $ unParsecT parser) >>= \case + Just _ -> P.unexpected "unexpected trailing input" + Nothing -> pure () + +getInput :: Monad m => ParsecT e T.Text m T.Text +getInput = ParsecT P.getInput + +setInput :: Monad m => T.Text -> ParsecT e T.Text m () +setInput = ParsecT . P.setInput + +getSourcePos :: Monad m => ParsecT e T.Text m PP.SourcePos +getSourcePos = ParsecT P.getPosition + +getParserState :: Monad m => ParsecT e T.Text m (ParserState T.Text) +getParserState = ParsecT $ do + input <- P.getState + pos <- P.getPosition + pure $ ParserState (PosState input pos) + +withRecovery + :: Monad m + => (ParseError T.Text e -> ParsecT e T.Text m a) + -> ParsecT e T.Text m a + -> ParsecT e T.Text m a +withRecovery handler parser = ParsecT $ PPri.mkPT $ \state -> + PPri.runParsecT (unParsecT parser) state >>= \case + PPri.Consumed replyM -> pure . PPri.Consumed $ replyM >>= \case + ok@(PPri.Ok _ _ _) -> pure ok + PPri.Error err -> + PPri.runParsecT (unParsecT $ handler $ ParsecError True err) (recoveryState err state) >>= \case + PPri.Consumed handledReply -> handledReply + PPri.Empty handledReply -> handledReply + PPri.Empty replyM -> replyM >>= \case + ok@(PPri.Ok _ _ _) -> pure $ PPri.Empty (pure ok) + PPri.Error err -> PPri.runParsecT (unParsecT $ handler $ ParsecError False err) (recoveryState err state) + where + recoveryState err parserState = + parserState + { PPri.stateInput = remainingInput (PPri.statePos parserState) (PPri.stateInput parserState) + , PPri.statePos = PE.errorPos err + } + where + targetPos = PE.errorPos err + remainingInput pos input + | pos == targetPos = input + | otherwise = + maybe T.empty advance $ T.uncons input + where + advance (c, rest) = remainingInput (PP.updatePosChar pos c) rest + +parseError :: Monad m => ParseError s e -> ParsecT e s m a +parseError = ParsecT . \case + ParsecError consumed err -> PPri.mkPT $ \_ -> pure $ + bool + (PPri.Empty $ pure $ PPri.Error err) + (PPri.Consumed $ pure $ PPri.Error err) + consumed + FancyError _ fancyErrors -> fail $ + intercalate ", " [msg | ErrorFail msg <- S.toList fancyErrors] diff --git a/src/Text/Megaparsec/Char.hs b/src/Text/Megaparsec/Char.hs new file mode 100644 index 0000000..56dd495 --- /dev/null +++ b/src/Text/Megaparsec/Char.hs @@ -0,0 +1,25 @@ +module Text.Megaparsec.Char ( + char, + char', + string, + space1 +) where + +import Control.Monad (void) +import Data.Char (isSpace, toLower) +import qualified Data.Text as T +import qualified Text.Parsec as P + +import Text.Megaparsec (ParsecT (..)) + +char :: Monad m => Char -> ParsecT e T.Text m Char +char = ParsecT . P.char + +char' :: Monad m => Char -> ParsecT e T.Text m Char +char' c = ParsecT $ P.satisfy ((== toLower c) . toLower) + +string :: Monad m => T.Text -> ParsecT e T.Text m T.Text +string = ParsecT . fmap T.pack . P.try . P.string . T.unpack + +space1 :: Monad m => ParsecT e T.Text m () +space1 = ParsecT $ void $ P.many1 $ P.satisfy isSpace diff --git a/src/Text/Megaparsec/Char/Lexer.hs b/src/Text/Megaparsec/Char/Lexer.hs new file mode 100644 index 0000000..0113f2b --- /dev/null +++ b/src/Text/Megaparsec/Char/Lexer.hs @@ -0,0 +1,112 @@ +module Text.Megaparsec.Char.Lexer ( + space, + skipLineComment, + skipBlockComment, + lexeme, + symbol, + charLiteral, + decimal, + hexadecimal, + octal, + signed +) where + +import Control.Applicative ((<|>)) +import Control.Monad (void) +import Data.Char (chr, isHexDigit, isOctDigit) +import qualified Data.Text as T +import Numeric (readHex, readOct) +import qualified Text.Parsec as P + +import Text.Megaparsec (ParsecT (..)) +import qualified Text.Megaparsec.Char as MC + +space :: Monad m => ParsecT e T.Text m () -> ParsecT e T.Text m () -> ParsecT e T.Text m () -> ParsecT e T.Text m () +space sp lineComment blockComment = ParsecT $ + P.skipMany $ P.try (unParsecT sp) <|> P.try (unParsecT lineComment) <|> unParsecT blockComment + +skipLineComment :: Monad m => T.Text -> ParsecT e T.Text m () +skipLineComment prefix = ParsecT $ + void $ P.try (unParsecT $ MC.string prefix) *> P.many (P.noneOf "\n") + +skipBlockComment :: Monad m => T.Text -> T.Text -> ParsecT e T.Text m () +skipBlockComment start end = ParsecT $ + void $ P.try (unParsecT $ MC.string start) *> P.manyTill P.anyChar (P.try $ unParsecT $ MC.string end) + +lexeme :: Monad m => ParsecT e T.Text m () -> ParsecT e T.Text m a -> ParsecT e T.Text m a +lexeme sc parser = ParsecT $ unParsecT parser <* unParsecT sc + +symbol :: Monad m => ParsecT e T.Text m () -> T.Text -> ParsecT e T.Text m T.Text +symbol sc = lexeme sc . MC.string + +charLiteral :: Monad m => ParsecT e T.Text m Char +charLiteral = ParsecT $ escaped <|> P.noneOf ['\\'] + where + escaped = + P.char '\\' + *> (hexEscape + <|> octalEscape + <|> simpleEscape + <|> invalidEscape + ) + + simpleEscape = P.choice + [ '\a' <$ P.char 'a' + , '\b' <$ P.char 'b' + , '\t' <$ P.char 't' + , '\n' <$ P.char 'n' + , '\v' <$ P.char 'v' + , '\f' <$ P.char 'f' + , '\r' <$ P.char 'r' + , '\ESC' <$ P.char 'e' + , '\\' <$ P.char '\\' + , '\'' <$ P.char '\'' + , '"' <$ P.char '"' + , '?' <$ P.char '?' + ] + + hexEscape = do + digits <- P.char 'x' *> P.many1 (P.satisfy isHexDigit) + maybe invalidCodePoint pure $ decode readHex digits + + octalEscape = do + digits <- octalDigits + maybe invalidCodePoint pure $ decode readOct digits + + octalDigits = + (:) <$> P.satisfy isOctDigit <*> P.option [] (P.try $ P.count 2 (P.satisfy isOctDigit) <|> P.count 1 (P.satisfy isOctDigit)) + + decode :: (String -> [(Integer, String)]) -> String -> Maybe Char + decode reader digits = safeChr . fst =<< listToMaybe (reader digits) + + listToMaybe [] = Nothing + listToMaybe (x : _) = Just x + + safeChr n + | n < 0 = Nothing + | n > fromIntegral (fromEnum (maxBound :: Char)) = Nothing + | 0xD800 <= n && n <= 0xDFFF = Nothing + | otherwise = Just (chr $ fromIntegral n) + + invalidEscape = + P.anyChar >>= \c -> fail ("invalid escape sequence \\" <> [c]) + + invalidCodePoint = fail "character code point out of range" + +decimal :: (Monad m, Num i) => ParsecT e T.Text m i +decimal = ParsecT $ fromInteger . read <$> P.many1 P.digit + +hexadecimal :: (Monad m, Num i) => ParsecT e T.Text m i +hexadecimal = ParsecT $ + fromInteger . fst . head . (readHex :: String -> [(Integer, String)]) <$> P.many1 (P.satisfy isHexDigit) + +octal :: (Monad m, Num i) => ParsecT e T.Text m i +octal = ParsecT $ + fromInteger . fst . head . (readOct :: String -> [(Integer, String)]) <$> P.many1 (P.satisfy isOctDigit) + +signed :: (Monad m, Num i) => ParsecT e T.Text m () -> ParsecT e T.Text m i -> ParsecT e T.Text m i +signed sc parser = ParsecT $ do + signFn <- P.option id $ + P.try ((negate <$ P.char '-') <* unParsecT sc) + <|> P.try ((id <$ P.char '+') <* unParsecT sc) + signFn <$> unParsecT parser diff --git a/src/Text/Megaparsec/Debug.hs b/src/Text/Megaparsec/Debug.hs new file mode 100644 index 0000000..9e85df3 --- /dev/null +++ b/src/Text/Megaparsec/Debug.hs @@ -0,0 +1,6 @@ +module Text.Megaparsec.Debug ( + dbg +) where + +dbg :: String -> a -> a +dbg _ = id From c2e3ed033747a37b557d3fa5c734ccb96935627a Mon Sep 17 00:00:00 2001 From: Hiroki Gomi Date: Wed, 1 Apr 2026 13:31:46 +0900 Subject: [PATCH 51/51] Implement multi-input output flow and type compatibility fixes --- .gitignore | 23 + README.md | 12 +- app/Main.hs | 1416 ++- htcc.cabal | 12 +- package.yaml | 19 +- src/Htcc/Asm.hs | 9 +- src/Htcc/Asm/Generate.hs | 551 +- src/Htcc/Asm/Generate/Core.hs | 256 +- src/Htcc/Asm/Intrinsic/Structure/Internal.hs | 27 +- .../Structure/Section/Text/Directive.hs | 20 +- .../Structure/Section/Text/Instruction.hs | 3 +- src/Htcc/CRules/Types/TypeKind.hs | 257 +- src/Htcc/Output.hs | 340 + src/Htcc/Parser/AST/Core.hs | 13 +- src/Htcc/Parser/AST/Type.hs | 20 +- src/Htcc/Parser/Combinators/ConstExpr.hs | 48 +- .../Parser/Combinators/Decl/Declarator.hs | 19 +- src/Htcc/Parser/Combinators/GNUExtensions.hs | 26 +- src/Htcc/Parser/Combinators/ParserType.hs | 54 +- .../Parser/Combinators/ParserType.hs-boot | 27 +- src/Htcc/Parser/Combinators/Program.hs | 1035 +- src/Htcc/Parser/Combinators/Type/Core.hs | 44 +- src/Htcc/Parser/Combinators/Utils.hs | 458 +- src/Htcc/Parser/Combinators/Var.hs | 708 +- src/Htcc/Parser/ConstructionData/Core.hs | 83 +- src/Htcc/Parser/ConstructionData/Core.hs-boot | 7 +- src/Htcc/Parser/ConstructionData/Scope.hs | 54 +- .../Parser/ConstructionData/Scope/Function.hs | 57 +- src/Htcc/Parser/ConstructionData/Scope/Var.hs | 101 +- src/Htcc/Tokenizer/Core.hs | 1 + src/Htcc/Visualizer/Core.hs | 6 + src/Text/Megaparsec.hs | 24 +- test/Spec.hs | 17 +- test/Tests/ComponentsTests.hs | 10 +- test/Tests/ComponentsTests/AsmOutput.hs | 1818 ++++ .../ComponentsTests/Parser/Combinators.hs | 1137 ++- test/Tests/SubProcTests.hs | 172 + test/Tests/SubProcTests/AsmOutput.hs | 8849 +++++++++++++++++ test/Tests/SubProcTests/LinkFuncRet.hs | 23 +- test/Tests/SubProcTests/LinkFuncStdOut.hs | 25 +- test/Tests/SubProcTests/StatementEqual.hs | 11 +- test/Tests/Utils.hs | 173 +- test/Tests/csrc/externals/test_bool_arg.c | 4 + test/Tests/csrc/self/array/basic.c | 1 - test/Tests/csrc/self/array/string.c | 6 +- test/Tests/csrc/self/expressions/cast.c | 8 +- test/Tests/csrc/self/expressions/operators.c | 4 +- 47 files changed, 17419 insertions(+), 569 deletions(-) create mode 100644 src/Htcc/Output.hs create mode 100644 test/Tests/ComponentsTests/AsmOutput.hs create mode 100644 test/Tests/SubProcTests/AsmOutput.hs create mode 100644 test/Tests/csrc/externals/test_bool_arg.c diff --git a/.gitignore b/.gitignore index fd0c8a8..c4d21d7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,27 @@ .stack-work +.stack-root*/ +.cabal-local/ +.cabal-home/ +.cabal-store/ +.cabal-sandbox/ +.codex-home/ +.home/ +.serena/ +dist-newstyle/ +dist-newstyle-review*/ +dist-newstyle-sandbox/ +dist-newstyle-local/ +dist-review*/ +a.out +.DS_Store +*.hi +*.hi-boot +*.o +*.o-boot +*.dyn_hi +*.dyn_o +tmp* +.tmp* *.swp bench_report.html docs/ diff --git a/README.md b/README.md index 54073fb..7443127 100644 --- a/README.md +++ b/README.md @@ -61,9 +61,14 @@ $ gcc -no-pie t.s -o out For one liner: ```sh -$ echo 'int printf(); int main() { printf("hello world!\n"); }' | stack exec htcc -- /dev/stdin | gcc -xassembler -no-pie -o out - +$ echo 'int printf(); int main() { printf("hello world!\n"); }' | stack exec htcc -- /dev/stdin | gcc -x assembler -no-pie -o out - ``` +When using `-r`/`--run-asm`, htcc uses the driver selected by +`$HTCC_ASSEMBLER` for both assembly and linking. +On hosts where `gcc` points to clang, set `HTCC_ASSEMBLER` to a +GNU-compatible compiler driver before running htcc. + ## AST diagram generation htcc has the ability to visualize ASTs built from loaded C code. @@ -167,8 +172,9 @@ The implementation description is available in [here](https://falgon.github.io/h ## Specification and Requirements htcc outputs x86_64 assembly according to System V ABI [[2]](#cite2) and -[GCC 7.4.0](https://gcc.gnu.org/onlinedocs/7.4.0/) is used for assemble. -Perhaps a newer version of GCC will work, but not checked currently. +[GCC 7.4.0](https://gcc.gnu.org/onlinedocs/7.4.0/) is used for assemble. +Perhaps a newer version of GCC will work, but not checked currently. When +assembling via `-r`, choose the driver with `HTCC_ASSEMBLER`. ## About emoji of commit messages diff --git a/app/Main.hs b/app/Main.hs index b2f13be..1130611 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,37 +1,115 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase, TemplateHaskell #-} module Main where -import Control.Monad (forM_) -import Data.Foldable (toList) -import qualified Data.Text.IO as T -import Data.Version (showVersion) -import Development.GitRev (gitHash) -import qualified Options.Applicative as OA -import qualified Paths_htcc as P +import Control.Exception (evaluate, finally) +import Control.Monad (foldM, forM_, + when) +import Data.Bool (bool) +import qualified Data.ByteString as B +import Data.Char (isAlpha, + isAlphaNum, + isSpace, toLower) +import Data.Foldable (toList) +import Data.List (isInfixOf, + isPrefixOf, + mapAccumL, + stripPrefix) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe, + mapMaybe) +import qualified Data.Text.IO as T +import Data.Version (showVersion) +import Data.Word (Word8) +import Language.Haskell.TH.Syntax (addDependentFile, + lift, runIO) +import qualified Options.Applicative as OA +import qualified Paths_htcc as P -import qualified Data.Text as T +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as T import Data.Void -import Htcc.Asm (casm') -import qualified Htcc.Asm.Intrinsic.Structure.Internal as SI -import Htcc.Parser (ASTs) -import Htcc.Parser.Combinators (parser, runParser) -import Htcc.Parser.ConstructionData.Core (Warnings) -import Htcc.Parser.ConstructionData.Scope.Var (GlobalVars, Literals) +import Htcc.Asm (casmNormalized', + prepareAsmInput) +import qualified Htcc.Asm.Intrinsic.Structure.Internal as SI +import qualified Htcc.CRules.Types as CT +import Htcc.Output (ReplacementOutputMode (..), + creationMaskedOutputMode, + stagedOutputMode, + temporaryWritableMode, + withReplacementOutputPath) +import Htcc.Parser (ASTs, ATKind (..), + ATKindFor (..), + ATree (..)) +import Htcc.Parser.Combinators (parser, runParser) +import qualified Htcc.Parser.Combinators.ParserType as PT +import Htcc.Parser.ConstructionData.Core (Warnings) +import qualified Htcc.Parser.ConstructionData.Scope.Function as PF +import Htcc.Parser.ConstructionData.Scope.Var (GVar (..), + GVarInitData (..), + GVarInitWith (..), + GlobalVars, + Literal (..), + Literals) import Htcc.Utils -import System.IO (hPutStr, stderr) -import qualified Text.Megaparsec as M +import Numeric.Natural (Natural) +import System.Directory (canonicalizePath, + doesFileExist, + executable, + getPermissions, + getTemporaryDirectory, + makeAbsolute, + removeFile) +import System.Environment (getEnvironment, + lookupEnv) +import System.Exit (ExitCode (..), + exitFailure) +import System.FilePath (normalise, + searchPathSeparator, + takeFileName, + ()) +import System.IO (Handle, + IOMode (ReadMode, WriteMode), + hClose, hPutStr, + openTempFile, + stderr, withFile) +import System.IO.Error (catchIOError, + isDoesNotExistError) +import System.Posix.Files (deviceID, fileID, + fileMode, + getFileStatus, + getSymbolicLinkStatus, + groupExecuteMode, + intersectFileModes, + isRegularFile, + isSymbolicLink, + otherExecuteMode, + ownerExecuteMode, + ownerReadMode, + setFileMode, + unionFileModes) +import System.Posix.Types (FileMode) +import System.Process (CreateProcess (..), + createProcess, + proc, + readCreateProcessWithExitCode, + readProcessWithExitCode, + showCommandForUser, + waitForProcess) +import qualified Text.Megaparsec as M +import qualified Text.Parsec as Parsec +import Text.Read (readMaybe) data Opts = Opts { optIsRunAsm :: !Bool , optIsVerbose :: !Bool - , optOutput :: FilePath + , optOutput :: Maybe FilePath , optInput :: [FilePath] } deriving (Read, Show) -output :: OA.Parser String -output = OA.strOption $ mconcat [ +output :: OA.Parser (Maybe String) +output = OA.optional $ OA.strOption $ mconcat [ OA.metavar "" - , OA.value "a.out" , OA.long "output" , OA.short 'o' , OA.help "Place the output into " @@ -47,7 +125,7 @@ isRunAsm :: OA.Parser Bool isRunAsm = OA.switch $ mconcat [ OA.long "run-asm" , OA.short 'r' - , OA.help "Generates executable binaries using the assembler built into the GCC compiler" + , OA.help "Generates executable binaries via the driver selected by $HTCC_ASSEMBLER" ] isVerbose :: OA.Parser Bool @@ -74,9 +152,41 @@ versionOption = OA.infoOption vopt $ mconcat [ "The C Language Compiler htcc " , showVersion P.version , "\ncommit hash: " - , $(gitHash) + , gitHashValue ] +gitHashValue :: String +gitHashValue = $(do + let trim = reverse . dropWhile isSpace . reverse + readGit args = + catchIOError + (do + (exitCode, stdoutOut, _) <- readProcessWithExitCode "git" args "" + pure $ case exitCode of + ExitSuccess -> Just $ trim stdoutOut + ExitFailure _ -> Nothing + ) + (const $ pure Nothing) + addGitDependency path = do + exists <- runIO $ doesFileExist path + when exists $ addDependentFile path + + gitDir <- runIO $ readGit ["rev-parse", "--git-dir"] + case gitDir of + Just dir -> do + let headPath = dir "HEAD" + addGitDependency headPath + addGitDependency $ dir "packed-refs" + headRef <- runIO $ + catchIOError + (stripPrefix "ref: " . trim <$> readFile headPath) + (const $ pure Nothing) + maybe (pure ()) (addGitDependency . (dir )) headRef + Nothing -> pure () + + lift . fromMaybe "unknown" =<< runIO (readGit ["rev-parse", "HEAD"]) + ) + optsParser :: OA.ParserInfo Opts optsParser = OA.info (OA.helper <*> versionOption <*> programOptions) $ mconcat [ OA.fullDesc @@ -86,16 +196,1256 @@ optsParser = OA.info (OA.helper <*> versionOption <*> programOptions) $ mconcat ] ] +ignoreIOException :: IO () -> IO () +ignoreIOException = flip catchIOError $ const $ pure () + +nonEmptyEnv :: Maybe String -> Maybe String +nonEmptyEnv (Just s) | all isSpace s = Nothing +nonEmptyEnv x = x + +shellWords :: String -> Either String [String] +shellWords commandLine = + either (Left . show) Right $ Parsec.parse shellParser "" commandLine + where + shellParser = skipSpaces *> Parsec.sepEndBy word spaces <* Parsec.eof + skipSpaces = Parsec.skipMany $ Parsec.satisfy isSpace + spaces = Parsec.skipMany1 $ Parsec.satisfy isSpace + word = concat <$> Parsec.many1 chunk + chunk = Parsec.choice [singleQuoted, doubleQuoted, escaped, bare] + singleQuoted = Parsec.char '\'' *> Parsec.manyTill Parsec.anyChar (Parsec.char '\'') + doubleQuoted = concat <$> (Parsec.char '"' *> Parsec.manyTill doubleChunk (Parsec.char '"')) + doubleChunk = Parsec.choice [doubleEscaped, pure <$> Parsec.noneOf "\""] + doubleEscaped = do + _ <- Parsec.char '\\' + c <- Parsec.anyChar + pure $ case c of + '\\' -> "\\" + '"' -> "\"" + '`' -> "`" + '$' -> "$" + '\n' -> "" + _ -> ['\\', c] + escaped = Parsec.char '\\' *> (pure <$> Parsec.anyChar) + bare = Parsec.many1 $ Parsec.noneOf "'\"\\ \t\r\n" + +data CompilerCommand = CompilerCommand + { compilerEnvOverrides :: [(String, String)] + , compilerExecutable :: FilePath + , compilerArguments :: [String] + } + +resolveCompilerCommand :: String -> IO CompilerCommand +resolveCompilerCommand compiler = do + parts <- case shellWords compiler of + Left parseErr -> ioError . userError $ + "failed to parse compiler command " <> show compiler <> ": " <> parseErr + Right [] -> ioError . userError $ + "empty compiler command: " <> show compiler + Right xs -> pure xs + let (envAssignments, compilerParts) = span isEnvironmentAssignmentWord parts + envOverrides = Map.fromList $ map splitEnvironmentAssignment envAssignments + when (null compilerParts) . ioError . userError $ + "empty compiler command: " <> show compiler + resolvedPrefix <- findExecutablePrefix envOverrides compilerParts + pure $ + case resolvedPrefix of + Just (compilerLen, resolvedCompiler) -> + CompilerCommand + { compilerEnvOverrides = map splitEnvironmentAssignment envAssignments + , compilerExecutable = resolvedCompiler + , compilerArguments = drop compilerLen compilerParts + } + Nothing -> + CompilerCommand + { compilerEnvOverrides = map splitEnvironmentAssignment envAssignments + , compilerExecutable = head compilerParts + , compilerArguments = tail compilerParts + } + where + isEnvironmentAssignmentWord word = case span (/= '=') word of + ([], _) -> False + (name, '=':_) -> + let startsLikeIdentifier c = isAlpha c || c == '_' + in startsLikeIdentifier (head name) && all (\c -> isAlphaNum c || c == '_') name + _ -> False + + splitEnvironmentAssignment word = case span (/= '=') word of + (name, '=':value) -> (name, value) + _ -> error "internal compiler error" + + findExecutablePrefix _ [] = pure Nothing + findExecutablePrefix envOverrides' (cmd:_) = do + resolved <- resolveExecutableCommand envOverrides' cmd + pure $ fmap (\resolvedCmd -> (1, resolvedCmd)) resolved + + resolveExecutableCommand envOverrides' cmd = do + case hasExplicitPath cmd of + True -> localExecutablePath cmd + False -> + firstResolved $ + [ findExecutableInSearchPath envOverrides' cmd + ] + <> [localExecutablePath cmd | not (hasOverriddenSearchPath envOverrides')] + + findExecutableInSearchPath envOverrides' cmd = do + pathValue <- maybe + (fromMaybe "" <$> lookupEnv "PATH") + pure + (Map.lookup "PATH" envOverrides') + firstResolved $ + map (localExecutablePath . searchPathCommand cmd) $ + searchPathEntries pathValue + + searchPathCommand cmd "" = cmd + searchPathCommand cmd dir = dir cmd + + hasOverriddenSearchPath = Map.member "PATH" + + searchPathEntries pathValue = case break (== searchPathSeparator) pathValue of + (dir, []) -> [dir] + (dir, _:remain) -> dir : searchPathEntries remain + + localExecutablePath cmd = do + isLocalFile <- doesFileExist cmd + isLocalExec <- if isLocalFile then executable <$> getPermissions cmd else pure False + pure $ + if isLocalExec + then Just $ normalizeLocalExecutablePath cmd + else Nothing + + hasExplicitPath = any (`elem` ['/', '\\']) + + firstResolved [] = pure Nothing + firstResolved (resolvePath : resolvePaths) = do + resolved <- resolvePath + maybe (firstResolved resolvePaths) (pure . Just) resolved + + normalizeLocalExecutablePath cmd + | hasExplicitPath cmd = cmd + | otherwise = "./" <> cmd + +compilerInvocationArgs :: CompilerCommand -> [String] -> [String] +compilerInvocationArgs compiler extraArgs = + compilerArguments compiler <> extraArgs + +compilerProcessEnv :: [(String, String)] -> IO (Maybe [(String, String)]) +compilerProcessEnv [] = pure Nothing +compilerProcessEnv overrides = + Just . Map.toList . Map.union (Map.fromList overrides) . Map.fromList + <$> getEnvironment + +showCompilerCommandForUser :: CompilerCommand -> [String] -> String +showCompilerCommandForUser compiler extraArgs = + case compilerEnvOverrides compiler of + [] -> + showCommandForUser + (compilerExecutable compiler) + (compilerInvocationArgs compiler extraArgs) + overrides -> + showCommandForUser + "env" + ( map (\(name, value) -> name <> "=" <> value) overrides + <> [compilerExecutable compiler] + <> compilerInvocationArgs compiler extraArgs + ) + +readCompilerProcessWithExitCode :: CompilerCommand -> [String] -> IO (ExitCode, String, String) +readCompilerProcessWithExitCode compiler extraArgs = do + processEnv <- compilerProcessEnv $ compilerEnvOverrides compiler + readCreateProcessWithExitCode + (proc (compilerExecutable compiler) (compilerInvocationArgs compiler extraArgs)) + { env = processEnv + } + "" + +callCompilerProcess :: CompilerCommand -> [String] -> IO () +callCompilerProcess compiler extraArgs = do + processEnv <- compilerProcessEnv $ compilerEnvOverrides compiler + (_, _, _, processHandle) <- createProcess + (proc (compilerExecutable compiler) (compilerInvocationArgs compiler extraArgs)) + { env = processEnv + } + waitForProcess processHandle >>= \case + ExitSuccess -> pure () + exitCode -> + ioError . userError $ + showCompilerCommandForUser compiler extraArgs + <> " failed with " + <> show exitCode + +withReadableFile :: FilePath -> FileMode -> IO a -> IO a +withReadableFile path originalMode action + | intersectFileModes originalMode ownerReadMode /= 0 = action + | otherwise = do + setFileMode path readableMode + action `finally` setFileMode path originalMode + where + readableMode = originalMode `unionFileModes` ownerReadMode + +validateRunnableLinkedOutput :: FilePath -> Maybe String -> IO Bool +validateRunnableLinkedOutput path maybeProbeMarker = + catchIOError + (do + status <- getSymbolicLinkStatus path + if isRegularFile status + then + withReadableFile path (fileMode status) $ do + bytes <- B.readFile path + pure $ + intersectFileModes (fileMode status) executableFileMode /= 0 + && looksRunnableLinkedOutput bytes + && maybe True (`probeMarkerPresent` bytes) maybeProbeMarker + else pure False + ) + (\ioErr -> if isDoesNotExistError ioErr then pure False else ioError ioErr) + +shouldValidateRunnableLinkedOutput :: FilePath -> IO Bool +shouldValidateRunnableLinkedOutput path = + catchIOError + (do + status <- getSymbolicLinkStatus path + pure $ isRegularFile status || isSymbolicLink status + ) + (\ioErr -> if isDoesNotExistError ioErr then pure True else ioError ioErr) + +probeMarkerPresent :: String -> B.ByteString -> Bool +probeMarkerPresent probeMarker = + B.isInfixOf $ B.pack $ map (fromIntegral . fromEnum) probeMarker + +looksRunnableLinkedOutput :: B.ByteString -> Bool +looksRunnableLinkedOutput bytes + | B.length bytes < 4 = False + | B.take 4 bytes /= elfMagic = False + | B.length bytes < 20 = False + | otherwise = + elfClass == 2 + && elfMachine == 62 + && elfType == 2 + where + elfClass = B.index bytes 4 + elfData = B.index bytes 5 + elfType = decodeElfHalfWord elfData (B.index bytes 16) (B.index bytes 17) :: Int + elfMachine = decodeElfHalfWord elfData (B.index bytes 18) (B.index bytes 19) :: Int + +decodeElfHalfWord :: Num a => Word8 -> Word8 -> Word8 -> a +decodeElfHalfWord elfData byte18 byte19 + | elfData == 2 = fromIntegral byte18 * 256 + fromIntegral byte19 + | otherwise = fromIntegral byte18 + fromIntegral byte19 * 256 + +elfMagic :: B.ByteString +elfMagic = B.pack [0x7f, 0x45, 0x4c, 0x46] + +markerSectionAsm :: String -> String -> String +markerSectionAsm label marker = unlines + [ ".section .rodata" + , label <> ":" + , " .asciz \"" <> escapeAsmString marker <> "\"" + , ".text" + ] + +escapeAsmString :: String -> String +escapeAsmString = concatMap $ \case + '"' -> "\\\"" + '\\' -> "\\\\" + c -> [c] + +asmCompiler :: IO CompilerCommand +asmCompiler = do + htccAssembler <- nonEmptyEnv <$> lookupEnv "HTCC_ASSEMBLER" + compilerSpec <- resolveCompilerCommand $ fromMaybe "gcc" htccAssembler + ensureX86_64ElfCompiler compilerSpec + pure compilerSpec + +data CompilerProbeFailure + = CompilerAssemblyProbeFailure + | CompilerLinkProbeFailure + +ensureX86_64ElfCompiler :: CompilerCommand -> IO () +ensureX86_64ElfCompiler compilerSpec = do + detectedTargets <- probeCompilerTargets compilerSpec + probeResult <- probeCompilerInvocation compilerSpec + case probeResult of + Right target + | isX86_64ElfTarget target -> pure () + | otherwise -> rejectTarget target + Left CompilerAssemblyProbeFailure -> + case filter isX86_64ElfTarget detectedTargets of + _ : _ -> rejectAssemblyProbeFailure + [] -> rejectDriverSelection + Left CompilerLinkProbeFailure -> + rejectLinkProbeFailure + where + rejectTarget target = + ioError . userError $ + "HTCC_ASSEMBLER must target x86_64-ELF for -r (detected " <> target <> ")" + + rejectAssemblyProbeFailure = + ioError . userError $ + "HTCC_ASSEMBLER passed target metadata probes but failed an x86_64-ELF assembly probe for -r" + + rejectDriverSelection = + ioError . userError $ + "failed to determine an x86_64-ELF target from HTCC_ASSEMBLER; choose a compiler driver that defaults to x86_64-ELF for -r" + + rejectLinkProbeFailure = + ioError . userError $ + "HTCC_ASSEMBLER assembled an x86_64-ELF object but failed a link probe for -r; choose a compiler driver that supports both assembly and linking for -r" + + probeCompilerTargets compilerSpec' = + mapMaybe id <$> mapM (probeCompilerTarget compilerSpec') + [ "-dumpmachine" + , "-print-target-triple" + ] + + probeCompilerTarget compilerSpec' probeArg = do + catchIOError + (do + (exitCode, stdout', _) <- readCompilerProcessWithExitCode compilerSpec' [probeArg] + pure $ case exitCode of + ExitSuccess -> nonEmptyTrimmed stdout' + ExitFailure _ -> Nothing + ) + (const $ pure Nothing) + + probeCompilerInvocation compilerSpec' = + withProbeFile "htcc-probe-.s" $ \asmPath asmHandle -> do + withProbeFile "htcc-probe-.o" $ \objPath objHandle -> do + let probeMarker = makeProbeMarker asmPath objPath + hPutStr asmHandle $ x86_64ElfProbeAsm probeMarker + hClose asmHandle + setFileMode objPath temporaryWritableMode + hClose objHandle + let assembleArgs = asmAssembleArgs objPath asmPath + probeProcessResult <- probeCommandExitCode compilerSpec' assembleArgs + case probeProcessResult of + Just ExitSuccess -> do + probeTarget <- detectProbeObjectTarget objPath + case probeTarget of + Just target + | isX86_64ElfTarget target -> do + linkSucceeded <- probeCompilerLink compilerSpec' objPath probeMarker + pure $ + if linkSucceeded + then Right target + else Left CompilerLinkProbeFailure + | otherwise -> pure $ Right target + Nothing -> + pure $ Left CompilerAssemblyProbeFailure + _ -> + pure $ Left CompilerAssemblyProbeFailure + + probeCompilerLink compilerSpec' objPath probeMarker = + withProbeFile "htcc-probe-.out" $ \outputPath outputHandle -> do + creationMode <- creationMaskedOutputMode + setFileMode outputPath $ + stagedOutputMode PreserveReplacementOutputModeKeepingExecutableBits creationMode + hClose outputHandle + let linkArgs = asmLinkArgs outputPath objPath + probeProcessResult <- probeCommandExitCode compilerSpec' linkArgs + case probeProcessResult of + Just ExitSuccess -> validateRunnableLinkedOutput outputPath (Just probeMarker) + _ -> pure False + + probeCommandExitCode compilerSpec' args = + catchIOError + (do + (exitCode, _, _) <- readCompilerProcessWithExitCode compilerSpec' args + pure $ Just exitCode + ) + (const $ pure Nothing) + + withProbeFile prefix action = do + tmpDir <- getTemporaryDirectory + (path, handle) <- openTempFile tmpDir prefix + finally + (action path handle) + ( ignoreIOException (hClose handle) + *> ignoreIOException (removeFile path) + ) + + makeProbeMarker asmPath objPath = + "htcc-probe-marker:" <> takeFileName asmPath <> ":" <> takeFileName objPath + + x86_64ElfProbeAsm probeMarker = + unlines [".intel_syntax noprefix"] + <> markerSectionAsm "htcc_probe_marker" probeMarker + <> unlines + [ ".global main" + , "main:" + , " lea rdx, [rip + htcc_probe_marker]" + , " xor eax, eax" + , " ret" + ] + + nonEmptyTrimmed outputText = + case trim outputText of + "" -> Nothing + xs -> Just xs + + detectProbeObjectTarget path = + catchIOError + (do + status <- getSymbolicLinkStatus path + if isRegularFile status + then describeProbeObject <$> B.readFile path + else pure Nothing + ) + (const $ pure Nothing) + + describeProbeObject bytes + | B.length bytes < 4 = Nothing + | B.take 4 bytes /= elfMagic = Just "non-ELF object file" + | B.length bytes < 20 = Just "truncated ELF object file" + | otherwise = + Just $ + case (elfClass == 2, elfMachine == 62, elfType == 1) of + (True, True, True) -> "x86_64-unknown-elf object" + (True, True, False) -> "non-relocatable x86_64-ELF file" + (_, _, True) -> "ELF object file" + _ -> "non-relocatable ELF file" + where + elfClass = B.index bytes 4 + elfData = B.index bytes 5 + elfType = decodeElfHalfWord elfData (B.index bytes 16) (B.index bytes 17) :: Int + elfMachine = decodeElfHalfWord elfData (B.index bytes 18) (B.index bytes 19) :: Int + + trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +isX86_64ElfTarget :: String -> Bool +isX86_64ElfTarget target = + let normalizedTarget = map toLower target + in isX86_64Target normalizedTarget && not (isKnownNonElfTarget normalizedTarget) + where + isX86_64Target normalizedTarget = + "x86_64" `isPrefixOf` normalizedTarget || "amd64" `isPrefixOf` normalizedTarget + + -- Most x86_64 Unix triples are ELF; reject only known Mach-O/PE families. + isKnownNonElfTarget normalizedTarget = + any (`isInfixOf` normalizedTarget) + [ "apple" + , "cygwin" + , "darwin" + , "mingw" + , "msvc" + , "windows" + ] + +asmOutputPath :: Opts -> FilePath +asmOutputPath = fromMaybe "a.out" . optOutput + +asmAssembleArgs :: FilePath -> FilePath -> [String] +asmAssembleArgs objPath asmPath = + [ "-x" + , "assembler" + , "-c" + , "-o" + , objPath + , asmPath + ] + +asmLinkArgs :: FilePath -> FilePath -> [String] +asmLinkArgs outputPath objPath = + [ "-no-pie" + , "-o" + , outputPath + , objPath + ] + +normalizeComparablePath :: FilePath -> IO FilePath +normalizeComparablePath path = do + exists <- doesFileExist path + normalise <$> if exists then canonicalizePath path else makeAbsolute path + +fileIdentity :: FilePath -> IO (Maybe (FilePath, FilePath)) +fileIdentity path = do + exists <- doesFileExist path + if exists + then do + status <- getFileStatus path + pure . Just $ + ( show $ deviceID status + , show $ fileID status + ) + else pure Nothing + +sameFileAs :: FilePath -> FilePath -> IO Bool +sameFileAs lhs rhs = do + normalizedLhs <- normalizeComparablePath lhs + normalizedRhs <- normalizeComparablePath rhs + if normalizedLhs == normalizedRhs + then pure True + else do + lhsIdentity <- fileIdentity lhs + rhsIdentity <- fileIdentity rhs + pure $ maybe False id $ (==) <$> lhsIdentity <*> rhsIdentity + +runAsmOutputAliasesInput :: Opts -> IO Bool +runAsmOutputAliasesInput opts = do + anyM (sameFileAs $ asmOutputPath opts) $ optInput opts + +plainOutputAliasesInput :: Opts -> IO Bool +plainOutputAliasesInput opts = maybe + (pure False) + (\path -> anyM (sameFileAs path) $ optInput opts) + (optOutput opts) + +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM _ [] = pure False +anyM p (x : xs) = do + matched <- p x + if matched then pure True else anyM p xs + +executableFileMode :: FileMode +executableFileMode = foldr1 unionFileModes + [ ownerExecuteMode + , groupExecuteMode + , otherExecuteMode + ] + +validateOpts :: Opts -> IO () +validateOpts opts + | length (optInput opts) > 1 && optIsRunAsm opts = + hPutStr stderr "multiple input files are not supported with -r\n" *> exitFailure + | optIsRunAsm opts = do + outputAliasesInput <- runAsmOutputAliasesInput opts + when outputAliasesInput $ + hPutStr stderr ("-r output path must not overwrite an input file: " <> asmOutputPath opts <> "\n") + *> exitFailure + | otherwise = do + outputAliasesInput <- plainOutputAliasesInput opts + when outputAliasesInput $ + hPutStr stderr ("-o output path must not overwrite an input file: " <> fromMaybe "" (optOutput opts) <> "\n") + *> exitFailure + +type ParsedInput = (ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) +type ParsedInputWithWarnings = (Warnings, ParsedInput) + +emitWarnings :: Foldable f => f (M.ParseErrorBundle T.Text Void) -> IO () +emitWarnings = + mapM_ (hPutStr stderr . M.errorBundlePretty) + +implicitFunctionWarningName :: M.ParseErrorBundle T.Text Void -> Maybe T.Text +implicitFunctionWarningName M.ParseErrorBundle { M.bundleErrors = M.FancyError _ fancyErrors :| [] } = do + msg <- case Set.toList fancyErrors of + [M.ErrorFail errMsg] -> Just $ T.pack errMsg + _ -> Nothing + T.stripPrefix (T.pack "warning: the function '") msg + >>= T.stripSuffix (T.pack "' is not declared.") +implicitFunctionWarningName _ = Nothing + +implicitFunctionResolvedAfterMerge :: ParsedInput -> T.Text -> Bool +implicitFunctionResolvedAfterMerge (_, _, _, funcs) name = + maybe + False + (\func -> not (CT.isSCStatic $ PF.fntype func) && not (PF.fnImplicit func)) + $ Map.lookup name funcs + +shouldEmitMergedWarning :: ParsedInput -> M.ParseErrorBundle T.Text Void -> Bool +shouldEmitMergedWarning parsedInput warning = + maybe True + (not . implicitFunctionResolvedAfterMerge parsedInput) + (implicitFunctionWarningName warning) + +literalLabelPrefix :: T.Text +literalLabelPrefix = T.pack ".L.data." + +literalLabel :: Natural -> T.Text +literalLabel n = literalLabelPrefix <> tshow n + +shiftLiteralLabelName :: Natural -> T.Text -> T.Text +shiftLiteralLabelName offset name = maybe name (literalLabel . (+ offset)) literalIndex + where + literalIndex = T.stripPrefix literalLabelPrefix name >>= readMaybe . T.unpack + +shiftLiteralLabelsInGVar :: Natural -> GVar Integer -> GVar Integer +shiftLiteralLabelsInGVar offset gvar = gvar + { initWith = case initWith gvar of + GVarInitWithOG ref -> GVarInitWithOG $ shiftLiteralLabelName offset ref + GVarInitWithData dats -> GVarInitWithData $ map shiftLiteralLabelsInGVarData dats + GVarInitWithAST ast -> GVarInitWithAST $ shiftLiteralLabelsInATree offset ast + other -> other + } + where + shiftLiteralLabelsInGVarData dat = case dat of + GVarInitReloc sz ref addend -> GVarInitReloc sz (shiftLiteralLabelName offset ref) addend + other -> other + +shiftLiteralLabelsInATKindFor :: Natural -> ATKindFor Integer -> ATKindFor Integer +shiftLiteralLabelsInATKindFor offset kind = case kind of + ATForkw -> ATForkw + ATForInit at -> ATForInit $ shiftLiteralLabelsInATree offset at + ATForCond at -> ATForCond $ shiftLiteralLabelsInATree offset at + ATForIncr at -> ATForIncr $ shiftLiteralLabelsInATree offset at + ATForStmt at -> ATForStmt $ shiftLiteralLabelsInATree offset at + +shiftLiteralLabelsInATKind :: Natural -> ATKind Integer -> ATKind Integer +shiftLiteralLabelsInATKind offset kind = case kind of + ATConditional cond tr fl -> + ATConditional + (shiftLiteralLabelsInATree offset cond) + (shiftLiteralLabelsInATree offset tr) + (shiftLiteralLabelsInATree offset fl) + ATSwitch cond cases -> + ATSwitch + (shiftLiteralLabelsInATree offset cond) + (map (shiftLiteralLabelsInATree offset) cases) + ATFor kinds -> + ATFor $ map (shiftLiteralLabelsInATKindFor offset) kinds + ATBlock ats -> + ATBlock $ map (shiftLiteralLabelsInATree offset) ats + ATStmtExpr ats -> + ATStmtExpr $ map (shiftLiteralLabelsInATree offset) ats + ATNull at -> + ATNull $ shiftLiteralLabelsInATree offset at + ATDefFunc name args -> + ATDefFunc name $ map (shiftLiteralLabelsInATree offset) <$> args + ATCallFunc name args -> + ATCallFunc name $ map (shiftLiteralLabelsInATree offset) <$> args + ATCallPtr args -> + ATCallPtr $ map (shiftLiteralLabelsInATree offset) <$> args + ATGVar ty name -> + ATGVar ty $ shiftLiteralLabelName offset name + _ -> + kind + +shiftLiteralLabelsInATree :: Natural -> ATree Integer -> ATree Integer +shiftLiteralLabelsInATree _ ATEmpty = ATEmpty +shiftLiteralLabelsInATree offset (ATNode kind ty lhs rhs) = + ATNode + (shiftLiteralLabelsInATKind offset kind) + ty + (shiftLiteralLabelsInATree offset lhs) + (shiftLiteralLabelsInATree offset rhs) + +shiftLiteralLabels :: Natural -> ParsedInput -> ParsedInput +shiftLiteralLabels offset (asts, gvars, lits, funcs) = + ( map (shiftLiteralLabelsInATree offset) asts + , Map.map (shiftLiteralLabelsInGVar offset) gvars + , map (\lit -> lit { ln = ln lit + offset }) lits + , funcs + ) + +namespaceInternalSymbol :: Natural -> T.Text -> T.Text +namespaceInternalSymbol inputIndex name = + namespaceInternalSymbolPrefix inputIndex <> name + +namespaceInternalSymbolPrefix :: Natural -> T.Text +namespaceInternalSymbolPrefix inputIndex = + T.pack ".L.internal." + <> tshow inputIndex + <> T.pack "." + +denamespaceInternalSymbol :: Natural -> T.Text -> T.Text +denamespaceInternalSymbol inputIndex name = + fromMaybe name $ + T.stripPrefix (namespaceInternalSymbolPrefix inputIndex) name + +renameInputSymbol :: Map.Map T.Text T.Text -> T.Text -> T.Text +renameInputSymbol renames name = Map.findWithDefault name name renames + +data InternalSymbolRenames = InternalSymbolRenames + { functionSymbolRenames :: Map.Map T.Text T.Text + , objectSymbolRenames :: Map.Map T.Text T.Text + } + +renameFunctionSymbol :: InternalSymbolRenames -> T.Text -> T.Text +renameFunctionSymbol renames = renameInputSymbol $ functionSymbolRenames renames + +renameObjectSymbol :: InternalSymbolRenames -> T.Text -> T.Text +renameObjectSymbol renames = renameInputSymbol $ objectSymbolRenames renames + +renameKnownInternalSymbol :: InternalSymbolRenames -> T.Text -> T.Text +renameKnownInternalSymbol renames name = + renameFunctionSymbol + renames + (renameObjectSymbol renames name) + +renameInternalSymbolsInGVar :: InternalSymbolRenames -> GVar Integer -> GVar Integer +renameInternalSymbolsInGVar renames gvar = gvar + { initWith = case initWith gvar of + GVarInitWithOG ref -> GVarInitWithOG $ renameKnownInternalSymbol renames ref + GVarInitWithData dats -> GVarInitWithData $ map renameInternalSymbolsInGVarData dats + GVarInitWithAST ast -> GVarInitWithAST $ renameInternalSymbolsInATree renames ast + other -> other + } + where + renameInternalSymbolsInGVarData dat = case dat of + GVarInitReloc sz ref addend -> GVarInitReloc sz (renameKnownInternalSymbol renames ref) addend + other -> other + +renameInternalSymbolsInATKind :: InternalSymbolRenames -> ATKind Integer -> ATKind Integer +renameInternalSymbolsInATKind renames kind = case kind of + ATConditional cond tr fl -> + ATConditional + (renameInternalSymbolsInATree renames cond) + (renameInternalSymbolsInATree renames tr) + (renameInternalSymbolsInATree renames fl) + ATSwitch cond cases -> + ATSwitch + (renameInternalSymbolsInATree renames cond) + (map (renameInternalSymbolsInATree renames) cases) + ATFor kinds -> + ATFor $ map (renameInternalSymbolsInATKindFor renames) kinds + ATBlock ats -> + ATBlock $ map (renameInternalSymbolsInATree renames) ats + ATStmtExpr ats -> + ATStmtExpr $ map (renameInternalSymbolsInATree renames) ats + ATNull at -> + ATNull $ renameInternalSymbolsInATree renames at + ATDefFunc name args -> + ATDefFunc + (renameFunctionSymbol renames name) + (map (renameInternalSymbolsInATree renames) <$> args) + ATCallFunc name args -> + ATCallFunc + (renameFunctionSymbol renames name) + (map (renameInternalSymbolsInATree renames) <$> args) + ATCallPtr args -> + ATCallPtr $ map (renameInternalSymbolsInATree renames) <$> args + ATFuncPtr name -> + ATFuncPtr $ renameFunctionSymbol renames name + ATGVar ty name -> + ATGVar ty $ renameObjectSymbol renames name + _ -> + kind + +renameInternalSymbolsInATKindFor :: InternalSymbolRenames -> ATKindFor Integer -> ATKindFor Integer +renameInternalSymbolsInATKindFor renames kind = case kind of + ATForkw -> ATForkw + ATForInit at -> ATForInit $ renameInternalSymbolsInATree renames at + ATForCond at -> ATForCond $ renameInternalSymbolsInATree renames at + ATForIncr at -> ATForIncr $ renameInternalSymbolsInATree renames at + ATForStmt at -> ATForStmt $ renameInternalSymbolsInATree renames at + +renameInternalSymbolsInATree :: InternalSymbolRenames -> ATree Integer -> ATree Integer +renameInternalSymbolsInATree _ ATEmpty = ATEmpty +renameInternalSymbolsInATree renames (ATNode kind ty lhs rhs) = + ATNode + (renameInternalSymbolsInATKind renames kind) + ty + (renameInternalSymbolsInATree renames lhs) + (renameInternalSymbolsInATree renames rhs) + +internalSymbolRenames :: Natural -> ParsedInput -> InternalSymbolRenames +internalSymbolRenames inputIndex (_, gvars, _, funcs) = + InternalSymbolRenames + { functionSymbolRenames = Map.fromList + [ (name, namespaceInternalSymbol inputIndex name) + | (name, func) <- Map.toList funcs + , CT.isSCStatic (PF.fntype func) + ] + , objectSymbolRenames = Map.fromList + [ (name, namespaceInternalSymbol inputIndex name) + | (name, gvar) <- Map.toList gvars + , CT.isSCStatic (gvtype gvar) + ] + } + +renameInternalSymbols :: Natural -> ParsedInput -> ParsedInput +renameInternalSymbols inputIndex (asts, gvars, lits, funcs) = + ( map (renameInternalSymbolsInATree renames) asts + , Map.mapKeys (renameObjectSymbol renames) $ Map.map (renameInternalSymbolsInGVar renames) gvars + , lits + , Map.mapKeys (renameFunctionSymbol renames) funcs + ) + where + renames = internalSymbolRenames inputIndex (asts, gvars, lits, funcs) + +shiftLiteralLabelsInInputs :: [ParsedInput] -> [ParsedInput] +shiftLiteralLabelsInInputs parsedInputs = snd $ mapAccumL step (0, 0) parsedInputs + where + shouldNamespaceInternalSymbols = length parsedInputs > 1 + step (inputIndex, offset) parsed@(_, _, lits, _) = + let renamed = bool parsed (renameInternalSymbols inputIndex parsed) shouldNamespaceInternalSymbols + shifted = shiftLiteralLabels offset renamed + in ((succ inputIndex, offset + fromIntegral (length lits)), shifted) + +data ExternalSymbol + = ExternalFunction (PF.Function Integer) Bool + | ExternalGlobal (GVar Integer) + | ExternalImplicitFunction + +type ExternalFunctionInfo = (PF.Function Integer, Bool) +type ExternalSymbolOrigin = Int +type TaggedExternalSymbol = (ExternalSymbolOrigin, ExternalSymbol) +type StaticSymbolKey = (ExternalSymbolOrigin, T.Text) +type StaticSymbols = Map.Map StaticSymbolKey ExternalSymbol + +duplicateExternalSymbolError :: T.Text -> String +duplicateExternalSymbolError name = + T.unpack $ T.pack "multiple external definitions in multi-input -o mode: " <> name + +conflictingExternalDeclarationError :: T.Text -> GVar Integer -> GVar Integer -> String +conflictingExternalDeclarationError name lhs rhs = + T.unpack $ mconcat + [ T.pack "conflicting external declarations in multi-input -o mode: " + , name + , T.pack " (" + , tshow $ CT.toTypeKind $ gvtype lhs + , T.pack " vs " + , tshow $ CT.toTypeKind $ gvtype rhs + , T.pack ")" + ] + +conflictingExternalFunctionDeclarationError :: T.Text -> PF.Function Integer -> PF.Function Integer -> String +conflictingExternalFunctionDeclarationError name lhs rhs = + T.unpack $ mconcat + [ T.pack "conflicting external function declarations in multi-input -o mode: " + , name + , T.pack " (" + , tshow $ CT.toTypeKind $ PF.fntype lhs + , T.pack " vs " + , tshow $ CT.toTypeKind $ PF.fntype rhs + , T.pack ")" + ] + +isTentativeExternalGlobal :: GVar Integer -> Bool +isTentativeExternalGlobal gvar = + not (CT.isSCStatic $ gvtype gvar) + && case initWith gvar of + GVarInitWithZero -> True + _ -> False + +mergeExternalGlobalTypes + :: CT.StorageClass Integer + -> CT.StorageClass Integer + -> Maybe (CT.StorageClass Integer) +mergeExternalGlobalTypes (CT.SCAuto lhs) (CT.SCAuto rhs) = + CT.SCAuto <$> CT.mergeCompatibleTypeKinds lhs rhs +mergeExternalGlobalTypes (CT.SCStatic lhs) (CT.SCStatic rhs) = + CT.SCStatic <$> CT.mergeCompatibleTypeKinds lhs rhs +mergeExternalGlobalTypes (CT.SCRegister lhs) (CT.SCRegister rhs) = + CT.SCRegister <$> CT.mergeCompatibleTypeKinds lhs rhs +mergeExternalGlobalTypes (CT.SCUndef lhs) (CT.SCUndef rhs) = + CT.SCUndef <$> CT.mergeCompatibleTypeKinds lhs rhs +mergeExternalGlobalTypes _ _ = Nothing + +mergeExternalGlobals :: T.Text -> GVar Integer -> GVar Integer -> Either String (GVar Integer) +mergeExternalGlobals name lhs rhs = case mergeExternalGlobalTypes (gvtype lhs) (gvtype rhs) of + Nothing -> + Left $ conflictingExternalDeclarationError name lhs rhs + Just mergedType + | isTentativeExternalGlobal lhs && isTentativeExternalGlobal rhs -> + Right $ lhs { gvtype = mergedType } + | isTentativeExternalGlobal lhs -> + Right $ rhs { gvtype = mergedType } + | isTentativeExternalGlobal rhs -> + Right $ lhs { gvtype = mergedType } + | otherwise -> + Left $ duplicateExternalSymbolError name + +mergeExternalFunctions :: T.Text -> ExternalFunctionInfo -> ExternalFunctionInfo -> Either String ExternalFunctionInfo +mergeExternalFunctions name (lhs, lhsDefined) (rhs, rhsDefined) + | lhsDefined && rhsDefined = + Left $ duplicateExternalSymbolError name + | otherwise = case mergeExternalFunctionTypes preferred fallback of + Nothing -> + Left $ conflictingExternalFunctionDeclarationError name lhs rhs + Just merged -> + Right (merged, lhsDefined || rhsDefined) + where + (preferred, fallback) + | rhsDefined = (rhs, lhs) + | otherwise = (lhs, rhs) + +mergeExternalFunctionTypes + :: PF.Function Integer + -> PF.Function Integer + -> Maybe (PF.Function Integer) +mergeExternalFunctionTypes preferred fallback = do + mergedType <- mergeExternalGlobalTypes (PF.fntype preferred) (PF.fntype fallback) + pure $ + preferred + { PF.fntype = mergedType + , PF.fnDefined = PF.fnDefined preferred || PF.fnDefined fallback + , PF.fnImplicit = PF.fnImplicit preferred && PF.fnImplicit fallback + } + +implicitExternalFunction :: PF.Function Integer +implicitExternalFunction = + PF.Function + { PF.fntype = CT.SCAuto $ CT.CTFunc CT.CTInt [] + , PF.fnDefined = False + , PF.fnImplicit = True + } + +definedFunctions :: ParsedInput -> Set.Set T.Text +definedFunctions (asts, _, _, _) = + Set.fromList + [ name + | ATNode (ATDefFunc name _) _ _ _ <- asts + ] + +implicitFunctionCalls :: ParsedInput -> Set.Set T.Text +implicitFunctionCalls (asts, _, _, funcs) = + foldMap implicitFunctionCallsInATree asts + `Set.difference` Set.fromList (Map.keys funcs) + +implicitFunctionCallsInATKindFor :: ATKindFor Integer -> Set.Set T.Text +implicitFunctionCallsInATKindFor kind = case kind of + ATForkw -> Set.empty + ATForInit at -> implicitFunctionCallsInATree at + ATForCond at -> implicitFunctionCallsInATree at + ATForIncr at -> implicitFunctionCallsInATree at + ATForStmt at -> implicitFunctionCallsInATree at + +implicitFunctionCallsInATKind :: ATKind Integer -> Set.Set T.Text +implicitFunctionCallsInATKind kind = case kind of + ATConditional cond tr fl -> + implicitFunctionCallsInATree cond + <> implicitFunctionCallsInATree tr + <> implicitFunctionCallsInATree fl + ATSwitch cond cases -> + implicitFunctionCallsInATree cond + <> foldMap implicitFunctionCallsInATree cases + ATFor kinds -> + foldMap implicitFunctionCallsInATKindFor kinds + ATBlock ats -> + foldMap implicitFunctionCallsInATree ats + ATStmtExpr ats -> + foldMap implicitFunctionCallsInATree ats + ATNull at -> + implicitFunctionCallsInATree at + ATDefFunc _ args -> + foldMap implicitFunctionCallsInATree $ fromMaybe [] args + ATCallFunc name args -> + Set.insert name $ foldMap implicitFunctionCallsInATree $ fromMaybe [] args + ATCallPtr args -> + foldMap implicitFunctionCallsInATree $ fromMaybe [] args + _ -> + Set.empty + +implicitFunctionCallsInATree :: ATree Integer -> Set.Set T.Text +implicitFunctionCallsInATree ATEmpty = Set.empty +implicitFunctionCallsInATree (ATNode kind _ lhs rhs) = + implicitFunctionCallsInATKind kind + <> implicitFunctionCallsInATree lhs + <> implicitFunctionCallsInATree rhs + +mergeOutputInputs :: [ParsedInput] -> Either String ParsedInput +mergeOutputInputs parsedInputs = + foldM mergeInput ([], Map.empty, [], Map.empty, Map.empty, Map.empty) (zip [0 :: Int ..] parsedInputs) >>= finalize + where + finalize (asts, gvars, lits, funcs, _, _) = do + (preparedAsts, preparedGVars) <- prepareAsmInput (fmap fst funcs) asts gvars + pure (preparedAsts, preparedGVars, lits, fmap fst funcs) + + mergeInput (astsAcc, gvarsAcc, litsAcc, funcsAcc, symbolsAcc, staticSymbolsAcc) (inputIndex, (asts, gvars, lits, funcs)) = do + let parsedInput = (asts, gvars, lits, funcs) + actualDefinitions = definedFunctions parsedInput + symbolsAcc' <- foldM (registerImplicitFunction inputIndex staticSymbolsAcc) symbolsAcc $ Set.toList $ implicitFunctionCalls parsedInput + (symbolsAcc'', staticSymbolsAcc', funcsAcc') <- foldM (registerFunction inputIndex actualDefinitions) (symbolsAcc', staticSymbolsAcc, funcsAcc) $ Map.toList funcs + (symbolsAcc''', staticSymbolsAcc'', gvarsAcc') <- foldM (registerGlobal inputIndex) (symbolsAcc'', staticSymbolsAcc', gvarsAcc) $ Map.toList gvars + pure + ( astsAcc <> asts + , gvarsAcc' + , litsAcc <> lits + , funcsAcc' + , symbolsAcc''' + , staticSymbolsAcc'' + ) + + registerImplicitFunction origin staticSymbols symbols name = do + rejectStaticSymbolConflict origin name ExternalImplicitFunction staticSymbols + case Map.lookup name symbols of + Nothing -> + pure $ insertSymbol origin name ExternalImplicitFunction symbols + Just (existingOrigin, existingSymbol) + | existingOrigin == origin -> + (\merged -> insertSymbol origin name merged symbols) + <$> mergeSameOriginExternalSymbol name existingSymbol ExternalImplicitFunction + | otherwise -> case existingSymbol of + ExternalGlobal _ -> + Left $ duplicateExternalSymbolError name + ExternalFunction existing existingHasBody -> + mergeExternalFunctions name (existing, existingHasBody) (implicitExternalFunction, False) + *> pure symbols + _ -> + pure symbols + + registerFunction origin actualDefinitions (symbols, staticSymbols, funcsAcc) (name, func) + | CT.isSCStatic (PF.fntype func) = do + rejectExternalSymbolConflict origin semanticName newSymbol symbols + staticSymbols' <- registerStaticSymbol origin semanticName newSymbol staticSymbols + pure (symbols, staticSymbols', insertFunction name (func, hasBody) funcsAcc) + | otherwise = do + rejectStaticSymbolConflict origin semanticName newSymbol staticSymbols + case Map.lookup semanticName symbols of + Nothing -> + pure + ( insertSymbol origin semanticName newSymbol symbols + , staticSymbols + , insertFunction name (func, hasBody) funcsAcc + ) + Just (existingOrigin, existingSymbol) + | existingOrigin == origin -> + case mergeSameOriginExternalSymbol name existingSymbol (ExternalFunction func hasBody) of + Left mergeErr -> + Left mergeErr + Right (ExternalFunction mergedFunc mergedHasBody) -> + pure + ( insertSymbol origin semanticName (ExternalFunction mergedFunc mergedHasBody) symbols + , staticSymbols + , insertFunction name (mergedFunc, mergedHasBody) funcsAcc + ) + Right _ -> + Left "internal compiler error: unexpected same-input symbol merge result" + | otherwise -> case existingSymbol of + ExternalImplicitFunction -> + mergeExternalFunctions name (implicitExternalFunction, False) (func, hasBody) >>= \_ -> + pure + ( insertSymbol origin semanticName newSymbol symbols + , staticSymbols + , insertFunction name (func, hasBody) funcsAcc + ) + ExternalFunction existing existingHasBody -> do + merged <- mergeExternalFunctions name (existing, existingHasBody) (func, hasBody) + pure + ( insertSymbol origin semanticName (uncurry ExternalFunction merged) symbols + , staticSymbols + , insertFunction name merged funcsAcc + ) + ExternalGlobal _ -> + Left $ duplicateExternalSymbolError name + where + hasBody = Set.member name actualDefinitions + semanticName = emittedSymbolName origin (CT.isSCStatic $ PF.fntype func) name + newSymbol = ExternalFunction func hasBody + + registerGlobal origin (symbols, staticSymbols, gvarsAcc) (name, gvar) + | CT.isSCStatic (gvtype gvar) = do + rejectExternalSymbolConflict origin semanticName newSymbol symbols + staticSymbols' <- registerStaticSymbol origin semanticName newSymbol staticSymbols + pure (symbols, staticSymbols', Map.insert name gvar gvarsAcc) + | otherwise = do + rejectStaticSymbolConflict origin semanticName newSymbol staticSymbols + case Map.lookup semanticName symbols of + Nothing -> + pure + ( insertSymbol origin semanticName newSymbol symbols + , staticSymbols + , Map.insert name gvar gvarsAcc + ) + Just (existingOrigin, existingSymbol) + | existingOrigin == origin -> + case mergeSameOriginExternalSymbol name existingSymbol (ExternalGlobal gvar) of + Left mergeErr -> + Left mergeErr + Right (ExternalGlobal mergedGVar) -> + pure + ( insertSymbol origin semanticName (ExternalGlobal mergedGVar) symbols + , staticSymbols + , Map.insert name mergedGVar gvarsAcc + ) + Right _ -> + Left "internal compiler error: unexpected same-input symbol merge result" + | otherwise -> case existingSymbol of + ExternalFunction _ _ -> + Left $ duplicateExternalSymbolError name + ExternalImplicitFunction -> + Left $ duplicateExternalSymbolError name + ExternalGlobal existing -> do + merged <- mergeExternalGlobals name existing gvar + pure + ( insertSymbol origin semanticName (ExternalGlobal merged) symbols + , staticSymbols + , Map.insert name merged gvarsAcc + ) + where + semanticName = emittedSymbolName origin (CT.isSCStatic $ gvtype gvar) name + newSymbol = ExternalGlobal gvar + + insertFunction name func = Map.insertWith preserveMergedFunctionType name func + insertSymbol origin name symbol = Map.insert name (origin, symbol) + insertStaticSymbol origin name symbol = Map.insert (origin, name) symbol + + emittedSymbolName origin isInternal name + | isInternal = + denamespaceInternalSymbol (fromIntegral origin) name + | otherwise = + name + + rejectExternalSymbolConflict origin name newSymbol symbols = case Map.lookup name symbols of + Just (existingOrigin, existingSymbol) + | existingOrigin == origin -> + mergeSameOriginExternalSymbol name existingSymbol newSymbol *> pure () + _ -> + pure () + + rejectStaticSymbolConflict origin name newSymbol staticSymbols = case Map.lookup (origin, name) staticSymbols of + Just existingSymbol -> + mergeSameOriginExternalSymbol name existingSymbol newSymbol *> pure () + Nothing -> + pure () + + registerStaticSymbol origin name newSymbol staticSymbols = case Map.lookup (origin, name) staticSymbols of + Just existingSymbol -> + (\merged -> insertStaticSymbol origin name merged staticSymbols) + <$> mergeSameOriginExternalSymbol name existingSymbol newSymbol + Nothing -> + pure $ insertStaticSymbol origin name newSymbol staticSymbols + + mergeSameOriginExternalSymbol name existingSymbol newSymbol = case (existingSymbol, newSymbol) of + (ExternalImplicitFunction, ExternalImplicitFunction) -> + pure ExternalImplicitFunction + (ExternalImplicitFunction, ExternalFunction func hasBody) -> + pure $ ExternalFunction func hasBody + (ExternalFunction func hasBody, ExternalImplicitFunction) -> + pure $ ExternalFunction func hasBody + (ExternalFunction existing existingHasBody, ExternalFunction func hasBody) -> + uncurry ExternalFunction + <$> mergeExternalFunctions name (existing, existingHasBody) (func, hasBody) + (ExternalGlobal existing, ExternalGlobal gvar) -> + ExternalGlobal <$> mergeExternalGlobals name existing gvar + _ -> + Left $ duplicateExternalSymbolError name + + preserveMergedFunctionType new old = + ( fromMaybe (fst new) $ mergeExternalFunctionTypes (fst new) (fst old) + , snd new || snd old + ) + +runAsm :: Maybe Handle -> Opts -> SI.Asm SI.AsmCodeCtx Integer a -> IO a +runAsm outputHandle opts asm + | optIsRunAsm opts = do + withReplacementOutputPath PreserveReplacementOutputModeKeepingExecutableBits (asmOutputPath opts) $ \tmpOutputPath -> do + compilerSpec <- asmCompiler + tmpDir <- getTemporaryDirectory + (asmPath, tmpHandle) <- openTempFile tmpDir "htcc-.s" + finally + ( do + (objPath, objHandle) <- openTempFile tmpDir "htcc-.o" + let cleanupObj = + ignoreIOException (hClose objHandle) + *> ignoreIOException (removeFile objPath) + finally + ( do + setFileMode objPath temporaryWritableMode + hClose objHandle + let assembleArgs = asmAssembleArgs objPath asmPath + linkArgs = asmLinkArgs tmpOutputPath objPath + result <- SI.runAsmWithHandle tmpHandle asm + hClose tmpHandle + when (optIsVerbose opts) $ + hPutStr stderr $ showCompilerCommandForUser compilerSpec assembleArgs <> "\n" + callCompilerProcess compilerSpec assembleArgs + when (optIsVerbose opts) $ + hPutStr stderr $ showCompilerCommandForUser compilerSpec linkArgs <> "\n" + callCompilerProcess compilerSpec linkArgs + shouldValidateOutput <- shouldValidateRunnableLinkedOutput tmpOutputPath + when shouldValidateOutput $ do + linkedOutputOk <- validateRunnableLinkedOutput tmpOutputPath Nothing + when (not linkedOutputOk) $ + ioError . userError $ + "HTCC_ASSEMBLER produced a non-runnable final output for -r: " + <> asmOutputPath opts + pure result + ) + cleanupObj + ) + ( ignoreIOException (hClose tmpHandle) + *> ignoreIOException (removeFile asmPath) + ) + | otherwise = maybe + (SI.runAsm asm) + (`SI.runAsmWithHandle` asm) + outputHandle + main :: IO () main = do opts <- OA.execParser optsParser - forM_ (optInput opts) $ \fname -> do - txt <- T.readFile fname - case runParser parser fname txt - :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer) of - Left x -> putStr $ M.errorBundlePretty x - Right r -> do - mapM_ (hPutStr stderr . M.errorBundlePretty) $ toList $ fst4 r - runAsm' $ casm' (snd4 r) (thd4 r) (fou4 r) - where - runAsm' = SI.runAsm :: SI.Asm SI.AsmCodeCtx Integer a -> IO a + validateOpts opts + let allowSameInputExternalCollisions = + not (optIsRunAsm opts) && length (optInput opts) > 1 + parserRunner = + if allowSameInputExternalCollisions + then PT.runParserAllowSameInputExternalCollisions + else runParser + parseInputRawEither fname txt = + case parserRunner parser fname txt + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) of + Left x -> Left x + Right (warns, asts, gvars, lits, funcs) -> + Right (warns, (asts, gvars, lits, funcs)) + parseInputRaw fname txt = + either + (\x -> hPutStr stderr (M.errorBundlePretty x) *> exitFailure) + pure + (parseInputRawEither fname txt) + readParsedInputRaw fname = + readInput fname >>= uncurry parseInputRaw + readParsedInput fname = do + (warns, parsedInput) <- readParsedInputRaw fname + emitWarnings warns + mergeParsedInputs [parsedInput] + readMergedInputRaw warnings parsedInputs [] = + pure (warnings, reverse parsedInputs) + readMergedInputRaw warnings parsedInputs (fname:fnames) = + catchIOError + ( do + (inputName, txt) <- readInput fname + case parseInputRawEither inputName txt of + Left parseErr -> do + emitWarnings warnings + hPutStr stderr (M.errorBundlePretty parseErr) + exitFailure + Right (warns, parsedInput) -> + readMergedInputRaw + (warnings <> toList warns) + (parsedInput : parsedInputs) + fnames + ) + (\ioErr -> emitWarnings warnings *> ioError ioErr) + mergeParsedInputsEither parsedInputs = + mergeOutputInputs $ shiftLiteralLabelsInInputs parsedInputs + mergeParsedInputs parsedInputs = + either + (\msg -> hPutStr stderr (msg <> "\n") *> exitFailure) + pure + (mergeParsedInputsEither parsedInputs) + readMergedInput = do + (warnings, parsedInputs) <- readMergedInputRaw [] [] (optInput opts) + case mergeParsedInputsEither parsedInputs of + Left msg -> do + emitWarnings warnings + hPutStr stderr (msg <> "\n") + exitFailure + Right parsedInput -> do + emitWarnings + [ warning + | warning <- warnings + , shouldEmitMergedWarning parsedInput warning + ] + pure parsedInput + runParsed outputHandle (asts, gvars, lits, _) = + runAsm outputHandle opts $ casmNormalized' asts gvars lits + readInput fname = do + txt <- withFile fname ReadMode $ \h -> do + txt' <- T.hGetContents h + _ <- evaluate $ T.foldl' (\n _ -> succ n) (0 :: Int) txt' + pure txt' + pure (fname, txt) + if optIsRunAsm opts + then forM_ (optInput opts) $ \fname -> + readParsedInput fname >>= runParsed Nothing + else maybe + (case optInput opts of + [_] -> + forM_ (optInput opts) $ \fname -> + readParsedInput fname >>= runParsed Nothing + _ -> + readMergedInput >>= runParsed Nothing + ) + (\path -> case optInput opts of + [fname] -> do + parsedInput <- readParsedInput fname + withReplacementOutputPath PreserveReplacementOutputMode path $ \tmpOutputPath -> + withFile tmpOutputPath WriteMode $ \h -> + runParsed (Just h) parsedInput + _ -> do + mergedInput <- readMergedInput + withReplacementOutputPath PreserveReplacementOutputMode path $ \tmpOutputPath -> + withFile tmpOutputPath WriteMode $ \h -> + runParsed (Just h) mergedInput + ) + (optOutput opts) diff --git a/htcc.cabal b/htcc.cabal index f33f181..f9f9c31 100644 --- a/htcc.cabal +++ b/htcc.cabal @@ -63,6 +63,7 @@ library Htcc.CRules.Types.CType Htcc.CRules.Types.StorageClass Htcc.CRules.Types.TypeKind + Htcc.Output Htcc.Parser Htcc.Parser.AST Htcc.Parser.AST.Core @@ -123,10 +124,12 @@ library , cond , containers , deepseq + , directory , diagrams-contrib , diagrams-lib , diagrams-svg , extra + , filepath , parsec , monad-finally , monad-loops @@ -139,6 +142,7 @@ library , split , text , transformers + , unix , utf8-string default-language: Haskell2010 @@ -161,8 +165,9 @@ executable htcc , diagrams-svg , directory , extra - , gitrev + , filepath , htcc + , process , parsec , monad-finally , monad-loops @@ -173,8 +178,10 @@ executable htcc , parser-combinators , safe , split + , template-haskell , text , transformers + , unix , utf8-string default-language: Haskell2010 @@ -183,8 +190,10 @@ test-suite htcc-test main-is: Spec.hs other-modules: Tests.ComponentsTests + Tests.ComponentsTests.AsmOutput Tests.ComponentsTests.Parser.Combinators Tests.SubProcTests + Tests.SubProcTests.AsmOutput Tests.SubProcTests.LinkFuncRet Tests.SubProcTests.LinkFuncStdOut Tests.SubProcTests.StatementEqual @@ -229,6 +238,7 @@ test-suite htcc-test , time , transformers , turtle + , unix , utf8-string default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 9aeb632..be53466 100644 --- a/package.yaml +++ b/package.yaml @@ -36,7 +36,9 @@ dependencies: - containers - bytestring - deepseq +- directory - safe +- filepath - mtl - monad-finally - mono-traversable @@ -48,6 +50,7 @@ dependencies: - optparse-applicative - parsec - parser-combinators +- unix - utf8-string library: @@ -67,12 +70,25 @@ executables: dependencies: - htcc - directory - - gitrev + - filepath + - process + - template-haskell + - unix tests: htcc-test: main: Spec.hs source-dirs: test + other-modules: + - Tests.ComponentsTests + - Tests.ComponentsTests.AsmOutput + - Tests.ComponentsTests.Parser.Combinators + - Tests.SubProcTests + - Tests.SubProcTests.AsmOutput + - Tests.SubProcTests.LinkFuncRet + - Tests.SubProcTests.LinkFuncStdOut + - Tests.SubProcTests.StatementEqual + - Tests.Utils ghc-options: - -threaded - -rtsopts @@ -94,6 +110,7 @@ tests: - dhall-json - dhall-yaml - process + - unix - utf8-string benchmarks: diff --git a/src/Htcc/Asm.hs b/src/Htcc/Asm.hs index 702e1b5..0992042 100644 --- a/src/Htcc/Asm.hs +++ b/src/Htcc/Asm.hs @@ -15,16 +15,17 @@ module Htcc.Asm ( casm ) where -import Data.Tuple.Extra (uncurry3) - +import Data.Bits (Bits) import Htcc.Asm.Generate import qualified Htcc.Asm.Intrinsic.Operand as O import qualified Htcc.Asm.Intrinsic.Structure.Internal as SI import qualified Htcc.Asm.Intrinsic.Structure.Section.Text.Instruction as TI import Htcc.Parser (ASTs) +import qualified Htcc.Parser.ConstructionData.Scope.Function as PF import Htcc.Parser.ConstructionData.Scope.Var (GlobalVars, Literals) +import Htcc.Utils (uncurry4) -- | Generate full assembly code from string of C source code -casm :: (O.IsOperand i, TI.UnaryInstruction i, TI.BinaryInstruction i, Integral i) => (ASTs i, GlobalVars i, Literals i) -> IO () -casm = SI.runAsm . uncurry3 casm' +casm :: (Bits i, Read i, Show i, Ord i, O.IsOperand i, TI.UnaryInstruction i, TI.BinaryInstruction i, Integral i) => (ASTs i, GlobalVars i, Literals i, PF.Functions i) -> IO () +casm = SI.runAsm . uncurry4 casm' diff --git a/src/Htcc/Asm/Generate.hs b/src/Htcc/Asm/Generate.hs index 404d3d3..4bd230d 100644 --- a/src/Htcc/Asm/Generate.hs +++ b/src/Htcc/Asm/Generate.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-| Module : Htcc.Asm.Generate Description : The modules of intrinsic (x86_64) assembly @@ -9,38 +10,556 @@ Portability : POSIX The executable module for compilation -} -{-# LANGUAGE OverloadedStrings #-} module Htcc.Asm.Generate ( InputCCode, + normalizeAsmInput, + prepareAsmInput, -- * Generator - casm' + casm', + casmNormalized' ) where -import qualified Data.Text as T +import Control.Monad (when) +import Data.Bits (Bits) +import Data.Foldable (traverse_) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import qualified Data.Text as T import Htcc.Asm.Generate.Core import Htcc.Asm.Intrinsic.Operand -import qualified Htcc.Asm.Intrinsic.Structure as SI -import qualified Htcc.Asm.Intrinsic.Structure.Section.Text as IT -import Htcc.Parser (ASTs) -import Htcc.Parser.ConstructionData.Scope.Var (GlobalVars, - Literals) +import qualified Htcc.Asm.Intrinsic.Structure as SI +import qualified Htcc.Asm.Intrinsic.Structure.Section.Text as IT +import qualified Htcc.CRules.Types as CT +import Htcc.Parser (ASTs, ATKind (..), + ATKindFor (..), + ATree (..)) +import Htcc.Parser.Combinators.Program (convertCallArgs, + foldGlobalInitWith) +import Htcc.Parser.Combinators.Utils (conditionalResultType, + decayExprType, + isInvalidFunctionPointerValue, + isInvalidObjectPointerValue) +import qualified Htcc.Parser.ConstructionData.Scope.Function as PF +import Htcc.Parser.ConstructionData.Scope.Var (GVar (..), + GVarInitWith (..), + GlobalVars, + Literals, + materializeTentativeIncompleteArray) -- | input string, C source code type InputCCode = T.Text -data MessageType = ErrorMessage | WarningMessage - deriving (Eq, Ord, Enum, Bounded) +normalizeGlobalInitializers :: (Integral i, Bits i, Read i, Show i, Ord i) => GlobalVars i -> Either String (GlobalVars i) +normalizeGlobalInitializers gvars = M.traverseWithKey resolveGlobalInit gvars + where + resolveGlobalInit _ gvar = case initWith gvar of + GVarInitWithAST ast -> + (\ginit -> gvar { initWith = ginit }) + <$> foldGlobalInitWith (gvtype gvar) ast + _ -> + Right gvar -instance Show MessageType where - show ErrorMessage = "error" - show WarningMessage = "warning" +retypeResolvedGlobalRefs :: GlobalVars i -> ASTs i -> ASTs i +retypeResolvedGlobalRefs = map . retypeResolvedGlobalRefsInATree + where + retypeResolvedGlobalRefsInATKindFor gvars kind = case kind of + ATForkw -> ATForkw + ATForInit at -> ATForInit $ retypeResolvedGlobalRefsInATree gvars at + ATForCond at -> ATForCond $ retypeResolvedGlobalRefsInATree gvars at + ATForIncr at -> ATForIncr $ retypeResolvedGlobalRefsInATree gvars at + ATForStmt at -> ATForStmt $ retypeResolvedGlobalRefsInATree gvars at + + retypeResolvedGlobalRefsInATKind gvars kind = case kind of + ATConditional cond tr fl -> + ATConditional + (retypeResolvedGlobalRefsInATree gvars cond) + (retypeResolvedGlobalRefsInATree gvars tr) + (retypeResolvedGlobalRefsInATree gvars fl) + ATSwitch cond cases -> + ATSwitch + (retypeResolvedGlobalRefsInATree gvars cond) + (map (retypeResolvedGlobalRefsInATree gvars) cases) + ATFor kinds -> + ATFor $ map (retypeResolvedGlobalRefsInATKindFor gvars) kinds + ATBlock ats -> + ATBlock $ map (retypeResolvedGlobalRefsInATree gvars) ats + ATStmtExpr ats -> + ATStmtExpr $ map (retypeResolvedGlobalRefsInATree gvars) ats + ATNull at -> + ATNull $ retypeResolvedGlobalRefsInATree gvars at + ATDefFunc name args -> + ATDefFunc name $ map (retypeResolvedGlobalRefsInATree gvars) <$> args + ATCallFunc name args -> + ATCallFunc name $ map (retypeResolvedGlobalRefsInATree gvars) <$> args + ATCallPtr args -> + ATCallPtr $ map (retypeResolvedGlobalRefsInATree gvars) <$> args + ATGVar ty name -> + ATGVar (maybe ty gvtype $ M.lookup name gvars) name + _ -> + kind + + retypeResolvedGlobalRefsInATree _ ATEmpty = ATEmpty + retypeResolvedGlobalRefsInATree gvars (ATNode kind ty lhs rhs) = + ATNode + retypedKind + retypedTy + (retypeResolvedGlobalRefsInATree gvars lhs) + (retypeResolvedGlobalRefsInATree gvars rhs) + where + retypedKind = retypeResolvedGlobalRefsInATKind gvars kind + retypedTy = case retypedKind of + ATGVar resolvedTy _ -> resolvedTy + _ -> ty + +normalizeAsmInput :: (Integral i, Bits i, Read i, Show i, Ord i) + => ASTs i + -> GlobalVars i + -> Either String (ASTs i, GlobalVars i) +normalizeAsmInput atl gvars = do + normalizedGVars <- normalizeGlobalInitializers gvars + pure (retypeResolvedGlobalRefs normalizedGVars atl, normalizedGVars) + +mergedCallableSignature :: Ord i => CT.StorageClass i -> Maybe (CT.StorageClass i, Maybe [CT.StorageClass i]) +mergedCallableSignature ty = case CT.toTypeKind ty of + CT.CTFunc retTy params -> + Just (CT.SCAuto retTy, explicitFunctionParamTypes params) + CT.CTPtr (CT.CTFunc retTy params) -> + Just (CT.SCAuto retTy, explicitFunctionParamTypes params) + _ -> + Nothing + where + explicitFunctionParamTypes [] = Nothing + explicitFunctionParamTypes [(CT.CTVoid, Nothing)] = Just [] + explicitFunctionParamTypes params = + Just $ map (CT.SCAuto . canonicalizeFunctionParamType . fst) params + + canonicalizeFunctionParamType = \case + CT.CTArray _ elemTy -> CT.CTPtr elemTy + CT.CTIncomplete (CT.IncompleteArray elemTy) -> CT.CTPtr elemTy + CT.CTFunc retTy params -> CT.CTPtr $ CT.CTFunc retTy params + other -> other + +mergedFunctionParamBindings :: Ord i => CT.StorageClass i -> Maybe [ATree i] -> M.Map i (CT.StorageClass i) +mergedFunctionParamBindings ty maybeArgs = case (maybeArgs, mergedParamTypes ty) of + (Just args, Just paramTys) + | length args == length paramTys + , Just offsets <- traverse paramOffset args -> + M.fromList $ zip offsets paramTys + _ -> + M.empty + where + mergedParamTypes resolvedTy = case mergedCallableSignature resolvedTy of + Just (_, formalParamTys) -> formalParamTys + Nothing -> Nothing + + paramOffset (ATNode (ATLVar _ offset) _ _ _) = Just offset + paramOffset _ = Nothing + +mergedFunctionType :: PF.Functions i -> T.Text -> CT.StorageClass i -> CT.StorageClass i +mergedFunctionType funcs name fallback = + maybe fallback PF.fntype $ M.lookup name funcs + +functionReturnType :: CT.StorageClass i -> Maybe (CT.StorageClass i) +functionReturnType ty = case CT.toTypeKind ty of + CT.CTFunc retTy _ -> Just $ CT.SCAuto retTy + _ -> Nothing + +derefMergedObjectType :: Ord i => CT.StorageClass i -> Maybe (CT.StorageClass i) +derefMergedObjectType ty = case CT.toTypeKind ty of + CT.CTArray n (CT.CTIncomplete (CT.IncompleteArray elemTy)) -> + Just $ CT.mapTypeKind (const $ CT.CTArray n elemTy) ty + _ -> + CT.deref ty + +objectPointerRetyped :: Ord i => ATree i -> ATree i -> ATree i -> ATree i -> Bool +objectPointerRetyped originalLhs originalRhs lhs rhs = + atype lhs /= atype originalLhs + || decayExprType (atype rhs) /= decayExprType (atype originalRhs) + +invalidAssignmentOperands :: (Ord i, Bits i, Integral i) => ATKind i -> ATree i -> ATree i -> ATree i -> ATree i -> Bool +invalidAssignmentOperands kind originalLhs originalRhs lhs rhs = case kind of + ATAssign -> + isInvalidFunctionPointerValue (atype lhs) rhs + || ( objectPointerRetyped originalLhs originalRhs lhs rhs + && isInvalidObjectPointerValue (atype lhs) rhs + ) + _ -> + False + +invalidIncompletePointerArithmetic :: Ord i => ATKind i -> ATree i -> ATree i -> Bool +invalidIncompletePointerArithmetic kind lhs rhs = case kind of + ATAddPtr -> + hasIncompletePointerTarget lhs + ATSubPtr -> + hasIncompletePointerTarget lhs + ATPtrDis -> + hasIncompletePointerTarget lhs || hasIncompletePointerTarget rhs + ATAddPtrAssign -> + hasIncompletePointerTarget lhs + ATSubPtrAssign -> + hasIncompletePointerTarget lhs + ATPreInc -> + hasIncompletePointerTarget lhs + ATPreDec -> + hasIncompletePointerTarget lhs + ATPostInc -> + hasIncompletePointerTarget lhs + ATPostDec -> + hasIncompletePointerTarget lhs + _ -> + False + where + hasIncompletePointerTarget expr = case CT.deref (atype expr) of + Just ty -> CT.isCTIncomplete ty + Nothing -> False + +invalidIncompleteMemOp :: Ord i => ATKind i -> ATree i -> Bool +invalidIncompleteMemOp kind lhs = case kind of + ATSizeof -> + CT.isCTIncomplete $ atype lhs + ATAlignof -> + CT.isCTIncomplete $ atype lhs + _ -> + False + +invalidReturnValue :: (Ord i, Bits i, Integral i) => Maybe (CT.StorageClass i) -> ATKind i -> ATree i -> Bool +invalidReturnValue currentReturnTy kind returnedExpr = case kind of + ATReturn -> + maybe False + (\returnTy -> + returnedExpr /= ATEmpty + && ( isInvalidFunctionPointerValue returnTy returnedExpr + || isInvalidObjectPointerValue returnTy returnedExpr + ) + ) + currentReturnTy + _ -> + False + +refreshMergedValueTypes :: (Ord i, Bits i, Integral i) => PF.Functions i -> Maybe (GlobalVars i) -> ATree i -> ATree i +refreshMergedValueTypes funcs maybeGVars = go + where + lastMaybe [] = Nothing + lastMaybe xs = Just $ last xs + + refreshKindFor = \case + ATForkw -> + ATForkw + ATForInit at -> + ATForInit $ go at + ATForCond at -> + ATForCond $ go at + ATForIncr at -> + ATForIncr $ go at + ATForStmt at -> + ATForStmt $ go at + + refreshKind = \case + ATConditional cond tr fl -> + ATConditional (go cond) (go tr) (go fl) + ATSwitch cond cases -> + ATSwitch (go cond) (map go cases) + ATFor kinds -> + ATFor $ map refreshKindFor kinds + ATBlock ats -> + ATBlock $ map go ats + ATStmtExpr ats -> + ATStmtExpr $ map go ats + ATNull at -> + ATNull $ go at + ATDefFunc name args -> + ATDefFunc name $ map go <$> args + ATCallFunc name args -> + ATCallFunc name $ map go <$> args + ATCallPtr args -> + ATCallPtr $ map go <$> args + ATGVar ty name -> + ATGVar (maybe ty gvtype $ maybeGVars >>= M.lookup name) name + other -> + other + + go ATEmpty = ATEmpty + go (ATNode kind ty lhs rhs) = + ATNode kind' ty' lhs' rhs' + where + kind' = refreshKind kind + lhs' = go lhs + rhs' = go rhs + ty' = case kind' of + ATConditional cond ATEmpty el -> + fromMaybe ty $ conditionalResultType cond el + ATConditional _ tr fl -> + fromMaybe ty $ conditionalResultType tr fl + ATDefFunc name _ -> + mergedFunctionType funcs name ty + ATGVar resolvedTy _ -> + resolvedTy + ATFuncPtr name -> + mergedFunctionType funcs name ty + ATAddr -> + CT.mapTypeKind CT.CTPtr $ atype lhs' + ATDeref -> + fromMaybe ty $ derefMergedObjectType $ atype lhs' + ATAddPtr -> + atype lhs' + ATSubPtr -> + atype lhs' + ATAssign -> + atype lhs' + ATAddPtrAssign -> + atype lhs' + ATSubPtrAssign -> + atype lhs' + ATComma -> + decayExprType $ atype rhs' + ATStmtExpr ats -> + maybe ty (decayExprType . atype) $ lastMaybe ats + _ -> + ty + + +revalidateMergedFunctionTree + :: (Ord i, Bits i, Integral i) + => PF.Functions i + -> Maybe (GlobalVars i) + -> Bool + -> ATree i + -> Either String (ATree i) +revalidateMergedFunctionTree funcs maybeGVars validateAssignments = revalidateTree M.empty Nothing + where + lastMaybe [] = Nothing + lastMaybe xs = Just $ last xs + + revalidateKindFor paramTys currentReturnTy = \case + ATForkw -> + Right ATForkw + ATForInit at -> + ATForInit <$> revalidateTree paramTys currentReturnTy at + ATForCond at -> + ATForCond <$> revalidateTree paramTys currentReturnTy at + ATForIncr at -> + ATForIncr <$> revalidateTree paramTys currentReturnTy at + ATForStmt at -> + ATForStmt <$> revalidateTree paramTys currentReturnTy at + + revalidateKind paramTys currentReturnTy = \case + ATConditional cond tr fl -> + ATConditional + <$> revalidateTree paramTys currentReturnTy cond + <*> revalidateTree paramTys currentReturnTy tr + <*> revalidateTree paramTys currentReturnTy fl + ATSwitch cond cases -> + ATSwitch + <$> revalidateTree paramTys currentReturnTy cond + <*> traverse (revalidateTree paramTys currentReturnTy) cases + ATFor kinds -> + ATFor <$> traverse (revalidateKindFor paramTys currentReturnTy) kinds + ATBlock ats -> + ATBlock <$> traverse (revalidateTree paramTys currentReturnTy) ats + ATStmtExpr ats -> + ATStmtExpr <$> traverse (revalidateTree paramTys currentReturnTy) ats + ATNull at -> + ATNull <$> revalidateTree paramTys currentReturnTy at + other -> + Right other + + revalidateTree _ _ ATEmpty = Right ATEmpty + revalidateTree currentParamTys currentReturnTy (ATNode (ATDefFunc name args) ty lhs rhs) = do + let resolvedFnTy = mergedFunctionType funcs name ty + nestedReturnTy = functionReturnType resolvedFnTy + nestedParamTys = mergedFunctionParamBindings resolvedFnTy args + args' <- traverse (traverse $ revalidateTree nestedParamTys nestedReturnTy) args + lhs' <- revalidateTree nestedParamTys nestedReturnTy lhs + rhs' <- revalidateTree currentParamTys currentReturnTy rhs + pure $ ATNode (ATDefFunc name args') resolvedFnTy lhs' rhs' + revalidateTree currentParamTys currentReturnTy (ATNode (ATLVar ty offset) _ lhs rhs) = do + lhs' <- revalidateTree currentParamTys currentReturnTy lhs + rhs' <- revalidateTree currentParamTys currentReturnTy rhs + let resolvedTy = fromMaybe ty $ M.lookup offset currentParamTys + pure $ ATNode (ATLVar resolvedTy offset) resolvedTy lhs' rhs' + revalidateTree currentParamTys currentReturnTy (ATNode (ATCallFunc name args) ty lhs rhs) = do + lhs' <- revalidateTree currentParamTys currentReturnTy lhs + rhs' <- revalidateTree currentParamTys currentReturnTy rhs + args' <- traverse (traverse $ revalidateTree currentParamTys currentReturnTy) args + case M.lookup name funcs of + Nothing -> + pure $ ATNode (ATCallFunc name args') ty lhs' rhs' + Just fn -> do + (callTy, formalParamTys) <- maybe + (Left "internal compiler error: merged function lookup returned non-callable type") + Right + (mergedCallableSignature $ PF.fntype fn) + params <- convertCallArgs formalParamTys $ fromMaybe [] args' + let params' = if null params then Nothing else Just params + pure $ ATNode (ATCallFunc name params') callTy lhs' rhs' + revalidateTree currentParamTys currentReturnTy (ATNode (ATCallPtr args) _ lhs rhs) = do + lhs' <- revalidateTree currentParamTys currentReturnTy lhs + rhs' <- revalidateTree currentParamTys currentReturnTy rhs + args' <- traverse (traverse $ revalidateTree currentParamTys currentReturnTy) args + (callTy, formalParamTys) <- maybe + (Left "called object is not a function or function pointer") + Right + (mergedCallableSignature $ atype lhs') + params <- convertCallArgs formalParamTys $ fromMaybe [] args' + let params' = if null params then Nothing else Just params + pure $ ATNode (ATCallPtr params') callTy lhs' rhs' + revalidateTree currentParamTys currentReturnTy (ATNode kind ty lhs rhs) = do + kind' <- revalidateKind currentParamTys currentReturnTy kind + let nestedReturnTy = case kind' of + ATDefFunc name _ -> + functionReturnType $ mergedFunctionType funcs name ty + _ -> + currentReturnTy + lhs' <- revalidateTree currentParamTys nestedReturnTy lhs + rhs' <- revalidateTree currentParamTys currentReturnTy rhs + let (kind'', ty') = refreshKindAndType kind' ty lhs' rhs' + when (validateAssignments && invalidAssignmentOperands kind'' lhs rhs lhs' rhs') $ + Left "invalid operands to assignment" + when (invalidIncompletePointerArithmetic kind'' lhs' rhs') $ + Left "invalid use of pointer to incomplete type" + when (invalidIncompleteMemOp kind'' lhs') $ + Left $ case kind'' of + ATSizeof -> "invalid application of 'sizeof' to incomplete type" + ATAlignof -> "invalid application of '_Alignof' to incomplete type" + _ -> "internal compiler error: unexpected incomplete memory operator" + when (invalidReturnValue currentReturnTy kind'' lhs') $ + Left "invalid return type" + pure $ ATNode kind'' ty' lhs' rhs' + + refreshKindAndType kind currentTy lhs rhs = case kind of + ATConditional cond ATEmpty el -> + ( kind + , fromMaybe currentTy $ conditionalResultType cond el + ) + ATConditional _ th el -> + ( kind + , fromMaybe currentTy $ conditionalResultType th el + ) + ATDefFunc name _ -> + (kind, mergedFunctionType funcs name currentTy) + ATGVar _ name -> + let resolvedTy = maybe currentTy gvtype $ maybeGVars >>= M.lookup name + in (ATGVar resolvedTy name, resolvedTy) + ATFuncPtr name -> + let resolvedTy = mergedFunctionType funcs name currentTy + in (ATFuncPtr name, resolvedTy) + ATAddr -> + (ATAddr, CT.mapTypeKind CT.CTPtr $ atype lhs) + ATDeref -> + (ATDeref, fromMaybe currentTy $ derefMergedObjectType $ atype lhs) + ATPreInc -> + (ATPreInc, atype lhs) + ATPreDec -> + (ATPreDec, atype lhs) + ATPostInc -> + (ATPostInc, atype lhs) + ATPostDec -> + (ATPostDec, atype lhs) + ATAddPtr -> + (ATAddPtr, atype lhs) + ATSubPtr -> + (ATSubPtr, atype lhs) + ATAssign -> + (ATAssign, atype lhs) + ATAddPtrAssign -> + (ATAddPtrAssign, atype lhs) + ATSubPtrAssign -> + (ATSubPtrAssign, atype lhs) + ATComma -> + (ATComma, decayExprType $ atype rhs) + ATStmtExpr ats -> + (kind, maybe currentTy (decayExprType . atype) $ lastMaybe ats) + _ -> + (kind, currentTy) + +revalidateMergedFunctionCalls + :: (Ord i, Bits i, Integral i) + => PF.Functions i + -> GlobalVars i + -> ASTs i + -> Either String (ASTs i) +revalidateMergedFunctionCalls funcs gvars = + traverse $ revalidateMergedFunctionTree funcs (Just gvars) True + +revalidateMergedGlobalInitializers + :: (Ord i, Bits i, Integral i) + => PF.Functions i + -> GlobalVars i + -> Either String (GlobalVars i) +revalidateMergedGlobalInitializers funcs gvars = + traverse revalidateGVar gvars + where + revalidateGVar gvar = case initWith gvar of + GVarInitWithAST ast -> do + let ast' = refreshMergedValueTypes funcs (Just gvars) ast + validateGlobalInitializerAssignments ast ast' + pure $ gvar { initWith = GVarInitWithAST ast' } + _ -> + Right gvar + + validateGlobalInitializerAssignments ATEmpty ATEmpty = Right () + validateGlobalInitializerAssignments + (ATNode originalKind _ originalLhs originalRhs) + (ATNode kind _ lhs rhs) = do + when (invalidIncompletePointerArithmetic kind lhs rhs) $ + Left "invalid use of pointer to incomplete type" + when (invalidIncompleteMemOp kind lhs) $ + Left $ case kind of + ATSizeof -> "invalid application of 'sizeof' to incomplete type" + ATAlignof -> "invalid application of '_Alignof' to incomplete type" + _ -> "internal compiler error: unexpected incomplete memory operator" + case (originalKind, kind) of + (ATBlock originalAts, ATBlock ats) + | length originalAts == length ats -> + traverse_ (uncurry validateGlobalInitializerAssignments) $ zip originalAts ats + | otherwise -> + Left "internal compiler error: global initializer shape changed during revalidation" + (ATExprStmt, ATExprStmt) -> + validateGlobalInitializerAssignments originalLhs lhs + (_, ATAssign) -> do + when (invalidAssignmentOperands kind originalLhs originalRhs lhs rhs) $ + Left "invalid initializer for scalar object" + validateGlobalInitializerAssignments originalLhs lhs + *> validateGlobalInitializerAssignments originalRhs rhs + _ -> + validateGlobalInitializerAssignments originalLhs lhs + *> validateGlobalInitializerAssignments originalRhs rhs + validateGlobalInitializerAssignments _ _ = + Left "internal compiler error: global initializer shape changed during revalidation" + +prepareAsmInput + :: (Integral i, Bits i, Read i, Show i, Ord i) + => PF.Functions i + -> ASTs i + -> GlobalVars i + -> Either String (ASTs i, GlobalVars i) +prepareAsmInput funcs asts gvars = do + let materializedGVars = M.map materializeTentativeIncompleteArray gvars + revalidatedGVars <- revalidateMergedGlobalInitializers funcs materializedGVars + (normalizedAsts, normalizedGVars) <- normalizeAsmInput asts revalidatedGVars + revalidatedAsts <- revalidateMergedFunctionCalls funcs normalizedGVars normalizedAsts + pure (revalidatedAsts, normalizedGVars) + +casmNormalized' :: (Show e, Show i, Integral e, Integral i, Ord i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) + => ASTs i + -> GlobalVars i + -> Literals i + -> SI.Asm SI.AsmCodeCtx e () +casmNormalized' atl gvars lits = + dataSection materializedGVars lits >> textSection (retypeResolvedGlobalRefs materializedGVars atl) + where + materializedGVars = M.map materializeTentativeIncompleteArray gvars -- | Executor that receives information about the constructed AST, -- global variables, and literals and composes assembly code -casm' :: (Integral e, Show e, Integral i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) +casm' :: (Bits i, Read i, Show e, Show i, Integral e, Integral i, Ord i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) => ASTs i -> GlobalVars i -> Literals i + -> PF.Functions i -> SI.Asm SI.AsmCodeCtx e () -casm' atl gvars lits = dataSection gvars lits >> textSection atl - +casm' atl gvars lits funcs = + case prepareAsmInput funcs atl gvars of + Left err -> SI.errCtx $ T.pack err + Right (normalizedAsts, normalizedGVars) -> + casmNormalized' normalizedAsts normalizedGVars lits diff --git a/src/Htcc/Asm/Generate/Core.hs b/src/Htcc/Asm/Generate/Core.hs index e0f5752..c341c4c 100644 --- a/src/Htcc/Asm/Generate/Core.hs +++ b/src/Htcc/Asm/Generate/Core.hs @@ -57,6 +57,7 @@ stackSize (ATNode (ATDefFunc _ args) _ body _) = let ms = f body $ maybe S.empty where f ATEmpty !s = s f (ATNode (ATCallFunc _ (Just arg)) t l r) !s = f (ATNode (ATBlock arg) t l r) s + f (ATNode (ATCallPtr (Just arg)) t l r) !s = f (ATNode (ATBlock arg) t l r) s f (ATNode (ATLVar t x) _ l r) !s = let i = S.insert (t, x) s in f l i `S.union` f r i f (ATNode (ATBlock xs) _ l r) !s = let i = foldr (S.union . (`f` s)) s xs in f l i `S.union` f r i f (ATNode (ATStmtExpr xs) t l r) !s = f (ATNode (ATBlock xs) t l r) s @@ -70,30 +71,61 @@ prologue :: Integral i => i -> SI.Asm IT.TextLabelCtx e () prologue ss = IT.push rbp >> IT.mov rbp rsp >> IT.sub rsp (fromIntegral ss :: Integer) {-# INLINE epilogue #-} -epilogue :: SI.Asm IT.TextLabelCtx e () -epilogue = retLabel *> IT.leave *> IT.ret +epilogue :: Ord i => CR.StorageClass i -> SI.Asm IT.TextLabelCtx e () +epilogue ty = retLabel *> when (returnsBool ty) normalizeBoolRax *> IT.leave *> IT.ret where retLabel = SI.Asm $ \x -> do cf <- readIORef (SI.curFn x) unless (isJust cf) $ err "stray epilogue" - T.putStrLn $ ".L.return." <> fromJust cf <> ":" + T.hPutStrLn (SI.outHandle x) $ ".L.return." <> fromJust cf <> ":" + + returnsBool sc = case CR.toTypeKind sc of + CR.CTFunc retTy _ -> retTy == CR.CTBool + _ -> False + +normalizeBoolRax :: SI.Asm IT.TextLabelCtx e () +normalizeBoolRax = normalizeBoolWordRax + +normalizeBoolWordRax :: SI.Asm IT.TextLabelCtx e () +normalizeBoolWordRax = IT.cmp rax (0 :: Int) *> IT.setne al *> IT.movzb rax al + +normalizeBoolAbiRax :: SI.Asm IT.TextLabelCtx e () +normalizeBoolAbiRax = IT.cmp al (0 :: Int) *> IT.setne al *> IT.movzb rax al + +truncateRax :: Ord i => CR.StorageClass i -> SI.Asm IT.TextLabelCtx e () +truncateRax t + | CR.sizeof t == 1 = IT.movsx rax al + | CR.sizeof t == 2 = IT.movsx rax ax + | CR.sizeof t == 4 = IT.movsxd rax eax + | otherwise = return () + +normalizeCallResultRax :: Ord i => CR.StorageClass i -> SI.Asm IT.TextLabelCtx e () +normalizeCallResultRax t + | CR.toTypeKind t == CR.CTBool = normalizeBoolAbiRax + | needsAbiTruncation (CR.toTypeKind t) && CR.sizeof t < 8 = truncateRax t + | otherwise = return () + where + needsAbiTruncation ty = case ty of + CR.CTChar -> True + CR.CTInt -> True + CR.CTEnum _ _ -> True + CR.CTSigned x -> needsAbiTruncation x + CR.CTShort x -> needsAbiTruncation x + CR.CTLong x -> needsAbiTruncation x + _ -> False truncate :: Ord i => CR.StorageClass i -> SI.Asm IT.TextLabelCtx e () truncate ty = do IT.pop rax - when (CR.toTypeKind ty == CR.CTBool) $ IT.cmp rax (0 :: Int) *> IT.setne al - truncate' ty + if CR.toTypeKind ty == CR.CTBool + then normalizeBoolRax + else truncateRax ty IT.push rax - where - truncate' t - | CR.sizeof t == 1 = IT.movsx rax al - | CR.sizeof t == 2 = IT.movsx rax ax - | CR.sizeof t == 4 = IT.movsxd rax eax - | otherwise = return () genAddr :: (Integral e, Show e, IsOperand i, Integral i, Ord i, IT.UnaryInstruction i, IT.BinaryInstruction i) => ATree i -> SI.Asm IT.TextLabelCtx e () genAddr (ATNode (ATLVar _ v) _ _ _) = IT.lea rax (Ref $ rbp `osub` v) >> IT.push rax genAddr (ATNode (ATGVar _ n) _ _ _) = IT.push (IT.Offset n) +genAddr (ATNode (ATFuncPtr n) _ _ _) = IT.push (IT.Offset n) genAddr (ATNode ATDeref _ lhs _) = genStmt lhs genAddr (ATNode (ATMemberAcc m) _ lhs _) = do genAddr lhs @@ -115,6 +147,13 @@ load t | CR.sizeof t == 4 = IT.pop rax >> IT.movsxd rax (IT.dword IT.Ptr (Ref rax)) >> IT.push rax | otherwise = IT.pop rax >> IT.mov rax (Ref rax) >> IT.push rax +nonLoadableDerefType :: CR.StorageClass i -> Bool +nonLoadableDerefType ty = + CR.isArray ty + || case CR.toTypeKind ty of + CR.CTFunc _ _ -> True + _ -> False + store :: Ord i => CR.StorageClass i -> SI.Asm IT.TextLabelCtx e () store t = do IT.pop rdi @@ -135,25 +174,129 @@ increment t = IT.pop rax >> IT.add rax (maybe 1 CR.sizeof $ CR.deref t) >> IT.pu decrement :: Ord i => CR.StorageClass i -> SI.Asm IT.TextLabelCtx e () decrement t = IT.pop rax >> IT.sub rax (maybe 1 CR.sizeof $ CR.deref t) >> IT.push rax -genStmt :: (Show e, Integral e, Show i, Integral i, Ord i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) => ATree i -> SI.Asm IT.TextLabelCtx e () -genStmt (ATNode (ATCallFunc x Nothing) _ _ _) = IT.call x >> IT.push rax -genStmt (ATNode (ATCallFunc x (Just args)) t _ _) = let (n', toReg, _) = splitAtLen 6 args in do - mapM_ genStmt toReg - mapM_ IT.pop $ popRegs n' +genCallTarget :: (Show e, Integral e, Show i, Integral i, Ord i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) => ATree i -> SI.Asm IT.TextLabelCtx e () +genCallTarget callee + | isFunctionDesignator callee = genAddr callee + | otherwise = genStmt callee + where + isFunctionDesignator expr = case CR.toTypeKind (atype expr) of + CR.CTFunc _ _ -> True + _ -> False + +stackArgCount :: [a] -> Int +stackArgCount = length . drop 6 + +callAligned + :: (Show e, Integral e) + => Int + -> SI.Asm IT.TextLabelCtx e () + -> SI.Asm IT.TextLabelCtx e () + -> SI.Asm IT.TextLabelCtx e () +callAligned nStackArgs prepare invoke = do + let callPrepared = do + prepare + invoke + cleanupStackArgs nStackArgs n <- IT.incrLbl IT.mov rax rsp + when (odd nStackArgs) $ + IT.sub rax (8 :: Int) IT.and rax (0x0f :: Int) IT.jnz $ IT.ref "call" n - IT.mov rax (0 :: Int) - IT.call x + callPrepared IT.jmp $ IT.refEnd n IT.label "call" n IT.sub rsp (8 :: Int) - IT.mov rax (0 :: Int) - IT.call x + callPrepared IT.add rsp (8 :: Int) IT.end n - when (CR.toTypeKind t == CR.CTBool) $ IT.movzb rax al + +invokeIndirect :: (Show e, Integral e) => SI.Asm IT.TextLabelCtx e () +invokeIndirect = do + IT.mov rax (0 :: Int) + IT.call "r11" + +prepareCallArgs + :: (Show e, Integral e, Show i, Integral i, Ord i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) + => [ATree i] + -> SI.Asm IT.TextLabelCtx e () +prepareCallArgs args = do + let (nReg, _, stackArgs) = splitAtLen 6 args + nArgs = nReg + length stackArgs + slotRef base idx = Ref $ base `oadd` (8 * idx :: Int) + storeValue base idx expr = do + genStmt expr + IT.pop rdx + IT.mov (slotRef base idx) rdx + restoreArgs base = do + zipWithM_ (\reg idx -> IT.mov reg (slotRef base idx)) (reverse $ popRegs nReg) [0 .. pred nReg] + mapM_ (IT.push . slotRef base) $ reverse [nReg .. pred nArgs] + if nArgs == 0 + then pure () + else do + IT.push rbx + IT.sub rsp (8 * nArgs) + IT.mov rbx rsp + zipWithM_ (storeValue rbx) [0..] args + IT.mov rax rbx + IT.add rsp (8 * nArgs) + IT.pop rbx + restoreArgs rax + +prepareIndirectCall + :: (Show e, Integral e, Show i, Integral i, Ord i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) + => ATree i + -> [ATree i] + -> SI.Asm IT.TextLabelCtx e () +prepareIndirectCall callee args = do + let (nReg, _, stackArgs) = splitAtLen 6 args + nArgs = nReg + length stackArgs + calleeSlot = nArgs + nSlots = succ nArgs + slotRef base idx = Ref $ base `oadd` (8 * idx :: Int) + storeValue base idx expr = do + genStmt expr + IT.pop rdx + IT.mov (slotRef base idx) rdx + restoreArgs base = do + zipWithM_ (\reg idx -> IT.mov reg (slotRef base idx)) (reverse $ popRegs nReg) [0 .. pred nReg] + IT.mov (rn 11) (slotRef base calleeSlot) + mapM_ (IT.push . slotRef base) $ reverse [nReg .. pred nArgs] + IT.push rbx + IT.sub rsp (8 * nSlots) + IT.mov rbx rsp + genCallTarget callee + IT.pop rdx + IT.mov (slotRef rbx calleeSlot) rdx + zipWithM_ (storeValue rbx) [0..] args + IT.mov rax rbx + IT.add rsp (8 * nSlots) + IT.pop rbx + restoreArgs rax + +cleanupStackArgs :: Integral e => Int -> SI.Asm IT.TextLabelCtx e () +cleanupStackArgs n = + when (n > 0) $ + IT.add rsp (8 * n) + +genStmt :: (Show e, Integral e, Show i, Integral i, Ord i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) => ATree i -> SI.Asm IT.TextLabelCtx e () +genStmt (ATNode (ATCallFunc x Nothing) t _ _) = do + callAligned 0 (pure ()) $ IT.mov rax (0 :: Int) >> IT.call x + normalizeCallResultRax t + IT.push rax +genStmt (ATNode (ATCallPtr Nothing) t callee _) = do + callAligned 0 (genCallTarget callee >> IT.pop (rn 11)) invokeIndirect + normalizeCallResultRax t + IT.push rax +genStmt (ATNode (ATCallFunc x (Just args)) t _ _) = do + callAligned (stackArgCount args) (prepareCallArgs args) $ do + IT.mov rax (0 :: Int) + IT.call x + normalizeCallResultRax t + IT.push rax +genStmt (ATNode (ATCallPtr (Just args)) t callee _) = do + callAligned (stackArgCount args) (prepareIndirectCall callee args) invokeIndirect + normalizeCallResultRax t IT.push rax genStmt (ATNode (ATBlock stmt) _ _ _) = mapM_ genStmt stmt genStmt (ATNode (ATStmtExpr stmt) _ _ _) = mapM_ genStmt stmt @@ -223,6 +366,8 @@ genStmt (ATNode ATReturn _ lhs _) = do IT.pop rax IT.jmp IT.refReturn genStmt (ATNode ATCast t lhs _) = genStmt lhs >> truncate t +genStmt (ATNode ATSizeof _ lhs _) = IT.push (fromIntegral (CR.sizeof $ atype lhs) :: Integer) +genStmt (ATNode ATAlignof _ lhs _) = IT.push (fromIntegral (CR.alignof $ atype lhs) :: Integer) genStmt (ATNode ATExprStmt _ lhs _) = genStmt lhs >> IT.add rsp (8 :: Int) genStmt (ATNode ATBitNot _ lhs _) = do genStmt lhs @@ -297,9 +442,9 @@ genStmt (ATNode ATPostDec t lhs _) = do decrement t store t increment t -genStmt (ATNode ATComma _ lhs rhs) = genStmt lhs >> genStmt rhs +genStmt (ATNode ATComma _ lhs rhs) = genStmt lhs >> IT.add rsp (8 :: Int) >> genStmt rhs genStmt (ATNode ATAddr _ lhs _) = genAddr lhs -genStmt (ATNode ATDeref t lhs _) = genStmt lhs >> unless (CR.isCTArray t) (load t) +genStmt (ATNode ATDeref t lhs _) = genStmt lhs >> unless (nonLoadableDerefType t) (load t) genStmt (ATNode ATNot _ lhs _) = do genStmt lhs IT.pop rax @@ -310,6 +455,7 @@ genStmt (ATNode ATNot _ lhs _) = do genStmt (ATNode (ATNum x) _ _ _) | x <= fromIntegral (maxBound :: Int32) = IT.push x | otherwise = IT.movabs rax x >> IT.push rax +genStmt n@(ATNode (ATFuncPtr _) _ _ _) = genAddr n genStmt n@(ATNode (ATLVar _ _) t _ _) = genAddr n >> unless (CR.isCTArray t) (load t) genStmt n@(ATNode (ATGVar _ _) t _ _) = genAddr n >> unless (CR.isCTArray t) (load t) genStmt n@(ATNode (ATMemberAcc _) t _ _) = genAddr n >> unless (CR.isCTArray t) (load t) @@ -371,16 +517,58 @@ genStmt (ATNode kd ty lhs rhs) _ -> SI.errCtx "internal compiler error: asm code generator should not reach here (binOp). Maybe abstract tree is broken it cause (bug)." genStmt _ = return () +spillRegisterParam + :: (Integral e, Ord i, IsOperand i, IT.BinaryInstruction i) + => ATree i + -> [Register] + -> SI.Asm IT.TextLabelCtx e () +spillRegisterParam (ATNode (ATLVar t o) _ _ _) regs + | CR.toTypeKind t == CR.CTBool = + maybe + (SI.errCtx "internal compiler error: there is no full-width register for a _Bool parameter") + (\fullReg -> IT.mov rax fullReg >> normalizeBoolAbiRax >> IT.mov (Ref $ rbp `osub` o) al) + (find ((== 8) . byteWidth) regs) + | otherwise = + maybe + (SI.errCtx "internal compiler error: there is no register that fits the specified size") + (IT.mov (Ref $ rbp `osub` o)) + (find ((== CR.sizeof t) . byteWidth) regs) +spillRegisterParam _ _ = + SI.errCtx "internal compiler error: expected local variable parameter slot" + +spillStackParam + :: (Integral e, Ord i, IsOperand i, IT.BinaryInstruction i) + => Integer + -> ATree i + -> SI.Asm IT.TextLabelCtx e () +spillStackParam callerOffset (ATNode (ATLVar t o) _ _ _) = case CR.sizeof t of + 1 + | CR.toTypeKind t == CR.CTBool -> + loadCallerSlot >> normalizeBoolAbiRax >> IT.mov localSlot al + | otherwise -> + loadCallerSlot >> IT.mov localSlot al + 2 -> loadCallerSlot >> IT.mov localSlot ax + 4 -> loadCallerSlot >> IT.mov localSlot eax + 8 -> loadCallerSlot >> IT.mov localSlot rax + _ -> SI.errCtx "internal compiler error: unsupported stack-passed parameter width" + where + localSlot = Ref $ rbp `osub` o + callerSlot = Ref $ rbp `oadd` callerOffset + loadCallerSlot = IT.mov rax callerSlot +spillStackParam _ _ = + SI.errCtx "internal compiler error: expected local variable parameter slot" + textSection' :: (Integral e, Show e, Integral i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) => ATree i -> SI.Asm IT.TextSectionCtx e () textSection' lc@(ATNode (ATDefFunc fn margs) ty st _) = do unless (CR.isSCStatic ty) $ IT.global fn IT.fn fn $ do prologue (stackSize lc) - when (isJust margs) $ flip (`zipWithM_` fromJust margs) argRegs $ \(ATNode (ATLVar t o) _ _ _) reg -> - maybe (SI.errCtx "internal compiler error: there is no register that fits the specified size") - (IT.mov (Ref $ rbp `osub` o)) $ find ((== CR.sizeof t) . byteWidth) reg + when (isJust margs) $ do + let (regArgs, stackArgs) = splitAt 6 $ fromJust margs + zipWithM_ spillRegisterParam regArgs argRegs + zipWithM_ spillStackParam [16, 24 ..] stackArgs genStmt st - epilogue + epilogue ty textSection' ATEmpty = return () textSection' _ = SI.errCtx "internal compiler error: all abstract tree should start from some functions" @@ -392,6 +580,20 @@ dataSection gvars lits = ID.dAta $ do PV.GVarInitWithZero -> ID.label var $ ID.zero (CR.sizeof t) PV.GVarInitWithOG ref -> ID.label var $ ID.quad ref PV.GVarInitWithVal val -> ID.label var $ ID.sbyte (CR.sizeof t) val + PV.GVarInitWithData ds -> ID.label var $ mapM_ emitInitData ds + PV.GVarInitWithAST _ -> SI.errCtx "internal compiler error: unresolved global initializer AST" + where + emitInitData dat = case dat of + PV.GVarInitZeroBytes sz -> ID.zero sz + PV.GVarInitBytes sz val -> ID.sbyte sz val + PV.GVarInitReloc sz ref addend + | sz == 8 -> ID.quad $ formatReloc ref addend + | otherwise -> SI.errCtx "internal compiler error: unsupported relocation width in global initializer" + + formatReloc ref addend + | addend == 0 = ref + | addend > 0 = ref <> "+" <> tshow addend + | otherwise = ref <> tshow addend -- | text section of assembly code textSection :: (Integral e, Show e, IsOperand i, Integral i, Show i, IT.UnaryInstruction i, IT.BinaryInstruction i) => [ATree i] -> SI.Asm SI.AsmCodeCtx e () diff --git a/src/Htcc/Asm/Intrinsic/Structure/Internal.hs b/src/Htcc/Asm/Intrinsic/Structure/Internal.hs index b1aec2c..ab831c9 100644 --- a/src/Htcc/Asm/Intrinsic/Structure/Internal.hs +++ b/src/Htcc/Asm/Intrinsic/Structure/Internal.hs @@ -16,6 +16,7 @@ module Htcc.Asm.Intrinsic.Structure.Internal ( AsmCodeCtx, unCtx, runAsm, + runAsmWithHandle, putStrWithIndent, putStrLnWithIndent, errCtx, @@ -28,17 +29,19 @@ import Control.Monad.Finally (MonadFinally (..)) import Data.IORef (IORef, newIORef, writeIORef) import qualified Data.Text as T import qualified Data.Text.IO as T +import System.IO (Handle, stdout) import Htcc.Utils (err) -- | Counter and label information used when generating assembly code data AsmInfo e = AsmInfo { - inLabel :: Bool, -- ^ the flag that indicates whether it is inside the label. If True, indent by single tab, - lblCnt :: IORef e, -- ^ the label counter - brkCnt :: IORef (Maybe e), -- ^ the @break@ label counter - cntCnt :: IORef (Maybe e), -- ^ the @continue@ label counter - curFn :: IORef (Maybe T.Text) -- ^ the function being processed + inLabel :: Bool, -- ^ the flag that indicates whether it is inside the label. If True, indent by single tab, + outHandle :: Handle, -- ^ output destination for generated assembly + lblCnt :: IORef e, -- ^ the label counter + brkCnt :: IORef (Maybe e), -- ^ the @break@ label counter + cntCnt :: IORef (Maybe e), -- ^ the @continue@ label counter + curFn :: IORef (Maybe T.Text) -- ^ the function being processed } -- | A monad that represents the context of the assembly code @@ -80,21 +83,25 @@ unCtx = Asm . unAsm -- | the executor that outputs assembly code runAsm :: (Num e, Enum e) => Asm AsmCodeCtx e a -> IO a -runAsm asm = do - putStrLn ".intel_syntax noprefix" +runAsm = runAsmWithHandle stdout + +-- | the executor that outputs assembly code to the specified handle +runAsmWithHandle :: (Num e, Enum e) => Handle -> Asm AsmCodeCtx e a -> IO a +runAsmWithHandle h asm = do + T.hPutStrLn h ".intel_syntax noprefix" c <- newIORef 0 brk <- newIORef Nothing cnt <- newIORef Nothing fn <- newIORef Nothing - unAsm asm (AsmInfo False c brk cnt fn) + unAsm asm (AsmInfo False h c brk cnt fn) -- | print a string with indentation, output is broken on a new line putStrLnWithIndent :: T.Text -> Asm ctx e () -putStrLnWithIndent s = Asm $ \x -> T.putStrLn $ if inLabel x then '\t' `T.cons` s else s +putStrLnWithIndent s = Asm $ \x -> T.hPutStrLn (outHandle x) $ if inLabel x then '\t' `T.cons` s else s -- | print a string with indentation putStrWithIndent :: T.Text -> Asm ctx e () -putStrWithIndent s = Asm $ \x -> T.putStr $ if inLabel x then '\t' `T.cons` s else s +putStrWithIndent s = Asm $ \x -> T.hPutStr (outHandle x) $ if inLabel x then '\t' `T.cons` s else s -- | The error context. -- when this is executed, diff --git a/src/Htcc/Asm/Intrinsic/Structure/Section/Text/Directive.hs b/src/Htcc/Asm/Intrinsic/Structure/Section/Text/Directive.hs index 966e1bd..03fd5ee 100644 --- a/src/Htcc/Asm/Intrinsic/Structure/Section/Text/Directive.hs +++ b/src/Htcc/Asm/Intrinsic/Structure/Section/Text/Directive.hs @@ -83,14 +83,14 @@ label :: (Show i, Show e) => T.Text -> i -> C.Asm TextLabelCtx e () label lbl n = C.Asm $ \x -> do cf <- readIORef $ C.curFn x unless (isJust cf) $ err "stray label" - T.putStrLn $ ".L." <> lbl <> "." <> fromJust cf <> "." <> tshow n <> ":" + T.hPutStrLn (C.outHandle x) $ ".L." <> lbl <> "." <> fromJust cf <> "." <> tshow n <> ":" -- | goto label gotoLabel :: T.Text -> C.Asm TextLabelCtx e () gotoLabel ident = C.Asm $ \x -> do cf <- readIORef $ C.curFn x unless (isJust cf) $ err "stray goto label" - T.putStrLn $ ".L.label." <> fromJust cf <> "." <> ident <> ":" + T.hPutStrLn (C.outHandle x) $ ".L.label." <> fromJust cf <> "." <> ident <> ":" -- | begin label begin :: (Show e, Show i) => i -> C.Asm TextLabelCtx e () @@ -109,7 +109,7 @@ cAse :: (Show e, Show i) => i -> C.Asm TextLabelCtx e () cAse n = C.Asm $ \x -> do cf <- readIORef $ C.curFn x unless (isJust cf) $ err "stray case" - T.putStrLn $ ".L.case." <> fromJust cf <> "." <> tshow n <> ":" + T.hPutStrLn (C.outHandle x) $ ".L.case." <> fromJust cf <> "." <> tshow n <> ":" -- | break label break :: (Show e, Show i) => i -> C.Asm TextLabelCtx e () @@ -124,7 +124,7 @@ refReturn :: Show e => C.Asm TargetLabelCtx e () refReturn = C.Asm $ \x -> do cf <- readIORef (C.curFn x) unless (isJust cf) $ err "stray label" - T.putStrLn $ ".L.return." <> fromJust cf + T.hPutStrLn (C.outHandle x) $ ".L.return." <> fromJust cf refCnt :: Show e => (C.AsmInfo a -> IORef (Maybe e)) -> T.Text -> C.Asm ctx a () refCnt f mes = C.Asm $ \x -> do @@ -132,7 +132,7 @@ refCnt f mes = C.Asm $ \x -> do unless (isJust cf) $ err $ "stray " <> mes n <- readIORef (f x) unless (isJust n) $ err $ "stray " <> mes - T.putStrLn $ ".L." <> mes <> "." <> fromJust cf <> "." <> tshow (fromJust n) + T.hPutStrLn (C.outHandle x) $ ".L." <> mes <> "." <> fromJust cf <> "." <> tshow (fromJust n) -- | reference for break label refBreak :: (Show e, Show i) => i -> C.Asm TargetLabelCtx e () @@ -155,7 +155,7 @@ refGoto :: T.Text -> C.Asm TargetLabelCtx e () refGoto ident = C.Asm $ \x -> do cf <- readIORef (C.curFn x) unless (isJust cf) $ err "stray label" - T.putStrLn $ ".L.label." <> fromJust cf <> "." <> ident + T.hPutStrLn (C.outHandle x) $ ".L.label." <> fromJust cf <> "." <> ident -- | reference to begin label refBegin :: (Show e, Show i) => i -> C.Asm TargetLabelCtx e () @@ -174,7 +174,7 @@ ref :: (Show e, Show i) => T.Text -> i -> C.Asm TargetLabelCtx e () ref lbl n = C.Asm $ \x -> do cf <- readIORef (C.curFn x) unless (isJust cf) $ err "stray label" - T.putStrLn $ ".L." <> lbl <> "." <> fromJust cf <> "." <> tshow n + T.hPutStrLn (C.outHandle x) $ ".L." <> lbl <> "." <> fromJust cf <> "." <> tshow n -- | generate cases and return abstract tree makeCases :: (Show e, Enum e, Integral e, Show i, Num i) => [ATree i] -> C.Asm TextLabelCtx e [ATree i] @@ -184,12 +184,12 @@ makeCases cases = C.Asm $ \x -> do (ATNode (ATCase _ cn) t lhs rhs) -> do modifyIORef (C.lblCnt x) succ n' <- readIORef (C.lblCnt x) - T.putStrLn $ "\tcmp rax, " <> tshow cn - T.putStrLn $ "\tje .L.case." <> fromJust cf <> "." <> tshow n' + T.hPutStrLn (C.outHandle x) $ "\tcmp rax, " <> tshow cn + T.hPutStrLn (C.outHandle x) $ "\tje .L.case." <> fromJust cf <> "." <> tshow n' return $ ATNode (ATCase (fromIntegral n') cn) t lhs rhs (ATNode (ATDefault _) t lhs rhs) -> do modifyIORef (C.lblCnt x) succ n' <- readIORef (C.lblCnt x) - T.putStrLn $ "\tjmp .L.case." <> fromJust cf <> "." <> tshow n' + T.hPutStrLn (C.outHandle x) $ "\tjmp .L.case." <> fromJust cf <> "." <> tshow n' return $ ATNode (ATDefault $ fromIntegral n') t lhs rhs at -> return at diff --git a/src/Htcc/Asm/Intrinsic/Structure/Section/Text/Instruction.hs b/src/Htcc/Asm/Intrinsic/Structure/Section/Text/Instruction.hs index 30e6a3a..e976cb1 100644 --- a/src/Htcc/Asm/Intrinsic/Structure/Section/Text/Instruction.hs +++ b/src/Htcc/Asm/Intrinsic/Structure/Section/Text/Instruction.hs @@ -217,5 +217,4 @@ jnz asm = I.putStrWithIndent "jnz " *> I.unCtx asm -- | @call@ instruction call :: T.Text -> I.Asm TextLabelCtx e () -call = intelSyntaxUnary "call" - +call arg = I.putStrLnWithIndent $ "call " <> arg diff --git a/src/Htcc/CRules/Types/TypeKind.hs b/src/Htcc/CRules/Types/TypeKind.hs index 61ce08a..dd04643 100644 --- a/src/Htcc/CRules/Types/TypeKind.hs +++ b/src/Htcc/CRules/Types/TypeKind.hs @@ -9,7 +9,7 @@ Portability : POSIX The types of C language -} -{-# LANGUAGE BangPatterns, DeriveGeneric #-} +{-# LANGUAGE BangPatterns, DeriveGeneric, LambdaCase #-} module Htcc.CRules.Types.TypeKind ( -- * TypeKind data type StructMember (..), @@ -23,6 +23,9 @@ module Htcc.CRules.Types.TypeKind ( -- * Utilities of C type alignas, Desg (..), + integerPromotedTypeKind, + mergeCompatibleTypeKinds, + mergeTentativeArrayTypeKinds, accessibleIndices, ) where @@ -143,13 +146,14 @@ data TypeKind i = CTInt -- ^ The type @int@ as C language | CTArray Natural (TypeKind i) -- ^ The array type | CTEnum (TypeKind i) (M.Map T.Text i) -- ^ The enum, has its underlying type and a map | CTStruct (M.Map T.Text (StructMember i)) -- ^ The struct, has its members and their names. + | CTNamedStruct T.Text (M.Map T.Text (StructMember i)) -- ^ A tagged struct definition. | CTIncomplete (Incomplete i) -- ^ The incomplete type. | CTUndef -- ^ Undefined type deriving Generic {-# INLINE fundamental #-} fundamental :: [TypeKind i] -fundamental = [CTChar, CTInt, CTShort CTUndef, CTLong CTUndef, CTSigned CTUndef, CTVoid] +fundamental = [CTChar, CTInt, CTBool, CTShort CTUndef, CTLong CTUndef, CTSigned CTUndef, CTVoid] {-# INLINE isLongShortable #-} isLongShortable :: TypeKind i -> Bool @@ -255,6 +259,7 @@ instance Eq i => Eq (TypeKind i) where (==) (CTEnum ut1 m1) (CTEnum ut2 m2) = ut1 == ut2 && m1 == m2 (==) (CTArray v1 t1) (CTArray v2 t2) = v1 == v2 && t1 == t2 (==) (CTStruct m1) (CTStruct m2) = m1 == m2 + (==) (CTNamedStruct tag1 m1) (CTNamedStruct tag2 m2) = tag1 == tag2 && m1 == m2 (==) CTUndef CTUndef = True (==) (CTPtr t1) (CTPtr t2) = t1 == t2 (==) (CTIncomplete t1) (CTIncomplete t2) = t1 == t2 @@ -279,6 +284,10 @@ instance Show i => Show (TypeKind i) where show (CTArray v t) = show t ++ "[" ++ show v ++ "]" show (CTEnum _ m) = "enum { " ++ intercalate ", " (map T.unpack $ M.keys m) ++ " }" show (CTStruct m) = "struct { " ++ concatMap (\(v, inf) -> show (smType inf) ++ " " ++ T.unpack v ++ "; ") (M.toList m) ++ "}" + show (CTNamedStruct tag m) = + "struct " ++ T.unpack tag ++ " { " + ++ concatMap (\(v, inf) -> show (smType inf) ++ " " ++ T.unpack v ++ "; ") (M.toList m) + ++ "}" show (CTIncomplete t) = show t show CTUndef = "undefined" @@ -327,6 +336,10 @@ instance Ord i => CType (TypeKind i) where | M.null m = 1 | otherwise = let sn = maximumBy (flip (.) smOffset . compare . smOffset) $ M.elems m in toNatural $ alignas (toInteger $ smOffset sn + sizeof (smType sn)) (toInteger $ alignof t) + sizeof t@(CTNamedStruct _ m) + | M.null m = 1 + | otherwise = let sn = maximumBy (flip (.) smOffset . compare . smOffset) $ M.elems m in + toNatural $ alignas (toInteger $ smOffset sn + sizeof (smType sn)) (toInteger $ alignof t) sizeof CTUndef = 0 sizeof (CTIncomplete _) = 0 sizeof _ = error "sizeof: sould not reach here" @@ -352,16 +365,19 @@ instance Ord i => CType (TypeKind i) where alignof (CTStruct m) | M.null m = 1 | otherwise = maximum $ map (alignof . smType) $ M.elems m + alignof (CTNamedStruct _ m) + | M.null m = 1 + | otherwise = maximum $ map (alignof . smType) $ M.elems m alignof CTUndef = 0 alignof _ = error "alignof: sould not reach here" deref (CTPtr x) = Just x deref ct@(CTArray _ _) = Just $ f ct where - f (CTArray n c@(CTArray _ _)) = CTArray n (f c) - f (CTArray _ t) = t - f t = t - deref (CTIncomplete (IncompleteArray (CTArray _ _))) = Nothing + f (CTArray _ t@(CTIncomplete (IncompleteArray _))) = t + f (CTArray n c@(CTArray _ _)) = CTArray n (f c) + f (CTArray _ t) = t + f t = t deref (CTIncomplete (IncompleteArray t)) = Just t deref _ = Nothing @@ -378,8 +394,11 @@ instance Ord i => CType (TypeKind i) where removeAllExtents x = x conversion l r - | l == r = l - | otherwise = max l r + | l' == r' = l' + | otherwise = max l' r' + where + l' = integerPromotedTypeKind l + r' = integerPromotedTypeKind r {-# INLINE implicitInt #-} implicitInt (CTLong x) = CTLong $ implicitInt x @@ -405,8 +424,9 @@ instance TypeKindBase TypeKind where isIntegral _ = False {-# INLINE isCTStruct #-} - isCTStruct (CTStruct _) = True - isCTStruct _ = False + isCTStruct (CTStruct _) = True + isCTStruct (CTNamedStruct _ _) = True + isCTStruct _ = False {-# INLINE isCTUndef #-} isCTUndef CTUndef = True @@ -466,5 +486,218 @@ alignas !n !aval = pred (n + aval) .&. complement (pred aval) -- | `lookupMember` search the specified member by its name from `CTStruct`. lookupMember :: T.Text -> TypeKind i -> Maybe (StructMember i) -lookupMember t (CTStruct m) = M.lookup t m -lookupMember _ _ = Nothing +lookupMember t (CTStruct m) = M.lookup t m +lookupMember t (CTNamedStruct _ m) = M.lookup t m +lookupMember _ _ = Nothing + +typeKindStructurallyEqual :: Eq i => TypeKind i -> TypeKind i -> Bool +typeKindStructurallyEqual CTInt CTInt = True +typeKindStructurallyEqual CTChar CTChar = True +typeKindStructurallyEqual CTBool CTBool = True +typeKindStructurallyEqual CTVoid CTVoid = True +typeKindStructurallyEqual CTUndef CTUndef = True +typeKindStructurallyEqual (CTFunc lhsRet lhsParams) (CTFunc rhsRet rhsParams) = + typeKindStructurallyEqual lhsRet rhsRet + && functionParamTypesStructurallyEqual lhsParams rhsParams +typeKindStructurallyEqual (CTEnum lhsTy lhsMembers) (CTEnum rhsTy rhsMembers) = + typeKindStructurallyEqual lhsTy rhsTy && lhsMembers == rhsMembers +typeKindStructurallyEqual (CTArray lhsLen lhsTy) (CTArray rhsLen rhsTy) = + lhsLen == rhsLen && typeKindStructurallyEqual lhsTy rhsTy +typeKindStructurallyEqual (CTStruct lhsMembers) (CTStruct rhsMembers) = + structMembersStructurallyEqual lhsMembers rhsMembers +typeKindStructurallyEqual (CTNamedStruct lhsTag lhsMembers) (CTNamedStruct rhsTag rhsMembers) = + lhsTag == rhsTag && structMembersStructurallyEqual lhsMembers rhsMembers +typeKindStructurallyEqual (CTPtr lhsTy) (CTPtr rhsTy) = + typeKindStructurallyEqual lhsTy rhsTy +typeKindStructurallyEqual (CTIncomplete lhs) (CTIncomplete rhs) = + incompleteTypesStructurallyEqual lhs rhs +typeKindStructurallyEqual lhs rhs + | isQualifier lhs || isQualifier rhs = maybe' False (combTable lhs) $ \lh -> + maybe' False (combTable rhs) $ \rh -> lh == rh + | otherwise = False + +functionParamTypesStructurallyEqual :: Eq i => [(TypeKind i, Maybe T.Text)] -> [(TypeKind i, Maybe T.Text)] -> Bool +functionParamTypesStructurallyEqual lhs rhs = + length lhs == length rhs + && and (zipWith (typeKindStructurallyEqual `on` fst) lhs rhs) + where + on f g x y = f (g x) (g y) + +structMembersStructurallyEqual + :: Eq i + => M.Map T.Text (StructMember i) + -> M.Map T.Text (StructMember i) + -> Bool +structMembersStructurallyEqual lhs rhs + | M.keysSet lhs /= M.keysSet rhs = False + | otherwise = + all + (\(name, lhsMember) -> maybe False (structMemberStructurallyEqual lhsMember) $ M.lookup name rhs) + (M.toList lhs) + +structMemberStructurallyEqual :: Eq i => StructMember i -> StructMember i -> Bool +structMemberStructurallyEqual lhs rhs = + smOffset lhs == smOffset rhs + && typeKindStructurallyEqual (smType lhs) (smType rhs) + +incompleteTypesStructurallyEqual :: Eq i => Incomplete i -> Incomplete i -> Bool +incompleteTypesStructurallyEqual (IncompleteArray lhsTy) (IncompleteArray rhsTy) = + typeKindStructurallyEqual lhsTy rhsTy +incompleteTypesStructurallyEqual (IncompleteStruct lhsTag) (IncompleteStruct rhsTag) = + lhsTag == rhsTag +incompleteTypesStructurallyEqual _ _ = False + +mergeCompatibleTypeKinds :: Eq i => TypeKind i -> TypeKind i -> Maybe (TypeKind i) +mergeCompatibleTypeKinds = mergeCompatibleTypeKinds' True + +mergeCompatibleTypeKinds' :: Eq i => Bool -> TypeKind i -> TypeKind i -> Maybe (TypeKind i) +mergeCompatibleTypeKinds' _ lhs rhs + | typeKindStructurallyEqual lhs rhs = Just rhs + | equivalentSignedIntegerSynonym lhs rhs = Just rhs +mergeCompatibleTypeKinds' _ (CTSigned lhs) (CTSigned rhs) = + CTSigned <$> mergeCompatibleTypeKinds' False lhs rhs +mergeCompatibleTypeKinds' _ (CTShort lhs) (CTShort rhs) = + CTShort <$> mergeCompatibleTypeKinds' False lhs rhs +mergeCompatibleTypeKinds' _ (CTLong lhs) (CTLong rhs) = + CTLong <$> mergeCompatibleTypeKinds' False lhs rhs +mergeCompatibleTypeKinds' _ (CTPtr lhs) (CTPtr rhs) = + CTPtr <$> mergeCompatibleTypeKinds' False lhs rhs +mergeCompatibleTypeKinds' allowExtentInference lhs@(CTArray _ _) rhs@(CTArray _ _) = + mergeTentativeArrayTypeKinds' allowExtentInference lhs rhs +mergeCompatibleTypeKinds' _ (CTFunc lhsRet lhsParams) (CTFunc rhsRet rhsParams) = do + retTy <- mergeCompatibleTypeKinds' False lhsRet rhsRet + params <- mergeCompatibleFunctionParamLists lhsParams rhsParams + pure $ CTFunc retTy params +mergeCompatibleTypeKinds' allowExtentInference lhs@(CTIncomplete (IncompleteArray _)) rhs@(CTIncomplete (IncompleteArray _)) = + mergeTentativeArrayTypeKinds' allowExtentInference lhs rhs +mergeCompatibleTypeKinds' _ (CTIncomplete (IncompleteStruct lhsTag)) (CTIncomplete (IncompleteStruct rhsTag)) + | lhsTag == rhsTag = + Just $ CTIncomplete $ IncompleteStruct lhsTag +mergeCompatibleTypeKinds' _ (CTIncomplete (IncompleteStruct lhsTag)) rhs@(CTNamedStruct rhsTag _) + | lhsTag == rhsTag = + Just rhs +mergeCompatibleTypeKinds' _ lhs@(CTNamedStruct lhsTag _) (CTIncomplete (IncompleteStruct rhsTag)) + | lhsTag == rhsTag = + Just lhs +mergeCompatibleTypeKinds' _ (CTEnum lhsTy lhsMembers) (CTEnum rhsTy rhsMembers) + | lhsMembers == rhsMembers = + CTEnum <$> mergeCompatibleTypeKinds' False lhsTy rhsTy <*> pure lhsMembers +mergeCompatibleTypeKinds' _ (CTStruct lhsMembers) (CTStruct rhsMembers) = + CTStruct <$> mergeCompatibleStructMembers lhsMembers rhsMembers +mergeCompatibleTypeKinds' _ (CTNamedStruct lhsTag lhsMembers) (CTNamedStruct rhsTag rhsMembers) + | lhsTag == rhsTag = + CTNamedStruct lhsTag <$> mergeCompatibleStructMembers lhsMembers rhsMembers +mergeCompatibleTypeKinds' allowExtentInference lhs rhs = + mergeTentativeArrayTypeKinds' allowExtentInference lhs rhs + +equivalentSignedIntegerSynonym :: Eq i => TypeKind i -> TypeKind i -> Bool +equivalentSignedIntegerSynonym lhs rhs = case (canonicalSignedIntegerType lhs, canonicalSignedIntegerType rhs) of + (Just lhsTy, Just rhsTy) -> lhsTy == rhsTy + _ -> False + +canonicalSignedIntegerType :: TypeKind i -> Maybe (TypeKind i) +canonicalSignedIntegerType CTInt = Just CTInt +canonicalSignedIntegerType CTUndef = Just CTInt +canonicalSignedIntegerType (CTSigned x) = canonicalSignedIntegerType x +canonicalSignedIntegerType (CTShort x) = CTShort <$> canonicalSignedIntegerType x +canonicalSignedIntegerType (CTLong x) = CTLong <$> canonicalSignedIntegerType x +canonicalSignedIntegerType _ = Nothing + +mergeCompatibleStructMembers + :: Eq i + => M.Map T.Text (StructMember i) + -> M.Map T.Text (StructMember i) + -> Maybe (M.Map T.Text (StructMember i)) +mergeCompatibleStructMembers lhsMembers rhsMembers + | M.keysSet lhsMembers /= M.keysSet rhsMembers = Nothing + | otherwise = M.traverseWithKey mergeMember lhsMembers + where + mergeMember name lhsMember = do + rhsMember <- M.lookup name rhsMembers + if smOffset lhsMember /= smOffset rhsMember + then Nothing + else + (\mergedTy -> rhsMember { smType = mergedTy }) + <$> mergeCompatibleTypeKinds' False (smType lhsMember) (smType rhsMember) + +-- | Merge array types for tentative declarations. +-- Only the outermost missing extent may be inferred; all inner extents and rank +-- must already match exactly. +mergeTentativeArrayTypeKinds :: Eq i => TypeKind i -> TypeKind i -> Maybe (TypeKind i) +mergeTentativeArrayTypeKinds lhs rhs + | typeKindStructurallyEqual lhs rhs = Just rhs + | equivalentSignedIntegerSynonym lhs rhs = Just rhs + | otherwise = mergeTentativeArrayTypeKinds' True lhs rhs + +mergeTentativeArrayTypeKinds' :: Eq i => Bool -> TypeKind i -> TypeKind i -> Maybe (TypeKind i) +mergeTentativeArrayTypeKinds' allowExtentInference (CTArray lhsLen lhsInner) (CTArray rhsLen rhsInner) + | lhsLen == rhsLen = + CTArray lhsLen <$> mergeCompatibleTypeKinds' allowExtentInference lhsInner rhsInner +mergeTentativeArrayTypeKinds' allowExtentInference (CTIncomplete (IncompleteArray lhsElemTy)) (CTIncomplete (IncompleteArray rhsElemTy)) = + CTIncomplete . IncompleteArray <$> mergeCompatibleTypeKinds' allowExtentInference lhsElemTy rhsElemTy +mergeTentativeArrayTypeKinds' True (CTIncomplete (IncompleteArray lhsElemTy)) (CTArray rhsLen rhsInnerTy) = + CTArray rhsLen <$> mergeCompatibleTypeKinds' False lhsElemTy rhsInnerTy +mergeTentativeArrayTypeKinds' True (CTArray lhsLen lhsInnerTy) (CTIncomplete (IncompleteArray rhsElemTy)) = + CTArray lhsLen <$> mergeCompatibleTypeKinds' False lhsInnerTy rhsElemTy +mergeTentativeArrayTypeKinds' _ _ _ = Nothing + +mergeCompatibleFunctionParamLists :: Eq i => [(TypeKind i, Maybe T.Text)] -> [(TypeKind i, Maybe T.Text)] -> Maybe [(TypeKind i, Maybe T.Text)] +mergeCompatibleFunctionParamLists lhsParams rhsParams + | isUnspecifiedParamList lhsParams + && oldStyleCompatibleWithPrototype rhsParamKinds = + Just rhsParams + | isUnspecifiedParamList rhsParams + && oldStyleCompatibleWithPrototype lhsParamKinds = + Just lhsParams + | length lhsParamKinds == length rhsParamKinds = + mapM mergeCompatibleFunctionParam $ zip lhsParams rhsParams + | otherwise = Nothing + where + lhsParamKinds = normalizedFunctionParamKinds lhsParams + rhsParamKinds = normalizedFunctionParamKinds rhsParams + + isUnspecifiedParamList [] = True + isUnspecifiedParamList _ = False + + oldStyleCompatibleWithPrototype = + all (maybe False (const True) . (\ty -> mergeCompatibleTypeKinds ty $ defaultPromotedFunctionParamType ty)) + mergeCompatibleFunctionParam ((lhsTy, lhsName), (rhsTy, rhsName)) = + (\mergedTy -> (mergedTy, rhsName <|> lhsName)) + <$> ( mergeCompatibleTypeKinds lhsTy rhsTy + <|> mergeCompatibleTypeKinds + (canonicalizeFunctionParamType lhsTy) + (canonicalizeFunctionParamType rhsTy) + ) + +normalizedFunctionParamKinds :: [(TypeKind i, Maybe T.Text)] -> [TypeKind i] +normalizedFunctionParamKinds [(CTVoid, Nothing)] = [] +normalizedFunctionParamKinds params = + map (canonicalizeFunctionParamType . fst) params + +canonicalizeFunctionParamType :: TypeKind i -> TypeKind i +canonicalizeFunctionParamType (CTArray _ elemTy) = CTPtr elemTy +canonicalizeFunctionParamType (CTIncomplete (IncompleteArray elemTy)) = CTPtr elemTy +canonicalizeFunctionParamType (CTFunc retTy params) = CTPtr (CTFunc retTy params) +canonicalizeFunctionParamType ty = ty + +defaultPromotedFunctionParamType :: TypeKind i -> TypeKind i +defaultPromotedFunctionParamType = integerPromotedTypeKind + +integerPromotedTypeKind :: TypeKind i -> TypeKind i +integerPromotedTypeKind = \case + CTChar -> CTInt + CTBool -> CTInt + CTEnum _ _ -> CTInt + CTShort _ -> CTInt + CTSigned ty + | isPromotableQualifiedType ty -> CTInt + | otherwise -> CTSigned ty + ty -> ty + +isPromotableQualifiedType :: TypeKind i -> Bool +isPromotableQualifiedType = \case + CTChar -> True + CTBool -> True + CTEnum _ _ -> True + CTShort _ -> True + _ -> False diff --git a/src/Htcc/Output.hs b/src/Htcc/Output.hs new file mode 100644 index 0000000..36c349e --- /dev/null +++ b/src/Htcc/Output.hs @@ -0,0 +1,340 @@ +module Htcc.Output ( + ReplacementOutputMode (..), + creationMaskedOutputMode, + replaceExistingOutputFromPathWith, + stagedOutputMode, + temporaryWritableMode, + withReplacementOutputPath, +) where + +import Control.Exception (SomeException, catch, displayException, + finally, throwIO) +import Control.Monad (when) +import Data.Bits (complement) +import qualified Data.ByteString as B +import System.Directory (getTemporaryDirectory, makeAbsolute, + removeDirectory, removeFile, renameFile) +import System.FilePath (isRelative, normalise, takeDirectory, + takeFileName, ()) +import System.IO (IOMode (ReadMode, WriteMode), hClose, + openTempFile, withBinaryFile) +import System.IO.Error (catchIOError, isDoesNotExistError, + isPermissionError) +import System.Posix.Files (fileMode, getFileStatus, + getSymbolicLinkStatus, groupExecuteMode, + groupReadMode, groupWriteMode, + intersectFileModes, isRegularFile, + isSymbolicLink, linkCount, + otherExecuteMode, otherReadMode, + otherWriteMode, ownerExecuteMode, + ownerReadMode, ownerWriteMode, + readSymbolicLink, setFileMode, + setGroupIDMode, setUserIDMode, + unionFileModes) +import System.Posix.IO (closeFd, createFile) +import System.Posix.Temp (mkdtemp) +import System.Posix.Types (FileMode) + +data ReplacementOutputMode + = PreserveReplacementOutputMode + | PreserveReplacementOutputModeKeepingExecutableBits + +ignoreIOException :: IO () -> IO () +ignoreIOException = flip catchIOError $ const $ pure () + +defaultOutputFileMode :: FileMode +defaultOutputFileMode = foldr1 unionFileModes + [ ownerReadMode + , ownerWriteMode + , groupReadMode + , groupWriteMode + , otherReadMode + , otherWriteMode + ] + +temporaryWritableMode :: FileMode +temporaryWritableMode = ownerReadMode `unionFileModes` ownerWriteMode + +creationMaskedOutputMode :: IO FileMode +creationMaskedOutputMode = do + tmpDir <- getTemporaryDirectory + probeDir <- mkdtemp (tmpDir "htcc-output-modeXXXXXX") + let probePath = probeDir "mask-probe" + cleanup = + ignoreIOException (removeFile probePath) + *> ignoreIOException (removeDirectory probeDir) + finally + ( do + probeFd <- createFile probePath defaultOutputFileMode + finally + ( do + probeMode <- fileMode <$> getFileStatus probePath + pure $ intersectFileModes probeMode defaultOutputFileMode + ) + (closeFd probeFd) + ) + cleanup + +resolveReplacementOutputPath :: FilePath -> IO FilePath +resolveReplacementOutputPath = go [] + where + go seen path = do + pathKey <- normalise <$> makeAbsolute path + when (pathKey `elem` seen) $ + ioError . userError $ "cyclic symbolic output path: " <> path + maybeStatus <- catchIOError + (Just <$> getSymbolicLinkStatus path) + (\ioErr -> if isDoesNotExistError ioErr then pure Nothing else ioError ioErr) + case maybeStatus of + Just status | isSymbolicLink status -> do + target <- readSymbolicLink path + let nextPath = normalise $ + if isRelative target + then takeDirectory path target + else target + go (pathKey : seen) nextPath + _ -> pure path + +existingOutputMode :: FilePath -> IO (Maybe FileMode) +existingOutputMode path = catchIOError + (Just . fileMode <$> getFileStatus path) + (\ioErr -> if isDoesNotExistError ioErr then pure Nothing else ioError ioErr) + +shouldReplaceOutputPath :: FilePath -> IO Bool +shouldReplaceOutputPath path = catchIOError + (isRegularFile <$> getFileStatus path) + (\ioErr -> if isDoesNotExistError ioErr then pure True else ioError ioErr) + +executableFileMode :: FileMode +executableFileMode = foldr1 unionFileModes + [ ownerExecuteMode + , groupExecuteMode + , otherExecuteMode + ] + +specialFileMode :: FileMode +specialFileMode = foldr1 unionFileModes + [ setUserIDMode + , setGroupIDMode + , 0o1000 + ] + +clearSpecialFileMode :: FileMode -> FileMode +clearSpecialFileMode mode = + intersectFileModes mode $ complement specialFileMode + +preservedExecuteMode :: FileMode -> FileMode +preservedExecuteMode mode = + intersectFileModes mode executableFileMode + +minimalRunnableExecuteMode :: FileMode -> FileMode +minimalRunnableExecuteMode mode + | preservedExecuteMode mode /= 0 = ownerExecuteMode + | otherwise = 0 + +replacementExecutableMode :: FileMode -> FileMode -> FileMode +replacementExecutableMode existingMode currentMode = + preservedExecuteMode existingMode + `unionFileModes` minimalRunnableExecuteMode replacementMode + where + replacementMode = existingMode `unionFileModes` currentMode + +stagedOutputMode :: ReplacementOutputMode -> FileMode -> FileMode +stagedOutputMode PreserveReplacementOutputMode _ = + temporaryWritableMode +stagedOutputMode PreserveReplacementOutputModeKeepingExecutableBits baseMode = + temporaryWritableMode `unionFileModes` stagedExecuteMode + where + stagedExecuteMode + | existingExecuteMode /= 0 = existingExecuteMode + | otherwise = ownerExecuteMode + existingExecuteMode = preservedExecuteMode baseMode + +updatedOutputMode :: ReplacementOutputMode -> FileMode -> FileMode -> FileMode +updatedOutputMode PreserveReplacementOutputMode existingMode _ = + clearSpecialFileMode existingMode +updatedOutputMode PreserveReplacementOutputModeKeepingExecutableBits existingMode currentMode = + clearSpecialFileMode existingMode + `unionFileModes` replacementExecutableMode existingMode currentMode + +freshOutputMode :: ReplacementOutputMode -> FileMode -> FileMode -> FileMode +freshOutputMode PreserveReplacementOutputMode baseMode _ = + clearSpecialFileMode baseMode +freshOutputMode PreserveReplacementOutputModeKeepingExecutableBits baseMode currentMode = + clearSpecialFileMode baseMode + `unionFileModes` preservedExecuteMode currentMode + `unionFileModes` minimalRunnableExecuteMode currentMode + +copyFileContents :: FilePath -> FilePath -> IO () +copyFileContents src dst = + withBinaryFile src ReadMode $ \srcHandle -> + withBinaryFile dst WriteMode $ \dstHandle -> + let go = do + chunk <- B.hGetSome srcHandle 32768 + if B.null chunk + then pure () + else B.hPut dstHandle chunk *> go + in go + +withReadableSource :: FilePath -> FileMode -> IO a -> IO a +withReadableSource path originalMode action + | intersectFileModes originalMode ownerReadMode /= 0 = action + | otherwise = do + setFileMode path readableMode + action `finally` setFileMode path originalMode + where + readableMode = originalMode `unionFileModes` ownerReadMode + +withWritableDestination :: FilePath -> FileMode -> IO a -> IO a +withWritableDestination path originalMode action + | intersectFileModes originalMode ownerWriteMode /= 0 = action + | otherwise = do + setFileMode path writableMode + action `finally` setFileMode path originalMode + where + writableMode = originalMode `unionFileModes` ownerWriteMode + +copyExistingOutputToBackup :: FilePath -> FileMode -> FilePath -> IO () +copyExistingOutputToBackup resolvedOutputPath baseMode backupPath = + copyFileContents resolvedOutputPath backupPath `catchIOError` \ioErr -> + if isPermissionError ioErr + then withReadableSource resolvedOutputPath baseMode $ + copyFileContents resolvedOutputPath backupPath + else ioError ioErr + +ensureInPlaceReplacementSafe :: FilePath -> IO () +ensureInPlaceReplacementSafe resolvedOutputPath = do + existingLinkCount <- linkCount <$> getFileStatus resolvedOutputPath + when (existingLinkCount > 1) $ + ioError . userError $ + "refusing to replace hard-linked output in place: " <> resolvedOutputPath + +replaceExistingOutputFromPathWith + :: (FilePath -> FilePath -> IO ()) + -> ReplacementOutputMode + -> FilePath + -> FileMode + -> FileMode + -> FilePath + -> IO () +replaceExistingOutputFromPathWith copyReplacementOutput modeStrategy resolvedOutputPath baseMode currentMode stagedOutputPath = do + ensureInPlaceReplacementSafe resolvedOutputPath + tmpDir <- getTemporaryDirectory + let backupTemplate = takeFileName resolvedOutputPath <> ".htcc-backup-" + (backupPath, backupHandle) <- openTempFile tmpDir backupTemplate + hClose backupHandle + let restoreOutput = do + withWritableDestination resolvedOutputPath baseMode $ + copyFileContents backupPath resolvedOutputPath + setFileMode resolvedOutputPath baseMode + cleanupBackup = + ignoreIOException (hClose backupHandle) + *> ignoreIOException (removeFile backupPath) + replaceOutput = do + withWritableDestination resolvedOutputPath baseMode $ + withReadableSource stagedOutputPath currentMode $ + copyReplacementOutput stagedOutputPath resolvedOutputPath + setFileMode resolvedOutputPath $ + updatedOutputMode modeStrategy baseMode currentMode + handleFailure :: SomeException -> IO () + handleFailure exc = do + restoreOutput `catch` rethrowWithRestoreFailure exc + throwIO exc + rethrowWithRestoreFailure :: SomeException -> SomeException -> IO () + rethrowWithRestoreFailure replacementExc restoreExc = + ioError . userError $ + "failed to restore original output after replacement failure (" + <> displayException replacementExc + <> "): " + <> displayException restoreExc + finally + ( do + copyExistingOutputToBackup resolvedOutputPath baseMode backupPath + replaceOutput `catch` handleFailure + ) + cleanupBackup + +replaceExistingOutputFromPath :: ReplacementOutputMode -> FilePath -> FileMode -> FileMode -> FilePath -> IO () +replaceExistingOutputFromPath = + replaceExistingOutputFromPathWith copyFileContents + +withDirectReplacementOutputPath :: ReplacementOutputMode -> FilePath -> FileMode -> (FilePath -> IO a) -> IO a +withDirectReplacementOutputPath modeStrategy resolvedOutputPath baseMode action = do + tmpDir <- getTemporaryDirectory + let outputTemplate = takeFileName resolvedOutputPath <> ".htcc-" + (tmpOutputPath, tmpOutputHandle) <- openTempFile tmpDir outputTemplate + finally + ( do + setFileMode tmpOutputPath $ stagedOutputMode modeStrategy baseMode + hClose tmpOutputHandle + result <- action tmpOutputPath + currentMode <- fileMode <$> getFileStatus tmpOutputPath + replaceExistingOutputFromPath modeStrategy resolvedOutputPath baseMode currentMode tmpOutputPath + pure result + ) + ( ignoreIOException (hClose tmpOutputHandle) + *> ignoreIOException (removeFile tmpOutputPath) + ) + +withFreshOutputPath :: ReplacementOutputMode -> FilePath -> (FilePath -> IO a) -> IO a +withFreshOutputPath modeStrategy resolvedOutputPath action = do + let outputDir = takeDirectory resolvedOutputPath + outputBaseName = takeFileName resolvedOutputPath + outputDirTemplate = outputBaseName <> ".htcc-XXXXXX" + tmpOutputDir <- mkdtemp (outputDir outputDirTemplate) + let tmpOutputPath = tmpOutputDir outputBaseName + cleanup = + ignoreIOException (removeFile tmpOutputPath) + *> ignoreIOException (removeDirectory tmpOutputDir) + finally + ( do + tmpOutputFd <- createFile tmpOutputPath defaultOutputFileMode + closeFd tmpOutputFd + baseMode <- intersectFileModes defaultOutputFileMode . fileMode <$> getFileStatus tmpOutputPath + setFileMode tmpOutputPath $ stagedOutputMode modeStrategy baseMode + result <- action tmpOutputPath + currentMode <- fileMode <$> getFileStatus tmpOutputPath + setFileMode tmpOutputPath $ freshOutputMode modeStrategy baseMode currentMode + renameFile tmpOutputPath resolvedOutputPath + pure result + ) + cleanup + +withReplacementOutputPath :: ReplacementOutputMode -> FilePath -> (FilePath -> IO a) -> IO a +withReplacementOutputPath modeStrategy outputPath action = do + resolvedOutputPath <- resolveReplacementOutputPath outputPath + shouldReplace <- shouldReplaceOutputPath resolvedOutputPath + if shouldReplace + then do + existingMode <- existingOutputMode resolvedOutputPath + case existingMode of + Nothing -> + withFreshOutputPath modeStrategy resolvedOutputPath action + Just baseMode -> do + let outputDir = takeDirectory resolvedOutputPath + outputTemplate = takeFileName resolvedOutputPath <> ".htcc-" + fallbackToDirect ioErr + | isPermissionError ioErr = + withDirectReplacementOutputPath modeStrategy resolvedOutputPath baseMode action + | otherwise = + ioError ioErr + catchIOError + ( do + (tmpOutputPath, tmpOutputHandle) <- openTempFile outputDir outputTemplate + finally + ( do + setFileMode tmpOutputPath $ stagedOutputMode modeStrategy baseMode + hClose tmpOutputHandle + result <- action tmpOutputPath + currentMode <- fileMode <$> getFileStatus tmpOutputPath + setFileMode tmpOutputPath $ + updatedOutputMode modeStrategy baseMode currentMode + renameFile tmpOutputPath resolvedOutputPath + pure result + ) + ( ignoreIOException (hClose tmpOutputHandle) + *> ignoreIOException (removeFile tmpOutputPath) + ) + ) + fallbackToDirect + else action resolvedOutputPath diff --git a/src/Htcc/Parser/AST/Core.hs b/src/Htcc/Parser/AST/Core.hs index 2a82661..5e48e7e 100644 --- a/src/Htcc/Parser/AST/Core.hs +++ b/src/Htcc/Parser/AST/Core.hs @@ -49,7 +49,7 @@ data ATKindFor a = ATForkw -- ^ The @for@ keyword | ATForCond (ATree a) -- ^ The conditional section of @for@ statement | ATForIncr (ATree a) -- ^ The incremental section of @for@ statement | ATForStmt (ATree a) -- ^ The statement section of @for@ statement - deriving Show + deriving (Eq, Show) {-# INLINE isATForInit #-} -- | An utility of `ATForInit`. When an argument is `ATForInit`, return `True` otherwise `False` @@ -130,6 +130,8 @@ data ATKind a = ATAdd -- ^ \(x+y\): @x + y@ | ATConditional (ATree a) (ATree a) (ATree a) -- ^ conditional operator: @a ? x : y;@. It has three AST (cond, then and else) | ATComma -- ^ comma operator: @x,b@ | ATCast -- ^ the cast operation: @(type) x@ + | ATSizeof -- ^ the @sizeof@ operator for expression operands. + | ATAlignof -- ^ the @_Alignof@ operator for expression operands. | ATMemberAcc (CT.StructMember a) -- ^ accessing the member of the @struct@ | ATReturn -- ^ the @return@ keyword | ATIf -- ^ the @if@ keyword @@ -147,12 +149,13 @@ data ATKind a = ATAdd -- ^ \(x+y\): @x + y@ | ATLVar (CT.StorageClass a) a -- ^ the local variable. It has a type information (as `CT.StorageClass`) and an offset value | ATGVar (CT.StorageClass a) T.Text -- ^ the global variable. It has a type information (as `CT.StorageClass`) and an name | ATDefFunc T.Text (Maybe [ATree a]) -- ^ the function definition - | ATCallFunc T.Text (Maybe [ATree a]) -- ^ the function call. It has a offset value and arguments (`Maybe`) - | ATFuncPtr -- ^ the function pointer. + | ATCallFunc T.Text (Maybe [ATree a]) -- ^ the direct function call. It has the target function name and arguments (`Maybe`) + | ATCallPtr (Maybe [ATree a]) -- ^ the indirect function call. The callee expression is stored in the lhs of `ATNode`. + | ATFuncPtr T.Text -- ^ the function designator / pointer. It has the target function name. | ATExprStmt -- ^ the expression of a statement | ATStmtExpr [ATree a] -- ^ the statement of a expression (GNU extension) | ATNull (ATree a) -- ^ indicates nothing to do - deriving Show + deriving (Eq, Show) {-# INLINE fromATVar #-} -- | Take its type when it is ATIVar or ATIVar. @@ -193,7 +196,7 @@ data ATree a = ATEmpty -- ^ The empty node atL :: ATree a, -- ^ The left hand side abstract tree atR :: ATree a -- ^ The right hand side abstract tree } -- ^ `ATKind` representing the kind of node and the two branches `ATree` it has - deriving Show + deriving (Eq, Show) -- | A class whose type can be converted to ATree class Treealizable a where diff --git a/src/Htcc/Parser/AST/Type.hs b/src/Htcc/Parser/AST/Type.hs index da81377..e5149d7 100644 --- a/src/Htcc/Parser/AST/Type.hs +++ b/src/Htcc/Parser/AST/Type.hs @@ -17,13 +17,14 @@ module Htcc.Parser.AST.Type ( ASTState ) where -import Htcc.Parser.AST.Core (ATree (..)) -import {-# SOURCE #-} Htcc.Parser.ConstructionData.Core (ConstructionData, - Warnings) -import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) -import qualified Htcc.Parser.ConstructionData.Scope.Var as PV -import qualified Htcc.Tokenizer as HT -import Htcc.Utils.CompilationState (CompilationState) +import Htcc.Parser.AST.Core (ATree (..)) +import {-# SOURCE #-} Htcc.Parser.ConstructionData.Core (ConstructionData, + Warnings) +import qualified Htcc.Parser.ConstructionData.Scope.Function as PF +import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) +import qualified Htcc.Parser.ConstructionData.Scope.Var as PV +import qualified Htcc.Tokenizer as HT +import Htcc.Utils.CompilationState (CompilationState) -- | The type to be used when the AST construction is successful type ASTSuccess i = ([HT.TokenLC i], ATree i, ConstructionData i) @@ -34,8 +35,9 @@ type ASTConstruction i = Either (ASTError i) (ASTSuccess i) -- | The type of AST list type ASTs i = [ATree i] --- | A type that represents the result after AST construction. Quadraple of warning list, constructed abstract syntax tree list, global variable map, literal list. -type ASTResult i = Either (ASTError i) (Warnings, ASTs i, PV.GlobalVars i, PV.Literals i) +-- | A type that represents the result after AST construction. Quintuple of warning list, +-- constructed abstract syntax tree list, global variable map, literal list, and function map. +type ASTResult i = Either (ASTError i) (Warnings, ASTs i, PV.GlobalVars i, PV.Literals i, PF.Functions i) -- | The type synonym of ASTState type ASTState i r = CompilationState (ConstructionData i) [HT.TokenLC i] i r diff --git a/src/Htcc/Parser/Combinators/ConstExpr.hs b/src/Htcc/Parser/Combinators/ConstExpr.hs index ec02030..c008e70 100644 --- a/src/Htcc/Parser/Combinators/ConstExpr.hs +++ b/src/Htcc/Parser/Combinators/ConstExpr.hs @@ -13,12 +13,13 @@ C language parser Combinators module Htcc.Parser.Combinators.ConstExpr ( evalConstexpr ) where -import Data.Bits (Bits (..)) -import Data.Bool (bool) -import Htcc.Parser.AST.Core (ATKind (..), - ATree (..)) -import Htcc.Parser.Combinators.Core -import {-# SOURCE #-} Htcc.Parser.Combinators.Program (conditional) +import Data.Bits (Bits (..)) +import Data.Bool (bool) +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATKind (..), + ATree (..)) +import Htcc.Parser.Combinators.Core +import {-# SOURCE #-} Htcc.Parser.Combinators.Program (conditional) evalConstexpr :: (Bits i, Integral i, Show i, Read i) => Parser i i evalConstexpr = conditional >>= constantExp' @@ -30,7 +31,8 @@ evalConstexpr = conditional >>= constantExp' ATAdd -> binop (+) ATSub -> binop (-) ATMul -> binop (*) - ATDiv -> binop div + ATDiv -> nonZeroBinop quot + ATMod -> nonZeroBinop rem ATAnd -> binop (.&.) ATXor -> binop xor ATOr -> binop (.|.) @@ -43,16 +45,38 @@ evalConstexpr = conditional >>= constantExp' ATLEQ -> binop ((.) fromBool . (<=)) ATGEQ -> binop ((.) fromBool . (>=)) ATConditional cn th el -> constantExp' cn - >>= bool (constantExp' el) (constantExp' th) . toBool - ATComma -> constantExp' rhs + >>= bool (constantExp' el) (constantExp' trueExpr) . toBool + where + trueExpr = case th of + ATEmpty -> cn + _ -> th + ATComma -> fail "The expression is not constant-expression" ATNot -> fromIntegral . fromEnum . not . toBool <$> constantExp' lhs ATBitNot -> complement <$> constantExp' lhs - ATLAnd -> binop ((.) fromBool . flip (.) toBool . (&&) . toBool) - ATLOr -> binop ((.) fromBool . flip (.) toBool . (||) . toBool) + ATLAnd -> constantExp' lhs >>= logicalAnd + ATLOr -> constantExp' lhs >>= logicalOr + ATSizeof -> memOp "sizeof" CT.sizeof lhs + ATAlignof -> memOp "_Alignof" CT.alignof lhs ATNum v -> pure v _ -> fail "The expression is not constant-expression" where binop f = constantExp' lhs >>= \lhs' -> fromIntegral . f lhs' <$> constantExp' rhs + logicalAnd lhs' + | not (toBool lhs') = pure $ fromBool False + | otherwise = fromBool . toBool <$> constantExp' rhs + logicalOr lhs' + | toBool lhs' = pure $ fromBool True + | otherwise = fromBool . toBool <$> constantExp' rhs + nonZeroBinop f = + constantExp' lhs >>= \lhs' -> + constantExp' rhs >>= \rhs' -> + if rhs' == 0 + then fail "The expression is not constant-expression" + else pure $ fromIntegral $ f lhs' rhs' + memOp opName op expr + | CT.isCTIncomplete (atype expr) = + fail $ "invalid application of '" <> opName <> "' to incomplete type" + | otherwise = + pure $ fromIntegral $ op $ atype expr constantExp' ATEmpty = fail "The expression is not constant-expression" - diff --git a/src/Htcc/Parser/Combinators/Decl/Declarator.hs b/src/Htcc/Parser/Combinators/Decl/Declarator.hs index c0e7c34..136c433 100644 --- a/src/Htcc/Parser/Combinators/Decl/Declarator.hs +++ b/src/Htcc/Parser/Combinators/Decl/Declarator.hs @@ -47,7 +47,24 @@ declarator ty = do ] where nested' ptrf ident t = - M.option (id, ident, ptrf t) ((id, ident,) . ptrf <$> typeSuffix t) + M.option + (id, ident, rebuildTy $ ptrf baseTy) + ((id, ident,) . rebuildTy . ptrf <$> typeSuffix baseTy) + where + (baseTyKind, rebuildTyKind) = dctorDirectSuffix $ CT.toTypeKind t + baseTy = CT.mapTypeKind (const baseTyKind) t + rebuildTy ty''' = CT.mapTypeKind (const $ rebuildTyKind $ CT.toTypeKind ty''') t + + dctorDirectSuffix (CT.CTArray n ty''') = + let (baseTyKind, rebuildTyKind) = dctorDirectSuffix ty''' + in (baseTyKind, CT.CTArray n . rebuildTyKind) + dctorDirectSuffix (CT.CTIncomplete (CT.IncompleteArray ty''')) = + let (baseTyKind, rebuildTyKind) = dctorDirectSuffix ty''' + in (baseTyKind, CT.CTIncomplete . CT.IncompleteArray . rebuildTyKind) + dctorDirectSuffix (CT.CTFunc retTy params) = + let (baseTyKind, rebuildTyKind) = dctorDirectSuffix retTy + in (baseTyKind, (`CT.CTFunc` params) . rebuildTyKind) + dctorDirectSuffix ty''' = (ty''', id) absDeclarator :: (Integral i, Show i, Read i, Bits i) => Parser i (CT.StorageClass i) absDeclarator = do diff --git a/src/Htcc/Parser/Combinators/GNUExtensions.hs b/src/Htcc/Parser/Combinators/GNUExtensions.hs index 320d617..8f39776 100644 --- a/src/Htcc/Parser/Combinators/GNUExtensions.hs +++ b/src/Htcc/Parser/Combinators/GNUExtensions.hs @@ -15,23 +15,31 @@ module Htcc.Parser.Combinators.GNUExtensions ( , stmtExpr ) where -import Data.Bits (Bits) -import Htcc.Parser.AST.Core (ATKind (..), ATree (..), - atConditional, atNoLeaf) -import Htcc.Parser.Combinators.Core -import {-# SOURCE #-} Htcc.Parser.Combinators.Program (compoundStmt, - conditional) -import qualified Text.Megaparsec as M +import Data.Bits (Bits) +import Htcc.Parser.AST.Core (ATKind (..), + ATree (..), + atConditional, + atNoLeaf) +import Htcc.Parser.Combinators.Core +import {-# SOURCE #-} Htcc.Parser.Combinators.Program (compoundStmt, + conditional) +import Htcc.Parser.Combinators.Utils (conditionalResultType, + decayExprType, + maybeToParser) +import qualified Text.Megaparsec as M -- Conditionals with Omitted Operands, see also: https://gcc.gnu.org/onlinedocs/gcc/Conditionals.html condOmitted :: (Ord i, Bits i, Read i, Show i, Integral i) => ATree i -> Parser i (ATree i) -condOmitted nd = M.try (symbol "?" *> symbol ":") *> ((atConditional (atype nd) nd ATEmpty) <$> conditional) +condOmitted nd = M.try (symbol "?" *> symbol ":") *> do + el <- conditional + ty <- maybeToParser "invalid operands" $ conditionalResultType nd el + pure $ atConditional ty nd ATEmpty el -- Statements and Declarations in Expressions, see also: https://gcc.gnu.org/onlinedocs/gcc/Statement-Exprs.html stmtExpr :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) stmtExpr = do k <- parens compoundStmt if null k then fail "void value not ignored as it ought to be" else case last k of - (ATNode ATExprStmt _ n _) -> pure $ atNoLeaf (ATStmtExpr $ init k <> [n]) (atype n) + (ATNode ATExprStmt _ n _) -> pure $ atNoLeaf (ATStmtExpr $ init k <> [n]) (decayExprType $ atype n) _ -> fail "void value not ignored as it ought to be" diff --git a/src/Htcc/Parser/Combinators/ParserType.hs b/src/Htcc/Parser/Combinators/ParserType.hs index 0bb7e7f..00c9a12 100644 --- a/src/Htcc/Parser/Combinators/ParserType.hs +++ b/src/Htcc/Parser/Combinators/ParserType.hs @@ -12,19 +12,22 @@ C language parser type {-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, TupleSections #-} module Htcc.Parser.Combinators.ParserType ( runParser + , runParserAllowSameInputExternalCollisions , ConstructionDataState , Parser ) where -import Control.Monad.Trans.State.Lazy (StateT, runStateT) -import Data.Functor.Identity -import qualified Data.Text as T -import Data.Void -import Htcc.Parser.AST.Type (ASTs) -import {-# SOURCE #-} Htcc.Parser.ConstructionData.Core -import qualified Htcc.Parser.ConstructionData.Scope as PS -import qualified Htcc.Parser.ConstructionData.Scope.Var as PSV -import qualified Text.Megaparsec as M +import Control.Monad.Trans.State.Lazy (StateT, + runStateT) +import Data.Functor.Identity +import qualified Data.Text as T +import Data.Void +import Htcc.Parser.AST.Type (ASTs) +import {-# SOURCE #-} Htcc.Parser.ConstructionData.Core +import qualified Htcc.Parser.ConstructionData.Scope as PS +import qualified Htcc.Parser.ConstructionData.Scope.Function as PF +import qualified Htcc.Parser.ConstructionData.Scope.Var as PSV +import qualified Text.Megaparsec as M type ConstructionDataState i = StateT (ConstructionData i) Identity type Parser i = M.ParsecT Void T.Text (ConstructionDataState i) @@ -33,10 +36,33 @@ runParser :: Parser i (ASTs i) -> FilePath -> T.Text - -> Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs i, PSV.GlobalVars i, PSV.Literals i) -runParser p fp input = - (warns (snd result),, PSV.globals $ PS.vars $ scope $ snd result, PSV.literals $ PS.vars $ scope $ snd result) + -> Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs i, PSV.GlobalVars i, PSV.Literals i, PF.Functions i) +runParser = runParserWithMode False + +runParserAllowSameInputExternalCollisions :: + Parser i (ASTs i) + -> FilePath + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs i, PSV.GlobalVars i, PSV.Literals i, PF.Functions i) +runParserAllowSameInputExternalCollisions = runParserWithMode True + +runParserWithMode :: + Bool + -> Parser i (ASTs i) + -> FilePath + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs i, PSV.GlobalVars i, PSV.Literals i, PF.Functions i) +runParserWithMode allowSameInputExternalCollisions p fp input = + ( warns (snd result) + ,, + PSV.globals (PS.vars $ scope $ snd result) + , PSV.literals (PS.vars $ scope $ snd result) + , PS.functions $ scope $ snd result + ) <$> fst result where - result = runIdentity $ runStateT (M.runParserT p fp input) initConstructionData - + result = + runIdentity $ + runStateT + (M.runParserT p fp input) + (ConstructionData mempty PS.initScope False allowSameInputExternalCollisions) diff --git a/src/Htcc/Parser/Combinators/ParserType.hs-boot b/src/Htcc/Parser/Combinators/ParserType.hs-boot index a7ddb22..bb734f9 100644 --- a/src/Htcc/Parser/Combinators/ParserType.hs-boot +++ b/src/Htcc/Parser/Combinators/ParserType.hs-boot @@ -1,15 +1,16 @@ {-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, TupleSections #-} module Htcc.Parser.Combinators.ParserType where -import Control.Monad.Trans.State.Lazy (StateT (..)) -import Data.Functor.Identity -import qualified Data.Text as T -import Data.Void -import Htcc.Parser.AST.Type (ASTs) -import {-# SOURCE #-} Htcc.Parser.ConstructionData.Core (ConstructionData, - Warnings) -import qualified Htcc.Parser.ConstructionData.Scope.Var as PSV -import qualified Text.Megaparsec as M +import Control.Monad.Trans.State.Lazy (StateT (..)) +import Data.Functor.Identity +import qualified Data.Text as T +import Data.Void +import Htcc.Parser.AST.Type (ASTs) +import {-# SOURCE #-} Htcc.Parser.ConstructionData.Core (ConstructionData, + Warnings) +import qualified Htcc.Parser.ConstructionData.Scope.Function as PF +import qualified Htcc.Parser.ConstructionData.Scope.Var as PSV +import qualified Text.Megaparsec as M type ConstructionDataState i = StateT (ConstructionData i) Identity type Parser i = M.ParsecT Void T.Text (ConstructionDataState i) @@ -18,4 +19,10 @@ runParser :: Parser i (ASTs i) -> FilePath -> T.Text - -> Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs i, PSV.GlobalVars i, PSV.Literals i) + -> Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs i, PSV.GlobalVars i, PSV.Literals i, PF.Functions i) + +runParserAllowSameInputExternalCollisions :: + Parser i (ASTs i) + -> FilePath + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs i, PSV.GlobalVars i, PSV.Literals i, PF.Functions i) diff --git a/src/Htcc/Parser/Combinators/Program.hs b/src/Htcc/Parser/Combinators/Program.hs index 7bcc807..7dcdb6e 100644 --- a/src/Htcc/Parser/Combinators/Program.hs +++ b/src/Htcc/Parser/Combinators/Program.hs @@ -12,8 +12,11 @@ C language Program parser {-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings, TupleSections #-} module Htcc.Parser.Combinators.Program ( parser + , assign , conditional , compoundStmt + , convertCallArgs + , foldGlobalInitWith ) where import Control.Monad (void, when, (>=>)) @@ -23,13 +26,19 @@ import Control.Monad.State (get, gets, modify) import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Bits (Bits) +import Data.Bits (Bits, bit, + complement, + shiftL, shiftR, + xor, (.&.), (.|.)) import Data.Char (ord) import Data.Functor ((<&>)) -import Data.List (find) -import Data.Maybe (fromJust, isJust) +import Data.List (find, sortBy) +import Data.Maybe (fromJust, + fromMaybe, isJust) +import Data.Ord (comparing) import qualified Data.Text as T -import Data.Tuple.Extra (dupe, first) +import Data.Tuple.Extra (dupe, first, + second) import qualified Htcc.CRules.Types as CT import Htcc.Parser.AST (Treealizable (..), addKind, @@ -59,12 +68,19 @@ import Htcc.Parser.AST.Type (ASTs) import Htcc.Parser.Combinators.BasicOperator import Htcc.Parser.Combinators.ConstExpr (evalConstexpr) import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Decl (absDeclarator, declarator, declspec) +import Htcc.Parser.Combinators.Decl (absDeclarator, + declarator, + declspec) import qualified Htcc.Parser.Combinators.GNUExtensions as GNU import Htcc.Parser.Combinators.Keywords import Htcc.Parser.Combinators.Type (toNamedParams) import Htcc.Parser.Combinators.Utils (bracket, + conditionalResultType, + decayExprType, getPosState, + isInvalidFunctionPointerInitializer, + isInvalidFunctionPointerValue, + isInvalidObjectPointerValue, maybeToParser, registerFunc, registerGVar, @@ -76,6 +92,8 @@ import Htcc.Parser.ConstructionData.Core (fallBack, incomplete, isSwitchStmt, lookupFunction, + lookupGVar, + lookupLVar, lookupVar, pushWarn, resetLocal, @@ -83,18 +101,229 @@ import Htcc.Parser.ConstructionData.Core (fallBack, import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) import qualified Htcc.Parser.ConstructionData.Scope.Function as PSF import qualified Htcc.Parser.ConstructionData.Scope.Var as PV +import Numeric.Natural (Natural) import qualified Text.Megaparsec as M import qualified Text.Megaparsec.Char as MC import Text.Megaparsec.Debug (dbg) -parser, program :: (Integral i, Bits i, Read i, Show i) => Parser i (ASTs i) +parser, program :: (Ord i, Integral i, Bits i, Read i, Show i) => Parser i (ASTs i) parser = spaceConsumer *> program <* M.eof program = some global +requireCompleteObjectType + :: (Ord i, Bits i, Read i, Show i, Integral i) + => String + -> CT.StorageClass i + -> Parser i (CT.StorageClass i) +requireCompleteObjectType err ty = do + resolvedTy <- gets (incomplete ty) >>= maybeToParser err + if CT.isIncompleteArray resolvedTy + then fail err + else pure resolvedTy + +resolveDerefObjectType + :: (Ord i, Bits i, Read i, Show i, Integral i) + => String + -> CT.StorageClass i + -> Parser i (CT.StorageClass i) +resolveDerefObjectType err ty + | isTopLevelOmittedBoundArrayType ty = pure ty + | otherwise = gets (incomplete ty) >>= maybeToParser err + +decayIncompleteArrayExpr :: Ord i => ATree i -> ATree i +decayIncompleteArrayExpr expr + | isTopLevelOmittedBoundArrayType (atype expr) = atCast (decayExprType $ atype expr) expr + | otherwise = expr + +isTopLevelOmittedBoundArrayType :: CT.StorageClass i -> Bool +isTopLevelOmittedBoundArrayType ty = case CT.toTypeKind ty of + CT.CTIncomplete (CT.IncompleteArray _) -> True + _ -> False + +isValidTentativeFileScopeArrayType :: CT.StorageClass i -> Bool +isValidTentativeFileScopeArrayType = go . CT.toTypeKind + where + go = \case + CT.CTArray _ innerTy -> + go innerTy + CT.CTIncomplete (CT.IncompleteArray elemTy) -> + isCompleteArrayElementType elemTy + _ -> + False + + isCompleteArrayElementType = \case + CT.CTIncomplete _ -> False + CT.CTArray _ innerTy -> isCompleteArrayElementType innerTy + _ -> True + +derefObjectType :: Ord i => CT.StorageClass i -> Maybe (CT.StorageClass i) +derefObjectType ty = case CT.toTypeKind ty of + CT.CTArray n (CT.CTIncomplete (CT.IncompleteArray elemTy)) -> + Just $ CT.mapTypeKind (const $ CT.CTArray n elemTy) ty + _ -> + CT.deref ty + +callableSignature :: CT.StorageClass i -> Maybe (CT.StorageClass i, Maybe [CT.StorageClass i]) +callableSignature ty = case CT.toTypeKind ty of + CT.CTFunc retTy params -> + Just (CT.SCAuto retTy, explicitFunctionParamTypes params) + CT.CTPtr (CT.CTFunc retTy params) -> + Just (CT.SCAuto retTy, explicitFunctionParamTypes params) + _ -> + Nothing + +explicitFunctionParamTypes :: [(CT.TypeKind i, Maybe T.Text)] -> Maybe [CT.StorageClass i] +explicitFunctionParamTypes [] = Nothing +explicitFunctionParamTypes [(CT.CTVoid, Nothing)] = Just [] +explicitFunctionParamTypes params = + Just $ map (CT.SCAuto . canonicalizeFunctionParamType . fst) params + +canonicalizeFunctionParamType :: CT.TypeKind i -> CT.TypeKind i +canonicalizeFunctionParamType (CT.CTArray _ elemTy) = CT.CTPtr elemTy +canonicalizeFunctionParamType (CT.CTIncomplete (CT.IncompleteArray elemTy)) = CT.CTPtr elemTy +canonicalizeFunctionParamType (CT.CTFunc retTy params) = CT.CTPtr $ CT.CTFunc retTy params +canonicalizeFunctionParamType ty = ty + +applyCallArgConversions :: (Ord i, Bits i, Integral i) => Maybe [CT.StorageClass i] -> [ATree i] -> Parser i [ATree i] +applyCallArgConversions paramTys args = + either fail pure $ convertCallArgs paramTys args + +convertCallArgs :: (Ord i, Bits i, Integral i) => Maybe [CT.StorageClass i] -> [ATree i] -> Either String [ATree i] +convertCallArgs Nothing args = Right $ map defaultPromotedCallArg args +convertCallArgs (Just paramTys) args + | actualArgCount < expectedArgCount = Left "too few arguments to function call" + | actualArgCount > expectedArgCount = Left "too many arguments to function call" + | otherwise = sequence $ zipWith convertTypedCallArg paramTys args + where + actualArgCount = length args + expectedArgCount = length paramTys + + convertTypedCallArg paramTy arg + | isInvalidFunctionPointerValue paramTy arg + || isInvalidObjectPointerValue paramTy arg = + Left "invalid argument type to function call" + | otherwise = + Right $ atCast paramTy arg + +defaultPromotedCallArg :: Ord i => ATree i -> ATree i +defaultPromotedCallArg = castExprType defaultPromotedCallArgType + +defaultPromotedCallArgType :: Ord i => CT.StorageClass i -> CT.StorageClass i +defaultPromotedCallArgType ty = CT.mapTypeKind (const promotedTy) decayedTy + where + decayedTy = decayExprType ty + promotedTy = CT.integerPromotedTypeKind $ CT.toTypeKind decayedTy + +integerPromotedExpr :: Eq i => ATree i -> ATree i +integerPromotedExpr = castExprType integerPromotedExprType + +integerPromotedExprType :: CT.StorageClass i -> CT.StorageClass i +integerPromotedExprType ty = CT.mapTypeKind (const promotedTy) ty + where + promotedTy = CT.integerPromotedTypeKind $ CT.toTypeKind ty + +castExprType :: Eq i => (CT.StorageClass i -> CT.StorageClass i) -> ATree i -> ATree i +castExprType f expr + | promotedTy == atype expr = expr + | otherwise = atCast promotedTy expr + where + promotedTy = f $ atype expr + +isFunctionType :: CT.StorageClass i -> Bool +isFunctionType ty = case CT.toTypeKind ty of + CT.CTFunc _ _ -> True + _ -> False + +requireNonFunctionOperand + :: String + -> ATree i + -> Parser i (ATree i) +requireNonFunctionOperand opName expr + | isFunctionType (atype expr) = fail $ "invalid application of '" <> opName <> "' to function type" + | otherwise = pure expr + +requirePointerArithmeticTarget + :: (Ord i, Bits i, Read i, Show i, Integral i) + => ATree i + -> Parser i () +requirePointerArithmeticTarget expr = case CT.deref (atype expr) of + Just ty + | isFunctionType ty -> + fail "invalid operands" + | otherwise -> + void $ requireCompleteObjectType "invalid use of pointer to incomplete type" ty + Nothing -> + pure () + +requirePointerArithmeticTargetAllowDeferred + :: (Ord i, Bits i, Read i, Show i, Integral i) + => ATree i + -> Parser i () +requirePointerArithmeticTargetAllowDeferred expr = case CT.deref (atype expr) of + Just ty + | isFunctionType ty -> + requirePointerArithmeticTarget expr + | CT.isCTIncomplete ty && isDeferredIncompletePointerArithmeticExpr expr -> + pure () + | otherwise -> + requirePointerArithmeticTarget expr + Nothing -> + requirePointerArithmeticTarget expr + +isDeferredIncompleteObjectExpr :: ATree i -> Bool +isDeferredIncompleteObjectExpr = \case + ATNode (ATLVar _ _) ty _ _ -> + not $ isTopLevelOmittedBoundArrayType ty + ATNode (ATGVar _ _) ty _ _ -> + not $ isTopLevelOmittedBoundArrayType ty + ATNode (ATMemberAcc _) ty _ _ -> + not $ isTopLevelOmittedBoundArrayType ty + _ -> + True + +isDeferredIncompletePointerArithmeticExpr :: ATree i -> Bool +isDeferredIncompletePointerArithmeticExpr = \case + ATNode ATAddr _ _ _ -> False + _ -> True + +resolveMemOperandType + :: (Ord i, Bits i, Read i, Show i, Integral i) + => String + -> ATree i + -> Parser i (CT.StorageClass i) +resolveMemOperandType err expr = do + resolvedTy <- gets (incomplete $ atype expr) + case resolvedTy of + Just ty + | CT.isIncompleteArray ty -> + if isDeferredIncompleteObjectExpr expr then pure (atype expr) else fail err + | otherwise -> + pure ty + Nothing -> + if isDeferredIncompleteObjectExpr expr then pure (atype expr) else fail err + +isModifiableLvalueExpr :: ATree i -> Bool +isModifiableLvalueExpr (ATNode kind ty _ _) + | CT.isCTArray ty = False + | isFunctionType ty = False + | otherwise = case kind of + ATLVar _ _ -> True + ATGVar _ _ -> True + ATMemberAcc _ -> True + ATDeref -> True + _ -> False +isModifiableLvalueExpr _ = False + +requireModifiableLvalue + :: String + -> ATree i + -> Parser i (ATree i) +requireModifiableLvalue err expr + | isModifiableLvalueExpr expr = pure expr + | otherwise = fail err + global, - function, - gvar, stmt, expr, assign, @@ -113,26 +342,41 @@ global, unary, factor :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i (ATree i) -global = choice - [ M.try function - , gvar - ] - -function = do +global = do pos <- getPosState - declspec >>= declarator >>= \case - (_, Nothing) -> fail "function name omitted, expected unqualified-id" - (ty@(CT.SCAuto (CT.CTFunc _ _)), Just ident) -> modify resetLocal - *> choice - [ declaration ty ident - , definition ty ident pos - ] - _ -> fail "expected function" -- TODO: currentry, ignore storage class + rejectInvalidFileScopeStorageClass + ty <- declspec + choice + [ ATEmpty <$ semi + , globalDecl ty pos + ] where - declaration ty ident = ATEmpty <$ (semi *> registerFunc False ty ident) + rejectInvalidFileScopeStorageClass = + M.lookAhead $ + choice + [ kAuto *> fail "storage-class specifier is not allowed at file scope" + , kRegister *> fail "storage-class specifier is not allowed at file scope" + , pure () + ] + + globalDecl ty pos = declarator ty >>= \case + (_, Nothing) -> fail "variable name omitted, expected unqualified-id" + (ty', Just ident) + | isFunctionType ty' -> modify resetLocal + *> choice + [ declaration ty' ident + , definition ty' ident pos + ] + (ty', Just ident) -> gvarDecl ty' ident + + isFunctionType ty' = case CT.toTypeKind ty' of + CT.CTFunc _ _ -> True + _ -> False + + declaration ty ident = ATEmpty <$ (semi *> registerFunc False False ty ident) definition ty ident pos = do - registerFunc True ty ident + registerFunc True False ty ident params <- mapM (uncurry registerLVar) =<< toNamedParams ty stmt >>= fromValidFunc params where @@ -153,54 +397,514 @@ function = do , T.unpack ident , "' is " , show (CT.toTypeKind ty) - , ", but the statement returns no value" - ] + , ", but the statement returns no value" + ] pure $ atDefFunc ident (if null params' then Nothing else Just params') ty st fromValidFunc _ _ = fail "internal compiler error" -gvar = do - ty <- declspec - M.choice - [ ATEmpty <$ semi - , declGVar ty - ] - where - declGVar ty = declarator ty >>= \case - (_, Nothing) -> fail "variable name omitted, expected unqualified-id" - (ty', Just ident) -> choice - [ nonInit ty' ident - , withInit ty' ident - ] - - nonInit ty ident = semi - >> gets (incomplete ty) - >>= maybeToParser "defining global variables with a incomplete type" - >>= flip registerGVar ident - >> pure ATEmpty + gvarDecl ty ident = choice + [ nonInit ty ident + , withInit ty ident + ] + nonInit ty ident + | CT.isIncompleteArray ty && isValidTentativeFileScopeArrayType ty = + semi *> registerGVar ty ident *> pure ATEmpty + | CT.isIncompleteArray ty = + fail "defining global variables with a incomplete type" + | otherwise = + semi + >> gets (incomplete ty) + >>= maybeToParser "defining global variables with a incomplete type" + >>= flip registerGVar ident + >> pure ATEmpty withInit ty ident = do void equal - ty' <- maybeToParser "defining global variables with a incomplete type" =<< gets (incomplete ty) - gvarInit ty' ident <* semi + (ty', initWith) <- parseGlobalVarInit ty ident + registerGVarWith ty' ident initWith <* semi - gvarInit ty ident = choice - [ M.try fromConstant - , fromOG - ] +parseGlobalVarInit :: (Ord i, Bits i, Read i, Show i, Integral i) + => CT.StorageClass i + -> T.Text + -> Parser i (CT.StorageClass i, PV.GVarInitWith i) +parseGlobalVarInit ty ident = + bracket get (modify . fallBack) $ const $ do + ensureTargetGlobalVisible ty ident + let tempIdent = ".L.global.init." <> ident + ast <- varInit assign ty tempIdent + rejectIncompleteGlobalSelfReference ty ident ast + ty' <- maybeToParser "defining global variables with a incomplete type" + =<< gets (fmap PV.lvtype . lookupLVar tempIdent) + void $ either fail pure $ foldGlobalInitWith ty' ast + pure (ty', PV.GVarInitWithAST ast) + where + ensureTargetGlobalVisible declaredTy name = + void $ registerGVar declaredTy name + + rejectIncompleteGlobalSelfReference declaredTy name ast + | CT.isIncompleteArray declaredTy && containsGlobalRef name ast = + fail "invalid initializer in global variable" + | otherwise = + pure () + +containsGlobalRef :: T.Text -> ATree i -> Bool +containsGlobalRef name = go + where + go ATEmpty = False + go (ATNode kind _ lhs rhs) = + goKind kind || go lhs || go rhs + + goKind = \case + ATConditional cond tr fl -> + any go [cond, tr, fl] + ATSwitch cond cases -> + go cond || any go cases + ATFor kinds -> + any (go . fromATKindFor) kinds + ATBlock ats -> + any go ats + ATStmtExpr ats -> + any go ats + ATNull at -> + go at + ATDefFunc _ args -> + maybe False (any go) args + ATCallFunc _ args -> + maybe False (any go) args + ATCallPtr args -> + maybe False (any go) args + ATGVar _ ref -> + ref == name + _ -> + False + +foldGlobalInitWith :: (Integral i, Bits i, Read i, Show i, Ord i) + => CT.StorageClass i + -> ATree i + -> Either String (PV.GVarInitWith i) +foldGlobalInitWith ty ast = do + entries <- globalInitEntries ast + PV.GVarInitWithData <$> finalizeGlobalInitData (CT.sizeof ty) entries + +globalInitEntries :: (Integral i, Bits i, Read i, Show i, Ord i) + => ATree i + -> Either String [(Natural, PV.GVarInitData i)] +globalInitEntries ATEmpty = Right [] +globalInitEntries (ATNode (ATBlock stmts) _ _ _) = concat <$> mapM globalInitEntries stmts +globalInitEntries (ATNode ATExprStmt _ expr _) = globalInitEntries expr +globalInitEntries (ATNode ATAssign _ lhs rhs) = do + offset <- maybe (Left "invalid initializer in global variable") Right $ globalInitByteOffset lhs + dat <- globalInitDatum (atype lhs) rhs + Right [(offset, dat)] +globalInitEntries _ = Left "invalid initializer in global variable" + +globalInitDatum :: (Integral i, Bits i, Read i, Show i, Ord i) + => CT.StorageClass i + -> ATree i + -> Either String (PV.GVarInitData i) +globalInitDatum ty rhs + | rejectsIncompatibleScalarInitializer = + Left "invalid initializer for scalar object" + | otherwise = globalInitReloc ty rhs >>= \case + Just (ref, addend) + | isRelocInitializerType ty -> pure $ PV.GVarInitReloc size ref addend + | otherwise -> Left "invalid initializer for scalar object" + Nothing -> do + val <- evalGlobalInitConstexpr ty rhs + Right $ + if val == 0 + then PV.GVarInitZeroBytes size + else PV.GVarInitBytes size val + where + size = CT.sizeof ty + rejectsIncompatibleScalarInitializer = + isInvalidFunctionPointerInitializer ty rhs + || isInvalidObjectPointerValue ty rhs + isRelocInitializerType = \case + CT.SCAuto (CT.CTPtr _) -> True + CT.SCRegister (CT.CTPtr _) -> True + CT.SCStatic (CT.CTPtr _) -> True + _ -> False + isFunctionPointerType sc = case CT.toTypeKind sc of + CT.CTPtr (CT.CTFunc _ _) -> True + _ -> False + +globalInitReloc :: (Integral i, Bits i, Read i, Show i) + => CT.StorageClass i + -> ATree i + -> Either String (Maybe (T.Text, Integer)) +globalInitReloc targetTy = \case + ATNode ATCast ty inner _ + | isPointerType ty + && (not (isFunctionPointerType targetTy) || isFunctionPointerType ty) -> + globalInitReloc targetTy inner + | otherwise -> Right Nothing + ATNode (ATNull inner) _ _ _ -> + globalInitReloc targetTy inner + ATNode ATExprStmt _ inner _ -> + globalInitReloc targetTy inner + ATNode (ATConditional cond ATEmpty el) _ _ _ -> + globalInitConditionalReloc cond cond el + ATNode (ATConditional cond th el) _ _ _ -> + globalInitConditionalReloc cond th el + ATNode (ATFuncPtr name) _ _ _ + | isFunctionPointerType targetTy -> Right $ Just (name, 0) + | otherwise -> Right Nothing + ast@(ATNode (ATGVar ty _) _ _ _) + | CT.isArray ty -> globalInitLvalueReloc targetTy ast + ast@(ATNode ATDeref ty _ _) + | CT.isArray ty -> globalInitLvalueReloc targetTy ast + ast@(ATNode (ATMemberAcc mem) _ _ _) + | CT.isArray (CT.smType mem) -> globalInitLvalueReloc targetTy ast + ATNode ATAddr _ inner _ -> globalInitLvalueReloc targetTy inner + ATNode ATAddPtr _ lhs rhs -> globalInitRelocWithAddend (+) lhs rhs + ATNode ATSubPtr _ lhs rhs -> globalInitRelocWithAddend (-) lhs rhs + _ -> Right Nothing + where + isPointerType ty = case CT.toTypeKind ty of + CT.CTPtr _ -> True + _ -> False + + isFunctionPointerType ty = case CT.toTypeKind ty of + CT.CTPtr (CT.CTFunc _ _) -> True + _ -> False + + offsetFromIndex lhs idx = + fromIntegral idx * maybe 0 (fromIntegral . CT.sizeof) (CT.deref $ atype lhs) + + globalInitConditionalReloc cond th el = case evalGlobalInitConditionMaybe cond of + Just True -> globalInitReloc targetTy th + Just False -> + globalInitReloc targetTy el + Nothing -> + Right Nothing + + globalInitRelocWithAddend op lhs rhs = + globalInitReloc targetTy lhs >>= \case + Just (name, addend) -> + Right $ (\idx -> Just (name, op addend (offsetFromIndex lhs idx))) =<< evalConstexprMaybe rhs + Nothing -> Right Nothing + + evalConstexprMaybe expr = either (const Nothing) Just $ evalConstexprTree expr + +globalInitLvalueReloc :: (Integral i, Bits i, Read i, Show i) + => CT.StorageClass i + -> ATree i + -> Either String (Maybe (T.Text, Integer)) +globalInitLvalueReloc targetTy = \case + ATNode (ATFuncPtr name) _ _ _ + | isFunctionPointerType targetTy -> Right $ Just (name, 0) + | otherwise -> Right Nothing + ATNode (ATGVar _ name) _ _ _ + | isFunctionPointerType targetTy -> Right Nothing + | otherwise -> Right $ Just (name, 0) + ATNode (ATMemberAcc mem) _ lhs _ -> do + globalInitLvalueReloc targetTy lhs <&> fmap (second (+ fromIntegral (CT.smOffset mem))) + ATNode ATDeref _ ptr _ -> globalInitReloc targetTy ptr + ATNode ATCast _ lhs _ -> globalInitLvalueReloc targetTy lhs + _ -> Right Nothing + where + isFunctionPointerType ty = case CT.toTypeKind ty of + CT.CTPtr (CT.CTFunc _ _) -> True + _ -> False + +applyConstexprCast :: (Bits i, Integral i) => CT.StorageClass i -> i -> i +applyConstexprCast ty val + | CT.toTypeKind ty == CT.CTBool = fromIntegral $ fromEnum $ val /= 0 + | otherwise = truncateToWidth (CT.sizeof ty) val + where + truncateToWidth sz x + | sz == 0 = 0 + | otherwise = fromInteger $ signExtend width $ toInteger x where - fromConstant = evalConstexpr - >>= registerGVarWith ty ident . PV.GVarInitWithVal - - fromOG = do - ast <- conditional - case (atkind ast, atkind (atL ast)) of - (ATAddr, ATGVar _ name) -> registerGVarWith ty ident (PV.GVarInitWithOG name) - (ATAddr, _) -> fail "invalid initializer in global variable" - (ATGVar t name, _) - | CT.isCTArray t -> registerGVarWith ty ident (PV.GVarInitWithOG name) - -- TODO: support initializing from other global variables - | otherwise -> fail "initializer element is not constant" - _ -> fail "initializer element is not constant" + width = fromIntegral $ sz * 8 + + signExtend width x = + if width <= 0 + then 0 + else + let modulus = bit width :: Integer + mask = pred modulus + truncated = x .&. mask + signBit = bit (pred width) :: Integer + in + if truncated .&. signBit == 0 + then truncated + else truncated - modulus + +evalGlobalInitConstexpr :: (Bits i, Integral i, Show i, Read i) => CT.StorageClass i -> ATree i -> Either String i +evalGlobalInitConstexpr ty rhs = + case CT.toTypeKind ty of + CT.CTPtr _ -> evalPointerNullGlobalInit rhs + _ -> applyConstexprCast ty <$> evalConstexprTree rhs + where + evalPointerNullGlobalInit ast = + evalPointerNullConstexpr ast >>= rejectUnlessZero + + rejectUnlessZero val + | val == 0 = pure 0 + | otherwise = Left "initializer element is not constant" + +evalGlobalInitConditionMaybe :: (Bits i, Integral i, Show i, Read i) => ATree i -> Maybe Bool +evalGlobalInitConditionMaybe = either (const Nothing) Just . evalGlobalInitCondition + +evalGlobalInitCondition :: (Bits i, Integral i, Show i, Read i) => ATree i -> Either String Bool +evalGlobalInitCondition ast = + case either (const Nothing) (Just . (/= 0)) $ evalConstexprTree ast of + Just truthy -> + pure truthy + Nothing -> case evalPointerNullConstexpr ast of + Right 0 -> + pure False + _ -> + maybe (Left "initializer element is not constant") pure $ + evalGlobalInitAddressCondition ast + +evalGlobalInitAddressCondition :: (Bits i, Integral i, Show i, Read i) => ATree i -> Maybe Bool +evalGlobalInitAddressCondition = \case + ATNode ATCast ty inner _ + | isPointerType ty -> + evalGlobalInitAddressCondition inner + ATNode (ATNull inner) _ _ _ -> + evalGlobalInitAddressCondition inner + ATNode ATExprStmt _ inner _ -> + evalGlobalInitAddressCondition inner + ATNode (ATConditional cond ATEmpty el) _ _ _ -> + evalGlobalInitConditionMaybe cond >>= \case + True -> + pure True + False -> + evalGlobalInitConditionMaybe el + ATNode (ATConditional cond th el) _ _ _ -> + evalGlobalInitConditionMaybe cond >>= \case + True -> + evalGlobalInitConditionMaybe th + False -> + evalGlobalInitConditionMaybe el + ATNode (ATFuncPtr _) _ _ _ -> + Just True + ast@(ATNode (ATGVar ty _) _ _ _) + | CT.isArray ty -> + globalInitLvalueCondition ast + ast@(ATNode ATDeref ty _ _) + | CT.isArray ty -> + globalInitLvalueCondition ast + ast@(ATNode (ATMemberAcc mem) _ _ _) + | CT.isArray (CT.smType mem) -> + globalInitLvalueCondition ast + ATNode ATAddr _ inner _ -> + globalInitLvalueCondition inner + ATNode ATAddPtr _ lhs rhs -> + globalInitAddressAdditiveCondition lhs rhs + ATNode ATSubPtr _ lhs rhs -> + globalInitAddressAdditiveCondition lhs rhs + _ -> + Nothing + where + isPointerType ty = case CT.toTypeKind ty of + CT.CTPtr _ -> True + _ -> False + + globalInitAddressAdditiveCondition lhs rhs = + globalInitAddressConditionBase lhs >> evalConstexprMaybe rhs >> pure True + + globalInitAddressConditionBase = \case + ATNode ATCast ty inner _ + | isPointerType ty -> + globalInitAddressConditionBase inner + ATNode (ATNull inner) _ _ _ -> + globalInitAddressConditionBase inner + ATNode ATExprStmt _ inner _ -> + globalInitAddressConditionBase inner + ATNode (ATConditional cond ATEmpty el) _ _ _ -> + evalGlobalInitConditionMaybe cond >>= \case + True -> + globalInitAddressConditionBase cond + False -> + globalInitAddressConditionBase el + ATNode (ATConditional cond th el) _ _ _ -> + evalGlobalInitConditionMaybe cond >>= \case + True -> + globalInitAddressConditionBase th + False -> + globalInitAddressConditionBase el + ATNode (ATFuncPtr _) _ _ _ -> + Just () + ast@(ATNode (ATGVar ty _) _ _ _) + | CT.isArray ty -> + globalInitLvalueConditionBase ast + ast@(ATNode ATDeref ty _ _) + | CT.isArray ty -> + globalInitLvalueConditionBase ast + ast@(ATNode (ATMemberAcc mem) _ _ _) + | CT.isArray (CT.smType mem) -> + globalInitLvalueConditionBase ast + ATNode ATAddr _ inner _ -> + globalInitLvalueConditionBase inner + ATNode ATAddPtr _ lhs rhs -> + globalInitAddressConditionBase lhs >> evalConstexprMaybe rhs >> pure () + ATNode ATSubPtr _ lhs rhs -> + globalInitAddressConditionBase lhs >> evalConstexprMaybe rhs >> pure () + _ -> + Nothing + + globalInitLvalueCondition = fmap (const True) . globalInitLvalueConditionBase + + globalInitLvalueConditionBase = \case + ATNode (ATFuncPtr _) _ _ _ -> + Just () + ATNode (ATGVar _ _) _ _ _ -> + Just () + ATNode (ATMemberAcc _) _ lhs _ -> + globalInitLvalueConditionBase lhs + ATNode ATDeref _ ptr _ -> + globalInitAddressConditionBase ptr + ATNode ATCast _ lhs _ -> + globalInitLvalueConditionBase lhs + _ -> + Nothing + + evalConstexprMaybe expr = either (const Nothing) Just $ evalConstexprTree expr + +evalPointerNullConstexpr :: (Bits i, Integral i, Show i, Read i) => ATree i -> Either String i +evalPointerNullConstexpr (ATNode ATCast castTy inner _) + | isPointerStorageClass castTy = + applyConstexprCast castTy <$> evalPointerNullConstexpr inner +evalPointerNullConstexpr ast = + evalConstexprTree ast + +isPointerStorageClass :: CT.StorageClass i -> Bool +isPointerStorageClass ty = case CT.toTypeKind ty of + CT.CTPtr _ -> True + _ -> False + +evalConstexprTree :: (Bits i, Integral i, Show i, Read i) => ATree i -> Either String i +evalConstexprTree = \case + ATNode k ty lhs rhs -> case k of + ATAdd -> binop (+) + ATSub -> binop (-) + ATMul -> binop (*) + ATDiv -> nonZeroBinop quot + ATMod -> nonZeroBinop rem + ATAnd -> binop (.&.) + ATXor -> binop xor + ATOr -> binop (.|.) + ATShl -> binop ((\l r -> shiftL l (fromIntegral r))) + ATShr -> binop ((\l r -> shiftR l (fromIntegral r))) + ATEQ -> binop (fromBool .: (==)) + ATNEQ -> binop (fromBool .: (/=)) + ATLT -> binop (fromBool .: (<)) + ATGT -> binop (fromBool .: (>)) + ATLEQ -> binop (fromBool .: (<=)) + ATGEQ -> binop (fromBool .: (>=)) + ATConditional cn th el -> + evalGlobalInitCondition cn >>= \cond -> + if cond + then evalConstexprTree $ + case th of + ATEmpty -> cn + _ -> th + else evalConstexprTree el + ATNot -> fromBool . not <$> evalGlobalInitCondition lhs + ATBitNot -> complement <$> evalConstexprTree lhs + ATLAnd -> evalGlobalInitCondition lhs >>= logicalAnd + ATLOr -> evalGlobalInitCondition lhs >>= logicalOr + ATSizeof -> memOp "sizeof" CT.sizeof lhs + ATAlignof -> memOp "_Alignof" CT.alignof lhs + ATCast + | isConstexprArithmeticCastType ty -> applyConstexprCast ty <$> evalConstexprTree lhs + | otherwise -> Left "initializer element is not constant" + ATNum v -> pure v + _ -> Left "initializer element is not constant" + where + binop f = evalConstexprTree lhs >>= \lhs' -> f lhs' <$> evalConstexprTree rhs + logicalAnd lhs' + | not lhs' = pure $ fromBool False + | otherwise = fromBool <$> evalGlobalInitCondition rhs + logicalOr lhs' + | lhs' = pure $ fromBool True + | otherwise = fromBool <$> evalGlobalInitCondition rhs + nonZeroBinop f = + evalConstexprTree lhs >>= \lhs' -> + evalConstexprTree rhs >>= \rhs' -> + if rhs' == 0 + then Left "initializer element is not constant" + else pure (f lhs' rhs') + memOp opName op expr + | CT.isCTIncomplete (atype expr) = + Left $ "invalid application of '" <> opName <> "' to incomplete type" + | otherwise = + pure $ fromIntegral $ op $ atype expr + fromBool = fromIntegral . fromEnum + (.:) f g x y = f (g x y) + _ -> Left "initializer element is not constant" + +isConstexprArithmeticCastType :: CT.StorageClass i -> Bool +isConstexprArithmeticCastType = \case + CT.SCAuto ty -> go ty + CT.SCRegister ty -> go ty + CT.SCStatic ty -> go ty + CT.SCUndef ty -> go ty + where + go = \case + CT.CTInt -> True + CT.CTChar -> True + CT.CTBool -> True + CT.CTEnum _ _ -> True + CT.CTSigned CT.CTUndef -> True + CT.CTShort CT.CTUndef -> True + CT.CTLong CT.CTUndef -> True + CT.CTSigned ty -> go ty + CT.CTShort ty -> go ty + CT.CTLong ty -> go ty + _ -> False + +finalizeGlobalInitData :: Natural -> [(Natural, PV.GVarInitData i)] -> Either String [PV.GVarInitData i] +finalizeGlobalInitData totalBytes entries = mergeGlobalInitData <$> go 0 sorted + where + sorted = sortBy (comparing fst) entries + + go offset [] = + pure $ + if offset < totalBytes + then [PV.GVarInitZeroBytes $ totalBytes - offset] + else [] + go offset ((nextOffset, dat):rest) + | nextOffset < offset = Left "internal compiler error: overlapping global initializer" + | otherwise = do + suffix <- go (nextOffset + globalInitDataSize dat) rest + pure $ + zeroGap offset nextOffset <> [dat] <> suffix + + zeroGap cur nxt + | cur < nxt = [PV.GVarInitZeroBytes $ nxt - cur] + | otherwise = [] + +globalInitDataSize :: PV.GVarInitData i -> Natural +globalInitDataSize = \case + PV.GVarInitZeroBytes sz -> sz + PV.GVarInitBytes sz _ -> sz + PV.GVarInitReloc sz _ _ -> sz + +mergeGlobalInitData :: [PV.GVarInitData i] -> [PV.GVarInitData i] +mergeGlobalInitData = foldr step [] + where + step (PV.GVarInitZeroBytes sz) (PV.GVarInitZeroBytes sz' : rest) = + PV.GVarInitZeroBytes (sz + sz') : rest + step dat acc = dat : acc + +globalInitByteOffset :: Integral i => ATree i -> Maybe Natural +globalInitByteOffset = \case + ATNode (ATLVar _ _) _ _ _ -> Just 0 + ATNode (ATMemberAcc mem) _ lhs _ -> (+ CT.smOffset mem) <$> globalInitByteOffset lhs + ATNode ATDeref _ ptr _ -> globalInitByteOffset ptr + ATNode ATAddr _ lhs _ -> globalInitByteOffset lhs + ATNode ATCast _ lhs _ -> globalInitByteOffset lhs + ATNode ATAddPtr _ lhs (ATNode (ATNum idx) _ _ _) -> + (+ offsetFromIndex lhs idx) <$> globalInitByteOffset lhs + _ -> Nothing + where + offsetFromIndex lhs idx = fromIntegral idx * maybe 0 CT.sizeof (CT.deref $ atype lhs) compoundStmt :: (Ord i, Bits i, Read i, Show i, Integral i) => Parser i [ATree i] compoundStmt = bracket get (modify . fallBack) $ const $ @@ -296,7 +1000,12 @@ stmt = choice nonInit ty ident = semi *> registerLVar ty ident <&> atNull withInit ty ident = equal *> varInit assign ty ident <* semi -expr = assign +expr = assign >>= go + where + go lhs = M.option lhs $ do + void comma + rhs <- assign + go $ ATNode ATComma (decayExprType $ atype rhs) lhs rhs assign = do nd <- conditional @@ -313,15 +1022,38 @@ assign = do , assignOp (maybe ATSubAssign (const ATSubPtrAssign) $ CT.deref (atype nd)) "-=" ] where - assignOp k s nd = symbol s *> (ATNode k (atype nd) nd <$> assign) + assignOp k s nd = symbol s *> do + lhs <- requireModifiableLvalue "lvalue required as left operand of assignment" nd + requireCompletePointerArithmetic k lhs + rhs <- assign + requireCompatibleAssignmentOperands k lhs rhs + pure $ ATNode k (atype lhs) lhs rhs + + requireCompletePointerArithmetic kind expr = case kind of + ATAddPtrAssign -> + requirePointerArithmeticTargetAllowDeferred expr + ATSubPtrAssign -> + requirePointerArithmeticTargetAllowDeferred expr + _ -> + pure () + + requireCompatibleAssignmentOperands kind lhs rhs + | isInvalidFunctionPointerValue (atype lhs) rhs = + fail "invalid operands to assignment" + | kind == ATAssign && isInvalidObjectPointerValue (atype lhs) rhs = + fail "invalid operands to assignment" + | otherwise = + pure () conditional = do nd <- logicalOr ifM (M.option False (True <$ M.lookAhead question)) (GNU.condOmitted nd M.<|> condOp nd) $ pure nd where - condOp nd = uncurry (`atConditional` nd) . first atype . dupe - <$> (question *> expr <* colon) - <*> conditional + condOp nd = do + th <- question *> expr <* colon + el <- conditional + ty <- maybeToParser "invalid operands" $ conditionalResultType th el + pure $ atConditional ty nd th el logicalOr = binaryOperator logicalAnd [(symbol "||", binOpBool ATLOr)] @@ -351,9 +1083,24 @@ shift = binaryOperator add ] add = binaryOperator term - [ (symbol "+", \l r -> maybeToParser "invalid operands" $ addKind l r) - , (symbol "-", \l r -> maybeToParser "invalid operands" $ subKind l r) + [ (symbol "+", pointerAwareBinaryOp addKind) + , (symbol "-", pointerAwareBinaryOp subKind) ] + where + pointerAwareBinaryOp mk l r = do + node <- maybeToParser "invalid operands" $ mk (decayIncompleteArrayExpr l) (decayIncompleteArrayExpr r) + requireCompletePointerArithmeticNode node + pure node + + requireCompletePointerArithmeticNode = \case + ATNode ATAddPtr _ ptr _ -> + requirePointerArithmeticTargetAllowDeferred ptr + ATNode ATSubPtr _ ptr _ -> + requirePointerArithmeticTargetAllowDeferred ptr + ATNode ATPtrDis _ lhs rhs -> + requirePointerArithmeticTargetAllowDeferred lhs + >> requirePointerArithmeticTargetAllowDeferred rhs + _ -> pure () term = binaryOperator cast [ (star, binOpCon ATMul) @@ -367,46 +1114,75 @@ cast = choice ] unary = choice - [ symbol "++" *> unary <&> \n -> ATNode ATPreInc (atype n) n ATEmpty - , symbol "--" *> unary <&> \n -> ATNode ATPreDec (atype n) n ATEmpty - , symbol "+" *> unary - , symbol "-" *> unary <&> \n -> ATNode ATSub (atype n) (atNumLit 0) n + [ symbol "++" *> unary >>= requireModifiableLvalue "lvalue required as increment operand" <&> \n -> ATNode ATPreInc (atype n) n ATEmpty + , symbol "--" *> unary >>= requireModifiableLvalue "lvalue required as decrement operand" <&> \n -> ATNode ATPreDec (atype n) n ATEmpty + , symbol "+" *> unary >>= requireNonFunctionOperand "+" <&> integerPromotedExpr + , symbol "-" *> unary >>= requireNonFunctionOperand "-" <&> \n -> + let promoted = integerPromotedExpr n + in ATNode ATSub (atype promoted) (atNumLit 0) promoted , lnot *> unary <&> flip (ATNode ATNot (CT.SCAuto CT.CTBool)) ATEmpty - , tilda *> unary <&> flip (ATNode ATBitNot (CT.SCAuto CT.CTInt)) ATEmpty + , tilda *> unary >>= requireNonFunctionOperand "~" <&> \n -> + let promoted = integerPromotedExpr n + in ATNode ATBitNot (atype promoted) promoted ATEmpty , addr , star *> unary >>= deref' , factor' ] where addr = MC.char '&' `notFollowedOp` MC.char '&' >> unary <&> \n -> - let ty = if CT.isArray (atype n) then fromJust $ CT.deref $ atype n else atype n in - atUnary ATAddr (CT.mapTypeKind CT.CTPtr ty) n + atUnary ATAddr (CT.mapTypeKind CT.CTPtr $ atype n) n factor' = factor >>= allAcc where allAcc fac = M.option fac $ choice - [ idxAcc fac + [ callAcc fac + , idxAcc fac , postInc fac , postDec fac ] + callAcc fac = do + rawParams <- lparen *> M.manyTill (M.try (assign <* comma) M.<|> assign) rparen + (callTy, formalParamTys) <- maybe + (fail "called object is not a function or function pointer") + pure + (callableSignature $ atype fac) + params <- applyCallArgConversions formalParamTys rawParams + let + params' = if null params then Nothing else Just params + allAcc =<< case fac of + ATNode (ATFuncPtr name) _ _ _ -> + pure $ atNoLeaf (ATCallFunc name params') callTy + _ -> + pure $ ATNode (ATCallPtr params') callTy fac ATEmpty + idxAcc fac = do idx <- brackets expr - kt <- maybeToParser "invalid operands" (addKind fac idx) - ty <- maybeToParser "subscripted value is neither array nor pointer nor vector" $ CT.deref $ atype kt - ty' <- maybeToParser "incomplete value dereference" =<< gets (incomplete ty) + kt <- maybeToParser "invalid operands" (addKind (decayIncompleteArrayExpr fac) idx) + ty <- maybeToParser "subscripted value is neither array nor pointer nor vector" $ derefObjectType $ atype kt + ty' <- resolveDerefObjectType "incomplete value dereference" ty allAcc $ atUnary ATDeref ty' kt - postInc fac = allAcc =<< atUnary ATPostInc (atype fac) fac <$ symbol "++" - postDec fac = allAcc =<< atUnary ATPostDec (atype fac) fac <$ symbol "--" + postInc fac = do + _ <- symbol "++" + fac' <- requireModifiableLvalue "lvalue required as increment operand" fac + allAcc $ atUnary ATPostInc (atype fac') fac' + + postDec fac = do + _ <- symbol "--" + fac' <- requireModifiableLvalue "lvalue required as decrement operand" fac + allAcc $ atUnary ATPostDec (atype fac') fac' deref' = runMaybeT . deref'' >=> maybe M.empty pure where + deref'' n + | isFunctionType (atype n) = + pure n deref'' n = do - ty <- MaybeT $ pure (CT.deref $ atype n) + ty <- MaybeT $ pure (derefObjectType $ atype n) case CT.toTypeKind ty of CT.CTVoid -> lift $ fail "void value not ignored as it ought to be" - _ -> MaybeT (lift $ gets $ incomplete ty) + _ -> lift (resolveDerefObjectType "incomplete value dereference" ty) >>= lift . pure . flip (atUnary ATDeref) n factor = choice @@ -416,55 +1192,86 @@ factor = choice , alignof , strLiteral , identifier' - , M.try (parens expr) - , GNU.stmtExpr + , parensExprOrStmt , ATEmpty <$ M.eof ] where - memOp p op opS = p *> choice + parensExprOrStmt = do + isStmtExpr <- M.option False $ True <$ M.lookAhead (M.try (lparen *> lbrace)) + if isStmtExpr then GNU.stmtExpr else parens expr + + memOp p deferredKind op opS = p *> choice [ memOpType , memOpUnary ] where - memOpType = incomplete <$> M.try (parens absDeclarator) <*> get - >>= fmap (atNumLit . fromIntegral . op) - . maybeToParser ("invalid application of '" <> opS <> "' to incomplete type") + memOpType = M.try (parens absDeclarator) + >>= requireCompleteObjectType ("invalid application of '" <> opS <> "' to incomplete type") + >>= pure . atNumLit . fromIntegral . op memOpUnary = do - u <- unary + u <- unary >>= requireNonFunctionOperand opS if CT.isCTUndef (atype u) then fail $ opS <> " must be an expression or type" else - pure $ atNumLit $ fromIntegral $ op $ atype u + do + uTy <- resolveMemOperandType ("invalid application of '" <> opS <> "' to incomplete type") u + let u' = case u of + ATNode kind _ lhs rhs -> ATNode kind uTy lhs rhs + ATEmpty -> ATEmpty + pure $ atUnary deferredKind (CT.SCAuto $ CT.CTLong CT.CTInt) u' - sizeof = memOp kSizeof CT.sizeof "sizeof" - alignof = memOp k_Alignof CT.alignof "alignof" + sizeof = memOp kSizeof ATSizeof CT.sizeof "sizeof" + alignof = memOp k_Alignof ATAlignof CT.alignof "_Alignof" strLiteral = stringLiteral >>= registerStringLiteral identifier' = do pos <- getPosState ident <- identifier - choice - [ fnCall ident pos - , variable ident - ] + gets (lookupVar ident) >>= \case + FoundGVar gvar -> + let gvarNode = + atGVar + (PV.gvtype gvar) + ident + in if callableSignature (PV.gvtype gvar) == Nothing + then + M.option gvarNode $ + M.lookAhead lparen *> fnCall ident pos + else + pure gvarNode + FoundLVar sct -> + return $ treealize sct + FoundEnum sct -> + return $ treealize sct + FoundFunc sct -> + return $ atNoLeaf (ATFuncPtr ident) (PSF.fntype sct) + NotFound -> + M.try (fnCall ident pos) + M.<|> fail ("The '" <> T.unpack ident <> "' is not defined identifier") where - variable ident = - gets (lookupVar ident) - >>= \case - FoundGVar (PV.GVar t _) -> return $ atGVar t ident - FoundLVar sct -> return $ treealize sct - FoundEnum sct -> return $ treealize sct - FoundFunc sct -> return $ treealize sct - NotFound -> fail $ "The '" <> T.unpack ident <> "' is not defined identifier" - fnCall ident pos = do - params <- lparen *> M.manyTill (M.try (expr <* comma) M.<|> expr) rparen - let params' = if null params then Nothing else Just params + rawParams <- lparen *> M.manyTill (M.try (assign <* comma) M.<|> assign) rparen gets (lookupFunction ident) >>= \case -- TODO: set warning message -- TODO: Infer the return type of a function - Nothing -> atNoLeaf (ATCallFunc ident params') (CT.SCAuto CT.CTInt) - <$ pushWarn pos ("the function '" <> T.unpack ident <> "' is not declared.") - Just fn -> pure $ atNoLeaf (ATCallFunc ident params') (PSF.fntype fn) + Nothing -> + let params = map defaultPromotedCallArg rawParams + params' = if null params then Nothing else Just params + implicitFnTy = CT.SCAuto $ CT.CTFunc CT.CTInt [] + in do + shadowingGlobal <- isJust <$> gets (lookupGVar ident) + when (not shadowingGlobal) $ + registerFunc False True implicitFnTy ident + pushWarn pos ("the function '" <> T.unpack ident <> "' is not declared.") + pure $ atNoLeaf (ATCallFunc ident params') (CT.SCAuto CT.CTInt) + Just fn -> do + (callTy, formalParamTys) <- maybe + (fail "internal compiler error: function lookup returned non-callable type") + pure + (callableSignature $ PSF.fntype fn) + params <- applyCallArgConversions formalParamTys rawParams + let + params' = if null params then Nothing else Just params + pure $ atNoLeaf (ATCallFunc ident params') callTy diff --git a/src/Htcc/Parser/Combinators/Type/Core.hs b/src/Htcc/Parser/Combinators/Type/Core.hs index 540cedb..7ca707e 100644 --- a/src/Htcc/Parser/Combinators/Type/Core.hs +++ b/src/Htcc/Parser/Combinators/Type/Core.hs @@ -15,25 +15,28 @@ module Htcc.Parser.Combinators.Type.Core ( -- * Helper functions , toNamedParams ) where -import Control.Monad (mfilter) -import Control.Monad.Combinators (choice) -import Control.Monad.Trans (MonadTrans (..)) -import Control.Monad.Trans.Maybe (MaybeT (..), - runMaybeT) -import Control.Monad.Trans.State (gets) -import Data.Bits (Bits (..)) -import Data.Functor ((<&>)) -import Data.Maybe (fromJust, isJust) -import qualified Data.Text as T -import Data.Tuple.Extra (dupe, first, second) -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.Combinators.ConstExpr (evalConstexpr) -import Htcc.Parser.Combinators.Core -import {-# SOURCE #-} Htcc.Parser.Combinators.Decl.Declarator -import Htcc.Parser.Combinators.Decl.Spec (declspec) -import Htcc.Parser.ConstructionData.Core (incomplete) -import Htcc.Utils (toNatural) -import qualified Text.Megaparsec as M +import Control.Monad (mfilter) +import Control.Monad.Combinators (choice) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.Maybe (MaybeT (..), + runMaybeT) +import Control.Monad.Trans.State (gets) +import Data.Bits (Bits (..)) +import Data.Functor ((<&>)) +import Data.Maybe (fromJust, + isJust) +import qualified Data.Text as T +import Data.Tuple.Extra (dupe, + first, + second) +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.Combinators.ConstExpr (evalConstexpr) +import Htcc.Parser.Combinators.Core +import {-# SOURCE #-} Htcc.Parser.Combinators.Decl.Declarator +import Htcc.Parser.Combinators.Decl.Spec (declspec) +import Htcc.Parser.ConstructionData.Core (incomplete) +import Htcc.Utils (toNatural) +import qualified Text.Megaparsec as M arraySuffix :: (Show i, Read i, Bits i, Integral i) => CT.StorageClass i @@ -76,7 +79,7 @@ funcParams :: (Show i, Read i, Integral i, Bits i) -> Parser i (CT.StorageClass i) funcParams ty = lparen *> choice - [ [] <$ (symbol "void" *> rparen) + [ [(CT.SCAuto CT.CTVoid, Nothing)] <$ (symbol "void" *> rparen) , withParams ] <&> CT.wrapCTFunc ty @@ -107,6 +110,7 @@ toNamedParams ty = case CT.toTypeKind ty of (CT.CTFunc _ params) -> pure [ first CT.SCAuto $ second fromJust p | p <- params + , fst p /= CT.CTVoid , isJust $ snd p ] _ -> fail "expected function parameters" diff --git a/src/Htcc/Parser/Combinators/Utils.hs b/src/Htcc/Parser/Combinators/Utils.hs index 55b49f4..75fe248 100644 --- a/src/Htcc/Parser/Combinators/Utils.hs +++ b/src/Htcc/Parser/Combinators/Utils.hs @@ -17,25 +17,35 @@ module Htcc.Parser.Combinators.Utils ( , registerGVarWith , registerStringLiteral , registerFunc + , decayExprType + , conditionalResultType + , isNullPointerConstant + , functionDesignatorSourcePointerType + , isInvalidObjectPointerValue + , isInvalidFunctionPointerValue + , isInvalidFunctionPointerInitializer , bracket , getPosState ) where -import qualified Data.ByteString.UTF8 as BSU +import Control.Applicative ((<|>)) import Control.Monad.State (gets, put) import Control.Natural (type (~>)) import Data.Bits (Bits (..)) +import qualified Data.ByteString.UTF8 as BSU +import Data.Maybe (isJust) import qualified Data.Text as T import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST.Core (ATree (..)) +import Htcc.Parser.AST.Core (ATKind (..), + ATree (..)) import Htcc.Parser.Combinators.Core import Htcc.Parser.ConstructionData.Core (ConstructionData, + addFunction, addGVar, addGVarWith, addLVar, - addLiteral, - addFunction) + addLiteral) import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) -import Htcc.Parser.ConstructionData.Scope.Var (GVarInitWith) +import Htcc.Parser.ConstructionData.Scope.Var (GVarInitWith) import qualified Htcc.Tokenizer.Token as HT import qualified Text.Megaparsec as M @@ -73,13 +83,13 @@ registerStringLiteral s = gets (addLiteral ty (HT.TokenLCNums 1 1, HT.TKString $ where ty = CT.SCAuto $ CT.CTArray (fromIntegral $ length s) CT.CTChar -registerGVar :: (Bits i, Integral i) +registerGVar :: (Ord i, Bits i, Integral i) => CT.StorageClass i -> T.Text -> Parser i (ATree i) registerGVar = registerVar addGVar -registerGVarWith :: (Bits i, Integral i) +registerGVarWith :: (Ord i, Bits i, Integral i) => CT.StorageClass i -> T.Text -> GVarInitWith i @@ -91,14 +101,446 @@ registerGVarWith ty ident to = gets (addGVarWith ty (tmpTKIdent ident) to) registerFunc :: (Bits i, Integral i) => Bool + -> Bool -> CT.StorageClass i -> T.Text -> Parser i () -registerFunc isDefined ty ident = gets (addFunction isDefined ty (tmpTKIdent ident)) +registerFunc isDefined isImplicit ty ident = gets (addFunction isDefined isImplicit ty (tmpTKIdent ident)) >>= \case Right scp -> put scp Left err -> fail $ T.unpack $ fst err +decayExprType :: Ord i => CT.StorageClass i -> CT.StorageClass i +decayExprType ty = case CT.toTypeKind ty of + CT.CTArray _ _ -> decayArrayType ty + CT.CTIncomplete (CT.IncompleteArray elemTy) -> CT.mapTypeKind (const $ CT.CTPtr elemTy) ty + CT.CTFunc _ _ -> CT.mapTypeKind CT.CTPtr ty + _ -> ty + where + decayArrayType arrTy = maybe arrTy (CT.mapTypeKind CT.CTPtr) $ CT.deref arrTy + +conditionalResultType :: (Ord i, Bits i, Integral i) => ATree i -> ATree i -> Maybe (CT.StorageClass i) +conditionalResultType lhs rhs = + if isPointerType lhsTy || isPointerType rhsTy + then + nullPointerConditionalType lhsTy rhs + <|> nullPointerConditionalType rhsTy lhs + <|> mergePointerConditionalType lhsTy rhsTy + else + Just $ CT.conversion lhsTy rhsTy + where + lhsTy = decayExprType $ atype lhs + rhsTy = decayExprType $ atype rhs + + mergePointerConditionalType lTy rTy + | isPointerType lTy && isPointerType rTy = + voidObjectPointerConditionalType lTy rTy + <|> voidObjectPointerConditionalType rTy lTy + <|> mergeCompatibleStorageClasses lTy rTy + <|> mergeCompatibleStorageClasses rTy lTy + | otherwise = + Nothing + + voidObjectPointerConditionalType voidTy objectTy + | isVoidPointerType voidTy && isObjectPointerType objectTy = + Just voidTy + | otherwise = + Nothing + + nullPointerConditionalType pointerTy expr + | isPointerType pointerTy && isConditionalNullPointerConstantFor pointerTy expr = + Just pointerTy + | otherwise = + Nothing + + isPointerType ty = case CT.toTypeKind ty of + CT.CTPtr _ -> True + _ -> False + + isFunctionPointerType ty = case CT.toTypeKind ty of + CT.CTPtr (CT.CTFunc _ _) -> True + _ -> False + + isVoidPointerType ty = case CT.toTypeKind ty of + CT.CTPtr CT.CTVoid -> True + _ -> False + + isObjectPointerType ty = case CT.toTypeKind ty of + CT.CTPtr (CT.CTFunc _ _) -> False + CT.CTPtr _ -> True + _ -> False + + mergeCompatibleStorageClasses lTy rTy = + CT.SCAuto <$> CT.mergeCompatibleTypeKinds (CT.toTypeKind lTy) (CT.toTypeKind rTy) + + isConditionalNullPointerConstantFor pointerTy expr = + isZeroIntegerNullPointerConstant expr + || (isObjectPointerType pointerTy && isTypedNullPointerConstant isObjectPointerType expr) + || (isFunctionPointerType pointerTy && isTypedNullPointerConstant isFunctionNullPointerCastType expr) + + isFunctionNullPointerCastType ty = + isVoidPointerType ty || isFunctionPointerType ty + + isZeroIntegerNullPointerConstant = \case + ATNode (ATNull inner) _ _ _ -> + isZeroIntegerNullPointerConstant inner + ATNode ATExprStmt _ inner _ -> + isZeroIntegerNullPointerConstant inner + expr -> + isZeroIntegerConstexpr expr + + isTypedNullPointerConstant matchesTy = \case + ATNode (ATNull inner) _ _ _ -> + isTypedNullPointerConstant matchesTy inner + ATNode ATExprStmt _ inner _ -> + isTypedNullPointerConstant matchesTy inner + ATNode ATCast ty inner _ + | matchesTy ty -> + isZeroIntegerNullPointerConstant inner + _ -> + False + + isZeroIntegerConstexpr expr = + either (const False) (== 0) $ evalIntegerConstexprTree expr + +isNullPointerConstant :: (Bits i, Integral i) => ATree i -> Bool +isNullPointerConstant = \case + ATNode (ATNull inner) _ _ _ -> + isNullPointerConstant inner + ATNode ATExprStmt _ inner _ -> + isNullPointerConstant inner + ATNode ATCast ty inner _ + | isVoidPointerType ty -> + isZeroIntegerConstexpr inner + expr -> + isZeroIntegerConstexpr expr + where + isVoidPointerType ty = case CT.toTypeKind ty of + CT.CTPtr CT.CTVoid -> True + _ -> False + + isZeroIntegerConstexpr expr = + either (const False) (== 0) $ evalIntegerConstexprTree expr + +functionDesignatorSourcePointerType :: Ord i => ATree i -> Maybe (CT.StorageClass i) +functionDesignatorSourcePointerType at@(ATNode _ ty _ _) + | carriesFunctionDesignatorValue at = functionPointerValueType at + | otherwise = Nothing +functionDesignatorSourcePointerType _ = Nothing + +functionPointerValueType :: Ord i => ATree i -> Maybe (CT.StorageClass i) +functionPointerValueType (ATNode _ ty _ _) = case CT.toTypeKind ty of + CT.CTFunc _ _ -> Just $ decayExprType ty + CT.CTPtr (CT.CTFunc _ _) -> Just ty + _ -> Nothing +functionPointerValueType _ = Nothing + +isVoidPointerType :: CT.StorageClass i -> Bool +isVoidPointerType ty = case CT.toTypeKind ty of + CT.CTPtr CT.CTVoid -> True + _ -> False + +isObjectPointerType :: CT.StorageClass i -> Bool +isObjectPointerType ty = case CT.toTypeKind ty of + CT.CTPtr (CT.CTFunc _ _) -> False + CT.CTPtr _ -> True + _ -> False + +objectPointerTypesCompatible :: Ord i => CT.StorageClass i -> CT.StorageClass i -> Bool +objectPointerTypesCompatible targetTy sourceTy = + isVoidPointerType targetTy + || isVoidPointerType sourceTy + || compatibleKinds (CT.toTypeKind targetTy) (CT.toTypeKind sourceTy) + || compatibleKinds (CT.toTypeKind sourceTy) (CT.toTypeKind targetTy) + where + compatibleKinds lhs rhs = + isJust $ CT.mergeCompatibleTypeKinds lhs rhs + +isInvalidObjectPointerValue :: (Ord i, Bits i, Integral i) => CT.StorageClass i -> ATree i -> Bool +isInvalidObjectPointerValue targetTy expr + | not (isObjectPointerType targetTy) = False + | isNullPointerConstant expr = False + | otherwise = case CT.toTypeKind sourceTy of + CT.CTPtr (CT.CTFunc _ _) -> + True + CT.CTPtr _ -> + not $ objectPointerTypesCompatible targetTy sourceTy + _ -> + True + where + sourceTy = decayExprType $ atype expr + +isInvalidFunctionPointerValue :: (Ord i, Bits i, Integral i) => CT.StorageClass i -> ATree i -> Bool +isInvalidFunctionPointerValue targetTy at + | hasInvalidFunctionPointerCast at = isFunctionPointerType targetTy + | otherwise = case inferredFunctionPointerValueType at of + Just sourcePtrTy -> + not $ isCompatibleFunctionPointerType targetTy sourcePtrTy + Nothing -> + isFunctionPointerType targetTy && not (isNullPointerConstant at) + where + isFunctionPointerType ty = case CT.toTypeKind ty of + CT.CTPtr (CT.CTFunc _ _) -> True + _ -> False + + isVoidPointerType ty = case CT.toTypeKind ty of + CT.CTPtr CT.CTVoid -> True + _ -> False + + isNullPointerCastType ty = isVoidPointerType ty || isFunctionPointerType ty + + isNullPointerConstant = \case + ATNode (ATNull inner) _ _ _ -> + isNullPointerConstant inner + ATNode ATExprStmt _ inner _ -> + isNullPointerConstant inner + ATNode ATCast ty inner _ + | isNullPointerCastType ty -> + isZeroIntegerConstexpr inner + expr -> + isZeroIntegerConstexpr expr + + isZeroIntegerConstexpr expr = + either (const False) (== 0) $ evalIntegerConstexprTree expr + + inferredFunctionPointerValueType expr = + if isNullPointerConstant expr + then Nothing + else case functionPointerValueType expr of + Just ty -> + Just ty + Nothing -> case expr of + ATNode (ATNull inner) _ _ _ -> + inferredFunctionPointerValueType inner + ATNode ATExprStmt _ inner _ -> + inferredFunctionPointerValueType inner + ATNode ATComma _ _ rhs -> + inferredFunctionPointerValueType rhs + ATNode (ATConditional cond ATEmpty el) _ _ _ -> + conditionalFunctionPointerValueType cond el + ATNode (ATConditional _ th el) _ _ _ -> + conditionalFunctionPointerValueType th el + ATNode (ATStmtExpr stmts) _ _ _ -> + maybe Nothing inferredFunctionPointerValueType (lastMaybe stmts) + _ -> + Nothing + + conditionalFunctionPointerValueType lhs rhs = case (inferredFunctionPointerValueType lhs, inferredFunctionPointerValueType rhs) of + (Just lhsTy, Just rhsTy) + | functionPointerTypesCompatible lhsTy rhsTy -> + Just lhsTy + (Just lhsTy, Nothing) + | isNullPointerConstant rhs -> + Just lhsTy + (Nothing, Just rhsTy) + | isNullPointerConstant lhs -> + Just rhsTy + _ -> + Nothing + + functionPointerTypesCompatible lhsTy rhsTy = + isCompatibleFunctionPointerType lhsTy rhsTy + || isCompatibleFunctionPointerType rhsTy lhsTy + + isCompatibleFunctionPointerType targetTy' sourcePtrTy = + isFunctionPointerType targetTy' + && + ( isJust + (CT.mergeCompatibleTypeKinds + (CT.toTypeKind targetTy') + (CT.toTypeKind sourcePtrTy) + ) + || oldStyleFunctionPointerCompatible + (CT.toTypeKind targetTy') + (CT.toTypeKind sourcePtrTy) + ) + + oldStyleFunctionPointerCompatible + (CT.CTPtr (CT.CTFunc targetRet targetParams)) + (CT.CTPtr (CT.CTFunc sourceRet sourceParams)) = + isJust (CT.mergeCompatibleTypeKinds targetRet sourceRet) + && + (oldStyleParamListCompatible targetParams sourceParams + || oldStyleParamListCompatible sourceParams targetParams) + oldStyleFunctionPointerCompatible _ _ = False + + oldStyleParamListCompatible [] params = + all oldStyleCallCompatibleParamType $ normalizedFunctionParamKinds params + oldStyleParamListCompatible _ _ = False + + normalizedFunctionParamKinds [(CT.CTVoid, Nothing)] = [] + normalizedFunctionParamKinds params = + map (normalizeFunctionParamType . fst) params + + normalizeFunctionParamType = \case + CT.CTArray _ elemTy -> CT.CTPtr elemTy + CT.CTIncomplete (CT.IncompleteArray elemTy) -> CT.CTPtr elemTy + CT.CTFunc retTy params -> CT.CTPtr $ CT.CTFunc retTy params + ty -> ty + + oldStyleCallCompatibleParamType ty = + isJust (CT.mergeCompatibleTypeKinds ty promotedTy) + where + promotedTy = CT.integerPromotedTypeKind ty + + hasInvalidFunctionPointerCast = \case + ATNode ATCast ty inner _ + | carriesFunctionDesignatorValue inner -> + not (isFunctionPointerType ty) || hasInvalidFunctionPointerCast inner + ATNode ATAddr _ inner _ -> + hasInvalidFunctionPointerCast inner + ATNode (ATNull inner) _ _ _ -> + hasInvalidFunctionPointerCast inner + ATNode ATExprStmt _ inner _ -> + hasInvalidFunctionPointerCast inner + ATNode ATComma _ _ rhs -> + hasInvalidFunctionPointerCast rhs + ATNode (ATConditional cond ATEmpty el) _ _ _ -> + any hasInvalidFunctionPointerCast [cond, el] + ATNode (ATConditional _ th el) _ _ _ -> + any hasInvalidFunctionPointerCast [th, el] + ATNode (ATStmtExpr stmts) _ _ _ -> + maybe False hasInvalidFunctionPointerCast (lastMaybe stmts) + _ -> + False + + lastMaybe [] = Nothing + lastMaybe xs = Just $ last xs + +evalIntegerConstexprTree :: (Bits i, Integral i) => ATree i -> Either String i +evalIntegerConstexprTree = \case + ATNode k ty lhs rhs -> case k of + ATAdd -> binop (+) + ATSub -> binop (-) + ATMul -> binop (*) + ATDiv -> nonZeroBinop quot + ATMod -> nonZeroBinop rem + ATAnd -> binop (.&.) + ATXor -> binop xor + ATOr -> binop (.|.) + ATShl -> binop (\l r -> shiftL l (fromIntegral r)) + ATShr -> binop (\l r -> shiftR l (fromIntegral r)) + ATEQ -> binop (fromBool .: (==)) + ATNEQ -> binop (fromBool .: (/=)) + ATLT -> binop (fromBool .: (<)) + ATGT -> binop (fromBool .: (>)) + ATLEQ -> binop (fromBool .: (<=)) + ATGEQ -> binop (fromBool .: (>=)) + ATConditional cond th el -> + evalIntegerConstexprTree cond >>= \cond' -> + if cond' == 0 + then evalIntegerConstexprTree el + else evalIntegerConstexprTree $ + case th of + ATEmpty -> cond + _ -> th + ATNot -> fromBool . (== 0) <$> evalIntegerConstexprTree lhs + ATBitNot -> complement <$> evalIntegerConstexprTree lhs + ATLAnd -> evalIntegerConstexprTree lhs >>= logicalAnd + ATLOr -> evalIntegerConstexprTree lhs >>= logicalOr + ATSizeof -> memOp "sizeof" CT.sizeof lhs + ATAlignof -> memOp "_Alignof" CT.alignof lhs + ATCast + | isConstexprArithmeticCastType ty -> applyConstexprCast ty <$> evalIntegerConstexprTree lhs + | otherwise -> Left "not an integer constant expression" + ATNum v -> pure v + _ -> Left "not an integer constant expression" + where + binop f = evalIntegerConstexprTree lhs >>= \lhs' -> f lhs' <$> evalIntegerConstexprTree rhs + logicalAnd lhs' + | lhs' == 0 = pure 0 + | otherwise = fromBool . (/= 0) <$> evalIntegerConstexprTree rhs + logicalOr lhs' + | lhs' /= 0 = pure 1 + | otherwise = fromBool . (/= 0) <$> evalIntegerConstexprTree rhs + nonZeroBinop f = + evalIntegerConstexprTree lhs >>= \lhs' -> + evalIntegerConstexprTree rhs >>= \rhs' -> + if rhs' == 0 + then Left "not an integer constant expression" + else pure (f lhs' rhs') + memOp opName op expr + | CT.isCTIncomplete (atype expr) = + Left $ "invalid application of '" <> opName <> "' to incomplete type" + | otherwise = + pure $ fromIntegral $ op $ atype expr + fromBool = fromIntegral . fromEnum + (.:) f g x y = f (g x y) + _ -> Left "not an integer constant expression" + +isConstexprArithmeticCastType :: CT.StorageClass i -> Bool +isConstexprArithmeticCastType = \case + CT.SCAuto ty -> go ty + CT.SCRegister ty -> go ty + CT.SCStatic ty -> go ty + CT.SCUndef ty -> go ty + where + go = \case + CT.CTInt -> True + CT.CTChar -> True + CT.CTBool -> True + CT.CTEnum _ _ -> True + CT.CTSigned CT.CTUndef -> True + CT.CTShort CT.CTUndef -> True + CT.CTLong CT.CTUndef -> True + CT.CTSigned ty -> go ty + CT.CTShort ty -> go ty + CT.CTLong ty -> go ty + _ -> False + +applyConstexprCast :: (Bits i, Integral i) => CT.StorageClass i -> i -> i +applyConstexprCast ty val + | CT.toTypeKind ty == CT.CTBool = fromIntegral $ fromEnum $ val /= 0 + | otherwise = truncateToWidth (CT.sizeof ty) val + where + truncateToWidth sz x + | sz == 0 = 0 + | otherwise = fromInteger $ signExtend width $ toInteger x + where + width = fromIntegral $ sz * 8 + + signExtend width x = + if width <= 0 + then 0 + else + let modulus = bit width :: Integer + mask = pred modulus + truncated = x .&. mask + signBit = bit (pred width) :: Integer + in + if truncated .&. signBit == 0 + then truncated + else truncated - modulus + +isInvalidFunctionPointerInitializer :: (Ord i, Bits i, Integral i) => CT.StorageClass i -> ATree i -> Bool +isInvalidFunctionPointerInitializer = isInvalidFunctionPointerValue + +carriesFunctionDesignatorValue :: ATree i -> Bool +carriesFunctionDesignatorValue = \case + ATNode (ATFuncPtr _) _ _ _ -> + True + ATNode ATAddr _ inner _ -> + carriesFunctionDesignatorValue inner + ATNode ATCast _ inner _ -> + carriesFunctionDesignatorValue inner + ATNode (ATNull inner) _ _ _ -> + carriesFunctionDesignatorValue inner + ATNode ATExprStmt _ inner _ -> + carriesFunctionDesignatorValue inner + ATNode ATComma _ _ rhs -> + carriesFunctionDesignatorValue rhs + ATNode (ATConditional cond ATEmpty el) _ _ _ -> + any carriesFunctionDesignatorValue [cond, el] + ATNode (ATConditional _ th el) _ _ _ -> + any carriesFunctionDesignatorValue [th, el] + ATNode (ATStmtExpr stmts) _ _ _ -> + maybe False carriesFunctionDesignatorValue (lastMaybe stmts) + _ -> + False + where + lastMaybe [] = Nothing + lastMaybe xs = Just $ last xs + bracket :: Parser i a -> (a -> Parser i b) -> (a -> Parser i c) -> Parser i c bracket beg end m = do b <- beg diff --git a/src/Htcc/Parser/Combinators/Var.hs b/src/Htcc/Parser/Combinators/Var.hs index 2098b1d..d5e8d36 100644 --- a/src/Htcc/Parser/Combinators/Var.hs +++ b/src/Htcc/Parser/Combinators/Var.hs @@ -13,34 +13,43 @@ C language parser Combinators module Htcc.Parser.Combinators.Var ( varInit ) where -import Control.Monad (foldM, forM, void, (>=>)) -import Control.Monad.Extra (andM) -import Control.Monad.Fix (fix) -import Control.Monad.Trans (MonadTrans (..)) -import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT) -import Control.Monad.Trans.State (gets) -import Data.Bits (Bits) -import Data.Bool (bool) -import Data.Char (ord) -import Data.Foldable (toList) -import Data.Functor ((<&>)) -import Data.List (sortBy) -import Data.Maybe (fromJust, fromMaybe) -import qualified Data.Sequence as SQ -import qualified Data.Text as T -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST (ATKind (..), ATree (..), - addKind, atAssign, atBlock, - atExprStmt, atMemberAcc, - atNumLit, atUnary, - treealize) +import Control.Monad (foldM, forM, unless, + void, when, (>=>)) +import Control.Monad.Extra (andM) +import Control.Monad.Fix (fix) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.Reader (ReaderT (..), asks, + runReaderT) +import Control.Monad.Trans.State (get, gets, put) +import Data.Bits (Bits) +import Data.Bool (bool) +import Data.Char (ord) +import Data.Foldable (toList) +import Data.Functor ((<&>)) +import Data.List (sortBy) +import qualified Data.Map as MP +import Data.Maybe (fromJust, fromMaybe) +import qualified Data.Sequence as SQ +import qualified Data.Text as T +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.AST (ATKind (..), + ATree (..), addKind, + atAssign, atBlock, + atCast, atExprStmt, + atMemberAcc, atNumLit, + atUnary, treealize) import Htcc.Parser.Combinators.Core -import Htcc.Parser.Combinators.Utils (bracket, maybeToParser, - registerLVar) -import Htcc.Parser.ConstructionData.Core (incomplete, lookupLVar) -import Htcc.Utils (tshow) -import qualified Text.Megaparsec as M -import Text.Megaparsec.Debug (dbg) +import Htcc.Parser.Combinators.Utils (bracket, + isInvalidFunctionPointerInitializer, + isInvalidObjectPointerValue, + maybeToParser, + registerLVar) +import Htcc.Parser.ConstructionData.Core (incomplete, lookupLVar) +import Htcc.Parser.ConstructionData.Scope.Var (Var (vtype)) +import Htcc.Utils (tshow) +import Numeric.Natural (Natural) +import qualified Text.Megaparsec as M +import qualified Text.Parsec.Error as PE type DesignatorParser i r = ReaderT (T.Text, Parser i (ATree i)) (Parser i) r @@ -50,58 +59,276 @@ runDesignator :: (SQ.Seq (ATree i) -> SQ.Seq (CT.Desg i) -> DesignatorParser i r -> Parser i r runDesignator p ident assignParser = runReaderT (p SQ.empty SQ.empty) (ident, assignParser) -fromValidAssignAST :: Eq i => ATree i -> Parser i (ATree i) -fromValidAssignAST at@(ATNode _ ty _ _) - | CT.toTypeKind ty == CT.CTVoid = fail "void value not ignored as it ought to be" +validateScalarInitializer :: (Ord i, Bits i, Integral i) => CT.StorageClass i -> ATree i -> DesignatorParser i (ATree i) +validateScalarInitializer targetTy at@(ATNode _ ty _ _) + | isVoidExpressionType ty = fail "void value not ignored as it ought to be" + | isInvalidFunctionInitializer = fail "invalid initializer for scalar object" + | isInvalidObjectInitializer = fail "invalid initializer for scalar object" | otherwise = pure at -fromValidAssignAST _ = fail "expected to assign" + where + isVoidExpressionType = isVoidTypeKind . CT.toTypeKind + + isVoidTypeKind ty' = case ty' of + CT.CTVoid -> True + CT.CTShort ty'' -> isVoidTypeKind ty'' + CT.CTLong ty'' -> isVoidTypeKind ty'' + CT.CTSigned ty'' -> isVoidTypeKind ty'' + _ -> False + + isInvalidFunctionInitializer = + isInvalidFunctionPointerInitializer targetTy at + + isInvalidObjectInitializer = + isInvalidObjectPointerValue targetTy at +validateScalarInitializer _ _ = fail "expected to assign" + +withDesignatorCheckpoint :: DesignatorParser i a -> DesignatorParser i a +withDesignatorCheckpoint p = ReaderT $ \ctx -> + bracket M.getParserState M.setParserState $ const $ + bracket (lift get) (lift . put) $ const $ + runReaderT p ctx + +tryDesignator :: DesignatorParser i a -> DesignatorParser i a +tryDesignator p = ReaderT $ \ctx -> + M.try $ runReaderT p ctx + +arrayElementType :: Ord i => CT.StorageClass i -> CT.StorageClass i +arrayElementType ty = CT.mapTypeKind (const elemTy) ty + where + elemTy = case CT.deref ty of + Just ty' -> CT.toTypeKind ty' + Nothing -> case CT.toTypeKind ty of + CT.CTIncomplete (CT.IncompleteArray ty') -> ty' + _ -> error "internal compiler error" + +fixedArrayLength :: Ord i => CT.StorageClass i -> Maybe Natural +fixedArrayLength ty + | not (CT.isArray ty) = Nothing + | elemBytes == 0 = Nothing + | totalBytes == 0 = Nothing + | otherwise = Just $ totalBytes `div` elemBytes + where + totalBytes = CT.sizeof ty + elemBytes = CT.sizeof $ arrayElementType ty + +inferredArrayBoundElementType :: Ord i => CT.StorageClass i -> CT.StorageClass i +inferredArrayBoundElementType ty = fromMaybe (arrayElementType ty) logicalElemTy + where + (baseTy, rebuild) = CT.dctorArray $ CT.toTypeKind ty + logicalElemTy = + CT.fromIncompleteArray baseTy + <&> rebuild + <&> \logicalTy -> CT.mapTypeKind (const logicalTy) ty + +fixedCharArrayStringFits :: Integral i => i -> String -> Bool +fixedCharArrayStringFits len s = toInteger (length s) <= toInteger len + 1 + +isCharArrayType :: Ord i => CT.StorageClass i -> Bool +isCharArrayType ty = + CT.isArray ty && maybe False isCharType (CT.deref ty) + where + isCharType ty' = case CT.toTypeKind ty' of + CT.CTChar -> True + _ -> False + +lookInitializerStringFor :: Ord i => CT.StorageClass i -> Parser i () +lookInitializerStringFor ty = bool M.empty (pure ()) =<< andM + [ pure $ isCharArrayType ty + , M.option False (True <$ M.lookAhead stringLiteral) + ] + +failCommitted :: String -> DesignatorParser i a +failCommitted msg = do + pos <- lift M.getSourcePos + lift $ M.parseError $ M.ParsecError True $ PE.newErrorMessage (PE.Message msg) pos + +data ArrayBoundInference i + = InferArrayBoundLength Int + | InferArrayBoundType (CT.StorageClass i) + +inferArrayBoundFromInitializer :: (Integral i, Bits i, Read i, Show i, Ord i) + => CT.StorageClass i + -> DesignatorParser i (ArrayBoundInference i) +inferArrayBoundFromInitializer ty = + withDesignatorCheckpoint $ inferArrayBoundFromInitializer' ty + +inferArrayBoundFromInitializer' :: (Integral i, Bits i, Read i, Show i, Ord i) + => CT.StorageClass i + -> DesignatorParser i (ArrayBoundInference i) +inferArrayBoundFromInitializer' ty = do + void $ lift lbrace + bracedStringInitializerLength M.<|> inferElementCount + where + elemTy = inferredArrayBoundElementType ty + emptyInitializerError = "cannot initialize incomplete array with an empty initializer list" -lengthArrayBrace :: Parser i Int -lengthArrayBrace = braces (arrayBrace 0) + inferElementCount = do + len <- countElements 0 + lift rbrace + pure $ InferArrayBoundLength len + + bracedStringInitializerLength + | isCharArrayType ty = do + lift $ lookInitializerStringFor ty + len <- length <$> lift stringLiteral + void $ lift $ M.option () (() <$ comma) + lift rbrace + pure $ InferArrayBoundLength len + | otherwise = M.empty + + countElements acc = M.choice + [ do + void $ lift (M.lookAhead rbrace) + if acc == 0 + then fail emptyInitializerError + else pure acc + , do + skipInitializer True elemTy + continue <- continueBracedAggregate + bool + (pure $ succ acc) + (countElements $ succ acc) + continue + ] + +lookAheadTrailingCommaBeforeRbrace :: DesignatorParser i Bool +lookAheadTrailingCommaBeforeRbrace = + lift $ M.option False $ True <$ M.try (M.lookAhead (comma *> rbrace)) + +continueBracedAggregate :: DesignatorParser i Bool +continueBracedAggregate = M.choice + [ False <$ lift (M.lookAhead rbrace) + , False <$ lift (M.try (comma *> M.lookAhead rbrace)) + , True <$ lift comma + ] + +continueBraceElidedAggregate :: DesignatorParser i Bool +continueBraceElidedAggregate = do + trailingOuterComma <- lookAheadTrailingCommaBeforeRbrace + if trailingOuterComma + then pure False + else M.choice + [ True <$ lift comma + , pure False + ] + +skipInitializer :: (Integral i, Bits i, Read i, Show i, Ord i) + => Bool + -> CT.StorageClass i + -> DesignatorParser i () +skipInitializer allowStructBraceElision ty = M.choice + [ lift lookInitializerString *> void (lift stringLiteral) + , lift lookInitializerList *> leadingBraceInitializer + , braceElidedAggregateInit + , rejectScalarFallback *> (void $ asks snd >>= lift >>= validateScalarInitializer ty) + ] + where + lookInitializerString = lookInitializerStringFor ty + lookInitializerList = bool M.empty (pure ()) =<< M.option False (True <$ M.lookAhead lbrace) + leadingBraceInitializer = skipInitializerList ty + braceElidedAggregateInit + | allowStructBraceElision = case CT.toTypeKind ty of + CT.CTArray _ _ -> + rejectAggregateExpr "expected '{' to initialize an array" *> skipArrayNoBraces ty + CT.CTStruct mems -> + rejectAggregateExpr "expected '{' to initialize a struct" *> skipStructNoBraces (orderedStructMembers mems) + CT.CTNamedStruct _ mems -> + rejectAggregateExpr "expected '{' to initialize a struct" *> skipStructNoBraces (orderedStructMembers mems) + _ -> + M.empty + | otherwise = M.empty + rejectScalarFallback = rejectScalarFallbackFor ty + +skipInitializerList :: (Integral i, Bits i, Read i, Show i, Ord i) + => CT.StorageClass i + -> DesignatorParser i () +skipInitializerList ty = do + void $ lift lbrace + case CT.toTypeKind ty of + CT.CTArray _ _ -> skipBracedInitializerString ty M.<|> (skipArrayList ty <* lift rbrace) + CT.CTStruct mems -> skipStructList (orderedStructMembers mems) <* lift rbrace + CT.CTNamedStruct _ mems -> skipStructList (orderedStructMembers mems) <* lift rbrace + _ -> do + skipInitializer False ty + void $ lift $ M.option () (() <$ comma) + void $ lift rbrace where - arrayBrace c = M.choice - [ (+) <$> M.try (acc c <$> braces (arrayBrace (succ c)) <* comma) <*> arrayBrace c - , acc c <$> braces (arrayBrace $ succ c) - , (+) <$> M.try (accN c <$ validCharSets <* comma) <*> arrayBrace c - , accN c <$ validCharSets <* M.lookAhead rbrace - , 0 <$ M.lookAhead rbrace + skipBracedInitializerString aty = tryDesignator $ do + lift $ lookInitializerStringFor aty + void $ lift stringLiteral + void $ lift $ M.option () (() <$ comma) + void $ lift rbrace + + skipArrayList aty = M.choice + [ () <$ lift (M.lookAhead rbrace) + , do + skipInitializer True (arrayElementType aty) + continue <- continueBracedAggregate + bool + (pure ()) + (skipArrayList aty) + continue ] - acc n | n == 0 = succ | otherwise = id - accN n | n == 0 = 1 | otherwise = 0 - validCharSets = M.choice - [ identifier - , T.pack <$> stringLiteral - , T.singleton <$> charLiteral - , tshow <$> integer - , semi - , comma - , colon - , lnot - , sharp - , ampersand - , lparen - , rparen - , langle - , rangle - , lbracket - , rbracket - , star - , period - , slash - , equal - , question - , hat - , tilda - , vertical - , percent + + skipStructList [] = pure () + skipStructList (mem:rest) = M.choice + [ () <$ lift (M.lookAhead rbrace) + , do + skipInitializer True (CT.SCAuto $ CT.smType mem) + continue <- continueBracedAggregate + bool + (pure ()) + (skipStructList rest) + continue ] +skipArrayNoBraces :: (Integral i, Bits i, Read i, Show i, Ord i) + => CT.StorageClass i + -> DesignatorParser i () +skipArrayNoBraces ty = case fixedArrayLength ty of + Just n -> skipArrayLoop (fromIntegral n) 0 + Nothing -> fail "internal compiler error" + where + elemTy = arrayElementType ty + + skipArrayLoop len idx + | idx >= len = pure () + | otherwise = do + skipInitializer True elemTy + if succ idx == len + then pure () + else do + continue <- continueBraceElidedAggregate + bool + (pure ()) + (skipArrayLoop len (succ idx)) + continue + +skipStructNoBraces :: (Integral i, Bits i, Read i, Show i, Ord i) + => [CT.StructMember i] + -> DesignatorParser i () +skipStructNoBraces [] = pure () +skipStructNoBraces (mem:rest) = do + skipInitializer True (CT.SCAuto $ CT.smType mem) + case rest of + [] -> pure () + _ -> do + continue <- continueBraceElidedAggregate + bool + (pure ()) + (skipStructNoBraces rest) + continue + desgNode :: (Num i, Ord i, Show i) => ATree i -> SQ.Seq (CT.Desg i) -> DesignatorParser i (ATree i) -desgNode nd desg = fmap (atExprStmt . flip atAssign nd) $ - flip (`foldr` facc) desg $ \idx acc -> case idx of +desgNode nd desg = atExprStmt . flip atAssign nd <$> desgLVal desg + +desgLVal :: (Num i, Ord i, Show i) + => SQ.Seq (CT.Desg i) + -> DesignatorParser i (ATree i) +desgLVal desg = flip (`foldr` facc) desg $ \idx acc -> case idx of CT.DesgIdx idx' -> do nd' <- maybeToParser' . (`addKind` atNumLit idx') =<< acc flip (atUnary ATDeref) nd' <$> maybeToParser' (CT.deref (atype nd')) @@ -113,23 +340,69 @@ desgNode nd desg = fmap (atExprStmt . flip atAssign nd) $ <&> treealize maybeToParser' = lift . maybeToParser "invalid initializer-list" -initLoop :: (Integral i, Bits i, Read i, Show i) +zeroFillByteOffsets :: (Integral i, Ord i, Show i) + => SQ.Seq (CT.Desg i) + -> [i] + -> DesignatorParser i (SQ.Seq (ATree i)) +zeroFillByteOffsets desg offsets = do + base <- desgLVal desg + let bytePtrTy = CT.SCAuto $ CT.CTPtr CT.CTChar + baseAddrTy = CT.mapTypeKind CT.CTPtr (atype base) + byteBase = atCast bytePtrTy $ atUnary ATAddr baseAddrTy base + fmap SQ.fromList $ forM offsets $ \offset -> do + bytePtr <- case offset of + 0 -> pure byteBase + _ -> lift + $ maybeToParser "invalid initializer-list" + $ addKind byteBase (atNumLit offset) + pure $ atExprStmt $ atAssign (atUnary ATDeref (CT.SCAuto CT.CTChar) bytePtr) (atNumLit 0) + +zeroFillObject :: (Integral i, Ord i, Show i) + => CT.StorageClass i + -> SQ.Seq (CT.Desg i) + -> DesignatorParser i (SQ.Seq (ATree i)) +zeroFillObject ty desg = zeroFillByteOffsets desg [0 .. pred totalBytes] + where + totalBytes = fromIntegral $ CT.sizeof ty + +zeroFillRemainingStructBytes :: (Integral i, Ord i, Show i) + => CT.StorageClass i + -> [CT.StructMember i] + -> SQ.Seq (CT.Desg i) + -> DesignatorParser i (SQ.Seq (ATree i)) +zeroFillRemainingStructBytes ty explicitMembers desg = + zeroFillByteOffsets desg $ filter (`notElem` explicitOffsets) [0 .. pred totalBytes] + where + totalBytes = fromIntegral $ CT.sizeof ty + explicitOffsets = concatMap memberByteOffsets explicitMembers + memberByteOffsets mem + | memberBytes == 0 = [] + | otherwise = [start .. start + pred memberBytes] + where + start = fromIntegral $ CT.smOffset mem + memberBytes = fromIntegral $ CT.sizeof $ CT.smType mem + +initLoop :: (Integral i, Bits i, Read i, Show i, Ord i) => CT.StorageClass i -> SQ.Seq (ATree i) -> SQ.Seq (CT.Desg i) -> DesignatorParser i (SQ.Seq (ATree i), i) -initLoop ty ai desg = initLoop' ai <* lift rbrace - where - initLoop' ai' = case CT.toTypeKind ty of - CT.CTArray _ _ -> ($ (0, ai')) . fix $ \f (idx, rl) -> do - rs <- desgInit (fromJust $ CT.deref ty) rl (CT.DesgIdx idx SQ.<| desg) - M.choice - [ (rs, succ idx) <$ lift (M.lookAhead rbrace) - , lift comma *> f (succ idx, rs) - ] - _ -> fail "internal compiler error" - -initZero :: (Num i, Ord i, Show i, Enum i) +initLoop ty ai desg = fmap (\(rs, idx) -> (rs, fromIntegral idx)) (initLoop' ai) <* lift rbrace + where + initLoop' ai' = case fixedArrayLength ty of + Just n -> ($ (0 :: Natural, ai')) . fix $ \f (idx, rl) -> do + let arrayLen = fromIntegral n + when (idx >= arrayLen) $ failCommitted "excess elements in array initializer" + rs <- desgInit True elemTy rl (CT.DesgIdx (fromIntegral idx) SQ.<| desg) + continue <- continueBracedAggregate + bool + (pure (rs, succ idx)) + (f (succ idx, rs)) + continue + Nothing -> fail "internal compiler error" + elemTy = arrayElementType ty + +initZero :: (Integral i, Ord i, Show i) => CT.TypeKind i -> SQ.Seq (CT.Desg i) -> DesignatorParser i (SQ.Seq (ATree i)) @@ -138,24 +411,108 @@ initZero (CT.CTArray n ty) desg = (\acc idx -> (SQ.>< acc) <$> initZero ty (CT.DesgIdx idx SQ.<| desg)) SQ.empty [0..fromIntegral (pred n)] +initZero t@(CT.CTStruct _) desg = zeroFillObject (CT.SCAuto t) desg +initZero t@(CT.CTNamedStruct _ _) desg = zeroFillObject (CT.SCAuto t) desg initZero _ desg = SQ.singleton <$> desgNode (atNumLit 0) desg -arType :: (CT.CType (a j), CT.TypeKindBase a, Integral i) => a j -> i -> a j -arType ty len = snd (CT.dctorArray ty) $ - CT.mapTypeKind (CT.CTArray (fromIntegral len) . fromJust . CT.fromIncompleteArray) ty +orderedStructMembers :: MP.Map T.Text (CT.StructMember i) -> [CT.StructMember i] +orderedStructMembers = sortBy (\x y -> compare (CT.smOffset x) (CT.smOffset y)) . MP.elems + +structStorageClassFromMembers :: [CT.StructMember i] -> CT.StorageClass i +structStorageClassFromMembers mems = + CT.SCAuto $ CT.CTStruct $ MP.fromList $ zipWith (\idx mem -> (tshow idx, mem)) [(0 :: Int)..] mems + +isAggregateType :: CT.StorageClass i -> Bool +isAggregateType ty = CT.isArray ty || CT.isCTStruct ty + +peekAssignType :: DesignatorParser i (Maybe (CT.StorageClass i)) +peekAssignType = do + assignParser <- asks snd + constructionData <- lift $ lift get + observed <- lift $ M.option Nothing $ Just <$> M.try (M.lookAhead assignParser) + lift $ lift $ put constructionData + pure $ atype <$> observed + +aggregateInitializerBraceError :: CT.StorageClass i -> Maybe String +aggregateInitializerBraceError ty + | CT.isCTStruct ty = Just "expected '{' to initialize a struct" + | CT.isArray ty = Just "expected '{' to initialize an array" + | otherwise = Nothing -initializerString :: (Integral i, Bits i, Read i, Show i) +rejectAggregateExpr :: String -> DesignatorParser i () +rejectAggregateExpr msg = do + startsWithString <- lift $ M.option False (True <$ M.lookAhead stringLiteral) + unless startsWithString $ do + isAggregateExpr <- maybe False isAggregateType <$> peekAssignType + bool (pure ()) (fail msg) isAggregateExpr + +rejectScalarFallbackFor :: CT.StorageClass i -> DesignatorParser i () +rejectScalarFallbackFor ty = + maybe + rejectInvalidScalarAggregate + fail + (aggregateInitializerBraceError ty) + where + rejectInvalidScalarAggregate = do + invalidAggregate <- maybe False (scalarAggregateNeedsBraces ty) <$> peekAssignType + when invalidAggregate $ fail "invalid initializer for scalar object" + + scalarAggregateNeedsBraces target rhs = case CT.toTypeKind target of + CT.CTPtr _ -> CT.isCTStruct rhs + _ -> isAggregateType rhs + +arType :: Integral i => CT.StorageClass i -> i -> CT.StorageClass i +arType ty len = case CT.toTypeKind ty of + CT.CTIncomplete (CT.IncompleteArray innerTy) -> + CT.mapTypeKind (const $ inferredOuterArrayType innerTy len) ty + _ -> snd (CT.dctorArray ty) $ + CT.mapTypeKind (CT.CTArray (fromIntegral len) . fromJust . CT.fromIncompleteArray) ty + +inferredOuterArrayType :: Integral i => CT.TypeKind i -> i -> CT.TypeKind i +inferredOuterArrayType innerTy len = case innerTy of + CT.CTArray _ _ -> + fromMaybe fallback $ + CT.concatCTArray + (CT.makeCTArray [fromIntegral len] $ CT.removeAllExtents innerTy) + innerTy + _ -> fallback + where + fallback = CT.CTArray (fromIntegral len) innerTy + +registerInferredArrayBound :: (Integral i, Bits i, Read i, Show i, Ord i) => CT.StorageClass i + -> ArrayBoundInference i + -> DesignatorParser i (CT.StorageClass i) +registerInferredArrayBound ty inferred = do + ident <- asks fst + let applyInference target = case inferred of + InferArrayBoundLength len -> arType target (fromIntegral len) + InferArrayBoundType ty' -> ty' + newt = applyInference ty + currentTy <- lift $ lift $ gets (fmap vtype . lookupLVar ident) + case currentTy of + Just currentTy' + | CT.isIncompleteArray currentTy' -> + void $ lift $ registerLVar (applyInference currentTy') ident + _ -> pure () + pure newt + +initializerString :: (Integral i, Bits i, Read i, Show i, Ord i) + => Bool + -> CT.StorageClass i -> SQ.Seq (ATree i) -> SQ.Seq (CT.Desg i) -> DesignatorParser i (SQ.Seq (ATree i)) -initializerString ty ai desg +initializerString allowStructBraceElision ty ai desg | CT.isIncompleteArray ty = do - newt <- lift $ bracket M.getInput M.setInput (const $ arType ty . length <$> stringLiteral) - asks fst >>= lift . registerLVar newt >> desgInit newt ai desg + len <- lift $ bracket M.getParserState M.setParserState (const $ length <$> stringLiteral) + newt <- registerInferredArrayBound ty $ InferArrayBoundLength len + desgInit allowStructBraceElision newt ai desg | otherwise = case CT.toTypeKind ty of CT.CTArray n _ -> do s <- lift stringLiteral + unless (fixedCharArrayStringFits n s) $ + failCommitted "initializer-string for array of chars is too long" let s' = s <> replicate (fromIntegral n - pred (length s)) (toEnum 0) inds = sortBy (flip (.) reverse . compare . reverse) $ CT.accessibleIndices $ CT.toTypeKind ty fmap ((ai SQ.><) . SQ.fromList) @@ -163,7 +520,20 @@ initializerString ty ai desg $ zipWith (flip (.) ((SQ.>< desg) . SQ.fromList) . (,) . atNumLit . fromIntegral . ord) s' inds _ -> fail "internal compiler error" -initializerList :: (Integral i, Bits i, Read i, Show i) +bracedInitializerString :: (Integral i, Bits i, Read i, Show i, Ord i) + => Bool + -> CT.StorageClass i + -> SQ.Seq (ATree i) + -> SQ.Seq (CT.Desg i) + -> DesignatorParser i (SQ.Seq (ATree i)) +bracedInitializerString allowStructBraceElision ty ai desg = do + lift $ lookInitializerStringFor ty + rs <- initializerString allowStructBraceElision ty ai desg + void $ lift $ M.option () (() <$ comma) + lift rbrace + pure rs + +initializerList :: (Integral i, Bits i, Read i, Show i, Ord i) => CT.StorageClass i -> SQ.Seq (ATree i) -> SQ.Seq (CT.Desg i) @@ -173,61 +543,147 @@ initializerList ty ai desg = M.choice , withInitElements ] where - allZeroInit = do - void $ lift $ M.try (lbrace *> rbrace) - (ai SQ.><) . SQ.fromList <$> forM - (CT.accessibleIndices $ CT.toTypeKind ty) - (desgNode (atNumLit 0) . (SQ.>< desg) . SQ.fromList) + allZeroInit + | (CT.isArray ty && not (CT.isIncompleteArray ty)) || CT.isCTStruct ty = do + void $ lift $ M.try (lbrace *> rbrace) + (ai SQ.><) <$> initZero (CT.toTypeKind ty) desg + | otherwise = M.empty withInitElements | CT.isIncompleteArray ty = do - newt <- lift $ bracket M.getInput M.setInput (const $ arType ty <$> lengthArrayBrace) - asks fst - >>= lift . registerLVar newt - >> desgInit newt ai desg + inferred <- inferArrayBoundFromInitializer ty + newt <- registerInferredArrayBound ty inferred + desgInit False newt ai desg | otherwise = do void $ lift lbrace case CT.toTypeKind ty of - CT.CTArray n bt -> do - (ast, idx) <- initLoop ty ai desg - (ai SQ.><) . (ast SQ.><) - <$> foldM - (\acc idx' -> (SQ.>< acc) <$> initZero bt (CT.DesgIdx idx' SQ.<| desg)) - SQ.empty - [fromIntegral idx..pred (fromIntegral n)] - _ -> fail "internal compiler error" - -desgInit :: (Integral i, Bits i, Read i, Show i) + CT.CTArray _ _ -> + bracedInitializerString False ty ai desg M.<|> do + (ast, idx) <- initLoop ty ai desg + (ast SQ.><) + <$> foldM + (\acc idx' -> (SQ.>< acc) <$> initZero (CT.toTypeKind elemTy) (CT.DesgIdx idx' SQ.<| desg)) + SQ.empty + [fromIntegral idx..pred (fromIntegral arrayLen)] + CT.CTStruct mems -> do + (ast, explicitMems, _) <- initStructLoop (orderedStructMembers mems) ai + (ast SQ.><) <$> zeroFillRemainingStructBytes ty explicitMems desg + CT.CTNamedStruct _ mems -> do + (ast, explicitMems, _) <- initStructLoop (orderedStructMembers mems) ai + (ast SQ.><) <$> zeroFillRemainingStructBytes ty explicitMems desg + _ -> do + rs <- desgInit False ty ai desg + void $ lift $ M.option () (() <$ comma) + lift rbrace + pure rs + where + elemTy = arrayElementType ty + arrayLen = fromMaybe 0 $ fixedArrayLength ty + initStructLoop mems ai' = initStructLoop' [] mems ai' <* lift rbrace + + initStructLoop' explicit [] ai' = pure (ai', explicit, []) + initStructLoop' explicit (mem:rest) ai' = do + rs <- desgInit True (CT.SCAuto $ CT.smType mem) ai' (CT.DesgMem mem SQ.<| desg) + let explicit' = mem : explicit + continue <- continueBracedAggregate + bool + (pure (rs, explicit', rest)) + (initStructLoop' explicit' rest rs) + continue + +initializerStructNoBraces :: (Integral i, Bits i, Read i, Show i, Ord i) + => [CT.StructMember i] + -> SQ.Seq (ATree i) + -> SQ.Seq (CT.Desg i) + -> DesignatorParser i (SQ.Seq (ATree i)) +initializerStructNoBraces mems ai desg = do + let structTy = structStorageClassFromMembers mems + (ast, explicitMems, _) <- initStructLoop [] mems ai + (ast SQ.><) <$> zeroFillRemainingStructBytes structTy explicitMems desg + where + initStructLoop explicit [] ai' = pure (ai', explicit, []) + initStructLoop explicit (mem:rest) ai' = do + rs <- desgInit True (CT.SCAuto $ CT.smType mem) ai' (CT.DesgMem mem SQ.<| desg) + let explicit' = mem : explicit + case rest of + [] -> pure (rs, explicit', []) + _ -> do + continue <- continueBraceElidedAggregate + bool + (pure (rs, explicit', rest)) + (initStructLoop explicit' rest rs) + continue + +initializerArrayNoBraces :: (Integral i, Bits i, Read i, Show i, Ord i) => CT.StorageClass i -> SQ.Seq (ATree i) -> SQ.Seq (CT.Desg i) -> DesignatorParser i (SQ.Seq (ATree i)) -desgInit ty ai desg = M.choice - [ lift lookInitializerString *> initializerString ty ai desg - , lift lookInitializerList *> initializerList ty ai desg - , ai <$ lift lookStructInit - , asks snd >>= lift >>= (flip desgNode desg >=> pure . (SQ.|>) ai) +initializerArrayNoBraces ty ai desg = case fixedArrayLength ty of + Just n -> do + let len = fromIntegral n + (ast, idx) <- initArrayLoop len bt 0 ai + (ast SQ.><) + <$> foldM + (\acc idx' -> (SQ.>< acc) <$> initZero bt (CT.DesgIdx idx' SQ.<| desg)) + SQ.empty + [fromIntegral idx..pred (fromIntegral n)] + Nothing -> fail "internal compiler error" + where + bt = CT.toTypeKind $ arrayElementType ty + initArrayLoop n bt idx ai' + | idx >= n = pure (ai', idx) + | otherwise = do + rs <- desgInit True (CT.SCAuto bt) ai' (CT.DesgIdx idx SQ.<| desg) + if idx == pred n + then pure (rs, succ idx) + else do + continue <- continueBraceElidedAggregate + bool + (pure (rs, succ idx)) + (initArrayLoop n bt (succ idx) rs) + continue + +desgInit :: (Integral i, Bits i, Read i, Show i, Ord i) + => Bool + -> CT.StorageClass i + -> SQ.Seq (ATree i) + -> SQ.Seq (CT.Desg i) + -> DesignatorParser i (SQ.Seq (ATree i)) +desgInit allowStructBraceElision ty ai desg = M.choice + [ lift (lookInitializerStringFor ty) *> initializerString allowStructBraceElision ty ai desg + , lift lookInitializerList *> leadingBraceInitializer + , braceElidedAggregateInit + , rejectScalarFallback *> scalarFallback ] where - lookInitializerString = bool M.empty (pure ()) =<< andM - [ pure $ CT.isArray ty - , pure $ maybe False ((==CT.CTChar) . CT.toTypeKind) (CT.deref ty) - , M.option False (True <$ M.lookAhead stringLiteral) - ] - lookInitializerList = bool M.empty (pure ()) $ CT.isArray ty - lookStructInit = bool M.empty (pure ()) $ CT.isCTStruct ty + lookInitializerList = bool M.empty (pure ()) =<< M.option False (True <$ M.lookAhead lbrace) + leadingBraceInitializer = initializerList ty ai desg + braceElidedAggregateInit + | allowStructBraceElision = case CT.toTypeKind ty of + CT.CTArray _ _ -> + rejectAggregateExpr "expected '{' to initialize an array" *> initializerArrayNoBraces ty ai desg + CT.CTStruct mems -> + rejectAggregateExpr "expected '{' to initialize a struct" *> initializerStructNoBraces (orderedStructMembers mems) ai desg + CT.CTNamedStruct _ mems -> + rejectAggregateExpr "expected '{' to initialize a struct" *> initializerStructNoBraces (orderedStructMembers mems) ai desg + _ -> + M.empty + | otherwise = M.empty + rejectScalarFallback = rejectScalarFallbackFor ty + scalarFallback = do + rhs <- asks snd >>= lift >>= validateScalarInitializer ty + (\stmt -> ai SQ.|> stmt) <$> desgNode rhs desg -varInit' :: (Integral i, Bits i, Read i, Show i) +varInit' :: (Integral i, Bits i, Read i, Show i, Ord i) => Parser i (ATree i) -> CT.StorageClass i -> T.Text -> ATree i -> Parser i (ATree i) -varInit' p ty ident lat - | CT.isArray ty || CT.isCTStruct ty = atBlock . toList <$> runDesignator (desgInit ty) ident p - | otherwise = p >>= fromValidAssignAST <&> atExprStmt . ATNode ATAssign (atype lat) lat +varInit' p ty ident _ = atBlock . toList <$> runDesignator (desgInit False ty) ident p -varInit :: (Integral i, Bits i, Read i, Show i) +varInit :: (Integral i, Bits i, Read i, Show i, Ord i) => Parser i (ATree i) -> CT.StorageClass i -> T.Text diff --git a/src/Htcc/Parser/ConstructionData/Core.hs b/src/Htcc/Parser/ConstructionData/Core.hs index 41d1fb5..f8aa135 100644 --- a/src/Htcc/Parser/ConstructionData/Core.hs +++ b/src/Htcc/Parser/ConstructionData/Core.hs @@ -39,30 +39,30 @@ module Htcc.Parser.ConstructionData.Core ( incomplete ) where -import Data.Bits (Bits (..)) -import Data.Maybe (fromJust) -import qualified Data.Sequence as SQ -import qualified Data.Text as T -import Data.Tuple.Extra (second) - -import qualified Htcc.CRules.Types as CT -import Htcc.Parser.AST.Core (ATree (..)) -import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) -import qualified Htcc.Parser.ConstructionData.Scope as AS -import qualified Htcc.Parser.ConstructionData.Scope.Enumerator as SE -import qualified Htcc.Parser.ConstructionData.Scope.Function as PF -import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) -import qualified Htcc.Parser.ConstructionData.Scope.Tag as PS -import qualified Htcc.Parser.ConstructionData.Scope.Typedef as PT -import qualified Htcc.Parser.ConstructionData.Scope.Var as PV -import qualified Htcc.Tokenizer.Token as HT - -import Control.Monad.State (modify) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Set as S -import Data.Void -import {-# SOURCE #-} Htcc.Parser.Combinators.ParserType -import qualified Text.Megaparsec as M +import Data.Bits (Bits (..)) +import Data.Maybe (fromJust) +import qualified Data.Sequence as SQ +import qualified Data.Text as T +import Data.Tuple.Extra (second) + +import qualified Htcc.CRules.Types as CT +import Htcc.Parser.AST.Core (ATree (..)) +import Htcc.Parser.ConstructionData.Scope (LookupVarResult (..)) +import qualified Htcc.Parser.ConstructionData.Scope as AS +import qualified Htcc.Parser.ConstructionData.Scope.Enumerator as SE +import qualified Htcc.Parser.ConstructionData.Scope.Function as PF +import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError) +import qualified Htcc.Parser.ConstructionData.Scope.Tag as PS +import qualified Htcc.Parser.ConstructionData.Scope.Typedef as PT +import qualified Htcc.Parser.ConstructionData.Scope.Var as PV +import qualified Htcc.Tokenizer.Token as HT + +import Control.Monad.State (modify) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Set as S +import Data.Void +import {-# SOURCE #-} Htcc.Parser.Combinators.ParserType +import qualified Text.Megaparsec as M -- | The warning messages type type Warnings = SQ.Seq (M.ParseErrorBundle T.Text Void) @@ -71,9 +71,10 @@ type Warnings = SQ.Seq (M.ParseErrorBundle T.Text Void) -- Contains error messages and scope information. data ConstructionData i = ConstructionData -- ^ The constructor of ConstructionData { - warns :: Warnings, -- ^ The warning messages - scope :: AS.Scoped i, -- ^ Scope type - isSwitchStmt :: Bool -- ^ When the statement is @switch@, this flag will be `True`, otherwise will be `False`. + warns :: Warnings, -- ^ The warning messages + scope :: AS.Scoped i, -- ^ Scope type + isSwitchStmt :: Bool, -- ^ When the statement is @switch@, this flag will be `True`, otherwise will be `False`. + allowSameInputExternalCollisions :: Bool -- ^ When `True`, same-input globals and function declarations may coexist so multi-input `-o` merge can resolve them. } deriving Show {-# INLINE applyScope #-} @@ -96,11 +97,22 @@ addLVar = addVar AS.addLVar -- -- >>> second (\x -> y { scope = x }) <$> Htcc.Parser.AST.Scope.addGVar ty tkn (scope x) addGVar :: (Integral i, Bits i) => CT.StorageClass i -> HT.TokenLC i -> ConstructionData i -> Either (ASTError i) (ATree i, ConstructionData i) -addGVar = addVar AS.addGVar +addGVar ty tkn cd = + addVar + (if allowSameInputExternalCollisions cd then AS.addGVarAllowFunctionConflict else AS.addGVar) + ty + tkn + cd -- | Shortcut to function `Htcc.Parser.AST.Scope.addGVarWith` for variable @x@ of tye `ConstructionData`. addGVarWith :: (Integral i, Bits i) => CT.StorageClass i -> HT.TokenLC i -> PV.GVarInitWith i -> ConstructionData i -> Either (ASTError i) (ATree i, ConstructionData i) -addGVarWith ty tkn iw cd = applyScope cd <$> AS.addGVarWith ty tkn iw (scope cd) +addGVarWith ty tkn iw cd = + applyScope cd <$> + (if allowSameInputExternalCollisions cd then AS.addGVarWithAllowFunctionConflict else AS.addGVarWith) + ty + tkn + iw + (scope cd) -- | Shortcut to function `Htcc.Parser.AST.Scope.addLiteral` for variable @x@ of type `ConstructionData`. -- This function is equivalent to @@ -195,8 +207,15 @@ addTypedef ty tkn cd = (\x -> cd { scope = x }) <$> AS.addTypedef ty tkn (scope -- This function is equivalent to -- -- >>> (\y -> x { scope = y }) <$> Htcc.Parser.AST.Scope.addFunction ty tkn (scope x) -addFunction :: Num i => Bool -> CT.StorageClass i -> HT.TokenLC i -> ConstructionData i -> Either (ASTError i) (ConstructionData i) -addFunction fd ty tkn cd = (\x -> cd { scope = x }) <$> AS.addFunction fd ty tkn (scope cd) +addFunction :: (Eq i, Num i) => Bool -> Bool -> CT.StorageClass i -> HT.TokenLC i -> ConstructionData i -> Either (ASTError i) (ConstructionData i) +addFunction fd isImplicit ty tkn cd = + (\x -> cd { scope = x }) <$> + (if allowSameInputExternalCollisions cd then AS.addFunctionAllowGlobalConflict else AS.addFunction) + fd + isImplicit + ty + tkn + (scope cd) -- | Shortcut to function `Htcc.Parser.AST.Scope.addEnumerator` for variable @x@ of type `ConstructionData`. -- This function is equivalent to @@ -208,7 +227,7 @@ addEnumerator ty tkn n cd = (\x -> cd { scope = x }) <$> AS.addEnumerator ty tkn -- | Shortcut to the initial state of `ConstructionData`. {-# INLINE initConstructionData #-} initConstructionData :: ConstructionData i -initConstructionData = ConstructionData SQ.empty AS.initScope False +initConstructionData = ConstructionData SQ.empty AS.initScope False False -- | Shortcut to function `Htcc.Parser.AST.Scope.resetLocal` for variable @x@ of type `ConstructionData`. -- This function is equivalent to diff --git a/src/Htcc/Parser/ConstructionData/Core.hs-boot b/src/Htcc/Parser/ConstructionData/Core.hs-boot index 27f2660..96ec009 100644 --- a/src/Htcc/Parser/ConstructionData/Core.hs-boot +++ b/src/Htcc/Parser/ConstructionData/Core.hs-boot @@ -10,7 +10,8 @@ type Warnings = SQ.Seq (M.ParseErrorBundle T.Text Void) data ConstructionData i = ConstructionData { - warns :: Warnings, - scope :: AS.Scoped i, - isSwitchStmt :: Bool + warns :: Warnings, + scope :: AS.Scoped i, + isSwitchStmt :: Bool, + allowSameInputExternalCollisions :: Bool } diff --git a/src/Htcc/Parser/ConstructionData/Scope.hs b/src/Htcc/Parser/ConstructionData/Scope.hs index 08b0b78..0facc86 100644 --- a/src/Htcc/Parser/ConstructionData/Scope.hs +++ b/src/Htcc/Parser/ConstructionData/Scope.hs @@ -9,7 +9,7 @@ Portability : POSIX The Data type of variables and its utilities used in parsing -} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} module Htcc.Parser.ConstructionData.Scope ( -- * The types Scoped (..), @@ -17,11 +17,14 @@ module Htcc.Parser.ConstructionData.Scope ( -- * Operations for scope addLVar, addGVar, + addGVarAllowFunctionConflict, addGVarWith, + addGVarWithAllowFunctionConflict, addLiteral, addTag, addTypedef, addFunction, + addFunctionAllowGlobalConflict, addEnumerator, succNest, fallBack, @@ -79,6 +82,29 @@ data LookupVarResult i = FoundGVar (PV.GVar i) -- ^ A type constructor indicati applyVars :: Scoped i -> (a, PV.Vars i) -> (a, Scoped i) applyVars sc = second (\x -> sc { vars = x }) +{-# INLINE identifierFromToken #-} +identifierFromToken :: HT.TokenLC i -> Maybe T.Text +identifierFromToken (_, HT.TKIdent ident) = Just ident +identifierFromToken _ = Nothing + +{-# INLINE rejectFunctionNameConflict #-} +rejectFunctionNameConflict :: HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) () +rejectFunctionNameConflict tkn sc = case identifierFromToken tkn of + Just ident + | Just _ <- lookupFunction ident sc -> + Left ("redeclaration of '" <> ident <> "' with no linkage", tkn) + _ -> + Right () + +{-# INLINE rejectGlobalNameConflict #-} +rejectGlobalNameConflict :: HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) () +rejectGlobalNameConflict tkn sc = case identifierFromToken tkn of + Just ident + | Just _ <- lookupGVar ident sc -> + Left ("conflicting types for '" <> ident <> "'", tkn) + _ -> + Right () + {-# INLINE addVar #-} addVar :: (Integral i, Bits i) => (CT.StorageClass i -> HT.TokenLC i -> PV.Vars i -> Either (T.Text, HT.TokenLC i) (ATree i, PV.Vars i)) -> CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (ATree i, Scoped i) addVar f ty tkn sc = applyVars sc <$> f ty tkn (vars sc) @@ -91,12 +117,22 @@ addLVar ty tkn scp = addVar (PV.addLVar $ curNestDepth scp) ty tkn scp -- | `addGVar` has a scoped type argument and is the same function as `PV.addGVar` internally. {-# INLINE addGVar #-} addGVar :: (Integral i, Bits i) => CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (ATree i, Scoped i) -addGVar = addVar PV.addGVar +addGVar ty tkn sc = rejectFunctionNameConflict tkn sc *> addVar PV.addGVar ty tkn sc + +{-# INLINE addGVarAllowFunctionConflict #-} +addGVarAllowFunctionConflict :: (Integral i, Bits i) => CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (ATree i, Scoped i) +addGVarAllowFunctionConflict ty tkn sc = addVar PV.addGVar ty tkn sc -- | `addGVarWith` has a scoped type argument and is the same function as `PV.addLiteral` internally. {-# INLINE addGVarWith #-} addGVarWith :: (Integral i, Bits i) => CT.StorageClass i -> HT.TokenLC i -> PV.GVarInitWith i -> Scoped i -> Either (SM.ASTError i) (ATree i, Scoped i) -addGVarWith ty tkn iw sc = applyVars sc <$> PV.addGVarWith ty tkn iw (vars sc) +addGVarWith ty tkn iw sc = + rejectFunctionNameConflict tkn sc *> (applyVars sc <$> PV.addGVarWith ty tkn iw (vars sc)) + +{-# INLINE addGVarWithAllowFunctionConflict #-} +addGVarWithAllowFunctionConflict :: (Integral i, Bits i) => CT.StorageClass i -> HT.TokenLC i -> PV.GVarInitWith i -> Scoped i -> Either (SM.ASTError i) (ATree i, Scoped i) +addGVarWithAllowFunctionConflict ty tkn iw sc = + applyVars sc <$> PV.addGVarWith ty tkn iw (vars sc) -- | `addLiteral` has a scoped type argument and is the same function as `PV.addLiteral` internally. {-# INLINE addLiteral #-} @@ -143,7 +179,7 @@ lookupVar ident scp = case lookupLVar ident scp of Just enum -> FoundEnum enum _ -> case lookupGVar ident scp of Just gvar -> FoundGVar gvar - _ -> maybe NotFound FoundFunc $ lookupFunction ident scp + _ -> maybe NotFound FoundFunc $ lookupFunction ident scp -- | `lookupTag` has a scoped type argument and is the same function as `PS.lookupTag` internally. {-# INLINE lookupTag #-} @@ -177,8 +213,14 @@ addTypedef ty tkn sc = (\x -> sc { typedefs = x }) <$> PT.add (curNestDepth sc) -- | `addFunction` has a scoped type argument and is the same function as `PT.add` internally. {-# INLINE addFunction #-} -addFunction :: Num i => Bool -> CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (Scoped i) -addFunction fd ty tkn sc = (\x -> sc { functions = x }) <$> PF.add fd ty tkn (functions sc) +addFunction :: (Eq i, Num i) => Bool -> Bool -> CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (Scoped i) +addFunction fd isImplicit ty tkn sc = + rejectGlobalNameConflict tkn sc *> ((\x -> sc { functions = x }) <$> PF.add fd isImplicit ty tkn (functions sc)) + +{-# INLINE addFunctionAllowGlobalConflict #-} +addFunctionAllowGlobalConflict :: (Eq i, Num i) => Bool -> Bool -> CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (Scoped i) +addFunctionAllowGlobalConflict fd isImplicit ty tkn sc = + (\x -> sc { functions = x }) <$> PF.add fd isImplicit ty tkn (functions sc) -- | `addEnumerator` has a scoped type argument and is the same function as `SE.add` internally. {-# INLINE addEnumerator #-} diff --git a/src/Htcc/Parser/ConstructionData/Scope/Function.hs b/src/Htcc/Parser/ConstructionData/Scope/Function.hs index 338ff04..71ef9ed 100644 --- a/src/Htcc/Parser/ConstructionData/Scope/Function.hs +++ b/src/Htcc/Parser/ConstructionData/Scope/Function.hs @@ -21,7 +21,6 @@ import qualified Data.Map as M import qualified Data.Text as T import GHC.Generics (Generic (..)) -import Htcc.Parser.AST.Core (Treealizable (..), ATree (..), ATKind (..), atUnary) import qualified Htcc.CRules.Types as CT import Htcc.Parser.ConstructionData.Scope.ManagedScope import Htcc.Parser.ConstructionData.Scope.Utils (internalCE) @@ -30,8 +29,9 @@ import qualified Htcc.Tokenizer.Token as HT -- | The data type of a typedef tag data Function a = Function -- ^ The contypedefor of a typedef tag { - fntype :: CT.StorageClass a, -- ^ The type of this typedef - fnDefined :: Bool -- ^ If the function is defined, it will be `True`, otherwise will be `False`. + fntype :: CT.StorageClass a, -- ^ The type of this typedef + fnDefined :: Bool, -- ^ If the function is defined, it will be `True`, otherwise will be `False`. + fnImplicit :: Bool -- ^ `True` only when the function only exists because of an implicit declaration synthesized from a call site. } deriving (Eq, Ord, Show, Generic) instance NFData a => NFData (Function a) @@ -41,10 +41,6 @@ instance ManagedScope (Function i) where fallBack = flip const initial = M.empty --- TODO: allow function pointer -instance Treealizable Function where - treealize (Function ftype _) = atUnary ATFuncPtr ftype ATEmpty - -- | The typedefs data typedefs type Functions i = M.Map T.Text (Function i) @@ -53,11 +49,44 @@ type Functions i = M.Map T.Text (Function i) -- return an error message and its location as a pair. -- Otherwise, add a new tag to `Functions` and return it. -- If the token does not indicate an identifier, an error indicating internal compiler error is returned. -add :: Num i => Bool -> CT.StorageClass i -> HT.TokenLC i -> Functions i -> Either (ASTError i) (Functions i) -add df t cur@(_, HT.TKIdent ident) sts = case M.lookup ident sts of - Just foundFunc - | not (fnDefined foundFunc) -> Right $ M.insert ident (Function t True) sts - | otherwise -> Left ("conflicting types for '" <> ident <> "'", cur) -- ODR - Nothing -> Right $ M.insert ident (Function t df) sts -add _ _ _ _ = Left (internalCE, (HT.TokenLCNums 0 0, HT.TKEmpty)) +add :: (Eq i, Num i) => Bool -> Bool -> CT.StorageClass i -> HT.TokenLC i -> Functions i -> Either (ASTError i) (Functions i) +add df isImplicit t cur@(_, HT.TKIdent ident) sts = case M.lookup ident sts of + Just foundFunc -> + case mergeFunctionTypes (fntype foundFunc) t of + Nothing -> + Left ("conflicting types for '" <> ident <> "'", cur) + Just mergedType + | fnDefined foundFunc && df -> + Left ("conflicting types for '" <> ident <> "'", cur) + | otherwise -> + Right $ + M.insert + ident + Function + { fntype = mergedType + , fnDefined = fnDefined foundFunc || df + , fnImplicit = fnImplicit foundFunc && isImplicit + } + sts + Nothing -> + Right $ + M.insert + ident + Function + { fntype = t + , fnDefined = df + , fnImplicit = isImplicit + } + sts +add _ _ _ _ _ = Left (internalCE, (HT.TokenLCNums 0 0, HT.TKEmpty)) +mergeFunctionTypes :: Eq i => CT.StorageClass i -> CT.StorageClass i -> Maybe (CT.StorageClass i) +mergeFunctionTypes (CT.SCAuto lhs) (CT.SCAuto rhs) = + CT.SCAuto <$> CT.mergeCompatibleTypeKinds lhs rhs +mergeFunctionTypes (CT.SCStatic lhs) (CT.SCStatic rhs) = + CT.SCStatic <$> CT.mergeCompatibleTypeKinds lhs rhs +mergeFunctionTypes (CT.SCRegister lhs) (CT.SCRegister rhs) = + CT.SCRegister <$> CT.mergeCompatibleTypeKinds lhs rhs +mergeFunctionTypes (CT.SCUndef lhs) (CT.SCUndef rhs) = + CT.SCUndef <$> CT.mergeCompatibleTypeKinds lhs rhs +mergeFunctionTypes _ _ = Nothing diff --git a/src/Htcc/Parser/ConstructionData/Scope/Var.hs b/src/Htcc/Parser/ConstructionData/Scope/Var.hs index d116e92..2d10556 100644 --- a/src/Htcc/Parser/ConstructionData/Scope/Var.hs +++ b/src/Htcc/Parser/ConstructionData/Scope/Var.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric, LambdaCase, OverloadedStrings #-} {-| Module : Htcc.Parser.ConstructionData.Scope.Var Description : The Data type of variables and its utilities used in parsing @@ -15,6 +15,7 @@ module Htcc.Parser.ConstructionData.Scope.Var ( Var (..), -- * The data type SomeVars, + GVarInitData (..), GVarInitWith (..), GVar (..), LVar (..), @@ -32,6 +33,7 @@ module Htcc.Parser.ConstructionData.Scope.Var ( addGVar, addLiteral, -- * Utilities + materializeTentativeIncompleteArray, initVars, resetLocal, fallBack @@ -41,6 +43,7 @@ import Control.DeepSeq (NFData (..)) import Data.Bits (Bits (..)) import qualified Data.ByteString as B import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) import qualified Data.Text as T import GHC.Generics (Generic, Generic1) @@ -63,19 +66,64 @@ class Var a where vtype :: a i -> CT.StorageClass i -- | The informations type about initial value of the global variable -data GVarInitWith i = GVarInitWithZero | GVarInitWithOG T.Text | GVarInitWithVal i +data GVarInitData i + = GVarInitZeroBytes Natural + | GVarInitBytes Natural i + | GVarInitReloc Natural T.Text Integer deriving (Eq, Ord, Show, Generic) -instance NFData i => NFData (GVarInitWith i) +instance NFData i => NFData (GVarInitData i) + +-- | The informations type about initial value of the global variable +data GVarInitWith i + = GVarInitWithZero + | GVarInitWithOG T.Text + | GVarInitWithVal i + | GVarInitWithData [GVarInitData i] + | GVarInitWithAST (ATree i) + deriving (Eq, Show, Generic) + +instance NFData i => NFData (GVarInitWith i) where + rnf GVarInitWithZero = () + rnf (GVarInitWithOG ref) = rnf ref + rnf (GVarInitWithVal val) = rnf val + rnf (GVarInitWithData ds) = rnf ds + rnf (GVarInitWithAST ast) = ast `seq` () -- | The data type of the global variable data GVar i = GVar -- ^ The constructor of the global variable { gvtype :: CT.StorageClass i, -- ^ The type of the global variable initWith :: GVarInitWith i -- ^ The informations about initial value of the global variable - } deriving (Eq, Ord, Show, Generic) + } deriving (Eq, Show, Generic) + +instance NFData i => NFData (GVar i) where + rnf (GVar ty iw) = rnf ty `seq` rnf iw -instance NFData i => NFData (GVar i) +materializeTentativeIncompleteArray :: Ord i => GVar i -> GVar i +materializeTentativeIncompleteArray gvar = case initWith gvar of + GVarInitWithZero -> + gvar { gvtype = CT.mapTypeKind materializeTentativeArrayType $ gvtype gvar } + _ -> + gvar + where + materializeTentativeArrayType = go + where + go (CT.CTArray n innerTy) = CT.CTArray n $ go innerTy + go (CT.CTIncomplete (CT.IncompleteArray elemTy)) = + materializeIncompleteArray elemTy + go ty = ty + + materializeIncompleteArray elemTy + | CT.isCTArray elemTy = + fromMaybe fallback $ + CT.concatCTArray + (CT.makeCTArray [1] $ CT.removeAllExtents elemTy) + elemTy + | otherwise = + fallback + where + fallback = CT.CTArray 1 elemTy instance Var GVar where vtype = gvtype @@ -196,16 +244,49 @@ addLVar _ _ _ _ = Left (internalCE, HT.emptyToken) -- | If the specified token is `HT.TKIdent` and the global variable does not exist in the list, `addLVar` adds a new global variable to the list, -- constructs a pair with the node representing the variable, wraps it in `Right` and return it. Otherwise, returns an error message and token pair wrapped in `Left`. -addGVarWith :: Num i => CT.StorageClass i -> HT.TokenLC i -> GVarInitWith i -> Vars i -> Either (SM.ASTError i) (ATree i, Vars i) -addGVarWith t cur@(_, HT.TKIdent ident) iw vars = flip (flip maybe $ const $ Left ("redeclaration of '" <> ident <> "' with no linkage", cur)) (lookupGVar ident vars) $ -- ODR - Right (atGVar (gvtype gvar) ident, vars { globals = M.insert ident gvar $ globals vars }) +addGVarWith :: (Ord i, Num i) => CT.StorageClass i -> HT.TokenLC i -> GVarInitWith i -> Vars i -> Either (SM.ASTError i) (ATree i, Vars i) +addGVarWith t cur@(_, HT.TKIdent ident) iw vars = + case lookupGVar ident vars of + Nothing -> pure inserted + Just existing -> + (\merged -> (atGVar (gvtype merged) ident, vars { globals = M.insert ident merged $ globals vars })) + <$> mergeGVar existing new where - gvar = GVar t iw + new = GVar t iw + inserted = (atGVar (gvtype new) ident, vars { globals = M.insert ident new $ globals vars }) + + mergeGVar lhs rhs = case mergeGVarTypes (gvtype lhs) (gvtype rhs) of + Nothing -> Left ("redeclaration of '" <> ident <> "' with no linkage", cur) + Just mergedType + | isTentativeGVar lhs && isTentativeGVar rhs -> + Right $ lhs { gvtype = mergedType } + | isTentativeGVar lhs -> + Right $ rhs { gvtype = mergedType } + | isTentativeGVar rhs -> + Right $ lhs { gvtype = mergedType } + | otherwise -> + Left ("redeclaration of '" <> ident <> "' with no linkage", cur) + + isTentativeGVar gvar = case initWith gvar of + GVarInitWithZero -> True + _ -> False + + mergeGVarTypes lhsTy' rhsTy' = case (lhsTy', rhsTy') of + (CT.SCAuto lhsTy, CT.SCAuto rhsTy) -> + CT.SCAuto <$> CT.mergeCompatibleTypeKinds lhsTy rhsTy + (CT.SCStatic lhsTy, CT.SCStatic rhsTy) -> + CT.SCStatic <$> CT.mergeCompatibleTypeKinds lhsTy rhsTy + (CT.SCRegister lhsTy, CT.SCRegister rhsTy) -> + CT.SCRegister <$> CT.mergeCompatibleTypeKinds lhsTy rhsTy + (CT.SCUndef lhsTy, CT.SCUndef rhsTy) -> + CT.SCUndef <$> CT.mergeCompatibleTypeKinds lhsTy rhsTy + _ -> + Nothing addGVarWith _ _ _ _ = Left (internalCE, (HT.TokenLCNums 0 0, HT.TKEmpty)) -- | If the specified token is `HT.TKIdent` and the global variable does not exist in the list, `addLVar` adds a new global variable that will be initialized by zero to the list, -- constructs a pair with the node representing the variable, wraps it in `Right` and return it. Otherwise, returns an error message and token pair wrapped in `Left`. -addGVar :: Num i => CT.StorageClass i -> HT.TokenLC i -> Vars i -> Either (SM.ASTError i) (ATree i, Vars i) +addGVar :: (Ord i, Num i) => CT.StorageClass i -> HT.TokenLC i -> Vars i -> Either (SM.ASTError i) (ATree i, Vars i) addGVar t ident = addGVarWith t ident GVarInitWithZero -- | If the specified token is `HT.TKString`, `addLiteral` adds a new literal to the list, diff --git a/src/Htcc/Tokenizer/Core.hs b/src/Htcc/Tokenizer/Core.hs index 2d98385..0b3af68 100644 --- a/src/Htcc/Tokenizer/Core.hs +++ b/src/Htcc/Tokenizer/Core.hs @@ -17,6 +17,7 @@ module Htcc.Tokenizer.Core ( import Control.Applicative (Alternative (..)) import Control.Conditional (ifM) +import Control.Monad (replicateM_) import Control.Monad.Extra (firstJustM) import Control.Monad.State import Data.Char (digitToInt, diff --git a/src/Htcc/Visualizer/Core.hs b/src/Htcc/Visualizer/Core.hs index a21e9cc..8d2e214 100644 --- a/src/Htcc/Visualizer/Core.hs +++ b/src/Htcc/Visualizer/Core.hs @@ -11,6 +11,7 @@ Build AST from C source code -} {-# LANGUAGE FlexibleContexts, OverloadedStrings #-} module Htcc.Visualizer.Core ( + mkWidth, visualize ) where @@ -64,6 +65,8 @@ encodeTree (ATNode ATGEQ _ l r) = Node ">=" [encodeTree l, encodeTree r] encodeTree (ATNode ATEQ _ l r) = Node "==" [encodeTree l, encodeTree r] encodeTree (ATNode ATNEQ _ l r) = Node "!=" [encodeTree l, encodeTree r] encodeTree (ATNode ATNot _ l _) = Node "!" [encodeTree l] +encodeTree (ATNode ATSizeof _ l _) = Node "sizeof" [encodeTree l] +encodeTree (ATNode ATAlignof _ l _) = Node "_Alignof" [encodeTree l] encodeTree (ATNode ATAddr _ l _) = Node "&" [encodeTree l] encodeTree (ATNode ATDeref _ l _) = Node "*" [encodeTree l] encodeTree (ATNode ATAssign _ l r) = Node "=" [encodeTree l, encodeTree r] @@ -91,10 +94,13 @@ encodeTree (ATNode (ATLabel lbl) _ l r) = Node (":" ++ T.unpack lbl) [encodeTree encodeTree (ATNode (ATBlock xs) _ _ _) = Node "{}" $ map encodeTree xs encodeTree (ATNode (ATLVar t o) _ l r) = Node (show t ++ " lvar" ++ show o) [encodeTree l, encodeTree r] encodeTree (ATNode (ATGVar t n) _ l r) = Node (show t ++ " " ++ T.unpack n) [encodeTree l, encodeTree r] +encodeTree (ATNode (ATFuncPtr name) _ _ _) = Node ("funcptr " ++ T.unpack name) [] encodeTree (ATNode (ATDefFunc fname Nothing) t lhs _) = Node (show (CT.toTypeKind t) ++ " " ++ T.unpack fname ++ "()") [encodeTree lhs] encodeTree (ATNode (ATDefFunc fname (Just args)) t lhs _) = Node (show (CT.toTypeKind t) ++ " " ++ T.unpack fname ++ "(some arguments)") $ map encodeTree args ++ [encodeTree lhs] encodeTree (ATNode (ATCallFunc fname Nothing) _ lhs rhs) = Node (T.unpack fname ++ "()") [encodeTree lhs, encodeTree rhs] encodeTree (ATNode (ATCallFunc fname (Just args)) _ lhs rhs) = Node (T.unpack fname ++ "(some arguments)") $ map encodeTree args ++ [encodeTree lhs, encodeTree rhs] +encodeTree (ATNode (ATCallPtr Nothing) _ lhs rhs) = Node "(*)(...)" [encodeTree lhs, encodeTree rhs] +encodeTree (ATNode (ATCallPtr (Just args)) _ lhs rhs) = Node "(*)(some arguments)" $ encodeTree lhs : map encodeTree args ++ [encodeTree rhs] encodeTree (ATNode ATExprStmt _ lhs _) = encodeTree lhs encodeTree (ATNode (ATStmtExpr exps) _ lhs rhs) = Node "({})" $ map encodeTree exps ++ [encodeTree lhs, encodeTree rhs] encodeTree (ATNode (ATNull _) _ _ _) = Node "" [] diff --git a/src/Text/Megaparsec.hs b/src/Text/Megaparsec.hs index 5d2ef1d..a1e239f 100644 --- a/src/Text/Megaparsec.hs +++ b/src/Text/Megaparsec.hs @@ -26,6 +26,7 @@ module Text.Megaparsec ( setInput, getSourcePos, getParserState, + setParserState, withRecovery, parseError, empty, @@ -79,7 +80,8 @@ data PosState s = PosState deriving (Eq, Show) data ParserState s = ParserState - { statePosState :: PosState s + { stateInput :: s + , statePosState :: PosState s } deriving (Eq, Show) @@ -196,9 +198,23 @@ getSourcePos = ParsecT P.getPosition getParserState :: Monad m => ParsecT e T.Text m (ParserState T.Text) getParserState = ParsecT $ do - input <- P.getState - pos <- P.getPosition - pure $ ParserState (PosState input pos) + parserState <- PPri.getParserState + pure $ ParserState + { stateInput = PPri.stateInput parserState + , statePosState = PosState + { pstateInput = PPri.stateUser parserState + , pstateSourcePos = PPri.statePos parserState + } + } + +setParserState :: Monad m => ParserState T.Text -> ParsecT e T.Text m () +setParserState parserState = ParsecT $ + () <$ PPri.setParserState + PPri.State + { PPri.stateInput = stateInput parserState + , PPri.statePos = pstateSourcePos $ statePosState parserState + , PPri.stateUser = pstateInput $ statePosState parserState + } withRecovery :: Monad m diff --git a/test/Spec.hs b/test/Spec.hs index b9fab68..2bc0fd9 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -16,8 +16,8 @@ import Dhall.Yaml (Options (..), defaultOptions, dhallToYaml) import Htcc.Utils (tshow) import qualified Options.Applicative as OA -import System.Directory (createDirectoryIfMissing) -import System.Directory (doesDirectoryExist, listDirectory) +import System.Directory (createDirectoryIfMissing, + doesDirectoryExist, listDirectory) import System.FilePath (()) import System.IO (hFlush, stdout) import System.Process (readCreateProcess, shell) @@ -92,9 +92,10 @@ genTestAsm' = lift (createDirectoryIfMissing False workDir *> createDirectoryIfM mkBin fname = do outAsmName <- gets (\n -> T.pack (asmDir "spec") <> tshow n <> ".s") lift $ + htccCommand >>= \htccCmd -> T.putStr ("[compiling] " <> fname) *> hFlush stdout - *> execErrFin ("stack exec htcc -- " <> fname <> " > " <> outAsmName) + *> execErrFin (htccCmd <> " " <> fname <> " > " <> outAsmName) *> T.putStrLn (" -> " <> outAsmName) outAsmName <$ modify succ @@ -106,10 +107,18 @@ genTestBins' = (genTestAsm' <* put 0) >>= mapM f where f fname = do binName <- gets (\n -> T.pack (workDir "spec") <> tshow n <> ".out") + asmCmd <- lift $ assemblerCommand + [ "-x" + , "assembler" + , "-no-pie" + , "-o" + , T.unpack binName + , T.unpack fname + ] lift $ T.putStr ("[assembling] " <> fname) *> hFlush stdout - *> execErrFin ("gcc -xassembler -no-pie -o " <> binName <> " " <> fname) + *> execErrFin asmCmd *> T.putStrLn (" -> " <> binName) binName <$ modify succ diff --git a/test/Tests/ComponentsTests.hs b/test/Tests/ComponentsTests.hs index 5e46003..a13b724 100644 --- a/test/Tests/ComponentsTests.hs +++ b/test/Tests/ComponentsTests.hs @@ -2,12 +2,14 @@ module Tests.ComponentsTests ( exec ) where -import Tests.Utils hiding (exec) +import Tests.Utils hiding (exec) -- import Test.HUnit (Test (..)) -import Tests.ComponentsTests.Parser.Combinators as PC +import qualified Tests.ComponentsTests.AsmOutput as AsmOutput +import Tests.ComponentsTests.Parser.Combinators as PC exec :: IO () -exec = runTests $ +exec = runTests $ TestList [ - PC.test + AsmOutput.test + , PC.test ] diff --git a/test/Tests/ComponentsTests/AsmOutput.hs b/test/Tests/ComponentsTests/AsmOutput.hs new file mode 100644 index 0000000..17542bf --- /dev/null +++ b/test/Tests/ComponentsTests/AsmOutput.hs @@ -0,0 +1,1818 @@ +{-# LANGUAGE OverloadedStrings #-} +module Tests.ComponentsTests.AsmOutput ( + test +) where + +import Control.Exception (IOException, + finally, try) +import qualified Data.ByteString as B +import Data.Either (isLeft) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Void (Void) +import Htcc.Asm (casm', + normalizeAsmInput, + prepareAsmInput) +import qualified Htcc.Asm.Intrinsic.Structure.Internal as SI +import qualified Htcc.CRules.Types as CT +import Htcc.Output (ReplacementOutputMode (..), + creationMaskedOutputMode, + replaceExistingOutputFromPathWith, + withReplacementOutputPath) +import Htcc.Parser (ASTs, ATKind (..), + ATree (..)) +import Htcc.Parser.Combinators (parser, runParser) +import Htcc.Parser.ConstructionData.Core (Warnings) +import qualified Htcc.Parser.ConstructionData.Scope.Function as PF +import Htcc.Parser.ConstructionData.Scope.Var (GVar (..), + GVarInitWith (..), + GlobalVars, + Literals, + materializeTentativeIncompleteArray) +import Htcc.Visualizer (mkWidth, + visualize) +import System.Directory (createDirectory, + doesDirectoryExist, + getTemporaryDirectory, + removeDirectory, + removeFile) +import System.IO (IOMode (ReadMode, WriteMode), + hClose, + openTempFile, + withBinaryFile) +import System.IO.Error (catchIOError) +import System.Posix.Files (createLink, + fileMode, + getFileStatus, + intersectFileModes, + ownerExecuteMode, + ownerReadMode, + ownerWriteMode, + setFileMode, + unionFileModes) +import System.Posix.IO (closeFd, + createFile) +import System.Posix.Temp (mkdtemp) +import System.Posix.Types (FileMode) +import Test.HUnit (Test (..), + assertBool, + assertEqual, + assertFailure) +import qualified Text.Megaparsec as M + +parseAsmSource :: T.Text -> IO (ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) +parseAsmSource source = + case runParser parser "" source + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) of + Left err -> + assertFailure (M.errorBundlePretty err) + Right (_, asts, gvars, lits, funcs) -> + pure (asts, gvars, lits, funcs) + +renderAsm :: T.Text -> IO T.Text +renderAsm = renderAsmWith id + +renderAsmWith :: (GlobalVars Integer -> GlobalVars Integer) -> T.Text -> IO T.Text +renderAsmWith transformGVars source = do + tmpDir <- getTemporaryDirectory + (path, h) <- openTempFile tmpDir "htcc-components-asm.s" + flip finally (ignoreIOException (hClose h) >> ignoreIOException (removeFile path)) $ do + (asts, gvars, lits, funcs) <- parseAsmSource source + SI.runAsmWithHandle h (casm' asts (transformGVars gvars) lits funcs :: SI.Asm SI.AsmCodeCtx Integer ()) + hClose h + T.readFile path + where + ignoreIOException = flip catchIOError $ const $ pure () + +renderVisualization :: T.Text -> IO T.Text +renderVisualization source = do + tmpDir <- getTemporaryDirectory + (path, h) <- openTempFile tmpDir "htcc-components-visualizer.svg" + flip finally (ignoreIOException (hClose h) >> ignoreIOException (removeFile path)) $ do + hClose h + (asts, _, _, _) <- parseAsmSource source + visualize asts (mkWidth 200) path + T.readFile path + where + ignoreIOException = flip catchIOError $ const $ pure () + +assertContains :: String -> [T.Text] -> T.Text -> IO () +assertContains label needles haystack = + assertBool label $ all (`T.isInfixOf` haystack) needles + +assertContainsInOrder :: String -> [T.Text] -> T.Text -> IO () +assertContainsInOrder label needles haystack = + assertBool label $ go needles (T.lines haystack) + where + go [] _ = True + go _ [] = False + go remaining@(needle:rest) (line:lines') + | needle `T.isInfixOf` line = go rest lines' + | otherwise = go remaining lines' + +assertOccursBefore :: String -> T.Text -> T.Text -> T.Text -> IO () +assertOccursBefore label first second haystack = + assertBool label $ + case (T.breakOn first haystack, T.breakOn second haystack) of + ((_, restFirst), (_, restSecond)) + | T.null restFirst || T.null restSecond -> False + | otherwise -> T.length restFirst > T.length restSecond + +replacementFailurePreservesWriteOnlyOutputTest :: ReplacementOutputMode -> T.Text -> FileMode -> Test +replacementFailurePreservesWriteOnlyOutputTest modeStrategy label targetMode = TestLabel (T.unpack label) $ TestCase $ do + tmpDir <- getTemporaryDirectory + (targetPath, targetHandle) <- openTempFile tmpDir "htcc-output-target" + (stagedPath, stagedHandle) <- openTempFile tmpDir "htcc-output-staged" + let cleanup = + ignoreIOException (hClose targetHandle) + >> ignoreIOException (hClose stagedHandle) + >> ignoreIOException (removeFile targetPath) + >> ignoreIOException (removeFile stagedPath) + failDuringReplacement src dst + | src == stagedPath = + withBinaryFile src ReadMode $ \srcHandle -> + withBinaryFile dst WriteMode $ \dstHandle -> do + chunk <- B.hGetSome srcHandle 4 + B.hPut dstHandle chunk + ioError $ userError "simulated replacement failure" + | otherwise = + assertFailure "unexpected replacement source path" + flip finally cleanup $ do + hClose targetHandle + hClose stagedHandle + T.writeFile targetPath staleOutput + setFileMode targetPath targetMode + T.writeFile stagedPath replacementOutput + stagedMode <- fileMode <$> getFileStatus stagedPath + result <- try + (replaceExistingOutputFromPathWith failDuringReplacement modeStrategy targetPath targetMode stagedMode stagedPath) + :: IO (Either IOException ()) + case result of + Left _ -> pure () + Right _ -> assertFailure "replacement should fail after partially overwriting the target" + restoredMode <- fileMode <$> getFileStatus targetPath + setFileMode targetPath $ restoredMode `unionFileModes` ownerReadMode + restoredOutput <- T.readFile targetPath + assertEqual "restored file mode" targetMode $ intersectFileModes restoredMode ownerPermissionMask + assertEqual "restored file contents" staleOutput restoredOutput + where + ownerPermissionMask = + ownerReadMode `unionFileModes` ownerWriteMode `unionFileModes` ownerExecuteMode + staleOutput = "stale output\n" + replacementOutput = "replacement output\n" + ignoreIOException = flip catchIOError $ const $ pure () + +extractFunctionSection :: T.Text -> T.Text -> T.Text +extractFunctionSection name asm = + fst $ + T.breakOn "\n.global " $ + snd $ + T.breakOn ("\n" <> name <> ":\n") ("\n" <> asm) + +returnLabelTest :: Test +returnLabelTest = TestLabel "Asm.Output.return" $ TestCase $ do + asm <- renderAsm "int main() { return 0; }" + assertContains + "return labels are emitted into the requested handle" + [ ".intel_syntax noprefix" + , "jmp .L.return.main" + , ".L.return.main:" + ] + asm + +controlFlowLabelTest :: Test +controlFlowLabelTest = TestLabel "Asm.Output.control-flow" $ TestCase $ do + asm <- renderAsm "int main() { int x; x = 0; while (x < 2) { if (x == 1) goto done; x = x + 1; continue; } done: switch (x) { case 1: return 0; default: return 1; } }" + assertContains + "control-flow labels and references stay on the requested handle" + [ ".L.continue.main." + , ".L.break.main." + , ".L.label.main.done:" + , "jmp .L.label.main.done" + , ".L.case.main." + , "je .L.case.main." + ] + asm + +globalInitializerCastTest :: Test +globalInitializerCastTest = TestLabel "Asm.Output.global-initializer-cast" $ TestCase $ do + asm <- renderAsm "int g = (char)0x1234; int h = (char)0xff; int main() { return g == 52 && h == -1; }" + assertContains + "global initializer casts are folded before emitting data bytes" + [ "g:" + , ".4byte 52" + , "h:" + , ".4byte -1" + ] + asm + assertBool + "global initializer should not retain the uncast value" + (not $ any (`T.isInfixOf` asm) [".4byte 4660", ".4byte 255"]) + +globalInitializerNullPointerCastTest :: Test +globalInitializerNullPointerCastTest = TestLabel "Asm.Output.global-initializer-null-pointer-cast" $ TestCase $ do + asm <- renderAsm "char *p = (char*)0; int main(void) { return p == 0; }" + assertContains + "file-scope null pointer casts are emitted as zero-initialized pointer storage" + [ "p:" + , ".zero 8" + ] + asm + +globalInitializerNestedNullPointerCastTest :: Test +globalInitializerNestedNullPointerCastTest = TestLabel "Asm.Output.global-initializer-nested-null-pointer-cast" $ TestCase $ do + asm <- renderAsm "int *p = (int*)(void*)0; int main(void) { return p == 0; }" + assertContains + "nested file-scope null pointer casts are emitted as zero-initialized pointer storage" + [ "p:" + , ".zero 8" + ] + asm + +globalInitializerFunctionNullPointerCastTest :: Test +globalInitializerFunctionNullPointerCastTest = TestLabel "Asm.Output.global-initializer-function-null-pointer-cast" $ TestCase $ do + asm <- renderAsm "int (*fp)(void) = (int (*)(void))0; int main(void) { return fp == 0; }" + assertContains + "file-scope function-pointer null casts are emitted as zero-initialized pointer storage" + [ "fp:" + , ".zero 8" + ] + asm + +globalInitializerWideCastTruncationTest :: Test +globalInitializerWideCastTruncationTest = TestLabel "Asm.Output.global-initializer-wide-cast-truncation" $ TestCase $ do + asm <- renderAsm "long g = (long)0x10000000000000000; long h = (long)0x10000000000000001; char *p = (char*)0x10000000000000000; int main(void) { return g == 0 && h == 1 && p == 0; }" + assertBool + "8-byte global initializer casts are truncated before data emission" + (all (`T.isInfixOf` asm) + [ "g:\n\t.zero 8" + , "h:\n\t.8byte 1" + , "p:\n\t.zero 8" + ] + ) + assertBool + "8-byte global initializer casts should not leak untruncated literals" + (not $ any (`T.isInfixOf` asm) + [ ".8byte 18446744073709551616" + , ".8byte 18446744073709551617" + ] + ) + +tentativeIncompleteArrayTest :: Test +tentativeIncompleteArrayTest = TestLabel "Asm.Output.tentative-incomplete-array" $ TestCase $ do + asm <- renderAsm "int x[]; int main() { x[0] = 1; return x[0]; }" + assertContains + "tentative incomplete arrays are materialized as one element before data emission" + [ "x:" + , ".zero 4" + ] + asm + +tentativeIncompleteArrayDecayRetypeFallbackTest :: Test +tentativeIncompleteArrayDecayRetypeFallbackTest = TestLabel "Asm.Output.tentative-incomplete-array-decay-retype-fallback" $ TestCase $ do + asm <- renderAsm "int x[]; int *f(void) { return x; } int main(void) { return 0; }" + let fSection = extractFunctionSection "f" asm + assertContainsInOrder + "tentative arrays without a later completing declaration are retyped for decay-only codegen after fallback materialization" + [ "f:" + , "push offset x" + , "pop rax" + , "jmp .L.return.f" + ] + fSection + assertBool + "fallback-sized tentative-array decay sites should not load the first element as a scalar" + (not $ "movsxd rax, dword ptr [rax]" `T.isInfixOf` fSection) + +tentativeIncompleteArraySizeofFallbackTest :: Test +tentativeIncompleteArraySizeofFallbackTest = TestLabel "Asm.Output.tentative-incomplete-array-sizeof-fallback" $ TestCase $ do + let incompleteTy :: CT.StorageClass Integer + incompleteTy = CT.SCAuto $ CT.CTIncomplete (CT.IncompleteArray CT.CTInt) + materializedTy :: CT.StorageClass Integer + materializedTy = CT.SCAuto $ CT.CTArray 1 CT.CTInt + gvars :: GlobalVars Integer + gvars = Map.fromList [("x", GVar incompleteTy GVarInitWithZero)] + sizeofExpr = + ATNode + ATSizeof + (CT.SCAuto CT.CTInt) + (ATNode (ATGVar incompleteTy "x") incompleteTy ATEmpty ATEmpty) + ATEmpty + case prepareAsmInput Map.empty [sizeofExpr] gvars of + Left err -> + assertFailure err + Right ([ATNode ATSizeof _ (ATNode (ATGVar resolvedTy _) _ _ _) _], preparedGVars) -> do + assertEqual + "tentative incomplete arrays should materialize before revalidating sizeof" + materializedTy + resolvedTy + assertEqual + "prepareAsmInput should materialize tentative incomplete arrays in global storage too" + (Just materializedTy) + (gvtype <$> Map.lookup "x" preparedGVars) + Right _ -> + assertFailure "internal test error: prepareAsmInput returned an unexpected AST shape" + +staticTentativeIncompleteArrayUseSiteRejectedTest :: Test +staticTentativeIncompleteArrayUseSiteRejectedTest = TestLabel "Asm.Output.static-tentative-incomplete-array-use-site-rejected" $ TestCase $ + assertBool + "static tentative incomplete arrays should remain incomplete at expression use sites" + (isLeft $ + (runParser parser "" + "static int x[]; int main(void) { return sizeof x / sizeof x[0]; }" + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) + ) + ) + +nestedTentativeIncompleteArrayUseSiteRejectedTest :: Test +nestedTentativeIncompleteArrayUseSiteRejectedTest = TestLabel "Asm.Output.nested-tentative-incomplete-array-use-site-rejected" $ TestCase $ + assertBool + "address arithmetic on tentative incomplete arrays should be rejected before data emission" + (isLeft $ + (runParser parser "" + "int x[][4]; int main(void) { return ((char*)(&x + 1)) - ((char*)&x); }" + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) + ) + ) + +tentativeNestedArrayExtentInferenceTest :: Test +tentativeNestedArrayExtentInferenceTest = TestLabel "Asm.Output.tentative-nested-array-extent-inference" $ TestCase $ do + asm <- renderAsm "int x[][4]; int x[2][4]; int main(void) { return ((char*)(&x + 1)) - ((char*)&x); }" + assertContains + "same-translation-unit tentative nested arrays infer the missing outer extent from a later redeclaration" + [ "x:" + , ".zero 32" + , "imul rdi, 32" + ] + asm + +tentativeArrayEarlierFunctionDecayRetypeTest :: Test +tentativeArrayEarlierFunctionDecayRetypeTest = TestLabel "Asm.Output.tentative-array-earlier-function-decay-retype" $ TestCase $ do + asm <- renderAsm "int x[]; int *f(void) { return x; } int x[4]; int main(void) { return 0; }" + let fSection = extractFunctionSection "f" asm + assertContainsInOrder + "same-translation-unit tentative arrays retype earlier decay-only uses before codegen" + [ "f:" + , "push offset x" + , "pop rax" + , "jmp .L.return.f" + ] + fSection + assertBool + "retyped tentative-array decay sites should not load the first element as a scalar" + (not $ "movsxd rax, dword ptr [rax]" `T.isInfixOf` fSection) + +tentativeNestedArrayOuterExtentMergeUnitTest :: Test +tentativeNestedArrayOuterExtentMergeUnitTest = TestLabel "Asm.Output.tentative-nested-array-merge-unit" $ TestCase $ do + let incompleteTy :: CT.TypeKind Integer + incompleteTy = CT.CTIncomplete (CT.IncompleteArray (CT.CTArray 4 CT.CTInt)) + completeTy :: CT.TypeKind Integer + completeTy = CT.CTArray 2 (CT.CTArray 4 CT.CTInt) + assertEqual + "tentative nested-array merging should infer only the missing outer extent" + (Just completeTy) + (CT.mergeTentativeArrayTypeKinds incompleteTy completeTy) + assertEqual + "tentative nested-array merging should be symmetric for the inferred outer extent" + (Just completeTy) + (CT.mergeTentativeArrayTypeKinds completeTy incompleteTy) + +compatiblePointerArrayExtentCompletionMergeUnitTest :: Test +compatiblePointerArrayExtentCompletionMergeUnitTest = TestLabel "Asm.Output.compatible-pointer-array-extent-completion-merge-unit" $ TestCase $ do + let incompletePtrTy :: CT.TypeKind Integer + incompletePtrTy = CT.CTPtr $ CT.CTIncomplete (CT.IncompleteArray CT.CTInt) + completePtrTy :: CT.TypeKind Integer + completePtrTy = CT.CTPtr $ CT.CTArray 4 CT.CTInt + assertEqual + "pointer-compatible type merging should reject inferring an omitted array bound through a pointee" + Nothing + (CT.mergeCompatibleTypeKinds incompletePtrTy completePtrTy) + assertEqual + "pointer-compatible type merging should reject pointee-bound inference symmetrically" + Nothing + (CT.mergeCompatibleTypeKinds completePtrTy incompletePtrTy) + +incompatiblePointerArrayExtentConflictMergeUnitTest :: Test +incompatiblePointerArrayExtentConflictMergeUnitTest = TestLabel "Asm.Output.incompatible-pointer-array-extent-conflict-merge-unit" $ TestCase $ do + let lhsPtrTy :: CT.TypeKind Integer + lhsPtrTy = CT.CTPtr $ CT.CTArray 3 CT.CTInt + rhsPtrTy :: CT.TypeKind Integer + rhsPtrTy = CT.CTPtr $ CT.CTArray 4 CT.CTInt + assertEqual + "pointer-compatible type merging should reject conflicting pointee array bounds" + Nothing + (CT.mergeCompatibleTypeKinds lhsPtrTy rhsPtrTy) + assertEqual + "pointer-compatible type merging should reject conflicting pointee array bounds symmetrically" + Nothing + (CT.mergeCompatibleTypeKinds rhsPtrTy lhsPtrTy) + +compatibleFunctionParamRefinementMergeUnitTest :: Test +compatibleFunctionParamRefinementMergeUnitTest = TestLabel "Asm.Output.compatible-function-param-refinement-merge-unit" $ TestCase $ do + let incompleteFnTy :: CT.TypeKind Integer + incompleteFnTy = + CT.CTFunc + CT.CTInt + [ (CT.CTPtr $ CT.CTIncomplete $ CT.IncompleteArray CT.CTInt, Nothing) + ] + refinedFnTy :: CT.TypeKind Integer + refinedFnTy = + CT.CTFunc + CT.CTInt + [ (CT.CTPtr $ CT.CTArray 4 CT.CTInt, Nothing) + ] + assertEqual + "function-compatible type merging should reject omitted pointee bounds completed through pointer-to-array parameters" + Nothing + (CT.mergeCompatibleTypeKinds incompleteFnTy refinedFnTy) + assertEqual + "function-compatible type merging should reject pointer-to-array parameter bound inference symmetrically" + Nothing + (CT.mergeCompatibleTypeKinds refinedFnTy incompleteFnTy) + +incompatibleFunctionParamArrayExtentConflictMergeUnitTest :: Test +incompatibleFunctionParamArrayExtentConflictMergeUnitTest = TestLabel "Asm.Output.incompatible-function-param-array-extent-conflict-merge-unit" $ TestCase $ do + let lhsFnTy :: CT.TypeKind Integer + lhsFnTy = + CT.CTFunc + CT.CTInt + [ (CT.CTPtr $ CT.CTArray 3 CT.CTInt, Nothing) + ] + rhsFnTy :: CT.TypeKind Integer + rhsFnTy = + CT.CTFunc + CT.CTInt + [ (CT.CTPtr $ CT.CTArray 4 CT.CTInt, Nothing) + ] + assertEqual + "function-compatible type merging should reject conflicting pointer-to-array parameter bounds" + Nothing + (CT.mergeCompatibleTypeKinds lhsFnTy rhsFnTy) + assertEqual + "function-compatible type merging should reject conflicting pointer-to-array parameter bounds symmetrically" + Nothing + (CT.mergeCompatibleTypeKinds rhsFnTy lhsFnTy) + +compatibleTaggedStructCompletionMergeUnitTest :: Test +compatibleTaggedStructCompletionMergeUnitTest = TestLabel "Asm.Output.compatible-tagged-struct-completion-merge-unit" $ TestCase $ do + let members :: Map.Map T.Text (CT.StructMember Integer) + members = Map.fromList + [ ("value", CT.StructMember CT.CTInt 0) + ] + incompletePtrTy :: CT.TypeKind Integer + incompletePtrTy = CT.CTPtr $ CT.CTIncomplete $ CT.IncompleteStruct "Foo" + completePtrTy :: CT.TypeKind Integer + completePtrTy = CT.CTPtr $ CT.CTNamedStruct "Foo" members + assertEqual + "pointer-compatible type merging should accept completion of a tagged opaque struct declaration" + (Just completePtrTy) + (CT.mergeCompatibleTypeKinds incompletePtrTy completePtrTy) + assertEqual + "pointer-compatible type merging should stay symmetric when the tagged struct definition appears first" + (Just completePtrTy) + (CT.mergeCompatibleTypeKinds completePtrTy incompletePtrTy) + +incompatibleTaggedStructAliasMergeUnitTest :: Test +incompatibleTaggedStructAliasMergeUnitTest = TestLabel "Asm.Output.incompatible-tagged-struct-alias-merge-unit" $ TestCase $ do + let members :: Map.Map T.Text (CT.StructMember Integer) + members = Map.fromList + [ ("value", CT.StructMember CT.CTInt 0) + ] + fooPtrTy :: CT.TypeKind Integer + fooPtrTy = CT.CTPtr $ CT.CTNamedStruct "Foo" members + barPtrTy :: CT.TypeKind Integer + barPtrTy = CT.CTPtr $ CT.CTNamedStruct "Bar" members + assertEqual + "pointer-compatible type merging should reject tagged structs that only match structurally" + Nothing + (CT.mergeCompatibleTypeKinds fooPtrTy barPtrTy) + assertEqual + "pointer-compatible type merging should reject structurally identical tagged structs symmetrically" + Nothing + (CT.mergeCompatibleTypeKinds barPtrTy fooPtrTy) + +compatibleAnonymousStructMergeUnitTest :: Test +compatibleAnonymousStructMergeUnitTest = TestLabel "Asm.Output.compatible-anonymous-struct-merge-unit" $ TestCase $ do + let lhsMembers :: Map.Map T.Text (CT.StructMember Integer) + lhsMembers = Map.fromList + [ ("value", CT.StructMember CT.CTInt 0) + ] + rhsMembers :: Map.Map T.Text (CT.StructMember Integer) + rhsMembers = Map.fromList + [ ("value", CT.StructMember CT.CTInt 0) + ] + lhsPtrTy :: CT.TypeKind Integer + lhsPtrTy = CT.CTPtr $ CT.CTStruct lhsMembers + rhsPtrTy :: CT.TypeKind Integer + rhsPtrTy = CT.CTPtr $ CT.CTStruct rhsMembers + assertEqual + "pointer-compatible type merging should accept anonymous structs that match structurally" + (Just rhsPtrTy) + (CT.mergeCompatibleTypeKinds lhsPtrTy rhsPtrTy) + assertEqual + "pointer-compatible type merging should accept structurally identical anonymous structs symmetrically" + (Just rhsPtrTy) + (CT.mergeCompatibleTypeKinds rhsPtrTy lhsPtrTy) + +compatibleNamedStructAnonymousMemberMergeUnitTest :: Test +compatibleNamedStructAnonymousMemberMergeUnitTest = TestLabel "Asm.Output.compatible-named-struct-anonymous-member-merge-unit" $ TestCase $ do + let lhsAnonMembers :: Map.Map T.Text (CT.StructMember Integer) + lhsAnonMembers = Map.fromList + [ ("value", CT.StructMember CT.CTInt 0) + ] + rhsAnonMembers :: Map.Map T.Text (CT.StructMember Integer) + rhsAnonMembers = Map.fromList + [ ("value", CT.StructMember CT.CTInt 0) + ] + lhsOuterMembers :: Map.Map T.Text (CT.StructMember Integer) + lhsOuterMembers = Map.fromList + [ ("anon", CT.StructMember (CT.CTStruct lhsAnonMembers) 0) + ] + rhsOuterMembers :: Map.Map T.Text (CT.StructMember Integer) + rhsOuterMembers = Map.fromList + [ ("anon", CT.StructMember (CT.CTStruct rhsAnonMembers) 0) + ] + lhsTy :: CT.TypeKind Integer + lhsTy = CT.CTNamedStruct "Outer" lhsOuterMembers + rhsTy :: CT.TypeKind Integer + rhsTy = CT.CTNamedStruct "Outer" rhsOuterMembers + assertEqual + "struct-compatible type merging should accept named structs whose anonymous member structs match structurally" + (Just rhsTy) + (CT.mergeCompatibleTypeKinds lhsTy rhsTy) + assertEqual + "struct-compatible type merging should accept nested anonymous member structs symmetrically" + (Just rhsTy) + (CT.mergeCompatibleTypeKinds rhsTy lhsTy) + +tentativeNestedArrayMaterializationUnitTest :: Test +tentativeNestedArrayMaterializationUnitTest = TestLabel "Asm.Output.tentative-nested-array-materialization-unit" $ TestCase $ do + let gvar :: GVar Integer + gvar = + GVar + { gvtype = CT.SCAuto $ CT.CTIncomplete (CT.IncompleteArray (CT.CTArray 4 CT.CTInt)) + , initWith = GVarInitWithZero + } + expectedTy :: CT.StorageClass Integer + expectedTy = CT.SCAuto $ CT.CTArray 4 (CT.CTArray 1 CT.CTInt) + assertEqual + "tentative nested-array globals should materialize one outer row before codegen" + expectedTy + (gvtype $ materializeTentativeIncompleteArray gvar) + +tentativeArrayUseSiteRejectedTest :: Test +tentativeArrayUseSiteRejectedTest = TestLabel "Asm.Output.tentative-array-use-site-rejected" $ TestCase $ + assertBool + "later global completions must not retroactively legitimize earlier sizeof uses" + (isLeft $ + (runParser parser "" + "int x[]; int main(void) { return sizeof x; } int x[4];" + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) + ) + ) + +tentativeArrayAddressUseSiteRejectedTest :: Test +tentativeArrayAddressUseSiteRejectedTest = TestLabel "Asm.Output.tentative-array-address-use-site-rejected" $ TestCase $ + assertBool + "later global completions must not retroactively legitimize earlier address arithmetic" + (isLeft $ + (runParser parser "" + "int x[]; int main(void) { return ((char*)(&x + 1)) - ((char*)&x); } int x[4];" + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) + ) + ) + +globalInitializerRelocAddendTest :: Test +globalInitializerRelocAddendTest = TestLabel "Asm.Output.global-initializer-reloc-addend" $ TestCase $ do + asm <- renderAsm "int a[4]; int *p = a + (1 + 1); char *end = (char*)(&a + 1); char *q = \"ab\" + 1; void *self = &self; int main() { return p != 0 && end != 0 && q[0] == 'b' && self != 0; }" + assertContains + "global pointer initializers retain compatible self-references and folded symbol addends in emitted relocations" + [ "a:" + , ".zero 16" + , "p:" + , ".quad a+8" + , "end:" + , ".quad a+16" + , "q:" + , ".quad .L.data.0+1" + , "self:" + , ".quad self" + ] + asm + +globalInitializerArraySubobjectRelocTest :: Test +globalInitializerArraySubobjectRelocTest = TestLabel "Asm.Output.global-initializer-array-subobject-reloc" $ TestCase $ do + asm <- renderAsm "int x[2][4]; int *row0 = x[0]; int *first = &x[0][0]; int *row1 = x[1]; int main(void) { return row0 == &x[0][0] && first == &x[0][0] && row1 == &x[1][0]; }" + assertContains + "global pointer initializers fold array subobjects reached through dereferences into relocations" + [ "x:" + , ".zero 32" + , "row0:" + , ".quad x" + , "first:" + , ".quad x" + , "row1:" + , ".quad x+16" + ] + asm + +globalInitializerTentativeNestedArrayFallbackRelocTest :: Test +globalInitializerTentativeNestedArrayFallbackRelocTest = TestLabel "Asm.Output.global-initializer-tentative-nested-array-fallback-reloc" $ TestCase $ do + asm <- renderAsm "int x[][4]; char *p = (char*)(x + 1); int main(void) { return p == ((char*)x) + 16; }" + assertContains + "tentative nested arrays should materialize before folding global initializer relocations" + [ "x:" + , ".zero 16" + , "p:" + , ".quad x+16" + ] + asm + +globalInitializerTentativeArrayUseSiteRejectedTest :: Test +globalInitializerTentativeArrayUseSiteRejectedTest = TestLabel "Asm.Output.global-initializer-tentative-array-use-site-rejected" $ TestCase $ + assertBool + "earlier global initializers must not be retyped from later tentative-array completions" + (isLeft $ + (runParser parser "" + "int x[]; int y = sizeof x; char *p = (char*)(&x + 1); int x[4]; int main(void) { return y == 16 && p == ((char*)&x) + 16; }" + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) + ) + ) + +globalInitializerSelfRetypeSizeofTest :: Test +globalInitializerSelfRetypeSizeofTest = TestLabel "Asm.Output.global-initializer-self-retype-sizeof" $ TestCase $ do + asm <- renderAsm "int x[]; int x[4] = { sizeof x }; int main(void) { return x[0] == 16; }" + assertContains + "completed array definitions retype self-referential sizeof expressions before folding the defining initializer" + [ "x:" + , ".4byte 16" + , ".zero 12" + ] + asm + +globalInitializerSelfRetypeAddressTest :: Test +globalInitializerSelfRetypeAddressTest = TestLabel "Asm.Output.global-initializer-self-retype-address" $ TestCase $ do + asm <- renderAsm "char *x[]; char *x[4] = { (char*)(&x + 1) }; int main(void) { return x[0] == ((char*)&x) + 32; }" + assertContains + "completed array definitions retype self-referential address arithmetic before folding the defining initializer" + [ "x:" + , ".quad x+32" + , ".zero 24" + ] + asm + +globalInitializerFunctionRelocTest :: Test +globalInitializerFunctionRelocTest = TestLabel "Asm.Output.global-initializer-function-reloc" $ TestCase $ do + asm <- renderAsm "int foo(void) { return 1; } int (*fp)(void) = foo; int (*fq)(void) = &foo; int main(void) { return fp != 0 && fq != 0; }" + assertContains + "file-scope function-pointer initializers emit relocations for bare and addressed function designators" + [ "foo:" + , "fp:" + , ".quad foo" + , "fq:" + , ".quad foo" + ] + asm + +bareFunctionDesignatorDerefCallTest :: Test +bareFunctionDesignatorDerefCallTest = TestLabel "Asm.Output.bare-function-designator-deref-call" $ TestCase $ do + asm <- renderAsm "int foo(void) { return 1; } int main(void) { return (*foo)(); }" + assertContains + "dereferencing a bare function designator remains callable" + [ "foo:" + , "main:" + , "call foo" + ] + asm + +functionPointerArrayZeroInitializerTest :: Test +functionPointerArrayZeroInitializerTest = TestLabel "Asm.Output.function-pointer-array-zero-initializer" $ TestCase $ do + asm <- renderAsm "int (*fps[2])(void) = { 0, 0 }; int main(void) { return fps[0] != 0 || fps[1] != 0; }" + assertContains + "brace initializers keep scanning all zeroed function-pointer array elements" + [ "fps:" + , ".zero 16" + ] + asm + +functionPointerArrayFunctionInitializerTest :: Test +functionPointerArrayFunctionInitializerTest = TestLabel "Asm.Output.function-pointer-array-function-initializer" $ TestCase $ do + asm <- renderAsm "int foo(void) { return 1; } int (*fps[2])(void) = { foo, &foo }; int main(void) { return fps[0]() != 1 || fps[1]() != 1; }" + assertContains + "brace initializers keep scanning all function-pointer array elements" + [ "foo:" + , "fps:" + ] + asm + assertEqual + "each function-pointer initializer should emit its own relocation" + 2 + (T.count ".quad foo" asm) + +omittedBoundArrayPointerDerefDecayTest :: Test +omittedBoundArrayPointerDerefDecayTest = TestLabel "Asm.Output.omitted-bound-array-pointer-deref-decay" $ TestCase $ do + asm <- renderAsm "int *f(int (*p)[]) { return *p; } int main(void) { int x[4]; int (*p)[] = (int (*)[])&x; return f(p) != x; }" + let fSection = extractFunctionSection "f" asm + assertEqual + "dereferencing a pointer-to-omitted-bound-array should keep the array lvalue and decay it without an extra scalar load" + 1 + (T.count "mov rax, [rax]" fSection) + +indirectFunctionPointerCallTest :: Test +indirectFunctionPointerCallTest = TestLabel "Asm.Output.indirect-function-pointer-call" $ TestCase $ do + asm <- renderAsm "int foo(void) { return 1; } int main(void) { int (*fp)(void) = foo; return fp(); }" + assertContains + "callable variables are lowered as indirect calls through the loaded function pointer" + [ "call r11" ] + asm + assertBool + "callable variables must not be emitted as implicit direct symbol calls" + (not $ "call \"fp\"" `T.isInfixOf` asm) + +indirectFunctionPointerCallAlignmentTest :: Test +indirectFunctionPointerCallAlignmentTest = TestLabel "Asm.Output.indirect-function-pointer-call-alignment" $ TestCase $ do + asm <- renderAsm "int foo(void) { return 1; } int main(void) { int (*fp)(void); fp = foo; return fp(); }" + assertContainsInOrder + "zero-argument indirect calls probe rsp before loading the callee and keep a padded fallback path" + [ "mov rax, rsp" + , "and rax, 15" + , "jnz .L.call." + , "pop r11" + , "mov rax, 0" + , "call r11" + , ".L.call." + , "sub rsp, 8" + , "pop r11" + , "mov rax, 0" + , "call r11" + , "add rsp, 8" + ] + asm + +directBoolFunctionCallNormalizationTest :: Test +directBoolFunctionCallNormalizationTest = TestLabel "Asm.Output.direct-bool-function-call-normalization" $ TestCase $ do + asm <- renderAsm "_Bool foo(void) { return 2; } int main(void) { return foo(); }" + assertContainsInOrder + "zero-argument direct _Bool calls normalize the ABI-defined low byte before pushing the result" + [ "call foo" + , "cmp al, 0" + , "setne al" + , "movzb rax, al" + , "push rax" + ] + asm + +indirectBoolFunctionPointerCallNormalizationTest :: Test +indirectBoolFunctionPointerCallNormalizationTest = TestLabel "Asm.Output.indirect-bool-function-pointer-call-normalization" $ TestCase $ do + asm <- renderAsm "_Bool foo(void) { return 2; } int main(void) { _Bool (*fp)(void); fp = foo; return fp(); }" + assertContainsInOrder + "zero-argument indirect _Bool calls normalize the ABI-defined low byte before pushing the result" + [ "call r11" + , "cmp al, 0" + , "setne al" + , "movzb rax, al" + , "push rax" + ] + asm + +directIntegralFunctionCallNormalizationTest :: Test +directIntegralFunctionCallNormalizationTest = TestLabel "Asm.Output.direct-integral-function-call-normalization" $ TestCase $ do + asm <- renderAsm "char ret_char(void) { return -1; } short ret_short(void) { return -1; } int ret_int(void) { return -1; } int main(void) { return ret_char() == -1 && ret_short() == -1 && ret_int() == -1; }" + let mainSection = extractFunctionSection "main" asm + assertContainsInOrder + "direct char/short/int calls truncate the ABI return register before the result is consumed" + [ "call ret_char" + , "movsx rax, al" + , "push rax" + , "call ret_short" + , "movsx rax, ax" + , "push rax" + , "call ret_int" + , "movsxd rax, eax" + , "push rax" + ] + mainSection + +indirectIntegralFunctionPointerCallNormalizationTest :: Test +indirectIntegralFunctionPointerCallNormalizationTest = TestLabel "Asm.Output.indirect-integral-function-pointer-call-normalization" $ TestCase $ do + asm <- renderAsm "char ret_char(void) { return -1; } short ret_short(void) { return -1; } int ret_int(void) { return -1; } int main(void) { char (*char_fp)(void); short (*short_fp)(void); int (*int_fp)(void); char_fp = ret_char; short_fp = ret_short; int_fp = ret_int; return char_fp() == -1 && short_fp() == -1 && int_fp() == -1; }" + let mainSection = extractFunctionSection "main" asm + assertContainsInOrder + "indirect char/short/int calls truncate the ABI return register before the result is consumed" + [ "call r11" + , "movsx rax, al" + , "push rax" + , "call r11" + , "movsx rax, ax" + , "push rax" + , "call r11" + , "movsxd rax, eax" + , "push rax" + ] + mainSection + +boolFunctionReturnNormalizationTest :: Test +boolFunctionReturnNormalizationTest = TestLabel "Asm.Output.bool-function-return-normalization" $ TestCase $ do + asm <- renderAsm "_Bool foo(void) { return 256; } int main(void) { return foo(); }" + assertContainsInOrder + "bool function epilogues normalize the full return register at the shared return label" + [ ".L.return.foo:" + , "cmp rax, 0" + , "setne al" + , "movzb rax, al" + , "leave" + , "ret" + ] + asm + +directBoolFunctionArgNormalizationTest :: Test +directBoolFunctionArgNormalizationTest = TestLabel "Asm.Output.direct-bool-function-arg-normalization" $ TestCase $ do + asm <- renderAsm "int takes_bool(_Bool x) { return x; } int main(void) { return takes_bool(256); }" + let mainSection = extractFunctionSection "main" asm + assertContainsInOrder + "direct calls cast integer arguments to _Bool before materializing the argument register from the scratch slot" + [ "main:" + , "push 256" + , "cmp rax, 0" + , "setne al" + , "movzb rax, al" + , "mov [rbx+0], rdx" + , "mov rdi, [rax+0]" + , "call takes_bool" + ] + mainSection + +directOldStyleBoolFunctionArgPromotionTest :: Test +directOldStyleBoolFunctionArgPromotionTest = TestLabel "Asm.Output.direct-old-style-bool-function-arg-promotion" $ TestCase $ do + asm <- renderAsm "int takes_bool(); int main(void) { return takes_bool(256); }" + let mainSection = extractFunctionSection "main" asm + assertContainsInOrder + "old-style direct calls pass the promoted integer argument through the scratch slot without _Bool normalization" + [ "main:" + , "push 256" + , "mov [rbx+0], rdx" + , "mov rdi, [rax+0]" + , "call takes_bool" + ] + mainSection + assertBool + "old-style direct calls must not normalize the argument to _Bool at the call site" + (not $ any (`T.isInfixOf` mainSection) ["cmp rax, 0", "setne al", "movzb rax, al"]) + +indirectBoolFunctionPointerArgNormalizationTest :: Test +indirectBoolFunctionPointerArgNormalizationTest = TestLabel "Asm.Output.indirect-bool-function-pointer-arg-normalization" $ TestCase $ do + asm <- renderAsm "int takes_bool(_Bool x) { return x; } int main(void) { int (*fp)(_Bool); fp = takes_bool; return fp(256); }" + let mainSection = extractFunctionSection "main" asm + assertContainsInOrder + "indirect calls cast integer arguments to _Bool before materializing the argument and callee from scratch slots" + [ "main:" + , "push 256" + , "cmp rax, 0" + , "setne al" + , "movzb rax, al" + , "mov [rbx+0], rdx" + , "mov rdi, [rax+0]" + , "mov r11, [rax+8]" + , "mov rax, 0" + , "call r11" + ] + mainSection + +indirectOldStyleBoolFunctionPointerPromotionConflictTest :: Test +indirectOldStyleBoolFunctionPointerPromotionConflictTest = TestLabel "Asm.Output.indirect-old-style-bool-function-pointer-promotion-conflict" $ TestCase $ do + assertBool + "old-style function pointers must reject _Bool parameters that only match after default promotions" + (isLeft $ + ( runParser parser "" + "int takes_bool(_Bool x) { return x; } int main(void) { int (*fp)(); fp = takes_bool; return fp(256); }" + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) + ) + ) + +indirectFunctionPointerArgAlignmentTest :: Test +indirectFunctionPointerArgAlignmentTest = TestLabel "Asm.Output.indirect-function-pointer-arg-alignment" $ TestCase $ do + asm <- renderAsm "int inc(int x) { return x + 1; } int main(void) { int (*fp)(int); fp = inc; return fp(41); }" + assertContainsInOrder + "indirect calls with register arguments probe rsp alignment before restoring the argument and callee from scratch slots" + [ "mov rax, rsp" + , "and rax, 15" + , "jnz .L.call." + , "mov rdi, [rax+0]" + , "mov r11, [rax+8]" + , "mov rax, 0" + , "call r11" + ] + asm + +directFunctionStackArgAlignmentTest :: Test +directFunctionStackArgAlignmentTest = TestLabel "Asm.Output.direct-function-stack-arg-alignment" $ TestCase $ do + asm <- renderAsm "long sum7(long a, long b, long c, long d, long e, long f, long g) { return a + b + c + d + e + f + g; } int main(void) { return sum7(1, 2, 3, 4, 5, 6, 7) - 28; }" + assertContainsInOrder + "stack-passed direct calls probe the final call alignment before preparing args and keep any padding ahead of outgoing stack arguments" + [ "mov rax, rsp" + , "sub rax, 8" + , "and rax, 15" + , "jnz .L.call." + , "push 7" + , "call sum7" + , ".L.call." + , "sub rsp, 8" + , "push 7" + , "call sum7" + , "add rsp, 8" + , "add rsp, 8" + ] + asm + +directFunctionLateStackArgCallOrderTest :: Test +directFunctionLateStackArgCallOrderTest = TestLabel "Asm.Output.direct-function-late-stack-arg-call-order" $ TestCase $ do + asm <- renderAsm "long g(void) { return 7; } long sum8(long a, long b, long c, long d, long e, long f, long g_, long h) { return g_ + h; } int main(void) { return sum8(1, 2, 3, 4, 5, 6, g(), 8) - 15; }" + let mainSection = extractFunctionSection "main" asm + assertOccursBefore + "later stack arguments should not be pushed before evaluating an earlier stack argument that contains a nested call" + "call g" + "push 8" + mainSection + +stackPassedParameterSpillTest :: Test +stackPassedParameterSpillTest = TestLabel "Asm.Output.stack-passed-parameter-spill" $ TestCase $ do + asm <- renderAsm "long last7(long a, long b, long c, long d, long e, long f, long g) { return g; } int main(void) { return last7(1, 2, 3, 4, 5, 6, 7) - 7; }" + assertContainsInOrder + "function prologues spill stack-passed parameters into their local slots before use" + [ "last7:" + , "mov rax, [rbp+16]" + , "mov [rbp-56], rax" + ] + asm + +stackPassedBoolParameterSpillTest :: Test +stackPassedBoolParameterSpillTest = TestLabel "Asm.Output.stack-passed-bool-parameter-spill" $ TestCase $ do + asm <- renderAsm "int bool7(int a, int b, int c, int d, int e, int f, _Bool g) { return g; } int main(void) { return bool7(1, 2, 3, 4, 5, 6, 256); }" + assertContainsInOrder + "stack-passed _Bool parameters normalize the ABI-defined low byte before spilling into the local slot" + [ "bool7:" + , "mov rax, [rbp+16]" + , "cmp al, 0" + , "setne al" + , "movzb rax, al" + , "mov [rbp-" + ] + asm + +writeOnlyFallbackReplacementRestoreTest :: Test +writeOnlyFallbackReplacementRestoreTest = + replacementFailurePreservesWriteOnlyOutputTest + PreserveReplacementOutputMode + "Asm.Output.write-only-fallback-replacement-restore" + ownerWriteMode + +writeOnlyExecutableFallbackReplacementRestoreTest :: Test +writeOnlyExecutableFallbackReplacementRestoreTest = + replacementFailurePreservesWriteOnlyOutputTest + PreserveReplacementOutputModeKeepingExecutableBits + "Asm.Output.write-only-executable-fallback-replacement-restore" + (ownerWriteMode `unionFileModes` ownerExecuteMode) + +unreadableStagedFallbackReplacementTest :: Test +unreadableStagedFallbackReplacementTest = + TestLabel "Asm.Output.unreadable-staged-fallback-replacement" $ TestCase $ do + tmpDir <- getTemporaryDirectory + (targetPath, targetHandle) <- openTempFile tmpDir "htcc-output-target" + (stagedPath, stagedHandle) <- openTempFile tmpDir "htcc-output-staged" + let cleanup = + ignoreIOException (hClose targetHandle) + >> ignoreIOException (hClose stagedHandle) + >> ignoreIOException (removeFile targetPath) + >> ignoreIOException (removeFile stagedPath) + existingMode = 0o555 + stagedMode = 0o055 + replacementOutput = "#!/bin/sh\nexit 0\n" + copyReplacementOutput src dst = + B.readFile src >>= B.writeFile dst + flip finally cleanup $ do + hClose targetHandle + hClose stagedHandle + T.writeFile targetPath "#!/bin/sh\nexit 99\n" + setFileMode targetPath existingMode + T.writeFile stagedPath replacementOutput + setFileMode stagedPath stagedMode + replaceExistingOutputFromPathWith + copyReplacementOutput + PreserveReplacementOutputModeKeepingExecutableBits + targetPath + existingMode + stagedMode + stagedPath + replacedMode <- fileMode <$> getFileStatus targetPath + setFileMode targetPath $ replacedMode `unionFileModes` ownerReadMode + replacedOutput <- T.readFile targetPath + assertEqual + "fallback replacement should temporarily restore owner read on unreadable staged outputs" + existingMode + (intersectFileModes replacedMode 0o777) + assertEqual "fallback replacement should copy the staged output" replacementOutput replacedOutput + where + ignoreIOException = flip catchIOError $ const $ pure () + +rollbackFailureSurfacedTest :: Test +rollbackFailureSurfacedTest = + TestLabel "Asm.Output.rollback-failure-surfaced" $ TestCase $ do + tmpDir <- getTemporaryDirectory + (targetPath, targetHandle) <- openTempFile tmpDir "htcc-output-target" + (stagedPath, stagedHandle) <- openTempFile tmpDir "htcc-output-staged" + let cleanup = + ignoreIOException (hClose targetHandle) + >> ignoreIOException (hClose stagedHandle) + >> ignoreIOException (removeFile stagedPath) + >> ignoreIOException (removeFile targetPath) + >> ignoreIOException (removeDirectory targetPath) + existingMode = ownerReadMode `unionFileModes` ownerWriteMode + stagedMode = ownerReadMode `unionFileModes` ownerWriteMode + failDuringReplacement src dst + | src == stagedPath = do + withBinaryFile src ReadMode $ \srcHandle -> + withBinaryFile dst WriteMode $ \dstHandle -> do + chunk <- B.hGetSome srcHandle 4 + B.hPut dstHandle chunk + removeFile dst + createDirectory dst + ioError $ userError "simulated replacement failure" + | otherwise = + assertFailure "unexpected replacement source path" + flip finally cleanup $ do + hClose targetHandle + hClose stagedHandle + T.writeFile targetPath "stale output\n" + setFileMode targetPath existingMode + T.writeFile stagedPath "replacement output\n" + result <- try + (replaceExistingOutputFromPathWith + failDuringReplacement + PreserveReplacementOutputMode + targetPath + existingMode + stagedMode + stagedPath + ) + :: IO (Either IOException ()) + case result of + Left ioErr -> do + let errText = T.pack $ show ioErr + assertBool + "rollback failures should be surfaced to the caller" + ("failed to restore original output after replacement failure" `T.isInfixOf` errText) + assertBool + "the surfaced error should retain the original replacement failure" + ("simulated replacement failure" `T.isInfixOf` errText) + Right _ -> + assertFailure "replacement should fail when both replacement and rollback fail" + targetIsDirectory <- doesDirectoryExist targetPath + assertBool + "the failed rollback fixture should leave the destination in its mutated state" + targetIsDirectory + where + ignoreIOException = flip catchIOError $ const $ pure () + +executableOnlyFallbackReplacementPreservesModeTest :: Test +executableOnlyFallbackReplacementPreservesModeTest = + TestLabel "Asm.Output.executable-only-fallback-replacement-preserves-mode" $ TestCase $ do + tmpDir <- getTemporaryDirectory + (targetPath, targetHandle) <- openTempFile tmpDir "htcc-output-target" + (stagedPath, stagedHandle) <- openTempFile tmpDir "htcc-output-staged" + let cleanup = + ignoreIOException (hClose targetHandle) + >> ignoreIOException (hClose stagedHandle) + >> ignoreIOException (removeFile targetPath) + >> ignoreIOException (removeFile stagedPath) + existingMode = 0o555 + currentMode = 0o755 + replacementOutput = "#!/bin/sh\nexit 0\n" + copyReplacementOutput src dst = + B.readFile src >>= B.writeFile dst + flip finally cleanup $ do + hClose targetHandle + hClose stagedHandle + T.writeFile targetPath "#!/bin/sh\nexit 99\n" + setFileMode targetPath existingMode + T.writeFile stagedPath replacementOutput + setFileMode stagedPath currentMode + replaceExistingOutputFromPathWith + copyReplacementOutput + PreserveReplacementOutputModeKeepingExecutableBits + targetPath + existingMode + currentMode + stagedPath + replacedMode <- fileMode <$> getFileStatus targetPath + replacedOutput <- T.readFile targetPath + assertEqual + "fallback replacement should temporarily make executable-only outputs writable and then restore the original mode" + existingMode + (intersectFileModes replacedMode 0o777) + assertEqual "fallback replacement should copy the staged output" replacementOutput replacedOutput + where + ignoreIOException = flip catchIOError $ const $ pure () + +replacementExecutableBitsIgnoreReadBitsTest :: Test +replacementExecutableBitsIgnoreReadBitsTest = + TestLabel "Asm.Output.replacement-executable-bits-ignore-read-bits" $ TestCase $ do + tmpDir <- getTemporaryDirectory + (targetPath, targetHandle) <- openTempFile tmpDir "htcc-output-target" + (stagedPath, stagedHandle) <- openTempFile tmpDir "htcc-output-staged" + let cleanup = + ignoreIOException (hClose targetHandle) + >> ignoreIOException (hClose stagedHandle) + >> ignoreIOException (removeFile targetPath) + >> ignoreIOException (removeFile stagedPath) + existingMode = 0o640 + currentMode = 0o755 + expectedMode = 0o740 + copyReplacementOutput src dst = + B.readFile src >>= B.writeFile dst + flip finally cleanup $ do + hClose targetHandle + hClose stagedHandle + T.writeFile targetPath "stale output\n" + setFileMode targetPath existingMode + T.writeFile stagedPath "#!/bin/sh\nexit 0\n" + replaceExistingOutputFromPathWith + copyReplacementOutput + PreserveReplacementOutputModeKeepingExecutableBits + targetPath + existingMode + currentMode + stagedPath + replacedMode <- fileMode <$> getFileStatus targetPath + replacedOutput <- T.readFile targetPath + assertEqual + "replacement should preserve the prior permission mask and add only owner execute" + expectedMode + (intersectFileModes replacedMode 0o777) + assertEqual "replacement should copy the staged output" "#!/bin/sh\nexit 0\n" replacedOutput + where + ignoreIOException = flip catchIOError $ const $ pure () + +replacementExecutableBitsRestoreOwnerExecuteTest :: Test +replacementExecutableBitsRestoreOwnerExecuteTest = + TestLabel "Asm.Output.replacement-executable-bits-restore-owner-execute" $ TestCase $ do + tmpDir <- getTemporaryDirectory + (targetPath, targetHandle) <- openTempFile tmpDir "htcc-output-target" + (stagedPath, stagedHandle) <- openTempFile tmpDir "htcc-output-staged" + let cleanup = + ignoreIOException (hClose targetHandle) + >> ignoreIOException (hClose stagedHandle) + >> ignoreIOException (removeFile targetPath) + >> ignoreIOException (removeFile stagedPath) + existingMode = 0o055 + currentMode = 0o755 + expectedMode = 0o155 + replacementOutput = "#!/bin/sh\nexit 0\n" + copyReplacementOutput src dst = + B.readFile src >>= B.writeFile dst + flip finally cleanup $ do + hClose targetHandle + hClose stagedHandle + T.writeFile targetPath "#!/bin/sh\nexit 99\n" + setFileMode targetPath existingMode + T.writeFile stagedPath replacementOutput + setFileMode stagedPath currentMode + replaceExistingOutputFromPathWith + copyReplacementOutput + PreserveReplacementOutputModeKeepingExecutableBits + targetPath + existingMode + currentMode + stagedPath + replacedMode <- fileMode <$> getFileStatus targetPath + setFileMode targetPath $ replacedMode `unionFileModes` ownerReadMode + replacedOutput <- T.readFile targetPath + assertEqual + "replacement should restore owner execute when the prior execute mask only covered group/other" + expectedMode + (intersectFileModes replacedMode 0o777) + assertEqual "replacement should copy the staged output" replacementOutput replacedOutput + where + ignoreIOException = flip catchIOError $ const $ pure () + +freshExecutableReplacementPreservesExecuteBitsTest :: Test +freshExecutableReplacementPreservesExecuteBitsTest = + TestLabel "Asm.Output.fresh-executable-replacement-preserves-execute-bits" $ TestCase $ do + tmpDir <- getTemporaryDirectory + creationMode <- creationMaskedOutputMode + (targetPath, targetHandle) <- openTempFile tmpDir "htcc-output-target" + let cleanup = + ignoreIOException (hClose targetHandle) + >> ignoreIOException (removeFile targetPath) + expectedMode = intersectFileModes creationMode 0o777 `unionFileModes` 0o111 + flip finally cleanup $ do + hClose targetHandle + removeFile targetPath + withReplacementOutputPath PreserveReplacementOutputModeKeepingExecutableBits targetPath $ \tmpOutputPath -> do + T.writeFile tmpOutputPath "#!/bin/sh\nexit 0\n" + setFileMode tmpOutputPath 0o755 + replacedMode <- fileMode <$> getFileStatus targetPath + replacedOutput <- T.readFile targetPath + assertEqual + "fresh executable replacements should preserve all execute bits emitted by the linker" + expectedMode + (intersectFileModes replacedMode 0o777) + assertEqual "fresh replacement should write the staged output" "#!/bin/sh\nexit 0\n" replacedOutput + where + ignoreIOException = flip catchIOError $ const $ pure () + +freshExecutableReplacementRestoresOwnerExecuteTest :: Test +freshExecutableReplacementRestoresOwnerExecuteTest = + TestLabel "Asm.Output.fresh-executable-replacement-restores-owner-execute" $ TestCase $ do + tmpDir <- getTemporaryDirectory + (targetPath, targetHandle) <- openTempFile tmpDir "htcc-output-target" + let cleanup = + ignoreIOException (hClose targetHandle) + >> ignoreIOException (removeFile targetPath) + currentMode = 0o055 + flip finally cleanup $ do + hClose targetHandle + removeFile targetPath + withReplacementOutputPath PreserveReplacementOutputModeKeepingExecutableBits targetPath $ \tmpOutputPath -> do + T.writeFile tmpOutputPath "#!/bin/sh\nexit 0\n" + setFileMode tmpOutputPath currentMode + replacedMode <- fileMode <$> getFileStatus targetPath + replacedOutput <- T.readFile targetPath + assertBool + "fresh executable replacements should restore owner execute when the linker only leaves group/other execute" + (intersectFileModes replacedMode ownerExecuteMode /= 0) + assertEqual + "fresh executable replacements should preserve the linker-provided group/other execute mask" + currentMode + (intersectFileModes replacedMode currentMode) + assertEqual "fresh replacement should write the staged output" "#!/bin/sh\nexit 0\n" replacedOutput + where + ignoreIOException = flip catchIOError $ const $ pure () + +creationMaskedOutputModeMatchesActualCreationTest :: Test +creationMaskedOutputModeMatchesActualCreationTest = + TestLabel "Asm.Output.creation-masked-output-mode-matches-actual-creation" $ TestCase $ do + tmpDir <- getTemporaryDirectory + probeDir <- mkdtemp (tmpDir <> "/htcc-output-modeXXXXXX") + let probePath = probeDir <> "/mask-probe" + cleanup = + ignoreIOException (removeFile probePath) + >> ignoreIOException (removeDirectory probeDir) + flip finally cleanup $ do + expectedMode <- creationMaskedOutputMode + probeFd <- createFile probePath 0o666 + finally + ( do + actualMode <- intersectFileModes 0o666 . fileMode <$> getFileStatus probePath + assertEqual + "creationMaskedOutputMode should match the mode that POSIX file creation actually receives" + expectedMode + actualMode + ) + (closeFd probeFd) + where + ignoreIOException = flip catchIOError $ const $ pure () + +hardLinkedFallbackReplacementRejectedTest :: Test +hardLinkedFallbackReplacementRejectedTest = + TestLabel "Asm.Output.hard-linked-fallback-replacement-rejected" $ TestCase $ do + tmpDir <- getTemporaryDirectory + (targetPath, targetHandle) <- openTempFile tmpDir "htcc-output-target" + (stagedPath, stagedHandle) <- openTempFile tmpDir "htcc-output-staged" + let aliasPath = targetPath <> ".alias" + cleanup = + ignoreIOException (hClose targetHandle) + >> ignoreIOException (hClose stagedHandle) + >> ignoreIOException (removeFile aliasPath) + >> ignoreIOException (removeFile targetPath) + >> ignoreIOException (removeFile stagedPath) + existingMode = 0o644 + currentMode = 0o644 + copyReplacementOutput src dst = + B.readFile src >>= B.writeFile dst + flip finally cleanup $ do + hClose targetHandle + hClose stagedHandle + T.writeFile targetPath "stale output\n" + createLink targetPath aliasPath + setFileMode targetPath existingMode + T.writeFile stagedPath "replacement output\n" + result <- try + (replaceExistingOutputFromPathWith + copyReplacementOutput + PreserveReplacementOutputMode + targetPath + existingMode + currentMode + stagedPath + ) + :: IO (Either IOException ()) + case result of + Left _ -> pure () + Right _ -> assertFailure "fallback replacement should reject hard-linked outputs" + targetContents <- T.readFile targetPath + aliasContents <- T.readFile aliasPath + assertEqual "target should remain unchanged" "stale output\n" targetContents + assertEqual "hard-linked alias should remain unchanged" "stale output\n" aliasContents + where + ignoreIOException = flip catchIOError $ const $ pure () + +hardLinkedRenameReplacementPreservesAliasTest :: Test +hardLinkedRenameReplacementPreservesAliasTest = + TestLabel "Asm.Output.hard-linked-rename-replacement-preserves-alias" $ TestCase $ do + tmpDir <- getTemporaryDirectory + (targetPath, targetHandle) <- openTempFile tmpDir "htcc-output-target" + let aliasPath = targetPath <> ".alias" + cleanup = + ignoreIOException (hClose targetHandle) + >> ignoreIOException (removeFile aliasPath) + >> ignoreIOException (removeFile targetPath) + staleOutput = "stale output\n" + replacementOutput = "replacement output\n" + flip finally cleanup $ do + hClose targetHandle + T.writeFile targetPath staleOutput + createLink targetPath aliasPath + result <- try + (withReplacementOutputPath PreserveReplacementOutputMode targetPath $ \tmpOutputPath -> + T.writeFile tmpOutputPath replacementOutput + ) + :: IO (Either IOException ()) + case result of + Left ioErr -> + assertFailure $ + "rename replacement should permit hard-linked outputs: " <> show ioErr + Right _ -> + pure () + targetContents <- T.readFile targetPath + aliasContents <- T.readFile aliasPath + assertEqual "target should receive the replacement output" replacementOutput targetContents + assertEqual "hard-linked alias should retain the previous inode contents" staleOutput aliasContents + where + ignoreIOException = flip catchIOError $ const $ pure () + +indirectFunctionPointerStackArgAlignmentTest :: Test +indirectFunctionPointerStackArgAlignmentTest = TestLabel "Asm.Output.indirect-function-pointer-stack-arg-alignment" $ TestCase $ do + asm <- renderAsm "long sum7(long a, long b, long c, long d, long e, long f, long g) { return a + b + c + d + e + f + g; } int main(void) { long (*fp)(long, long, long, long, long, long, long); fp = sum7; return fp(1, 2, 3, 4, 5, 6, 7) - 28; }" + assertContainsInOrder + "stack-passed indirect calls probe the final call alignment before preparing args and keep any padding ahead of outgoing stack arguments" + [ "mov rax, rsp" + , "sub rax, 8" + , "and rax, 15" + , "jnz .L.call." + , "mov r11, [rax+56]" + , "push [rax+48]" + , "mov rax, 0" + , "call r11" + , "add rsp, 8" + , ".L.call." + , "sub rsp, 8" + , "mov r11, [rax+56]" + , "push [rax+48]" + , "mov rax, 0" + , "call r11" + , "add rsp, 8" + , "add rsp, 8" + ] + asm + +indirectFunctionLateStackArgCallOrderTest :: Test +indirectFunctionLateStackArgCallOrderTest = TestLabel "Asm.Output.indirect-function-late-stack-arg-call-order" $ TestCase $ do + asm <- renderAsm "long g(void) { return 7; } long sum8(long a, long b, long c, long d, long e, long f, long g_, long h) { return g_ + h; } int main(void) { long (*fp)(long, long, long, long, long, long, long, long); fp = sum8; return fp(1, 2, 3, 4, 5, 6, g(), 8) - 15; }" + let mainSection = extractFunctionSection "main" asm + assertOccursBefore + "indirect-call preparation should evaluate nested stack-argument calls before pushing later stack arguments" + "call g" + "push 8" + mainSection + +functionPointerGlobalObjectAddressRejectedTest :: Test +functionPointerGlobalObjectAddressRejectedTest = TestLabel "Asm.Output.function-pointer-global-object-address-rejected" $ TestCase $ + assertBool + "function-pointer global initializers should reject object addresses, even when cast to a function-pointer type" + (all rejected + [ "int g; int (*fp)(void) = &g;" + , "int g; int (*fp)(void) = (int (*)(void))&g;" + ] + ) + where + rejected source = + isLeft $ + (runParser parser "" source + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) + ) + +objectPointerGlobalAddressMismatchRejectedTest :: Test +objectPointerGlobalAddressMismatchRejectedTest = TestLabel "Asm.Output.object-pointer-global-address-mismatch-rejected" $ TestCase $ + assertBool + "object-pointer global initializers should reject already-known incompatible object addresses" + (all rejected + [ "int x[4]; int (*p)[5] = &x;" + , "int x[4]; char *p = &x;" + ] + ) + where + rejected source = + isLeft $ + (runParser parser "" source + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) + ) + +globalInitializerGnuConditionalTest :: Test +globalInitializerGnuConditionalTest = TestLabel "Asm.Output.global-initializer-gnu-conditional" $ TestCase $ do + asm <- renderAsm "int g = 1 ?: 2; int h = 0 ?: 2; int i = 42 ?: 7; int main(void) { return g == 1 && h == 2 && i == 42; }" + assertBool + "GNU omitted-middle conditionals fold by reusing the condition value on the true branch" + (all (`T.isInfixOf` asm) + [ "g:\n\t.4byte 1" + , "h:\n\t.4byte 2" + , "i:\n\t.4byte 42" + ] + ) + +globalInitializerConditionalFunctionDecaySizeofTest :: Test +globalInitializerConditionalFunctionDecaySizeofTest = TestLabel "Asm.Output.global-initializer-conditional-function-decay-sizeof" $ TestCase $ do + asm <- renderAsm "int f(void); int g = sizeof(1 ? f : 0); int main(void) { return g == 8; }" + assertContains + "conditional expressions preserve their decayed result type during normalization" + [ "g:" + , ".4byte 8" + ] + asm + +globalInitializerConditionalRelocTest :: Test +globalInitializerConditionalRelocTest = TestLabel "Asm.Output.global-initializer-conditional-reloc" $ TestCase $ do + asm <- renderAsm "int x; int f(void) { return 0; } int *p = 1 ? &x : 0; int (*fp)(void) = 1 ? f : 0;" + assertContains + "file-scope conditional initializers preserve wrapped object and function relocations" + [ "x:" + , ".zero 4" + , "p:" + , ".quad x" + , "fp:" + , ".quad f" + ] + asm + +globalInitializerAddressConditionBoolTest :: Test +globalInitializerAddressConditionBoolTest = TestLabel "Asm.Output.global-initializer-address-condition-bool" $ TestCase $ do + asm <- renderAsm "int x; int g = &x && 1; int h = &x ? 1 : 0; int main(void) { return g == 1 && h == 1; }" + assertContains + "file-scope scalar initializers fold address constants in boolean contexts" + [ "x:" + , ".zero 4" + , "g:" + , ".4byte 1" + , "h:" + , ".4byte 1" + ] + asm + +globalInitializerAddressConditionRelocTest :: Test +globalInitializerAddressConditionRelocTest = TestLabel "Asm.Output.global-initializer-address-condition-reloc" $ TestCase $ do + asm <- renderAsm "int x; int f(void) { return 0; } int *p = &x ? &x : 0; int (*fp)(void) = f ? f : 0;" + assertContains + "file-scope pointer initializers fold address-constant conditions before selecting relocations" + [ "x:" + , ".zero 4" + , "p:" + , ".quad x" + , "fp:" + , ".quad f" + ] + asm + +commaFunctionDesignatorCallDecayTest :: Test +commaFunctionDesignatorCallDecayTest = TestLabel "Asm.Output.comma-function-designator-call-decay" $ TestCase $ do + asm <- renderAsm "int foo(void) { return 42; } int main(void) { return (0, foo)(); }" + assertContains + "comma expressions decay bare function designators before indirect-call lowering" + [ "foo:" + , "main:" + ] + asm + +commaAssignmentDiscardsLhsTest :: Test +commaAssignmentDiscardsLhsTest = TestLabel "Asm.Output.comma-assignment-discards-lhs" $ TestCase $ do + asm <- renderAsm "int main(void) { int x; x = (1, 2); return x; }" + assertContainsInOrder + "comma expressions discard the lhs result before feeding assignments" + [ "push 1" + , "add rsp, 8" + , "push 2" + ] + asm + +globalInitializerStmtExprArrayDecaySizeofTest :: Test +globalInitializerStmtExprArrayDecaySizeofTest = TestLabel "Asm.Output.global-initializer-stmt-expr-array-decay-sizeof" $ TestCase $ do + asm <- renderAsm "int x[4]; int y = sizeof(({ x; })); int main(void) { return y == 8; }" + assertContains + "statement expressions preserve their decayed result type during normalization" + [ "x:" + , ".zero 16" + , "y:" + , ".4byte 8" + ] + asm + +globalInitializerModRemainderTest :: Test +globalInitializerModRemainderTest = TestLabel "Asm.Output.global-initializer-mod-remainder" $ TestCase $ do + asm <- renderAsm "int g = -5 % 2; int h = 5 % -2; int main(void) { return g == -1 && h == 1; }" + assertBool + "global initializer modulo folding follows C remainder semantics" + (all (`T.isInfixOf` asm) + [ "g:\n\t.4byte -1" + , "h:\n\t.4byte 1" + ] + ) + +globalInitializerDivTruncationTest :: Test +globalInitializerDivTruncationTest = TestLabel "Asm.Output.global-initializer-div-truncation" $ TestCase $ do + asm <- renderAsm "int g = -5 / 2; int h = 5 / -2; char *p = \"abc\" + (-5 / 2 + 3); int main(void) { return g == -2 && h == -2 && p[0] == 'b'; }" + assertBool + "global initializer division folding truncates toward zero for integers and reloc addends" + (all (`T.isInfixOf` asm) + [ "g:\n\t.4byte -2" + , "h:\n\t.4byte -2" + , "p:\n\t.quad .L.data.0+1" + ] + ) + +normalizeAsmInputPreservesOperatorTypesTest :: Test +normalizeAsmInputPreservesOperatorTypesTest = TestLabel "Asm.Output.normalize-input-preserves-operator-types" $ TestCase $ do + let intTy :: CT.StorageClass Integer + intTy = CT.SCAuto CT.CTInt + lit n = ATNode (ATNum n) intTy ATEmpty ATEmpty + lessNode = ATNode ATLT intTy (lit 1) (lit 2) + bitNode = ATNode ATAnd intTy (lit 1) (lit 2) + case normalizeAsmInput [lessNode, bitNode] Map.empty of + Left err -> + assertFailure err + Right ([normalizedLess, normalizedBit], _) -> do + assertEqual + "normalization should preserve existing comparison-node types when no rewritten global changes them" + intTy + (atype normalizedLess) + assertEqual + "normalization should preserve existing bitwise-node types when no rewritten global changes them" + intTy + (atype normalizedBit) + Right _ -> + assertFailure "internal test error: normalizeAsmInput returned an unexpected AST shape" + +assertPrepareAsmInputError :: String -> T.Text -> String -> IO () +assertPrepareAsmInputError label source expected = do + (asts, gvars, _, funcs) <- parseAsmSource source + case prepareAsmInput funcs asts gvars of + Left err -> + assertEqual label expected err + Right _ -> + assertFailure $ label <> ": expected asm input preparation failure" + +functionCallRefinementRevalidationTest :: Test +functionCallRefinementRevalidationTest = TestLabel "Asm.Output.function-call-refinement-revalidation" $ TestCase $ + assertPrepareAsmInputError + "asm input preparation should revalidate refined function calls before codegen" + "int f(); int main(void) { return f(1); } int f(void) { return 1; }" + "too many arguments to function call" + +objectPointerAssignmentRefinementRevalidationTest :: Test +objectPointerAssignmentRefinementRevalidationTest = TestLabel "Asm.Output.object-pointer-assignment-refinement-revalidation" $ TestCase $ + assertPrepareAsmInputError + "asm input preparation should reject object-pointer assignments after later tentative-array completion" + "int x[]; int main(void) { int (*p)[]; p = &x; return 0; } int x[4];" + "invalid operands to assignment" + +globalInitializerFunctionPointerRefinementRevalidationTest :: Test +globalInitializerFunctionPointerRefinementRevalidationTest = TestLabel "Asm.Output.global-initializer-function-pointer-refinement-revalidation" $ TestCase $ + assertPrepareAsmInputError + "asm input preparation should reject file-scope function-pointer initializers after later function refinement" + "int f(); int (*p)(void) = f; int f(int x) { return x; }" + "invalid initializer for scalar object" + +globalInitializerObjectPointerRefinementRevalidationTest :: Test +globalInitializerObjectPointerRefinementRevalidationTest = TestLabel "Asm.Output.global-initializer-object-pointer-refinement-revalidation" $ TestCase $ + assertPrepareAsmInputError + "asm input preparation should reject file-scope object-pointer initializers after later tentative-array completion" + "int x[]; int (*p)[] = &x; int main(void) { return 0; } int x[4];" + "invalid initializer for scalar object" + +globalInitializerIncompleteSizeofRevalidationTest :: Test +globalInitializerIncompleteSizeofRevalidationTest = TestLabel "Asm.Output.global-initializer-incomplete-sizeof-revalidation" $ TestCase $ do + let longTy :: CT.StorageClass Integer + longTy = CT.SCAuto $ CT.CTLong CT.CTInt + incompleteArrayTy :: CT.StorageClass Integer + incompleteArrayTy = CT.SCAuto $ CT.CTIncomplete (CT.IncompleteArray CT.CTInt) + arrayPointerTy :: CT.StorageClass Integer + arrayPointerTy = CT.SCAuto $ CT.CTPtr (CT.CTIncomplete (CT.IncompleteArray CT.CTInt)) + lhs = + ATNode + (ATLVar longTy 0) + longTy + ATEmpty + ATEmpty + rhs = + ATNode + ATSizeof + longTy + (ATNode + ATDeref + incompleteArrayTy + (ATNode (ATGVar arrayPointerTy "p") arrayPointerTy ATEmpty ATEmpty) + ATEmpty + ) + ATEmpty + initAst = + ATNode + (ATBlock [ATNode ATExprStmt longTy (ATNode ATAssign longTy lhs rhs) ATEmpty]) + longTy + ATEmpty + ATEmpty + gvars :: GlobalVars Integer + gvars = + Map.fromList + [ ("p", GVar arrayPointerTy GVarInitWithZero) + , ("n", GVar longTy (GVarInitWithAST initAst)) + ] + case prepareAsmInput Map.empty [] gvars of + Left err -> + assertEqual + "asm input preparation should reject deferred sizeof in global initializers when the operand stays incomplete" + "invalid application of 'sizeof' to incomplete type" + err + Right _ -> + assertFailure "expected asm input preparation failure" + +functionPointerReturnRefinementRevalidationTest :: Test +functionPointerReturnRefinementRevalidationTest = TestLabel "Asm.Output.function-pointer-return-refinement-revalidation" $ TestCase $ + assertPrepareAsmInputError + "asm input preparation should reject function-pointer return expressions after later function refinement" + "int f(); int (*g(void))(void) { return f; } int f(int x) { return x; }" + "invalid return type" + +objectPointerReturnRefinementRevalidationTest :: Test +objectPointerReturnRefinementRevalidationTest = TestLabel "Asm.Output.object-pointer-return-refinement-revalidation" $ TestCase $ + assertPrepareAsmInputError + "asm input preparation should reject object-pointer return expressions after later tentative-array completion" + "int a[]; int (*f(void))[3] { return &a; } int a[4];" + "invalid return type" + +pointerIncDecRefinementRevalidationTest :: Test +pointerIncDecRefinementRevalidationTest = TestLabel "Asm.Output.pointer-inc-dec-refinement-revalidation" $ TestCase $ + assertBool + "same-input pointer ++/-- should reject pointer-to-array redeclarations that refine pointee bounds" + (isLeft $ + (runParser parser "" + "int (*p)[]; int main(void) { ++p; p++; --p; p--; return 0; } int (*p)[4];" + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) + ) + ) + +pointerAddSubAssignRefinementRevalidationTest :: Test +pointerAddSubAssignRefinementRevalidationTest = TestLabel "Asm.Output.pointer-add-sub-assign-refinement-revalidation" $ TestCase $ + assertBool + "same-input pointer compound assignments should reject pointer-to-array redeclarations that refine pointee bounds" + (isLeft $ + (runParser parser "" + "int (*p)[]; int main(void) { p += 1; p -= 1; return 0; } int (*p)[4];" + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) + ) + ) + +pointerIncDecIncompleteRevalidationFailureTest :: Test +pointerIncDecIncompleteRevalidationFailureTest = TestLabel "Asm.Output.pointer-inc-dec-incomplete-revalidation-failure" $ TestCase $ + assertPrepareAsmInputError + "asm input preparation should reject deferred ++/-- on pointers that stay incomplete" + "int (*f(void))[]; int main(void) { int (*p)[] = f(); ++p; return 0; }" + "invalid use of pointer to incomplete type" + +pointerAddSubAssignIncompleteRevalidationFailureTest :: Test +pointerAddSubAssignIncompleteRevalidationFailureTest = TestLabel "Asm.Output.pointer-add-sub-assign-incomplete-revalidation-failure" $ TestCase $ + assertPrepareAsmInputError + "asm input preparation should reject deferred +=/-= on pointers that stay incomplete" + "int (*f(void))[]; int main(void) { int (*p)[] = f(); p += 1; return 0; }" + "invalid use of pointer to incomplete type" + +incompleteGlobalSelfReferenceRejectedTest :: Test +incompleteGlobalSelfReferenceRejectedTest = TestLabel "Asm.Output.incomplete-global-self-reference-rejected" $ TestCase $ + assertBool + "self-referential incomplete-array global initializers should be rejected before later normalization can retype them" + (isLeft $ + (runParser parser "" + "int x[] = { sizeof x, 0 };" + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, GlobalVars Integer, Literals Integer, PF.Functions Integer) + ) + ) + +visualizerSizeofExprTest :: Test +visualizerSizeofExprTest = TestLabel "Visualizer.sizeof-expr" $ TestCase $ do + svg <- renderVisualization "int main(void) { int x; return sizeof x; }" + assertBool + "visualizer renders expression-form sizeof nodes" + ("sizeof" `T.isInfixOf` svg) + +visualizerFunctionDesignatorTest :: Test +visualizerFunctionDesignatorTest = TestLabel "Visualizer.function-designator" $ TestCase $ do + svg <- renderVisualization "int foo(void) { return 1; } int (*fp)(void) = &foo;" + assertBool + "visualizer renders bare function designators emitted as ATFuncPtr nodes" + (" T.Text -> Either (M.ParseErrorBundle T.Text Void) a +runInitializerParser p input = + fst $ runIdentity $ runStateT (M.runParserT p "" input) initConstructionData + +runInitializerParserState + :: Parser Integer a + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (ConstructionData Integer) +runInitializerParserState p input = case runIdentity $ runStateT (M.runParserT p "" input) initConstructionData of + (Left err, _) -> Left err + (Right _, state) -> Right state + +parseInitializerAST + :: CT.StorageClass Integer + -> [(T.Text, CT.StorageClass Integer)] + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (ATree Integer) +parseInitializerAST ty surroundingVars = + runInitializerParser $ do + spaceConsumer + mapM_ (\(ident, ty') -> void $ registerLVar ty' ident) surroundingVars + equal *> varInit assign ty "x" <* semi <* M.eof + +parseInitializer :: CT.StorageClass Integer -> [(T.Text, CT.StorageClass Integer)] -> T.Text -> Either (M.ParseErrorBundle T.Text Void) () +parseInitializer ty surroundingVars = + runInitializerParser $ do + spaceConsumer + mapM_ (\(ident, ty') -> void $ registerLVar ty' ident) surroundingVars + void $ equal *> varInit assign ty "x" <* semi + M.eof + +inferInitializerType + :: CT.StorageClass Integer + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (CT.StorageClass Integer) +inferInitializerType ty input = + inferInitializerTypeWithVars ty [] input + +inferInitializerTypeWithVars + :: CT.StorageClass Integer + -> [(T.Text, CT.StorageClass Integer)] + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (CT.StorageClass Integer) +inferInitializerTypeWithVars ty surroundingVars input = + fmap (PV.lvtype . maybe (error "missing variable x") id . lookupLVar "x") $ + runInitializerParserState parser' input + where + parser' = do + spaceConsumer + mapM_ (\(ident, ty') -> void $ registerLVar ty' ident) surroundingVars + void $ equal *> varInit assign ty "x" <* semi + M.eof + +inferGlobalType + :: T.Text + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (CT.StorageClass Integer) +inferGlobalType ident input = + fmap + (PV.gvtype . maybe (error $ "missing global variable " <> T.unpack ident) id . MP.lookup ident) + $ (\(_, _, gvars, _, _) -> gvars) <$> runParser parser "" input + +inferFunctionType + :: T.Text + -> T.Text + -> Either (M.ParseErrorBundle T.Text Void) (CT.StorageClass Integer) +inferFunctionType ident input = + fmap + (PF.fntype . maybe (error $ "missing function " <> T.unpack ident) id . MP.lookup ident) + $ (\(_, _, _, _, fns) -> fns) <$> runParser parser "" input + +parseProgram :: T.Text -> Either (M.ParseErrorBundle T.Text Void) () +parseProgram input = + () <$ (runParser parser "" input :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, PV.GlobalVars Integer, PV.Literals Integer, PF.Functions Integer)) + +parseProgramAllowSameInputExternalCollisions :: T.Text -> Either (M.ParseErrorBundle T.Text Void) () +parseProgramAllowSameInputExternalCollisions input = + () <$ + ( runParserAllowSameInputExternalCollisions parser "" input + :: Either (M.ParseErrorBundle T.Text Void) (Warnings, ASTs Integer, PV.GlobalVars Integer, PV.Literals Integer, PF.Functions Integer) + ) + +assertProgramErrorContains :: T.Text -> T.Text -> IO () +assertProgramErrorContains errMsg input = case parseProgram input of + Left err -> assertBool + "unexpected error message" + (errMsg `T.isInfixOf` T.pack (show err)) + Right _ -> assertFailure "expected parse failure" + +errorBundleLoc :: M.ParseErrorBundle T.Text Void -> (Int, Int) +errorBundleLoc err = + ( fromIntegral $ PP.sourceLine pos + , fromIntegral $ PP.sourceColumn pos + ) + where + pos = M.pstateSourcePos $ M.bundlePosState err + +pairMembers :: MP.Map T.Text (CT.StructMember Integer) +pairMembers = MP.fromList + [ ("left", CT.StructMember CT.CTInt 0) + , ("right", CT.StructMember CT.CTInt 8) + ] + +pairTy :: CT.StorageClass Integer +pairTy = CT.SCAuto $ CT.CTStruct pairMembers + +boxTy :: CT.StorageClass Integer +boxTy = CT.SCAuto $ CT.CTStruct $ MP.fromList + [ ("pair", CT.StructMember (CT.CTStruct pairMembers) 0) + , ("value", CT.StructMember CT.CTInt (CT.sizeof (CT.CTStruct pairMembers))) + ] + +pairArrayTy :: CT.StorageClass Integer +pairArrayTy = CT.SCAuto $ CT.CTArray 2 (CT.CTStruct pairMembers) + +charPtrTy :: CT.TypeKind Integer +charPtrTy = CT.CTPtr CT.CTChar + +charPtrIncompleteArrayTy :: CT.StorageClass Integer +charPtrIncompleteArrayTy = CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray charPtrTy + +charIncompleteArrayTy :: CT.StorageClass Integer +charIncompleteArrayTy = CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray CT.CTChar + +fixedCharArrayTy :: CT.StorageClass Integer +fixedCharArrayTy = CT.SCAuto $ CT.CTArray 3 CT.CTChar + +twoCharArrayTy :: CT.StorageClass Integer +twoCharArrayTy = CT.SCAuto $ CT.CTArray 2 CT.CTChar + +oneCharArrayTy :: CT.StorageClass Integer +oneCharArrayTy = CT.SCAuto $ CT.CTArray 1 CT.CTChar + +intArrayTy :: CT.TypeKind Integer +intArrayTy = CT.CTArray 2 CT.CTInt + +intFunctionTy :: CT.TypeKind Integer +intFunctionTy = CT.CTFunc CT.CTInt [(CT.CTVoid, Nothing)] + +intFunctionPtrTy :: CT.StorageClass Integer +intFunctionPtrTy = CT.SCAuto $ CT.CTPtr intFunctionTy + +wideIntArrayTy :: CT.TypeKind Integer +wideIntArrayTy = CT.CTArray 3 CT.CTInt + +wideNestedIntArrayTy :: CT.StorageClass Integer +wideNestedIntArrayTy = CT.SCAuto $ CT.makeCTArray [2, 3] CT.CTInt + +shortCharRowTy :: CT.TypeKind Integer +shortCharRowTy = CT.CTArray 3 CT.CTChar + +nestedIntArrayTy :: CT.StorageClass Integer +nestedIntArrayTy = CT.SCAuto $ CT.CTArray 2 intArrayTy + +fixedOuterIncompleteInnerIntArrayTy :: CT.StorageClass Integer +fixedOuterIncompleteInnerIntArrayTy = CT.SCAuto $ CT.CTArray 2 $ CT.CTIncomplete $ CT.IncompleteArray CT.CTInt + +wideOuterIncompleteInnerIntArrayTy :: CT.StorageClass Integer +wideOuterIncompleteInnerIntArrayTy = CT.SCAuto $ CT.CTArray 3 $ CT.CTIncomplete $ CT.IncompleteArray CT.CTInt + +wideOuterIncompleteInnerCharArrayTy :: CT.StorageClass Integer +wideOuterIncompleteInnerCharArrayTy = CT.SCAuto $ CT.CTArray 3 $ CT.CTIncomplete $ CT.IncompleteArray CT.CTChar + +charRowTy :: CT.TypeKind Integer +charRowTy = CT.CTArray 4 CT.CTChar + +nestedCharArrayTy :: CT.StorageClass Integer +nestedCharArrayTy = CT.SCAuto $ CT.makeCTArray [2, 4] CT.CTChar + +pointerMemberTy :: CT.StorageClass Integer +pointerMemberTy = CT.SCAuto $ CT.CTStruct $ MP.fromList + [ ("ptr", CT.StructMember (CT.CTPtr CT.CTInt) 0) + ] + +arrayMemberTy :: CT.StorageClass Integer +arrayMemberTy = CT.SCAuto $ CT.CTStruct $ MP.fromList + [ ("values", CT.StructMember intArrayTy 0) + , ("value", CT.StructMember CT.CTInt (fromIntegral $ CT.sizeof intArrayTy)) + ] + +charArrayMemberTy :: CT.StorageClass Integer +charArrayMemberTy = CT.SCAuto $ CT.CTStruct $ MP.fromList + [ ("text", CT.StructMember charRowTy 0) + , ("value", CT.StructMember CT.CTInt (fromIntegral $ CT.sizeof charRowTy)) + ] + +paddedStructTy :: CT.StorageClass Integer +paddedStructTy = CT.SCAuto $ CT.CTStruct $ MP.fromList + [ ("c", CT.StructMember CT.CTChar 0) + , ("i", CT.StructMember CT.CTInt 4) + ] + +initializerFirstStmtZeroByteOffset :: ATree Integer -> Maybe Integer +initializerFirstStmtZeroByteOffset ast = case ast of + ATNode (ATBlock (stmt:_)) _ _ _ -> initializerStmtZeroByteOffset stmt + _ -> Nothing + +initializerZeroByteOffsets :: ATree Integer -> [Integer] +initializerZeroByteOffsets ast = case ast of + ATNode (ATBlock stmts) _ _ _ -> mapMaybe initializerStmtZeroByteOffset stmts + _ -> [] + +initializerStmtZeroByteOffset :: ATree Integer -> Maybe Integer +initializerStmtZeroByteOffset (ATNode ATExprStmt _ expr _) = initializerExprZeroByteOffset expr +initializerStmtZeroByteOffset _ = Nothing + +initializerExprZeroByteOffset :: ATree Integer -> Maybe Integer +initializerExprZeroByteOffset (ATNode ATAssign _ lhs rhs) + | initializerIsZeroLiteral rhs = initializerLhsZeroByteOffset lhs + | otherwise = Nothing +initializerExprZeroByteOffset _ = Nothing + +initializerLhsZeroByteOffset :: ATree Integer -> Maybe Integer +initializerLhsZeroByteOffset (ATNode ATDeref ty ptr _) + | CT.toTypeKind ty == CT.CTChar = initializerPointerByteOffset ptr + | otherwise = Nothing +initializerLhsZeroByteOffset _ = Nothing + +initializerPointerByteOffset :: ATree Integer -> Maybe Integer +initializerPointerByteOffset (ATNode ATCast _ lhs _) = initializerPointerByteOffset lhs +initializerPointerByteOffset (ATNode ATAddPtr _ lhs (ATNode (ATNum offset) _ _ _)) = + (+ offset) <$> initializerPointerByteOffset lhs +initializerPointerByteOffset (ATNode ATAddr _ _ _) = Just 0 +initializerPointerByteOffset _ = Nothing + +initializerIsZeroLiteral :: ATree Integer -> Bool +initializerIsZeroLiteral (ATNode (ATNum 0) _ _ _) = True +initializerIsZeroLiteral _ = False + +structInitializerTest :: Test +structInitializerTest = TestLabel "Parser.Program.struct-initializer" $ + TestList + [ "rejects struct copy initialization without braces" ~: + isLeft (parseInitializer pairTy [("y", pairTy)] "= y;") ~?= True + , "rejects braced struct copy initialization" ~: + isLeft (parseInitializer pairTy [("y", pairTy)] "= { y };") ~?= True + , "rejects brace-elided nested struct copy expressions" ~: + isLeft (parseInitializer boxTy [("y", pairTy)] "= { y, 3 };") ~?= True + , "rejects braced nested struct copy expressions" ~: + isLeft (parseInitializer boxTy [("y", pairTy)] "= { { y }, 3 };") ~?= True + , "rejects brace-elided array member copy expressions" ~: + isLeft (parseInitializer arrayMemberTy [("y", CT.SCAuto intArrayTy)] "= { y, 3 };") ~?= True + , "accepts brace-elided nested struct initializers" ~: + isRight (parseInitializer boxTy [] "= { 1, 2, 3 };") ~?= True + , "accepts brace-elided array members inside struct initializers" ~: + isRight (parseInitializer arrayMemberTy [] "= { 1, 2, 3 };") ~?= True + , "rejects treating braced array members as part of a single brace-elided struct element" ~: + isLeft + ( parseInitializer + (CT.SCAuto $ CT.CTArray 1 $ CT.toTypeKind arrayMemberTy) + [] + "= { { 1, 2 }, 3 };" + ) + ~?= True + , "accepts braced array-of-struct elements whose first member is braced" ~: + isRight + ( parseInitializer + (CT.SCAuto $ CT.CTArray 2 $ CT.toTypeKind arrayMemberTy) + [] + "= { {{1, 2}, 3}, {{4, 5}, 6} };" + ) + ~?= True + , "accepts brace-elided array-of-struct initializers" ~: + isRight (parseInitializer pairArrayTy [] "= { 1, 2, 3, 4 };") ~?= True + , "accepts trailing commas after short brace-elided array-of-struct initializers" ~: + isRight (parseInitializer pairArrayTy [] "= { 1, 2, 3, };") ~?= True + , "accepts array-to-pointer decay for pointer members inside struct initializers" ~: + isRight (parseInitializer pointerMemberTy [("a", CT.SCAuto intArrayTy)] "= { a };") ~?= True + , "accepts string literals for leading char-array members in brace-elided struct initializers" ~: + isRight + ( parseInitializer + (CT.SCAuto $ CT.CTArray 1 $ CT.toTypeKind charArrayMemberTy) + [] + "= { \"abc\", 1 };" + ) + ~?= True + , TestLabel "zero-fills only omitted struct storage after explicit initialization" $ TestCase $ + case parseInitializerAST paddedStructTy [] "= { 1 };" of + Left err -> assertFailure $ show err + Right ast -> do + assertEqual + "explicit member initialization should precede zero fill" + Nothing + (initializerFirstStmtZeroByteOffset ast) + assertEqual + "unexpected zero-filled byte offsets" + [1 .. fromIntegral (pred $ CT.sizeof $ CT.toTypeKind paddedStructTy)] + (initializerZeroByteOffsets ast) + ] + +incompleteArrayInitializerTest :: Test +incompleteArrayInitializerTest = TestLabel "Parser.Program.incomplete-array-initializer" $ + TestList + [ "rejects empty brace initialization for incomplete arrays" ~: + isLeft + (inferInitializerType (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray CT.CTInt) "= {};") + ~?= True + , "rejects empty brace initialization for incomplete nested arrays" ~: + isLeft + (inferInitializerType (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray intArrayTy) "= {};") + ~?= True + , "accepts empty brace initialization for fixed arrays" ~: + isRight (parseInitializer (CT.SCAuto intArrayTy) [] "= {};") ~?= True + , "infers row count from brace-elided nested arrays" ~: + inferInitializerType + (CT.SCAuto $ CT.CTArray 2 $ CT.CTIncomplete $ CT.IncompleteArray CT.CTInt) + "= { 1, 2, 3, 4 };" + ~?= Right (CT.SCAuto $ CT.CTArray 2 intArrayTy) + , "accepts brace-elided nested arrays when only the inner bound is inferred" ~: + isRight (parseInitializer fixedOuterIncompleteInnerIntArrayTy [] "= { 1, 2, 3, 4 };") ~?= True + , "accepts brace-elided initializers when only the immediate inner array bound is inferred" ~: + isRight (parseInitializer fixedOuterIncompleteInnerIntArrayTy [] "= { 1, 2, 3, 4, 5, 6 };") ~?= True + , "infers only the immediate inner bound for braced nested arrays with fixed outer arrays" ~: + inferInitializerType + fixedOuterIncompleteInnerIntArrayTy + "= {{1, 2}, {3, 4}};" + ~?= Right (CT.SCAuto $ CT.CTArray 2 intArrayTy) + , "preserves the declared inner width when outer row count is inferred" ~: + inferInitializerType + wideOuterIncompleteInnerIntArrayTy + "= {{1, 2}, {3, 4}, {5, 6}};" + ~?= Right (CT.SCAuto $ CT.makeCTArray [3, 3] CT.CTInt) + , "preserves the declared inner width even when explicit rows are narrower" ~: + inferInitializerType + wideOuterIncompleteInnerIntArrayTy + "= {{1}, {2, 3}, {4}};" + ~?= Right (CT.SCAuto $ CT.makeCTArray [3, 3] CT.CTInt) + , "infers only the immediate inner array bound for fixed outer arrays" ~: + inferInitializerType + fixedOuterIncompleteInnerIntArrayTy + "= { 1, 2, 3, 4, 5, 6 };" + ~?= Right (CT.SCAuto $ CT.CTArray 2 wideIntArrayTy) + , "infers explicit string row width for fixed outer char arrays" ~: + inferInitializerType + wideOuterIncompleteInnerCharArrayTy + "= {\"ab\", \"cd\", \"ef\"};" + ~?= Right (CT.SCAuto $ CT.CTArray 3 shortCharRowTy) + , "preserves the declared char[][N] row width for direct string rows" ~: + inferInitializerType + wideOuterIncompleteInnerCharArrayTy + "= {\"a\", \"b\", \"c\"};" + ~?= Right (CT.SCAuto $ CT.CTArray 3 shortCharRowTy) + , "preserves the declared char[][N] row width for braced string rows" ~: + inferInitializerType + wideOuterIncompleteInnerCharArrayTy + "= {{\"a\"}, {\"b\"}, {\"c\"}};" + ~?= Right (CT.SCAuto $ CT.CTArray 3 shortCharRowTy) + , "preserves the declared char[][N] row width for braced char-list rows" ~: + inferInitializerType + wideOuterIncompleteInnerCharArrayTy + "= {{'a', 'b'}, {'c'}};" + ~?= Right (CT.SCAuto $ CT.makeCTArray [2, 3] CT.CTChar) + , "preserves the declared char[][N] row width for mixed string and braced char-list rows" ~: + inferInitializerType + wideOuterIncompleteInnerCharArrayTy + "= {\"ab\", {'c'}};" + ~?= Right (CT.SCAuto $ CT.makeCTArray [2, 3] CT.CTChar) + , "infers only the omitted outer bound for char[][4] braced char-list rows" ~: + inferInitializerType + (CT.SCAuto $ CT.CTArray 4 $ CT.CTIncomplete $ CT.IncompleteArray CT.CTChar) + "= {{'a'}};" + ~?= Right (CT.SCAuto $ CT.makeCTArray [1, 4] CT.CTChar) + , "rejects overlong string rows when char[][N] only infers the outer bound" ~: + isLeft + (parseInitializer wideOuterIncompleteInnerCharArrayTy [] "= {\"abcd\"};") + ~?= True + , "infers pointer arrays when string literals decay to pointer elements" ~: + inferInitializerType charPtrIncompleteArrayTy "= { \"x\" };" + ~?= Right (CT.SCAuto $ CT.CTArray 1 charPtrTy) + , "infers char array length from braced string initializers" ~: + inferInitializerType charIncompleteArrayTy "= {\"abc\"};" + ~?= Right (CT.SCAuto $ CT.CTArray 4 CT.CTChar) + , "accepts braced string initializers for incomplete char arrays" ~: + isRight (parseInitializer charIncompleteArrayTy [] "= {\"abc\"};") ~?= True + , "infers char[][N] bounds from braced char-list rows" ~: + inferInitializerType + (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray charRowTy) + "= {{'a'}, \"bc\"};" + ~?= Right (CT.SCAuto $ CT.makeCTArray [2, 4] CT.CTChar) + , "accepts numeric braced char-list rows while inferring char[][N] bounds" ~: + inferInitializerType + (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray charRowTy) + "= {{1}, \"bc\"};" + ~?= Right (CT.SCAuto $ CT.makeCTArray [2, 4] CT.CTChar) + , "rejects brace-elided nested array copy expressions while probing incomplete array length" ~: + isLeft + ( inferInitializerTypeWithVars + (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray intArrayTy) + [("b", CT.SCAuto intArrayTy)] + "= { b };" + ) + ~?= True + , "rejects brace-elided nested array copy expressions during initialization" ~: + isLeft (parseInitializer nestedIntArrayTy [("b", CT.SCAuto intArrayTy)] "= { b };") ~?= True + , "accepts braced scalar elements inside brace-elided nested arrays" ~: + isRight (parseInitializer nestedIntArrayTy [] "= { 1, {2}, 3 };") ~?= True + , "accepts braced rows in fixed nested arrays" ~: + isRight (parseInitializer nestedIntArrayTy [] "= {{1, 2}, {3, 4}};") ~?= True + , "accepts wide braced rows in fixed nested arrays" ~: + isRight (parseInitializer wideNestedIntArrayTy [] "= {{1, 2, 3}, {4, 5, 6}};") ~?= True + , "infers row count when brace-elided nested arrays contain braced scalar elements" ~: + inferInitializerType + (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray intArrayTy) + "= { 1, {2}, 3 };" + ~?= Right (CT.SCAuto $ CT.CTArray 2 intArrayTy) + , "infers element count from brace-elided struct aggregates" ~: + inferInitializerType + (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray (CT.CTStruct pairMembers)) + "= { 1, 2, 3, 4 };" + ~?= Right (CT.SCAuto $ CT.CTArray 2 (CT.CTStruct pairMembers)) + , "infers separate elements when struct element initialization starts with braces" ~: + inferInitializerType + (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray $ CT.toTypeKind arrayMemberTy) + "= { { 1, 2 }, 3 };" + ~?= Right (CT.SCAuto $ CT.CTArray 2 $ CT.toTypeKind arrayMemberTy) + , "infers element count when braced struct elements start with braced array members" ~: + inferInitializerType + (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray $ CT.toTypeKind arrayMemberTy) + "= { {{1, 2}, 3}, {{4, 5}, 6} };" + ~?= Right (CT.SCAuto $ CT.CTArray 2 $ CT.toTypeKind arrayMemberTy) + , "infers element count when brace-elided struct elements start with string literals" ~: + inferInitializerType + (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray $ CT.toTypeKind charArrayMemberTy) + "= { \"abc\", 1 };" + ~?= Right (CT.SCAuto $ CT.CTArray 1 $ CT.toTypeKind charArrayMemberTy) + , TestLabel "restores parser position after probing incomplete array length" $ TestCase $ + case parseInitializer + (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray intArrayTy) + [] + "={1,2};@" + of + Left err -> assertEqual "unexpected error location" (1, 8) (errorBundleLoc err) + Right _ -> assertFailure "expected parse failure" + , TestLabel "restores parser position after probing direct string length for incomplete char arrays" $ TestCase $ + case parseInitializer charIncompleteArrayTy [] "=\"abc\";@" of + Left err -> assertEqual "unexpected error location" (1, 8) (errorBundleLoc err) + Right _ -> assertFailure "expected parse failure" + , "rejects excess brace-elided rows in fixed nested arrays" ~: + isLeft (parseInitializer nestedIntArrayTy [] "= { 1, 2, 3, 4, 5 };") ~?= True + , "accepts trailing commas after short brace-elided nested arrays" ~: + isRight (parseInitializer nestedIntArrayTy [] "= { 1, 2, 3, };") ~?= True + , "accepts braced string rows in fixed nested char arrays" ~: + isRight (parseInitializer nestedCharArrayTy [] "= {{\"abc\"}, {\"def\"}};") ~?= True + , "accepts exact-fit fixed char arrays from string literals" ~: + isRight (parseInitializer fixedCharArrayTy [] "= \"abc\";") ~?= True + , "accepts exact-fit fixed char arrays from braced string literals" ~: + isRight (parseInitializer fixedCharArrayTy [] "= {\"abc\"};") ~?= True + , "accepts fixed char arrays that omit the trailing terminator when the bound is exact" ~: + isRight (parseInitializer twoCharArrayTy [] "= \"ab\";") ~?= True + , "accepts single-element fixed char arrays initialized from one-character strings" ~: + isRight (parseInitializer oneCharArrayTy [] "= \"x\";") ~?= True + , "accepts exact-fit string rows in brace-elided fixed nested char arrays" ~: + isRight (parseInitializer (CT.SCAuto $ CT.makeCTArray [1, 3] CT.CTChar) [] "= {\"abc\"};") ~?= True + , "accepts exact-fit string rows in braced fixed nested char arrays" ~: + isRight (parseInitializer (CT.SCAuto $ CT.makeCTArray [1, 3] CT.CTChar) [] "= {{\"abc\"}};") ~?= True + , "rejects overlong fixed char arrays from string literals" ~: + isLeft (parseInitializer fixedCharArrayTy [] "= \"abcd\";") ~?= True + , "rejects fixed char arrays that exceed the bound before the terminator" ~: + isLeft (parseInitializer twoCharArrayTy [] "= \"abc\";") ~?= True + , "rejects overlong fixed char arrays from braced string literals" ~: + isLeft (parseInitializer fixedCharArrayTy [] "= {\"abcd\"};") ~?= True + , "infers row count from braced string rows in incomplete nested char arrays" ~: + inferInitializerType + (CT.SCAuto $ CT.CTIncomplete $ CT.IncompleteArray charRowTy) + "= {{\"abc\"}, {\"def\"}};" + ~?= Right nestedCharArrayTy + , TestLabel "reports excess fixed-array elements at the offending initializer" $ TestCase $ + case parseInitializer nestedIntArrayTy [] "= { 1, 2, 3, 4, 5 };" of + Left err -> do + assertEqual "unexpected error location" (1, 17) (errorBundleLoc err) + assertBool + "unexpected error message" + (T.isInfixOf "excess elements in array initializer" $ T.pack $ show err) + Right _ -> assertFailure "expected parse failure" + ] + +constantExpressionTest :: Test +constantExpressionTest = TestLabel "Parser.Program.constant-expression" $ + TestList + [ "accepts '%' in array-bound constant expressions" ~: + isRight (parseProgram "int a[5 % 2]; int main(void) { return sizeof a / sizeof a[0] == 1; }") + ~?= True + , "accepts '%' in case-label constant expressions" ~: + isRight (parseProgram "int main(void) { switch (0) { case 5 % 2: return 1; default: return 0; } }") + ~?= True + , "rejects ',' in array-bound integer constant expressions" ~: + isLeft (parseProgram "int a[(1, 2)]; int main(void) { return 0; }") + ~?= True + , TestLabel "rejects ',' in case-label integer constant expressions" $ TestCase $ + assertProgramErrorContains + "The expression is not constant-expression" + "int main(void) { switch (0) { case (1, 2): return 1; default: return 0; } }" + , "short-circuits '||' in array-bound constant expressions" ~: + isRight (parseProgram "int a[1 || 1 / 0]; int main(void) { return sizeof a / sizeof a[0] == 1; }") + ~?= True + , "short-circuits '&&' in case-label constant expressions" ~: + isRight (parseProgram "int main(void) { switch (0) { case 0 && 1 % 0: return 1; default: return 0; } }") + ~?= True + , TestLabel "rejects sizeof of incomplete operands in case-label constant expressions" $ TestCase $ + assertProgramErrorContains + "invalid application of 'sizeof' to incomplete type" + "int (*p)[]; int main(void) { switch (0) { case sizeof(*p): return 1; default: return 0; } }" + , TestLabel "rejects _Alignof of incomplete operands in case-label constant expressions" $ TestCase $ + assertProgramErrorContains + "invalid application of '_Alignof' to incomplete type" + "int (*p)[]; int main(void) { switch (0) { case _Alignof(*p): return 1; default: return 0; } }" + ] + +globalInitializerTest :: Test +globalInitializerTest = TestLabel "Parser.Program.global-initializer" $ + TestList + [ "accepts file-scope declarations without declarators" ~: + isRight (parseProgram "int; int main(void) { return 0; }") + ~?= True + , "accepts file-scope static declarations without declarators" ~: + isRight (parseProgram "static int; int main(void) { return 0; }") + ~?= True + , TestLabel "rejects file-scope auto declarations without declarators" $ TestCase $ + assertProgramErrorContains + "storage-class specifier is not allowed at file scope" + "auto int; int main(void) { return 0; }" + , TestLabel "rejects file-scope register declarations without declarators" $ TestCase $ + assertProgramErrorContains + "storage-class specifier is not allowed at file scope" + "register int; int main(void) { return 0; }" + , "infers file-scope int array bounds from braced initializers" ~: + inferGlobalType "a" "int a[] = {1, 2};" + ~?= Right (CT.SCAuto $ CT.CTArray 2 CT.CTInt) + , "infers file-scope char array bounds from string initializers" ~: + inferGlobalType "s" "char s[] = \"x\";" + ~?= Right (CT.SCAuto $ CT.CTArray 2 CT.CTChar) + , "merges same-file tentative incomplete arrays with later complete declarations" ~: + inferGlobalType "x" "int x[]; int x[4];" + ~?= Right (CT.SCAuto $ CT.CTArray 4 CT.CTInt) + , "merges same-file tentative nested incomplete arrays when only the outermost bound is missing" ~: + inferGlobalType "x" "int x[][4]; int x[2][4];" + ~?= Right (CT.SCAuto $ CT.makeCTArray [2, 4] CT.CTInt) + , "rejects same-file tentative arrays whose element type is an incomplete struct" ~: + isLeft (parseProgram "struct S a[];") + ~?= True + , "rejects same-file tentative arrays whose omitted bound is not the only incompleteness" ~: + isLeft (parseProgram "int a[][];") + ~?= True + , "rejects sizeof on a tentative array before a later completing declaration" ~: + isLeft (parseProgram "int x[]; int main(void) { return sizeof x; } int x[4];") + ~?= True + , "rejects address arithmetic on a tentative array before a later completing declaration" ~: + isLeft (parseProgram "int x[]; int main(void) { return ((char*)(&x + 1)) - ((char*)&x); } int x[4];") + ~?= True + , "rejects pointer arithmetic after a later function-return pointer-to-array redeclaration changes the pointee bound" ~: + isLeft (parseProgram "int (*f(void))[]; int *g(void) { return *(f() + 1); } int (*f(void))[4];") + ~?= True + , "rejects sizeof after a later function-return pointer-to-array redeclaration changes the pointee bound" ~: + isLeft (parseProgram "int (*f(void))[]; int main(void) { return sizeof *f(); } int (*f(void))[4];") + ~?= True + , "rejects _Alignof after a later function-return pointer-to-array redeclaration changes the pointee bound" ~: + isLeft (parseProgram "int (*f(void))[]; int main(void) { return _Alignof *f(); } int (*f(void))[4];") + ~?= True + , "accepts same-file tentative nested incomplete arrays at use sites before finalization" ~: + isRight (parseProgram "int x[][4]; int main(void) { return sizeof x[0]; }") + ~?= True + , "accepts dereferenced omitted-bound array pointers in ordinary expression contexts" ~: + isRight + (parseProgram "int main(void) { int x[4]; int (*p)[] = (int (*)[])&x; int *q = *p; q[1] = 7; return (*p)[1]; }") + ~?= True + , "rejects same-file tentative arrays whose omitted bound is not outermost" ~: + isLeft (parseProgram "int x[2][]; int x[2][4];") + ~?= True + , TestLabel "rejects same-file tentative arrays whose later declaration changes rank" $ TestCase $ + case parseProgram "int x[]; int x[2][4];" of + Left err -> assertBool + "unexpected error message" + (T.isInfixOf "redeclaration of 'x' with no linkage" $ T.pack $ show err) + Right _ -> assertFailure "expected parse failure" + , "accepts file-scope static tentative incomplete arrays" ~: + isRight (parseProgram "static int x[];") ~?= True + , "accepts file-scope static function definitions" ~: + isRight (parseProgram "static int helper(void) { return 1; } int main(void) { return helper(); }") ~?= True + , "accepts top-level braced scalar int initializers" ~: + isRight (parseInitializer (CT.SCAuto CT.CTInt) [] "= {1};") ~?= True + , "accepts top-level braced scalar pointer initializers" ~: + isRight (parseInitializer (CT.SCAuto $ CT.CTPtr CT.CTChar) [] "= {\"x\"};") ~?= True + , "accepts pointer casts of address constants in file-scope initializers" ~: + isRight (parseProgram "int arr[1]; char* p = (char*)arr; int main() { return p == (char*)arr; }") + ~?= True + , "accepts casted null constants in pointer file-scope initializers" ~: + isRight (parseProgram "char *p = (char*)0; int main(void) { return p == 0; }") + ~?= True + , "accepts nested pointer-cast null constants in pointer file-scope initializers" ~: + isRight (parseProgram "int *p = (int*)(void*)0; int main(void) { return p == 0; }") + ~?= True + , "accepts plain address constants in pointer file-scope initializers" ~: + isRight (parseProgram "int g; int* p = &g;") + ~?= True + , "accepts self-referential address constants in pointer file-scope initializers" ~: + isRight (parseProgram "void *p = &p;") + ~?= True + , "accepts array-subobject decay reached through a dereference in file-scope initializers" ~: + isRight (parseProgram "int x[2][4]; int *p = x[0];") + ~?= True + , "accepts addressed array-subobject elements in file-scope initializers" ~: + isRight (parseProgram "int x[2][4]; int *p = &x[0][0];") + ~?= True + , "accepts address constants with byte addends in pointer file-scope initializers" ~: + isRight (parseProgram "int a[2]; int *p = &a[1]; char *q = \"ab\" + 1;") + ~?= True + , "accepts address constants with non-trivial integer addends in pointer file-scope initializers" ~: + isRight (parseProgram "int a[4]; int *p = a + (1 + 1);") + ~?= True + , "accepts short-circuited logical-and addends in pointer file-scope initializers" ~: + isRight (parseProgram "int a[4]; int *p = a + (0 && 1/0);") + ~?= True + , "accepts short-circuited logical-or elements in aggregate file-scope initializers" ~: + isRight (parseProgram "int g[] = {1 || 1/0};") + ~?= True + , "accepts GNU omitted-middle conditionals in scalar file-scope initializers" ~: + isRight (parseProgram "int g = 1 ?: 2; int h = 0 ?: 2; int main(void) { return g == 1 && h == 2; }") + ~?= True + , "accepts GNU omitted-middle conditionals in array bounds" ~: + isRight (parseProgram "int a[42 ?: 7]; int main(void) { return sizeof(a) / sizeof(a[0]) == 42; }") + ~?= True + , "accepts bare function designators in file-scope pointer initializers" ~: + isRight (parseProgram "int foo(void) { return 1; } int (*fp)(void) = foo;") + ~?= True + , "accepts address-of function designators in file-scope pointer initializers" ~: + isRight (parseProgram "int foo(void) { return 1; } int (*fp)(void) = &foo;") + ~?= True + , "accepts typed null function-pointer casts in file-scope initializers" ~: + isRight (parseProgram "int (*fp)(void) = (int (*)(void))0; int main(void) { return fp == 0; }") + ~?= True + , "accepts explicitly cast function designators in file-scope function-pointer initializers" ~: + isRight (parseProgram "int foo(int x) { return x; } int (*fp)(void) = (int (*)(void))foo;") + ~?= True + , "accepts void-returning bare function designators in file-scope pointer initializers" ~: + isRight (parseProgram "void helper(void) {} void (*fp)(void) = helper; int main(void) { return fp != 0; }") + ~?= True + , "accepts void-returning address-of function designators in file-scope pointer initializers" ~: + isRight (parseProgram "void helper(void) {} void (*fp)(void) = &helper; int main(void) { return fp != 0; }") + ~?= True + , "accepts function designators in aggregate file-scope function-pointer initializers" ~: + isRight (parseProgram "int foo(void) { return 1; } int (*fps[1])(void) = { foo }; int main(void) { return fps[0](); }") + ~?= True + , "accepts same-file redeclarations that refine empty parameter lists to void prototypes" ~: + isRight (parseProgram "int foo(); int foo(void) { return 1; }") + ~?= True + , "accepts same-file function redeclarations that spell int as signed" ~: + isRight (parseProgram "int foo(void); signed foo(void); int foo(void) { return 1; }") + ~?= True + , "accepts same-file function-pointer redeclarations that refine empty parameter lists to void prototypes" ~: + isRight (parseProgram "int foo(void) { return 1; } int (*fp)(); int (*fp)(void) = foo;") + ~?= True + , "rejects same-file pointer-to-array redeclarations that complete an omitted pointee bound" ~: + isLeft (parseProgram "int (*p)[]; int (*p)[4]; int main(void) { return 0; }") + ~?= True + , "rejects same-file pointer-to-array redeclarations that disagree on pointee bounds" ~: + isLeft (parseProgram "int (*p)[3]; int (*p)[4]; int main(void) { return 0; }") + ~?= True + , "rejects same-file function redeclarations that refine pointer-to-array parameter bounds" ~: + isLeft (parseProgram "int f(int (*p)[]); int f(int (*p)[4]); int main(void) { return 0; }") + ~?= True + , "accepts implicit direct calls even when a same-file global already uses the identifier" ~: + isRight (parseProgram "int foo; int main(void) { return foo(); }") + ~?= True + , TestLabel "rejects same-file function declarations that reuse a global identifier" $ TestCase $ + assertProgramErrorContains + "conflicting types for 'bar'" + "int bar; int bar(void) { return 0; }" + , TestLabel "rejects same-file global declarations that reuse a function identifier" $ TestCase $ + assertProgramErrorContains + "redeclaration of 'bar' with no linkage" + "int bar(void) { return 0; } int bar;" + , TestLabel "rejects same-file globals that reuse an implicitly declared function identifier" $ TestCase $ + assertProgramErrorContains + "redeclaration of 'bar' with no linkage" + "int foo(void) { return bar(); } static int bar;" + , TestLabel "rejects same-file redeclarations that only match via function-return equality" $ TestCase $ + case parseProgram "int *p; int (*p)(void);" of + Left err -> assertBool + "unexpected error message" + (T.isInfixOf "redeclaration of 'p' with no linkage" $ T.pack $ show err) + Right _ -> assertFailure "expected parse failure" + , "accepts same-file tentative globals that spell int as signed" ~: + isRight (parseProgram "int x; signed x; int main(void) { return x; }") + ~?= True + , TestLabel "preserves array declarators for function-pointer objects" $ TestCase $ + assertEqual + "unexpected function-pointer array type" + (Right $ CT.SCAuto $ CT.CTArray 2 $ CT.CTPtr intFunctionTy) + (inferGlobalType "fps" "int (*fps[2])(void);") + , TestLabel "preserves function return declarators when rebuilding nested arrays" $ TestCase $ + assertEqual + "unexpected function return type" + (Right $ CT.CTFunc (CT.CTPtr intArrayTy) [(CT.CTVoid, Nothing)]) + (CT.toTypeKind <$> inferFunctionType "f" "int (*f(void))[2];") + , "rejects bare function designators in non-function-pointer file-scope initializers" ~: + isLeft (parseProgram "int foo(void) { return 1; } char *p = foo;") + ~?= True + , "rejects address-of function designators in non-function-pointer file-scope initializers" ~: + isLeft (parseProgram "int foo(void) { return 1; } char *p = &foo;") + ~?= True + , TestLabel "rejects incompatible bare function designators in file-scope function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(int x) { return x; } int (*fp)(void) = foo;" + , TestLabel "rejects incompatible addressed function designators in file-scope function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(int x) { return x; } int (*fp)(void) = &foo;" + , TestLabel "rejects incompatible function-pointer values in file-scope function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(int x) { return x; } int (*a)(int) = foo; int (*b)(void) = a;" + , TestLabel "rejects object-pointer casts of function designators in file-scope function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(void) { return 1; } int (*fp)(void) = (int*)foo;" + , TestLabel "rejects intermediate object-pointer casts in file-scope function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(void) { return 1; } int (*fp)(void) = (int (*)(void))(int*)foo;" + , "rejects address constants whose folded addends raise constexpr evaluation errors" ~: + isLeft (parseProgram "int a[4]; int *p = a + (1 / 0);") + ~?= True + , "rejects plain address constants in non-pointer file-scope initializers" ~: + isLeft (parseProgram "int g; int x = &g;") + ~?= True + , "rejects non-pointer casts of address constants in file-scope initializers" ~: + isLeft (parseProgram "int arr[1]; int x = (int)arr;") ~?= True + , "rejects non-address pointer casts in pointer file-scope initializers" ~: + isLeft (parseProgram "char *p = (char*)1;") + ~?= True + , "rejects non-zero integer constant expressions in pointer file-scope initializers" ~: + isLeft (parseProgram "int *p = 1;") + ~?= True + , "rejects incompatible self-referential object-pointer file-scope initializers" ~: + isLeft (parseProgram "int *p = &p;") + ~?= True + , "rejects non-zero integer constant expressions in function-pointer file-scope initializers" ~: + isLeft (parseProgram "int (*fp)(void) = 1 + 1;") + ~?= True + , TestLabel "rejects comma expressions in scalar file-scope initializers" $ TestCase $ + assertProgramErrorContains + "initializer element is not constant" + "int x = (1, 2);" + , TestLabel "rejects comma expressions in pointer file-scope initializers" $ TestCase $ + assertProgramErrorContains + "initializer element is not constant" + "int x; int *p = (0, &x);" + , "rejects pointer-typed casts in non-pointer file-scope initializers" ~: + isLeft (parseProgram "int x = (char*)0;") + ~?= True + ] + +scalarInitializerTest :: Test +scalarInitializerTest = TestLabel "Parser.Program.scalar-initializer" $ + TestList + [ TestLabel "rejects plain void scalar initializers" $ TestCase $ + case parseProgram "void f(void) {} int main() { int x = f(); return 0; }" of + Left err -> assertBool + "unexpected error message" + (T.isInfixOf "void value not ignored as it ought to be" $ T.pack $ show err) + Right _ -> assertFailure "expected parse failure" + , TestLabel "rejects braced void scalar initializers" $ TestCase $ + case parseProgram "void f(void) {} int main() { int x = { f() }; return 0; }" of + Left err -> assertBool + "unexpected error message" + (T.isInfixOf "void value not ignored as it ought to be" $ T.pack $ show err) + Right _ -> assertFailure "expected parse failure" + , "rejects bare function designators in local scalar initializers" ~: + isLeft (parseProgram "int foo(void) { return 1; } int main(void) { int x = foo; return x; }") + ~?= True + , "rejects addressed function designators in local scalar initializers" ~: + isLeft (parseProgram "int foo(void) { return 1; } int main(void) { char *p = &foo; return p != 0; }") + ~?= True + , TestLabel "rejects incompatible object-pointer values in local scalar initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int main(void) { int a[2]; char *p = a; return 0; }" + , TestLabel "rejects function designators in void-pointer local scalar initializers without a cast" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int helper(void) { return 1; } int main(void) { void *p = helper; return p != 0; }" + , "accepts function designators cast to object pointers in local scalar initializers" ~: + isRight (parseProgram "int foo(void) { return 1; } int main(void) { char *p = (char *)foo; return p != 0; }") + ~?= True + , "accepts function designators cast to void pointers in local scalar initializers" ~: + isRight (parseProgram "int foo(void) { return 1; } int main(void) { void *p = (void *)foo; return p != 0; }") + ~?= True + , "accepts function designators cast to integers in local scalar initializers" ~: + isRight (parseProgram "int foo(void) { return 1; } int main(void) { long x = (long)foo; return x != 0; }") + ~?= True + , TestLabel "rejects conditional-wrapped function designators in local scalar initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(void) { return 1; } int main(void) { int x = 1 ? foo : foo; return x; }" + , "rejects comma-wrapped function designators in local scalar initializers" ~: + isLeft (parseProgram "int foo(void) { return 1; } int main(void) { char *p = (0, foo); return p != 0; }") + ~?= True + , TestLabel "rejects statement-expression-wrapped function designators in local scalar initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(void) { return 1; } int main(void) { char *p = ({ foo; }); return p != 0; }" + , "rejects bare function designators in brace-elided member scalar initializers" ~: + isLeft (parseProgram "int foo(void) { return 1; } struct S { int x; }; int main(void) { struct S s = { foo }; return s.x; }") + ~?= True + , "rejects addressed function designators in brace-elided member scalar initializers" ~: + isLeft (parseProgram "int foo(void) { return 1; } struct S { char *p; }; int main(void) { struct S s = { &foo }; return s.p != 0; }") + ~?= True + , "accepts bare function designators in local function-pointer initializers" ~: + isRight (parseProgram "int foo(void) { return 1; } int main(void) { int (*fp)(void) = foo; return fp(); }") + ~?= True + , TestLabel "rejects incompatible bare function designators in local function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(int x) { return x; } int main(void) { int (*fp)(void) = foo; return 0; }" + , TestLabel "rejects incompatible addressed function designators in local function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(int x) { return x; } int main(void) { int (*fp)(void) = &foo; return 0; }" + , TestLabel "rejects integer constants in local function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int main(void) { int (*fp)(void) = 1; return 0; }" + , TestLabel "rejects object pointers in local function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int main(void) { int x; int *p = &x; int (*fp)(void) = p; return 0; }" + , TestLabel "rejects object-pointer casts of function designators in local function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(void) { return 1; } int main(void) { int (*fp)(void) = (int*)foo; return 0; }" + , TestLabel "rejects intermediate object-pointer casts in local function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(void) { return 1; } int main(void) { int (*fp)(void) = (int (*)(void))(int*)foo; return 0; }" + , "accepts addressed function designators in local function-pointer initializers" ~: + isRight (parseProgram "int foo(void) { return 1; } int main(void) { int (*fp)(void) = &foo; return fp(); }") + ~?= True + , "accepts dereferenced function pointers in local function-pointer initializers" ~: + isRight (parseProgram "int foo(void) { return 1; } int main(void) { int (*fp)(void) = foo; int (*gp)(void) = *fp; return gp(); }") + ~?= True + , "accepts typed null function-pointer casts in local function-pointer initializers" ~: + isRight (parseProgram "int main(void) { int (*fp)(void) = (int (*)(void))0; return fp == 0; }") + ~?= True + , TestLabel "rejects incompatible function-pointer values in local function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(int x) { return x; } int main(void) { int (*a)(int) = foo; int (*b)(void) = a; return 0; }" + , "accepts void-returning bare function designators in local function-pointer initializers" ~: + isRight (parseProgram "void helper(void) {} int main(void) { void (*fp)(void) = helper; return fp != 0; }") + ~?= True + , "accepts void-returning function designators in aggregate function-pointer initializers" ~: + isRight (parseProgram "void helper(void) {} int main(void) { void (*fps[1])(void) = { helper }; return fps[0] != 0; }") + ~?= True + , TestLabel "rejects incompatible function designators in aggregate function-pointer initializers" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(int x) { return x; } int main(void) { int (*fps[1])(void) = { foo }; return 0; }" + , TestLabel "tracks indirect call expressions as their return type for sizeof" $ TestCase $ + case parseInitializerAST (CT.SCAuto $ CT.CTLong CT.CTInt) [("fp", intFunctionPtrTy)] "= sizeof fp();" of + Right + ( ATNode + (ATBlock [ATNode ATExprStmt _ (ATNode ATAssign _ _ (ATNode ATSizeof _ (ATNode (ATCallPtr Nothing) ty _ _) _)) _]) + _ _ _ + ) -> + assertEqual "unexpected indirect call result type" (CT.SCAuto CT.CTInt) ty + Right ast -> + assertFailure $ "unexpected AST: " <> show ast + Left err -> + assertFailure $ "unexpected parse error: " <> show err + , TestLabel "folds _Alignof over indirect calls using the return type" $ TestCase $ + case parseInitializerAST (CT.SCAuto $ CT.CTLong CT.CTInt) [("fp", intFunctionPtrTy)] "= _Alignof fp();" of + Right + ( ATNode + (ATBlock [ATNode ATExprStmt _ (ATNode ATAssign _ _ (ATNode ATAlignof _ (ATNode (ATCallPtr Nothing) ty _ _) _)) _]) + _ _ _ + ) -> + assertEqual + "unexpected indirect call result type" + (CT.SCAuto CT.CTInt) + ty + Right ast -> + assertFailure $ "unexpected AST: " <> show ast + Left err -> + assertFailure $ "unexpected parse error: " <> show err + ] + +functionDesignatorContextTest :: Test +functionDesignatorContextTest = TestLabel "Parser.Program.function-designator-context" $ + TestList + [ TestLabel "rejects sizeof on bare function designators" $ TestCase $ + assertProgramErrorContains + "invalid application of 'sizeof' to function type" + "int f(void) { return 1; } int main(void) { return sizeof f; }" + , TestLabel "rejects _Alignof on bare function designators" $ TestCase $ + assertProgramErrorContains + "invalid application of '_Alignof' to function type" + "int f(void) { return 1; } int main(void) { return _Alignof f; }" + , TestLabel "rejects incrementing bare function designators" $ TestCase $ + assertProgramErrorContains + "lvalue required as increment operand" + "int f(void) { return 1; } int main(void) { ++f; return 0; }" + , TestLabel "rejects assigning to bare function designators" $ TestCase $ + assertProgramErrorContains + "lvalue required as left operand of assignment" + "int f(void) { return 1; } int main(void) { f = 0; return 0; }" + , TestLabel "rejects unary plus on bare function designators" $ TestCase $ + assertProgramErrorContains + "invalid application of '+' to function type" + "int f(void) { return 1; } int main(void) { return +f != 0; }" + , TestLabel "rejects unary minus on bare function designators" $ TestCase $ + assertProgramErrorContains + "invalid application of '-' to function type" + "int f(void) { return 1; } int main(void) { return -f != 0; }" + , TestLabel "rejects bitwise not on bare function designators" $ TestCase $ + assertProgramErrorContains + "invalid application of '~' to function type" + "int f(void) { return 1; } int main(void) { return ~f; }" + ] + +functionCallTest :: Test +functionCallTest = TestLabel "Parser.Program.function-call" $ + TestList + [ "accepts repeated dereference of function pointers in indirect calls" ~: + isRight (parseProgram "int inc(int x) { return x + 1; } int main(void) { int (*fp)(int) = inc; return (**fp)(41) - 42; }") + ~?= True + , "accepts typed null function-pointer casts for function-pointer parameters" ~: + isRight (parseProgram "int use(int (*fp)(void)) { return fp == 0; } int main(void) { return use((int (*)(void))0); }") + ~?= True + , TestLabel "rejects old-style function designators for typed function-pointer parameters when promotions change the type" $ TestCase $ + assertProgramErrorContains + "invalid argument type to function call" + "int use(int (*fp)(char)) { return 0; } int foo(); int main(void) { return use(foo); }" + , TestLabel "rejects incompatible bare function designators for typed function-pointer parameters" $ TestCase $ + assertProgramErrorContains + "invalid argument type to function call" + "int use(int (*fp)(void)) { return fp(); } int f(int x) { return x; } int main(void) { return use(f); }" + , TestLabel "rejects integer constants for typed function-pointer parameters" $ TestCase $ + assertProgramErrorContains + "invalid argument type to function call" + "int use(int (*fp)(void)) { return fp(); } int main(void) { return use(1); }" + , TestLabel "rejects non-null integers for typed object-pointer parameters" $ TestCase $ + assertProgramErrorContains + "invalid argument type to function call" + "int use(int *p) { return p == 0; } int main(void) { return use(1); }" + , TestLabel "rejects incompatible object pointers for typed pointer parameters" $ TestCase $ + assertProgramErrorContains + "invalid argument type to function call" + "int use(char **p) { return p == 0; } int main(void) { int *x = 0; int **pp = &x; return use(pp); }" + , TestLabel "rejects too few arguments through typed function pointers" $ TestCase $ + assertProgramErrorContains + "too few arguments to function call" + "int inc(int x) { return x + 1; } int main(void) { int (*fp)(int) = inc; return fp(); }" + , TestLabel "rejects too many arguments through void function pointers" $ TestCase $ + assertProgramErrorContains + "too many arguments to function call" + "int zero(void) { return 0; } int main(void) { int (*fp)(void) = zero; return fp(1); }" + , TestLabel "rejects too many arguments after refining empty parameter lists to void prototypes" $ TestCase $ + assertProgramErrorContains + "too many arguments to function call" + "int foo(); int foo(void); int main(void) { return foo(1); }" + , TestLabel "rejects too many arguments after refining function-pointer redeclarations to void prototypes" $ TestCase $ + assertProgramErrorContains + "too many arguments to function call" + "int (*fp)(); int (*fp)(void); int main(void) { return fp(1); }" + , TestLabel "rejects too few arguments through complete function prototypes" $ TestCase $ + assertProgramErrorContains + "too few arguments to function call" + "int inc(int x) { return x + 1; } int main(void) { return inc(); }" + , TestLabel "rejects too many arguments through void function prototypes" $ TestCase $ + assertProgramErrorContains + "too many arguments to function call" + "int zero(void) { return 0; } int main(void) { return zero(1); }" + ] + +conditionalPointerTypeTest :: Test +conditionalPointerTypeTest = TestLabel "Parser.Program.conditional-pointer-type" $ + TestList + [ "preserves function-pointer results for standard conditionals against null" ~: + isRight (parseProgram "int foo(void) { return 7; } int main(void) { return (1 ? foo : 0)(); }") + ~?= True + , "preserves object-pointer results for standard conditionals against null" ~: + isRight (parseProgram "int main(void) { int x = 7; int *p = &x; return *(1 ? p : 0); }") + ~?= True + , "preserves function-pointer results for GNU omitted conditionals against null" ~: + isRight (parseProgram "int foo(void) { return 7; } int main(void) { int (*fp)(void) = foo; return (fp ?: 0)(); }") + ~?= True + , "preserves object-pointer results for GNU omitted conditionals against null" ~: + isRight (parseProgram "int main(void) { int x = 7; int *p = &x; return *(p ?: 0); }") + ~?= True + , TestLabel "rejects dereferencing standard conditionals that merge void* with object pointers" $ TestCase $ + assertProgramErrorContains + "void value not ignored as it ought to be" + "int main(void) { void *vp; int *ip; return *(1 ? vp : ip); }" + , TestLabel "rejects dereferencing GNU omitted conditionals that merge void* with object pointers" $ TestCase $ + assertProgramErrorContains + "void value not ignored as it ought to be" + "int main(void) { void *vp; int *ip; return *(vp ?: ip); }" + , TestLabel "rejects standard conditionals with incompatible object-pointer operands" $ TestCase $ + assertProgramErrorContains + "invalid operands" + "int main(void) { int x = 7; char y = 3; int *p = &x; char *q = &y; return *(1 ? p : q); }" + , TestLabel "rejects GNU omitted conditionals with incompatible object-pointer operands" $ TestCase $ + assertProgramErrorContains + "invalid operands" + "int main(void) { int x = 7; char y = 3; int *p = &x; char *q = &y; return *(p ?: q); }" + , "preserves function-pointer results for standard conditionals against void* null casts" ~: + isRight + (parseProgram "int foo(void) { return 7; } int main(void) { int (*fp)(void) = foo; return (1 ? (void*)0 : fp) == 0; }") + ~?= True + , "preserves function-pointer results for GNU omitted conditionals against void* null casts" ~: + isRight + (parseProgram "int foo(void) { return 7; } int main(void) { int (*fp)(void) = foo; return (fp ?: (void*)0) != 0; }") + ~?= True + ] + +functionPointerAssignmentTest :: Test +functionPointerAssignmentTest = TestLabel "Parser.Program.function-pointer-assignment" $ + TestList + [ "accepts compatible function-pointer assignments from variables" ~: + isRight (parseProgram "int foo(void) { return 1; } int main(void) { int (*a)(void) = foo; int (*b)(void) = 0; b = a; return b(); }") + ~?= True + , "accepts typed null function-pointer casts in function-pointer assignments" ~: + isRight (parseProgram "int main(void) { int (*fp)(void) = 0; fp = (int (*)(void))0; return fp == 0; }") + ~?= True + , TestLabel "rejects old-style function declarations in typed function-pointer initializers when promotions change the type" $ TestCase $ + assertProgramErrorContains + "invalid initializer for scalar object" + "int foo(); int main(void) { int (*fp)(char) = foo; return 0; }" + , TestLabel "rejects assigning bare function designators to ordinary scalars" $ TestCase $ + assertProgramErrorContains + "invalid operands to assignment" + "int helper(void) { return 1; } int main(void) { int x; x = helper; return 0; }" + , TestLabel "rejects assigning incompatible object-pointer values" $ TestCase $ + assertProgramErrorContains + "invalid operands to assignment" + "int main(void) { char *p = 0; int a[2]; p = a; return 0; }" + , TestLabel "rejects assigning function designators to object pointers without a cast" $ TestCase $ + assertProgramErrorContains + "invalid operands to assignment" + "int helper(void) { return 1; } int main(void) { void *p = 0; p = helper; return 0; }" + , TestLabel "rejects incompatible bare function designators in function-pointer assignments" $ TestCase $ + assertProgramErrorContains + "invalid operands to assignment" + "int foo(int x) { return x; } int main(void) { int (*fp)(void) = 0; fp = foo; return 0; }" + , TestLabel "rejects assigning old-style function pointers to typed function pointers when promotions change the type" $ TestCase $ + assertProgramErrorContains + "invalid operands to assignment" + "int foo(); int main(void) { int (*src)() = foo; int (*dst)(char) = 0; dst = src; return 0; }" + , TestLabel "rejects incompatible function-pointer values in function-pointer assignments" $ TestCase $ + assertProgramErrorContains + "invalid operands to assignment" + "int foo(int x) { return x; } int main(void) { int (*a)(int) = foo; int (*b)(void) = 0; b = a; return 0; }" + , TestLabel "rejects assigning object pointers to function pointers" $ TestCase $ + assertProgramErrorContains + "invalid operands to assignment" + "int main(void) { int x; int *p = &x; int (*fp)(void) = 0; fp = p; return 0; }" + ] + +functionPointerArithmeticTest :: Test +functionPointerArithmeticTest = TestLabel "Parser.Program.function-pointer-arithmetic" $ + TestList + [ TestLabel "rejects adding to function pointers" $ TestCase $ + assertProgramErrorContains + "invalid operands" + "int helper(void) { return 0; } int main(void) { int (*fp)(void) = helper; fp + 1; return 0; }" + , TestLabel "rejects subtracting function pointers" $ TestCase $ + assertProgramErrorContains + "invalid operands" + "int helper(void) { return 0; } int main(void) { int (*fp)(void) = helper; int (*gp)(void) = helper; return fp - gp; }" + ] + +sameInputExternalCollisionTest :: Test +sameInputExternalCollisionTest = TestLabel "Parser.Program.same-input-external-collision" $ + TestList + [ "accepts prototype-before-global collisions in allowSameInputExternalCollisions mode" ~: + isRight + ( parseProgramAllowSameInputExternalCollisions + "int foo(void); int foo; int main(void) { return 0; }" + ) + ~?= True + , "accepts global-before-prototype collisions in allowSameInputExternalCollisions mode" ~: + isRight + ( parseProgramAllowSameInputExternalCollisions + "int foo; int foo(void); int main(void) { return 0; }" + ) + ~?= True + ] + test :: Test test = TestLabel "Parser.Combinators.Core" $ TestList [ @@ -192,4 +1304,15 @@ test = TestLabel "Parser.Combinators.Core" $ , naturalTest , integerTest , identifierTest + , structInitializerTest + , incompleteArrayInitializerTest + , constantExpressionTest + , globalInitializerTest + , scalarInitializerTest + , sameInputExternalCollisionTest + , functionDesignatorContextTest + , functionCallTest + , conditionalPointerTypeTest + , functionPointerAssignmentTest + , functionPointerArithmeticTest ] diff --git a/test/Tests/SubProcTests.hs b/test/Tests/SubProcTests.hs index 294d3d9..d2cd490 100644 --- a/test/Tests/SubProcTests.hs +++ b/test/Tests/SubProcTests.hs @@ -6,6 +6,7 @@ module Tests.SubProcTests ( import Data.Char (ord) import qualified Htcc.CRules.Types as CT import Numeric.Natural +import qualified Tests.SubProcTests.AsmOutput as AsmOutput import qualified Tests.SubProcTests.LinkFuncRet as LinkFuncRet import qualified Tests.SubProcTests.LinkFuncStdOut as LinkFuncStdOut import qualified Tests.SubProcTests.StatementEqual as StatementEqual @@ -77,8 +78,34 @@ exec = runTestsEx , (LinkFuncRet.test "int main() { int a; a = test_func1(); test_func1(); return a; }" ["test_func1"], 0) , (LinkFuncRet.test "int main() { return test_func2(40); }" ["test_func2"], 0) , (LinkFuncRet.test "int main() { return test_func5(1, 2); }" ["test_func5"], 3) + , (StatementEqual.test "long sum7(long a, long b, long c, long d, long e, long f, long g) { return a + b + c + d + e + f + g; } int main(void) { return sum7(1, 2, 3, 4, 5, 6, 7) - 28; }", 0) + , (StatementEqual.test "long last7(long a, long b, long c, long d, long e, long f, long g) { return g; } int main(void) { return last7(1, 2, 3, 4, 5, 6, 7) - 7; }", 0) + , (StatementEqual.test "long g(void) { return 7; } long sum8(long a, long b, long c, long d, long e, long f, long g_, long h) { return g_ + h; } int main(void) { return sum8(1, 2, 3, 4, 5, 6, g(), 8) - 15; }", 0) + , (LinkFuncRet.test "long sum7(long, long, long, long, long, long, long); int main(void) { long (*fp)(long, long, long, long, long, long, long); fp = sum7; return fp(1, 2, 3, 4, 5, 6, 7) - 28; }" ["test_func3"], 0) + , (StatementEqual.test "long sum7(long a, long b, long c, long d, long e, long f, long g) { return a + b + c + d + e + f + g; } int main(void) { long (*fp)(long, long, long, long, long, long, long); fp = sum7; return fp(1, 2, 3, 4, 5, 6, 7) - 28; }", 0) + , (StatementEqual.test "long last7(long a, long b, long c, long d, long e, long f, long g) { return g; } int main(void) { long (*fp)(long, long, long, long, long, long, long); fp = last7; return fp(1, 2, 3, 4, 5, 6, 7) - 7; }", 0) + , (StatementEqual.test "long g(void) { return 7; } long sum8(long a, long b, long c, long d, long e, long f, long g_, long h) { return g_ + h; } int main(void) { long (*fp)(long, long, long, long, long, long, long, long); fp = sum8; return fp(1, 2, 3, 4, 5, 6, g(), 8) - 15; }", 0) + , (StatementEqual.test "int helper(void) { return 7; } int main(void) { int (*fp)(void) = helper; int (*gp)(void); gp = *fp; return gp != helper; }", 0) + , (StatementEqual.test "int helper(void) { return 7; } int main(void) { int (*fp)(void) = helper; return *fp != helper; }", 0) + , (StatementEqual.test "int helper(void) { return 42; } int main(void) { int a[4]; return sizeof(0, a) != sizeof(int*) || (0, helper)() != 42; }", 0) + , (StatementEqual.test "int main(void) { int x; x = 0; x = (1, 2); return x - 2; }", 0) + , (StatementEqual.test "int x[]; int *f(void) { return x; } int main(void) { x[0] = 1; return f() != x || x[0] != 1; }", 0) , (StatementEqual.test "int f() { return 42; } int main() { return f(); }", 42) , (StatementEqual.test "int g() { return 42; } int f() { return g(); } int main() { return f(); }", 42) + , (StatementEqual.test "_Bool f(void) { return 2; } int main(void) { return f() != 1; }", 0) + , (StatementEqual.test "_Bool f(int x) { return x; } int main(void) { return f(256) != 1; }", 0) + , (StatementEqual.test "_Bool f(void) { return 2; } int main(void) { _Bool (*fp)(void); fp = f; return fp() != 1; }", 0) + , (StatementEqual.test "_Bool f(int x) { return x; } int main(void) { _Bool (*fp)(int); fp = f; return fp(256) != 1; }", 0) + , (StatementEqual.test "int main(void) { _Bool b; _Bool c; b = 1; c = 1; return sizeof(b + c) - 4; }", 0) + , (StatementEqual.test "int main(void) { _Bool b; b = 1; return sizeof(+b) - 4; }", 0) + , (StatementEqual.test "int main(void) { _Bool b; b = 1; return sizeof(-b) - 4; }", 0) + , (LinkFuncRet.test "int test_bool_arg(_Bool); int main(void) { return test_bool_arg(256) - 1; }" ["test_bool_arg"], 0) + , (LinkFuncRet.test "int test_bool_arg(_Bool); int main(void) { int (*fp)(_Bool); fp = test_bool_arg; return fp(256) - 1; }" ["test_bool_arg"], 0) + , (LinkFuncRet.test "int test_bool_arg(); int main(void) { return test_bool_arg(256); }" ["test_bool_arg"], 0) + , (LinkFuncRet.test "int test_bool_arg(_Bool); int main(void) { int (*fp)(); fp = test_bool_arg; return fp(256); }" ["test_bool_arg"], 0) + , (AsmOutput.externalBoolLowByteNormalizationTest, 0) + , (AsmOutput.externalBoolParameterLowByteNormalizationTest, 0) + , (AsmOutput.externalIntegralReturnNormalizationTest, 0) , (StatementEqual.test "int id(int a) { return a; } int main() { int a; a = 1; return id(a-1) + id(1); }", 1) , (StatementEqual.test "int get1() { return 1; } int get2() { return 2; } int main() { int a; a = get1(); return a + get2(); }", 3) , (StatementEqual.test "int add(int a, int b) { return a + b; } int main() { return add(1, 2); }", 3) @@ -129,6 +156,8 @@ exec = runTestsEx , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; p[4] = 42; return ar[1][1]; }", 42) , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; p[5] = 42; return ar[1][2]; }", 42) , (StatementEqual.test "int main() { int ar[2][3]; int* p; p = ar; p[6] = 42; return ar[2][0]; }", 42) + , (StatementEqual.test "int main() { int a[][2] = {1, 2, 3, 4}; return sizeof a / sizeof a[0]; }", 2) + , (StatementEqual.test "int main(void) { int x[4]; int (*p)[] = (int (*)[])&x; int *q = *p; q[1] = 7; return (*p)[1]; }", 7) , (StatementEqual.test "int main() { int a; return sizeof(a); }", fromIntegral $ sizeof CT.CTInt) , (StatementEqual.test "int main() { int a; return sizeof a; }", fromIntegral $ sizeof CT.CTInt) , (StatementEqual.test "int main() { int* p; return sizeof p; }", fromIntegral $ sizeof $ CT.CTPtr CT.CTInt) @@ -143,6 +172,10 @@ exec = runTestsEx , (StatementEqual.test "int g; int main() { return g; }", 0) , (StatementEqual.test "int g; int main() { g = 42; return g; }", 42) , (StatementEqual.test "int g = 42; int main() { return g; }", 42) + , (StatementEqual.test "int g = (char)0x1234; int main() { return g; }", 52) + , (StatementEqual.test "int g = (char)0xff; int main() { return g == -1; }", 1) + , (StatementEqual.test "int g[] = {1, 2}; int main() { return sizeof g / sizeof g[0] + g[1]; }", 4) + , (StatementEqual.test "char s[] = \"x\"; int main() { return s[0] + s[1]; }", ord 'x') --, (StatementEqual.test "int g = 42; int h = g; int main() { return h; }", 42) , (StatementEqual.test "int g = 42; int* h = &g; int main() { return *h; }", 42) , (StatementEqual.test "int gr[3]; int main() { int i; i = 0; for (; i < sizeof gr / sizeof gr[0]; i = i + 1) gr[i] = i + 1; return gr[0]; }", 1) @@ -193,9 +226,148 @@ exec = runTestsEx , (StatementEqual.test "int main() { int* ar[3]; int x; ar[0] = &x; x = 42; ar[0][0]; }", 42) , (StatementEqual.test "int main() { int a = 42; return ({ a; }); }", 42) , (StatementEqual.test "int main() { return ({ int a = 42; int b = 1; a + b; }); }", 43) + , (StatementEqual.test "int main() { int x = {1}; return x; }", 1) + , (StatementEqual.test "int main() { char* p = {\"x\"}; return p[0]; }", ord 'x') ] *> runTestsEx [ (LinkFuncStdOut.test "int test_func1(); int main() { return test_func1(); }" ["test_func1"], Right "test/Tests/csrc/externals/test_func1.c::test_func1(): [OK]") , (LinkFuncStdOut.test "int test_func2(); int main() { return test_func2(40); }" ["test_func2"], Right "test/Tests/csrc/externals/test_func2.c::test_func2(40) outputs: \"2 3 5 7 11 13 17 19 23 29 31 37 \": [OK]") + , (AsmOutput.outputFileTest, Right "CLI -o writes complete asm to the requested file") + , (AsmOutput.outputFileSingleInputStaticTest, Right "CLI -o preserves internal-linkage symbols for single-input outputs") + , (AsmOutput.outputFileSingleInputImplicitFunctionTest, Right "CLI -o keeps single-input implicit function calls on the standalone code path") + , (AsmOutput.outputFileSingleInputImplicitFunctionConflictTest, Right "CLI -o rejects single-input implicit-function/global collisions on the standalone code path") + , (AsmOutput.outputFileSingleInputStaticImplicitFunctionConflictTest, Right "CLI -o rejects single-input implicit-function/static-global collisions on the standalone code path") + , (AsmOutput.outputFileSingleInputPrototypeRetypeTest, Right "CLI -o revalidates same-file direct calls after later prototype refinements") + , (AsmOutput.stdoutSingleInputImplicitFunctionConflictTest, Right "CLI stdout rejects single-input implicit-function/global collisions on the standalone code path") + , (AsmOutput.stdoutMultiInputStaticFunctionTest, Right "CLI stdout namespaces internal-linkage functions across multiple inputs") + , (AsmOutput.stdoutMultiInputImplicitFunctionDefinitionWarningTest, Right "CLI stdout suppresses pre-merge implicit-function warnings once another input provides the declaration") + , (AsmOutput.stdoutMultiInputImplicitFunctionUnresolvedWarningTest, Right "CLI stdout keeps implicit-function warnings when other inputs do not provide a real declaration") + , (AsmOutput.stdoutMultiInputParseFailurePreservesWarningsTest, Right "CLI stdout flushes earlier warnings before aborting on a later multi-input parse failure") + , (AsmOutput.stdoutMultiInputPrototypeOnlyArityRetypeTest, Right "CLI stdout revalidates direct calls after merging later prototype-only declarations") + , (AsmOutput.stdoutMultiInputParameterIndirectFunctionPointerArityRetypeTest, Right "CLI stdout revalidates indirect calls inside definitions after merged parameter-type refinements") + , (AsmOutput.outputFileMultiInputTest, Right "CLI -o combines asm from multiple inputs into one file") + , (AsmOutput.outputFileMultiInputFunctionDeclarationConflictTest, Right "CLI -o rejects function declarations that conflict with globals across multiple inputs") + , (AsmOutput.outputFileMultiInputImplicitFunctionConflictTest, Right "CLI -o rejects implicit function references that conflict with globals across multiple inputs") + , (AsmOutput.outputFileMultiInputConflictPreservesWarningsTest, Right "CLI -o preserves earlier warnings even when multi-input merge later fails") + , (AsmOutput.outputFileMultiInputReadFailurePreservesWarningsTest, Right "CLI -o flushes earlier warnings before aborting on a later multi-input read failure") + , (AsmOutput.outputFileMultiInputImplicitFunctionTypeConflictTest, Right "CLI -o rejects implicit function references that conflict with later function declarations across multiple inputs") + , (AsmOutput.outputFileMultiInputImplicitFunctionTypeConflictReverseOrderTest, Right "CLI -o rejects implicit function references that conflict with earlier function declarations across multiple inputs") + , (AsmOutput.outputFileMultiInputFunctionTypeConflictTest, Right "CLI -o rejects incompatible extern function declarations across multiple inputs") + , (AsmOutput.outputFileMultiInputFunctionPointerRedeclarationConflictTest, Right "CLI -o rejects extern globals that only looked compatible via function-return equality") + , (AsmOutput.outputFileMultiInputAdjustedFunctionParamTypeTest, Right "CLI -o accepts compatible extern declarations after array/function parameter adjustment") + , (AsmOutput.outputFileMultiInputCompatiblePrototypeMergeTest, Right "CLI -o rejects extern function returns that only differ by pointee array bound inference") + , (AsmOutput.outputFileMultiInputRepeatedPrototypeTest, Right "CLI -o accepts repeated prototypes when another input provides the single function definition") + , (AsmOutput.outputFileMultiInputPrototypeOnlyArityRetypeTest, Right "CLI -o revalidates direct calls after merging later prototype-only declarations") + , (AsmOutput.outputFileMultiInputSignedIntRedeclarationTest, Right "CLI -o accepts compatible int/signed redeclarations across multiple inputs") + , (AsmOutput.outputFileMultiInputOldStyleDeclarationTest, Right "CLI -o accepts old-style declarations when another input provides the function definition") + , (AsmOutput.outputFileMultiInputOldStylePromotionConflictTest, Right "CLI -o rejects old-style declarations that only match after default promotions") + , (AsmOutput.outputFileMultiInputVoidPrototypeConflictTest, Right "CLI -o rejects void prototypes that conflict with later parameterized declarations") + , (AsmOutput.outputFileMultiInputImplicitFunctionDefinitionTest, Right "CLI -o accepts implicit function calls when another input provides the function definition") + , (AsmOutput.outputFileMultiInputDeferredIncompletePointeeUseTest, Right "CLI -o rejects cross-input function returns that only differ by pointee array bound inference") + , (AsmOutput.outputFileMultiInputDeferredIncompletePointerAddSubAssignRejectTest, Right "CLI -o rejects deferred +=/-= on incomplete pointers before emitting asm") + , (AsmOutput.outputFileMultiInputDeferredIncompletePointerIncDecRejectTest, Right "CLI -o rejects deferred ++/-- on incomplete pointers before emitting asm") + , (AsmOutput.outputFileMultiInputImplicitFunctionArityRetypeTest, Right "CLI -o revalidates implicit calls against later merged function arity") + , (AsmOutput.outputFileMultiInputImplicitFunctionObjectPointerRetypeTest, Right "CLI -o rejects implicit calls that later resolve to object-pointer parameters") + , (AsmOutput.outputFileMultiInputImplicitFunctionObjectPointerMismatchRetypeTest, Right "CLI -o rejects implicit calls whose merged object-pointer parameters are incompatible") + , (AsmOutput.outputFileMultiInputIndirectFunctionPointerArityRetypeTest, Right "CLI -o revalidates indirect calls after merged extern function-pointer declarations") + , (AsmOutput.outputFileMultiInputParameterSizeofRetypeTest, Right "CLI -o rejects cross-input parameter declarations that only differ by pointer-to-array bounds") + , (AsmOutput.outputFileMultiInputIndirectFunctionPointerVoidRetypeTest, Right "CLI -o preserves void prototypes when merged extern function-pointer declarations refine empty parameter lists") + , (AsmOutput.outputFileMultiInputImplicitFunctionVoidRetypeTest, Right "CLI -o rejects implicit calls whose merged target later resolves to a void prototype") + , (AsmOutput.outputFileMultiInputFunctionDesignatorAssignmentRetypeTest, Right "CLI -o rechecks function-designator assignments after merged prototypes") + , (AsmOutput.outputFileMultiInputFunctionDesignatorReturnRetypeTest, Right "CLI -o rechecks function-pointer returns after merged prototypes") + , (AsmOutput.outputFileMultiInputObjectPointerReturnRetypeTest, Right "CLI -o rechecks object-pointer returns after merged tentative-array completion") + , (AsmOutput.outputFileMultiInputFunctionDesignatorInitializerRetypeTest, Right "CLI -o rechecks function-pointer initializers after merged prototypes") + , (AsmOutput.outputFileMultiInputFunctionDesignatorInitializerParamRefinementRetypeTest, Right "CLI -o rejects merged function-pointer initializers when parameter declarations conflict on pointer-to-array bounds") + , (AsmOutput.outputFileMultiInputObjectPointerAssignmentRetypeTest, Right "CLI -o rechecks object-pointer assignments after merged tentative-array completion") + , (AsmOutput.outputFileMultiInputObjectPointerInitializerRetypeTest, Right "CLI -o rechecks object-pointer initializers after merged tentative-array completion") + , (AsmOutput.outputFileMultiInputPointerPointeeArrayConflictTest, Right "CLI -o rejects extern pointer-to-array declarations that disagree on pointee bounds") + , (AsmOutput.outputFileMultiInputAggregateFunctionDesignatorInitializerTest, Right "CLI -o accepts aggregate function-pointer initializers during merged global revalidation") + , (AsmOutput.outputFileMultiInputSameInputImplicitFunctionConflictTest, Right "CLI -o rejects same-input implicit-function/global collisions even when another input is present") + , (AsmOutput.outputFileMultiInputSameInputFunctionDeclarationConflictTest, Right "CLI -o rejects same-input prototype/global collisions even when another input is present") + , (AsmOutput.outputFileMultiInputSameInputStaticImplicitFunctionConflictTest, Right "CLI -o rejects same-input implicit-function/static-global collisions even when another input is present") + , (AsmOutput.outputFileMultiInputSameInputInternalLinkageConflictTest, Right "CLI -o rejects same-input object/function collisions involving internal linkage even when another input is present") + , (AsmOutput.outputFileMultiInputTentativeGlobalTest, Right "CLI -o coalesces tentative globals across multiple inputs") + , (AsmOutput.outputFileMultiInputTentativeArrayTest, Right "CLI -o coalesces tentative array declarations across multiple inputs") + , (AsmOutput.outputFileMultiInputTentativeArrayDecayRetypeTest, Right "CLI -o retypes earlier array-decay uses after cross-input tentative-array completion") + , (AsmOutput.outputFileMultiInputTentativeIncompleteArrayTest, Right "CLI -o materializes merged tentative incomplete arrays as one element") + , (AsmOutput.outputFileMultiInputTentativeNestedIncompleteArrayTest, Right "CLI -o rejects address arithmetic on tentative nested arrays before any cross-input merge") + , (AsmOutput.outputFileMultiInputTentativeNestedArrayExtentInferenceTest, Right "CLI -o keeps each input bound to its own incomplete tentative nested-array use sites") + , (AsmOutput.outputFileMultiInputTentativeArrayRankConflictTest, Right "CLI -o rejects tentative array merges that change array rank across multiple inputs") + , (AsmOutput.outputFileMultiInputTentativeArrayInnerExtentConflictTest, Right "CLI -o rejects tentative array merges that disagree on inner extents across multiple inputs") + , (AsmOutput.outputFileMultiInputTentativeArrayUseSiteTest, Right "CLI -o rejects sizeof on tentative arrays before cross-input completion") + , (AsmOutput.outputFileMultiInputTentativeArrayAddressUseSiteTest, Right "CLI -o rejects address-based pointer arithmetic on tentative arrays before cross-input completion") + , (AsmOutput.outputFileMultiInputTentativeArrayInitializerRetypeTest, Right "CLI -o rejects global initializers that depend on later cross-input tentative-array completion") + , (AsmOutput.outputFileMultiInputStaticTest, Right "CLI -o namespaces internal-linkage symbols across multiple inputs") + , (AsmOutput.outputFileMultiInputStaticFunctionTest, Right "CLI -o namespaces internal-linkage functions across multiple inputs") + , (AsmOutput.outputFileMultiInputStaticFunctionPointerTest, Right "CLI -o namespaces internal-linkage function designators across multiple inputs") + , (AsmOutput.outputFilePreservesExistingModeTest, Right "CLI -o preserves the existing output file mode when replacing it") + , (AsmOutput.outputFileClearsSpecialBitsTest, Right "CLI -o clears setuid/setgid/sticky bits when replacing an existing output") + , (AsmOutput.outputFileFollowsSymlinkTargetTest, Right "CLI -o updates symlink targets without replacing the symlink itself") + , (AsmOutput.outputFileSpecialPathDevNullTest, Right "CLI -o writes directly to special output paths such as /dev/null") + , (AsmOutput.outputFileSamePathTest, Right "CLI -o rejects same-path input/output aliases before overwriting source files") + , (AsmOutput.outputFileHardLinkAliasTest, Right "CLI -o rejects hard-linked input/output aliases before overwriting source files") + , (AsmOutput.outputFileParseFailurePreservesExistingOutputTest, Right "CLI -o preserves existing outputs when parsing fails before opening the destination") + , (AsmOutput.outputFileReadFailurePreservesExistingOutputTest, Right "CLI -o preserves existing outputs when reading an input fails before opening the destination") + , (AsmOutput.outputFileOpenFailurePreservesExistingOutputTest, Right "CLI -o preserves existing outputs when opening the destination fails") + , (AsmOutput.outputFileHardLinkedRenameReplacementPreservesAliasTest, Right "CLI -o replaces hard-linked outputs via rename without rewriting sibling aliases") + , (AsmOutput.outputFileReadOnlyParentWritableTargetTest, Right "CLI -o falls back to in-place writes when an existing output is writable but its parent directory is not") + , (AsmOutput.outputFileReadOnlyParentWriteOnlyTargetTest, Right "CLI -o falls back to in-place writes when an existing write-only output has a read-only parent directory") + , (AsmOutput.outputFileReadOnlyParentHardLinkAliasPreservesExistingOutputTest, Right "CLI -o refuses read-only-parent fallback writes that would overwrite hard-linked aliases") + , (AsmOutput.outputFileReadOnlyParentWriteFailurePreservesExistingOutputTest, Right "CLI -o preserves existing outputs when fallback writes fail under a read-only parent directory") + , (AsmOutput.outputFileWriteFailurePreservesExistingOutputTest, Right "CLI -o preserves existing outputs when asm emission fails after opening the replacement file") + , (AsmOutput.outputFileFreshOutputRestrictiveUmaskTest, Right "CLI -o creates fresh outputs under restrictive umasks and applies the final mode after writing") + , (AsmOutput.runAsmTest, Right "CLI -r keeps asm off stdout and still produces a runnable binary") + , (AsmOutput.runAsmSingleInputImplicitFunctionConflictTest, Right "CLI -r rejects single-input implicit-function/global collisions before invoking the assembler") + , (AsmOutput.runAsmSpecialPathDevNullTest, Right "CLI -r links directly to special output paths such as /dev/null") + , (AsmOutput.runAsmPreservesExecutableBitsTest, Right "CLI -r preserves execute bits when replacing a non-executable output") + , (AsmOutput.runAsmPreservesExistingExecuteMaskTest, Right "CLI -r preserves the existing execute mask when replacing a private executable") + , (AsmOutput.runAsmRestoresOwnerExecuteBitTest, Right "CLI -r restores owner execute when replacing outputs that were executable only for group/other") + , (AsmOutput.runAsmFreshOutputInPlaceLinkDriverTest, Right "CLI -r preserves execute bits for fresh outputs when the link driver rewrites -o in place") + , (AsmOutput.runAsmProbePreservesPrecreatedOutputTest, Right "CLI -r probes link drivers against a pre-created output file") + , (AsmOutput.runAsmClearsSpecialBitsTest, Right "CLI -r clears setuid/setgid/sticky bits when replacing an existing output") + , (AsmOutput.runAsmLinkUsesResolvedDriverTest, Right "CLI -r reuses the resolved HTCC_ASSEMBLER driver when linking") + , (AsmOutput.runAsmBareLocalAssemblerPathTest, Right "CLI -r prefers PATH bare HTCC_ASSEMBLER drivers over ./") + , (AsmOutput.runAsmQuotedCompilerTest, Right "CLI -r quotes assembler paths selected from HTCC_ASSEMBLER") + , (AsmOutput.runAsmWrappedAssemblerTest, Right "CLI -r preserves wrapper args selected from HTCC_ASSEMBLER") + , (AsmOutput.runAsmWrappedAssemblerFirstWordDriverTest, Right "CLI -r resolves only the first HTCC_ASSEMBLER shell word as the driver executable") + , (AsmOutput.runAsmWrappedAssemblerProbeFallbackTest, Right "CLI -r accepts wrapper commands whose probe flags fail when assemble/link forwarding still works") + , (AsmOutput.runAsmWrappedAssemblerHostMetadataFallbackTest, Right "CLI -r accepts wrapped drivers whose metadata probes report the host target while assemble/link forwarding stays x86_64-ELF") + , (AsmOutput.runAsmAcceptsMarkerStrippedFinalOutputTest, Right "CLI -r accepts valid final x86_64-ELF outputs even when wrapped drivers strip htcc's unreferenced marker") + , (AsmOutput.runAsmLeadingEnvAssignmentTest, Right "CLI -r applies leading PATH env assignments in HTCC_ASSEMBLER before resolving the driver") + , (AsmOutput.runAsmLeadingEnvAssignmentWithoutEnvPathTest, Right "CLI -r executes PATH-assigned HTCC_ASSEMBLER drivers without depending on env in the parent PATH") + , (AsmOutput.runAsmLeadingEnvAssignmentPreservesPathOverrideTest, Right "CLI -r preserves leading PATH env assignments in HTCC_ASSEMBLER exactly during invocation") + , (AsmOutput.runAsmEnvPathOverrideEmptyEntryTest, Right "CLI -r keeps empty PATH entries in HTCC_ASSEMBLER overrides when resolving bare drivers") + , (AsmOutput.runAsmEnvPathOverrideNoLocalFallbackTest, Right "CLI -r does not fall back to ./ when HTCC_ASSEMBLER overrides PATH") + , (AsmOutput.runAsmQuotedBackslashArgTest, Right "CLI -r preserves backslashes in quoted HTCC_ASSEMBLER args") + , (AsmOutput.runAsmIgnoresCcTest, Right "CLI -r ignores inherited CC and falls back to gcc") + , (AsmOutput.runAsmGccPrefersPathTest, Right "CLI -r prefers PATH gcc over ./gcc when HTCC_ASSEMBLER is unset") + , (AsmOutput.runAsmFailurePreservesExistingOutputTest, Right "CLI -r preserves existing outputs when the assembler command fails before linking") + , (AsmOutput.runAsmParseFailurePreservesExistingOutputTest, Right "CLI -r preserves existing outputs when parsing fails before assembler invocation") + , (AsmOutput.runAsmReadFailurePreservesExistingOutputTest, Right "CLI -r preserves existing outputs when reading an input fails before assembler invocation") + , (AsmOutput.runAsmHardLinkedRenameReplacementPreservesAliasTest, Right "CLI -r replaces hard-linked outputs via rename without rewriting sibling aliases") + , (AsmOutput.runAsmReadOnlyParentWritableTargetTest, Right "CLI -r falls back to in-place linking when an existing output is writable but its parent directory is not") + , (AsmOutput.runAsmReadOnlyParentWriteOnlyTargetTest, Right "CLI -r falls back to in-place linking when an existing write-only output has a read-only parent directory") + , (AsmOutput.runAsmReadOnlyParentExecutableOnlyTargetTest, Right "CLI -r falls back to in-place linking when an existing executable-only output has a read-only parent directory") + , (AsmOutput.runAsmReadOnlyParentHardLinkAliasPreservesExistingOutputTest, Right "CLI -r refuses read-only-parent fallback linking that would overwrite hard-linked aliases") + , (AsmOutput.runAsmReadOnlyParentLinkFailurePreservesExistingOutputTest, Right "CLI -r preserves existing outputs when fallback linking fails under a read-only parent directory") + , (AsmOutput.runAsmFailurePreservesInputOutputAliasTest, Right "CLI -r rejects input/output aliasing before invoking the assembler and preserves input files") + , (AsmOutput.runAsmFailurePreservesHardLinkInputOutputAliasTest, Right "CLI -r rejects hard-linked input/output aliases before invoking the assembler") + , (AsmOutput.runAsmMalformedAssemblerPreservesExistingOutputTest, Right "CLI -r preserves existing outputs when HTCC_ASSEMBLER is malformed") + , (AsmOutput.runAsmMalformedAssemblerTest, Right "CLI -r does not leak temp asm files when HTCC_ASSEMBLER is malformed") + , (AsmOutput.runAsmAcceptsFreeBsdElfTargetDriverTest, Right "CLI -r accepts x86_64 FreeBSD targets reported by HTCC_ASSEMBLER drivers") + , (AsmOutput.runAsmRejectsMissingAssemblerDriverTest, Right "CLI -r reports a user-facing error when HTCC_ASSEMBLER names a missing command") + , (AsmOutput.runAsmRejectsAssemblerWithoutLinkDriverTest, Right "CLI -r rejects HTCC_ASSEMBLER commands that can assemble but cannot link") + , (AsmOutput.runAsmRejectsScriptLinkProbeDriverTest, Right "CLI -r rejects HTCC_ASSEMBLER commands whose link probe only emits executable scripts") + , (AsmOutput.runAsmRejectsSharedLinkProbeDriverTest, Right "CLI -r rejects HTCC_ASSEMBLER commands whose link probe emits ET_DYN shared-library outputs") + , (AsmOutput.runAsmRejectsBlobLinkProbeDriverTest, Right "CLI -r rejects HTCC_ASSEMBLER commands whose link probe copies an unrelated x86_64 ELF blob") + , (AsmOutput.runAsmRejectsSymlinkLinkProbeDriverTest, Right "CLI -r rejects HTCC_ASSEMBLER commands whose link probe leaves the requested output as a symlink") + , (AsmOutput.runAsmRejectsBogusFinalLinkOutputTest, Right "CLI -r revalidates the final linked output even when the HTCC_ASSEMBLER probe succeeded") + , (AsmOutput.runAsmRejectsExecutableObjectProbeDriverTest, Right "CLI -r rejects HTCC_ASSEMBLER commands whose assembly probe emits non-relocatable x86_64 ELF files") + , (AsmOutput.runAsmRejectsSymlinkObjectProbeDriverTest, Right "CLI -r rejects HTCC_ASSEMBLER commands whose assembly probe emits the object file as a symlink") + , (AsmOutput.runAsmRejectsTouchingLinkDriverTest, Right "CLI -r rejects HTCC_ASSEMBLER commands whose link probe only touches the requested output") + , (AsmOutput.runAsmRejectsIncompatibleTargetDriverTest, Right "CLI -r rejects HTCC_ASSEMBLER drivers that do not target x86_64-ELF") + , (AsmOutput.runAsmRejectsMetadataSpoofingDriverTest, Right "CLI -r rejects HTCC_ASSEMBLER drivers whose metadata target is x86_64-ELF but whose effective assembly probe is not") + , (AsmOutput.runAsmRejectsWrappedNonElfDriverTest, Right "CLI -r rejects probe-hiding HTCC_ASSEMBLER wrappers around non-ELF x86_64 drivers") + , (AsmOutput.runAsmFreshOutputRestrictiveUmaskTest, Right "CLI -r creates fresh outputs under restrictive umasks and applies the final mode after linking") ] where diff --git a/test/Tests/SubProcTests/AsmOutput.hs b/test/Tests/SubProcTests/AsmOutput.hs new file mode 100644 index 0000000..ce8baf5 --- /dev/null +++ b/test/Tests/SubProcTests/AsmOutput.hs @@ -0,0 +1,8849 @@ +{-# LANGUAGE OverloadedStrings #-} +module Tests.SubProcTests.AsmOutput ( + externalBoolLowByteNormalizationTest, + externalBoolParameterLowByteNormalizationTest, + externalIntegralReturnNormalizationTest, + outputFileTest, + outputFileSingleInputStaticTest, + outputFileSingleInputImplicitFunctionTest, + outputFileSingleInputImplicitFunctionConflictTest, + outputFileSingleInputStaticImplicitFunctionConflictTest, + outputFileSingleInputPrototypeRetypeTest, + stdoutSingleInputImplicitFunctionConflictTest, + stdoutMultiInputStaticFunctionTest, + stdoutMultiInputImplicitFunctionDefinitionWarningTest, + stdoutMultiInputImplicitFunctionUnresolvedWarningTest, + stdoutMultiInputParseFailurePreservesWarningsTest, + stdoutMultiInputPrototypeOnlyArityRetypeTest, + stdoutMultiInputParameterIndirectFunctionPointerArityRetypeTest, + outputFileMultiInputTest, + outputFileMultiInputFunctionDeclarationConflictTest, + outputFileMultiInputImplicitFunctionConflictTest, + outputFileMultiInputConflictPreservesWarningsTest, + outputFileMultiInputReadFailurePreservesWarningsTest, + outputFileMultiInputImplicitFunctionTypeConflictTest, + outputFileMultiInputImplicitFunctionTypeConflictReverseOrderTest, + outputFileMultiInputFunctionTypeConflictTest, + outputFileMultiInputFunctionPointerRedeclarationConflictTest, + outputFileMultiInputAdjustedFunctionParamTypeTest, + outputFileMultiInputCompatiblePrototypeMergeTest, + outputFileMultiInputRepeatedPrototypeTest, + outputFileMultiInputPrototypeOnlyArityRetypeTest, + outputFileMultiInputSignedIntRedeclarationTest, + outputFileMultiInputOldStyleDeclarationTest, + outputFileMultiInputOldStylePromotionConflictTest, + outputFileMultiInputVoidPrototypeConflictTest, + outputFileMultiInputImplicitFunctionDefinitionTest, + outputFileMultiInputDeferredIncompletePointeeUseTest, + outputFileMultiInputDeferredIncompletePointerAddSubAssignRejectTest, + outputFileMultiInputDeferredIncompletePointerIncDecRejectTest, + outputFileMultiInputImplicitFunctionArityRetypeTest, + outputFileMultiInputImplicitFunctionObjectPointerRetypeTest, + outputFileMultiInputImplicitFunctionObjectPointerMismatchRetypeTest, + outputFileMultiInputIndirectFunctionPointerArityRetypeTest, + outputFileMultiInputParameterSizeofRetypeTest, + outputFileMultiInputIndirectFunctionPointerVoidRetypeTest, + outputFileMultiInputImplicitFunctionVoidRetypeTest, + outputFileMultiInputFunctionDesignatorAssignmentRetypeTest, + outputFileMultiInputFunctionDesignatorReturnRetypeTest, + outputFileMultiInputObjectPointerReturnRetypeTest, + outputFileMultiInputFunctionDesignatorInitializerRetypeTest, + outputFileMultiInputFunctionDesignatorInitializerParamRefinementRetypeTest, + outputFileMultiInputObjectPointerAssignmentRetypeTest, + outputFileMultiInputObjectPointerInitializerRetypeTest, + outputFileMultiInputPointerPointeeArrayConflictTest, + outputFileMultiInputAggregateFunctionDesignatorInitializerTest, + outputFileMultiInputSameInputImplicitFunctionConflictTest, + outputFileMultiInputSameInputFunctionDeclarationConflictTest, + outputFileMultiInputSameInputStaticImplicitFunctionConflictTest, + outputFileMultiInputSameInputInternalLinkageConflictTest, + outputFileMultiInputTentativeGlobalTest, + outputFileMultiInputTentativeArrayTest, + outputFileMultiInputTentativeArrayDecayRetypeTest, + outputFileMultiInputTentativeIncompleteArrayTest, + outputFileMultiInputTentativeNestedIncompleteArrayTest, + outputFileMultiInputTentativeNestedArrayExtentInferenceTest, + outputFileMultiInputTentativeArrayRankConflictTest, + outputFileMultiInputTentativeArrayInnerExtentConflictTest, + outputFileMultiInputTentativeArrayUseSiteTest, + outputFileMultiInputTentativeArrayAddressUseSiteTest, + outputFileMultiInputTentativeArrayInitializerRetypeTest, + outputFileMultiInputStaticTest, + outputFileMultiInputStaticFunctionTest, + outputFileMultiInputStaticFunctionPointerTest, + outputFilePreservesExistingModeTest, + outputFileClearsSpecialBitsTest, + outputFileFollowsSymlinkTargetTest, + outputFileSpecialPathDevNullTest, + outputFileSamePathTest, + outputFileHardLinkAliasTest, + outputFileParseFailurePreservesExistingOutputTest, + outputFileReadFailurePreservesExistingOutputTest, + outputFileOpenFailurePreservesExistingOutputTest, + outputFileHardLinkedRenameReplacementPreservesAliasTest, + outputFileReadOnlyParentWritableTargetTest, + outputFileReadOnlyParentWriteOnlyTargetTest, + outputFileReadOnlyParentHardLinkAliasPreservesExistingOutputTest, + outputFileReadOnlyParentWriteFailurePreservesExistingOutputTest, + outputFileWriteFailurePreservesExistingOutputTest, + outputFileFreshOutputRestrictiveUmaskTest, + runAsmTest, + runAsmSingleInputImplicitFunctionConflictTest, + runAsmSpecialPathDevNullTest, + runAsmPreservesExecutableBitsTest, + runAsmPreservesExistingExecuteMaskTest, + runAsmRestoresOwnerExecuteBitTest, + runAsmFreshOutputInPlaceLinkDriverTest, + runAsmProbePreservesPrecreatedOutputTest, + runAsmClearsSpecialBitsTest, + runAsmLinkUsesResolvedDriverTest, + runAsmBareLocalAssemblerPathTest, + runAsmQuotedCompilerTest, + runAsmWrappedAssemblerTest, + runAsmWrappedAssemblerFirstWordDriverTest, + runAsmWrappedAssemblerProbeFallbackTest, + runAsmWrappedAssemblerHostMetadataFallbackTest, + runAsmLeadingEnvAssignmentTest, + runAsmLeadingEnvAssignmentWithoutEnvPathTest, + runAsmLeadingEnvAssignmentPreservesPathOverrideTest, + runAsmEnvPathOverrideEmptyEntryTest, + runAsmEnvPathOverrideNoLocalFallbackTest, + runAsmQuotedBackslashArgTest, + runAsmIgnoresCcTest, + runAsmGccPrefersPathTest, + runAsmFailurePreservesExistingOutputTest, + runAsmParseFailurePreservesExistingOutputTest, + runAsmReadFailurePreservesExistingOutputTest, + runAsmHardLinkedRenameReplacementPreservesAliasTest, + runAsmReadOnlyParentWritableTargetTest, + runAsmReadOnlyParentWriteOnlyTargetTest, + runAsmReadOnlyParentExecutableOnlyTargetTest, + runAsmReadOnlyParentHardLinkAliasPreservesExistingOutputTest, + runAsmReadOnlyParentLinkFailurePreservesExistingOutputTest, + runAsmFailurePreservesInputOutputAliasTest, + runAsmFailurePreservesHardLinkInputOutputAliasTest, + runAsmMalformedAssemblerPreservesExistingOutputTest, + runAsmMalformedAssemblerTest, + runAsmAcceptsFreeBsdElfTargetDriverTest, + runAsmRejectsMissingAssemblerDriverTest, + runAsmRejectsAssemblerWithoutLinkDriverTest, + runAsmRejectsScriptLinkProbeDriverTest, + runAsmRejectsSharedLinkProbeDriverTest, + runAsmRejectsBlobLinkProbeDriverTest, + runAsmRejectsSymlinkLinkProbeDriverTest, + runAsmAcceptsMarkerStrippedFinalOutputTest, + runAsmRejectsBogusFinalLinkOutputTest, + runAsmRejectsExecutableObjectProbeDriverTest, + runAsmRejectsSymlinkObjectProbeDriverTest, + runAsmRejectsTouchingLinkDriverTest, + runAsmRejectsIncompatibleTargetDriverTest, + runAsmRejectsMetadataSpoofingDriverTest, + runAsmRejectsWrappedNonElfDriverTest, + runAsmFreshOutputRestrictiveUmaskTest +) where + +import Control.Exception (finally) +import Control.Monad (when) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import System.Directory (createDirectoryIfMissing, doesFileExist, + findExecutable, listDirectory) +import System.FilePath (()) +import System.Posix.Files (fileMode, getFileStatus, + getSymbolicLinkStatus, groupExecuteMode, + groupReadMode, groupWriteMode, + intersectFileModes, isSymbolicLink, + otherExecuteMode, otherReadMode, + otherWriteMode, ownerExecuteMode, + ownerReadMode, ownerWriteMode, setFileMode, + setGroupIDMode, setUserIDMode, + unionFileModes) +import System.Posix.Types (FileMode) +import Tests.Utils + +source :: T.Text +source = "int main() { int x; x = 0; while (x < 2) { if (x == 1) goto done; x = x + 1; continue; } done: switch (x) { case 1: return 0; default: return 1; } }" + +parseFailureSource :: T.Text +parseFailureSource = "int main( { return 0; }" + +writeFailureSource :: T.Text +writeFailureSource = T.unlines $ + [ "int main() {" + , " int x;" + , " x = 0;" + ] + <> replicate 512 " x = x + 1;" + <> [ " return x;" + , "}" + ] + +outputFileMsg :: T.Text +outputFileMsg = "CLI -o writes complete asm to the requested file" + +outputFileSingleInputStaticMsg :: T.Text +outputFileSingleInputStaticMsg = "CLI -o preserves internal-linkage symbols for single-input outputs" + +outputFileSingleInputImplicitFunctionMsg :: T.Text +outputFileSingleInputImplicitFunctionMsg = "CLI -o keeps single-input implicit function calls on the standalone code path" + +outputFileSingleInputImplicitFunctionConflictMsg :: T.Text +outputFileSingleInputImplicitFunctionConflictMsg = "CLI -o rejects single-input implicit-function/global collisions on the standalone code path" + +outputFileSingleInputStaticImplicitFunctionConflictMsg :: T.Text +outputFileSingleInputStaticImplicitFunctionConflictMsg = "CLI -o rejects single-input implicit-function/static-global collisions on the standalone code path" + +outputFileSingleInputPrototypeRetypeMsg :: T.Text +outputFileSingleInputPrototypeRetypeMsg = "CLI -o revalidates same-file direct calls after later prototype refinements" + +stdoutSingleInputImplicitFunctionConflictMsg :: T.Text +stdoutSingleInputImplicitFunctionConflictMsg = "CLI stdout rejects single-input implicit-function/global collisions on the standalone code path" + +stdoutMultiInputStaticFunctionMsg :: T.Text +stdoutMultiInputStaticFunctionMsg = "CLI stdout namespaces internal-linkage functions across multiple inputs" + +stdoutMultiInputImplicitFunctionDefinitionWarningMsg :: T.Text +stdoutMultiInputImplicitFunctionDefinitionWarningMsg = "CLI stdout suppresses pre-merge implicit-function warnings once another input provides the declaration" + +stdoutMultiInputImplicitFunctionUnresolvedWarningMsg :: T.Text +stdoutMultiInputImplicitFunctionUnresolvedWarningMsg = "CLI stdout keeps implicit-function warnings when other inputs do not provide a real declaration" + +stdoutMultiInputParseFailurePreservesWarningsMsg :: T.Text +stdoutMultiInputParseFailurePreservesWarningsMsg = "CLI stdout flushes earlier warnings before aborting on a later multi-input parse failure" + +stdoutMultiInputPrototypeOnlyArityRetypeMsg :: T.Text +stdoutMultiInputPrototypeOnlyArityRetypeMsg = "CLI stdout revalidates direct calls after merging later prototype-only declarations" + +stdoutMultiInputParameterIndirectFunctionPointerArityRetypeMsg :: T.Text +stdoutMultiInputParameterIndirectFunctionPointerArityRetypeMsg = "CLI stdout revalidates indirect calls inside definitions after merged parameter-type refinements" + +outputFileMultiInputMsg :: T.Text +outputFileMultiInputMsg = "CLI -o combines asm from multiple inputs into one file" + +outputFileMultiInputFunctionDeclarationConflictMsg :: T.Text +outputFileMultiInputFunctionDeclarationConflictMsg = "CLI -o rejects function declarations that conflict with globals across multiple inputs" + +outputFileMultiInputImplicitFunctionConflictMsg :: T.Text +outputFileMultiInputImplicitFunctionConflictMsg = "CLI -o rejects implicit function references that conflict with globals across multiple inputs" + +outputFileMultiInputConflictPreservesWarningsMsg :: T.Text +outputFileMultiInputConflictPreservesWarningsMsg = "CLI -o preserves earlier warnings even when multi-input merge later fails" + +outputFileMultiInputReadFailurePreservesWarningsMsg :: T.Text +outputFileMultiInputReadFailurePreservesWarningsMsg = "CLI -o flushes earlier warnings before aborting on a later multi-input read failure" + +outputFileMultiInputImplicitFunctionTypeConflictMsg :: T.Text +outputFileMultiInputImplicitFunctionTypeConflictMsg = "CLI -o rejects implicit function references that conflict with later function declarations across multiple inputs" + +outputFileMultiInputImplicitFunctionTypeConflictReverseOrderMsg :: T.Text +outputFileMultiInputImplicitFunctionTypeConflictReverseOrderMsg = "CLI -o rejects implicit function references that conflict with earlier function declarations across multiple inputs" + +outputFileMultiInputFunctionTypeConflictMsg :: T.Text +outputFileMultiInputFunctionTypeConflictMsg = "CLI -o rejects incompatible extern function declarations across multiple inputs" + +outputFileMultiInputFunctionPointerRedeclarationConflictMsg :: T.Text +outputFileMultiInputFunctionPointerRedeclarationConflictMsg = "CLI -o rejects extern globals that only looked compatible via function-return equality" + +outputFileMultiInputAdjustedFunctionParamTypeMsg :: T.Text +outputFileMultiInputAdjustedFunctionParamTypeMsg = "CLI -o accepts compatible extern declarations after array/function parameter adjustment" + +outputFileMultiInputCompatiblePrototypeMergeMsg :: T.Text +outputFileMultiInputCompatiblePrototypeMergeMsg = "CLI -o rejects extern function returns that only differ by pointee array bound inference" + +outputFileMultiInputRepeatedPrototypeMsg :: T.Text +outputFileMultiInputRepeatedPrototypeMsg = "CLI -o accepts repeated prototypes when another input provides the single function definition" + +outputFileMultiInputPrototypeOnlyArityRetypeMsg :: T.Text +outputFileMultiInputPrototypeOnlyArityRetypeMsg = "CLI -o revalidates direct calls after merging later prototype-only declarations" + +outputFileMultiInputSignedIntRedeclarationMsg :: T.Text +outputFileMultiInputSignedIntRedeclarationMsg = "CLI -o accepts compatible int/signed redeclarations across multiple inputs" + +outputFileMultiInputOldStyleDeclarationMsg :: T.Text +outputFileMultiInputOldStyleDeclarationMsg = "CLI -o accepts old-style declarations when another input provides the function definition" + +outputFileMultiInputOldStylePromotionConflictMsg :: T.Text +outputFileMultiInputOldStylePromotionConflictMsg = "CLI -o rejects old-style declarations that only match after default promotions" + +outputFileMultiInputVoidPrototypeConflictMsg :: T.Text +outputFileMultiInputVoidPrototypeConflictMsg = "CLI -o rejects void prototypes that conflict with later parameterized declarations" + +outputFileMultiInputImplicitFunctionDefinitionMsg :: T.Text +outputFileMultiInputImplicitFunctionDefinitionMsg = "CLI -o accepts implicit function calls when another input provides the function definition" + +outputFileMultiInputDeferredIncompletePointeeUseMsg :: T.Text +outputFileMultiInputDeferredIncompletePointeeUseMsg = "CLI -o rejects cross-input function returns that only differ by pointee array bound inference" + +outputFileMultiInputDeferredIncompletePointerAddSubAssignRejectMsg :: T.Text +outputFileMultiInputDeferredIncompletePointerAddSubAssignRejectMsg = "CLI -o rejects deferred +=/-= on incomplete pointers before emitting asm" + +outputFileMultiInputDeferredIncompletePointerIncDecRejectMsg :: T.Text +outputFileMultiInputDeferredIncompletePointerIncDecRejectMsg = "CLI -o rejects deferred ++/-- on incomplete pointers before emitting asm" + +outputFileMultiInputImplicitFunctionArityRetypeMsg :: T.Text +outputFileMultiInputImplicitFunctionArityRetypeMsg = "CLI -o revalidates implicit calls against later merged function arity" + +outputFileMultiInputImplicitFunctionObjectPointerRetypeMsg :: T.Text +outputFileMultiInputImplicitFunctionObjectPointerRetypeMsg = "CLI -o rejects implicit calls that later resolve to object-pointer parameters" + +outputFileMultiInputImplicitFunctionObjectPointerMismatchRetypeMsg :: T.Text +outputFileMultiInputImplicitFunctionObjectPointerMismatchRetypeMsg = "CLI -o rejects implicit calls whose merged object-pointer parameters are incompatible" + +outputFileMultiInputIndirectFunctionPointerArityRetypeMsg :: T.Text +outputFileMultiInputIndirectFunctionPointerArityRetypeMsg = "CLI -o revalidates indirect calls after merged extern function-pointer declarations" + +outputFileMultiInputParameterSizeofRetypeMsg :: T.Text +outputFileMultiInputParameterSizeofRetypeMsg = "CLI -o rejects cross-input parameter declarations that only differ by pointer-to-array bounds" + +outputFileMultiInputIndirectFunctionPointerVoidRetypeMsg :: T.Text +outputFileMultiInputIndirectFunctionPointerVoidRetypeMsg = "CLI -o preserves void prototypes when merged extern function-pointer declarations refine empty parameter lists" + +outputFileMultiInputImplicitFunctionVoidRetypeMsg :: T.Text +outputFileMultiInputImplicitFunctionVoidRetypeMsg = "CLI -o rejects implicit calls whose merged target later resolves to a void prototype" + +outputFileMultiInputFunctionDesignatorAssignmentRetypeMsg :: T.Text +outputFileMultiInputFunctionDesignatorAssignmentRetypeMsg = "CLI -o rechecks function-designator assignments after merged prototypes" + +outputFileMultiInputFunctionDesignatorReturnRetypeMsg :: T.Text +outputFileMultiInputFunctionDesignatorReturnRetypeMsg = "CLI -o rechecks function-pointer returns after merged prototypes" + +outputFileMultiInputObjectPointerReturnRetypeMsg :: T.Text +outputFileMultiInputObjectPointerReturnRetypeMsg = "CLI -o rechecks object-pointer returns after merged tentative-array completion" + +outputFileMultiInputFunctionDesignatorInitializerRetypeMsg :: T.Text +outputFileMultiInputFunctionDesignatorInitializerRetypeMsg = "CLI -o rechecks function-pointer initializers after merged prototypes" + +outputFileMultiInputFunctionDesignatorInitializerParamRefinementRetypeMsg :: T.Text +outputFileMultiInputFunctionDesignatorInitializerParamRefinementRetypeMsg = "CLI -o rejects merged function-pointer initializers when parameter declarations conflict on pointer-to-array bounds" + +outputFileMultiInputObjectPointerAssignmentRetypeMsg :: T.Text +outputFileMultiInputObjectPointerAssignmentRetypeMsg = "CLI -o rechecks object-pointer assignments after merged tentative-array completion" + +outputFileMultiInputObjectPointerInitializerRetypeMsg :: T.Text +outputFileMultiInputObjectPointerInitializerRetypeMsg = "CLI -o rechecks object-pointer initializers after merged tentative-array completion" + +outputFileMultiInputPointerPointeeArrayConflictMsg :: T.Text +outputFileMultiInputPointerPointeeArrayConflictMsg = "CLI -o rejects extern pointer-to-array declarations that disagree on pointee bounds" + +outputFileMultiInputAggregateFunctionDesignatorInitializerMsg :: T.Text +outputFileMultiInputAggregateFunctionDesignatorInitializerMsg = "CLI -o accepts aggregate function-pointer initializers during merged global revalidation" + +outputFileMultiInputSameInputImplicitFunctionConflictMsg :: T.Text +outputFileMultiInputSameInputImplicitFunctionConflictMsg = "CLI -o rejects same-input implicit-function/global collisions even when another input is present" + +outputFileMultiInputSameInputFunctionDeclarationConflictMsg :: T.Text +outputFileMultiInputSameInputFunctionDeclarationConflictMsg = "CLI -o rejects same-input prototype/global collisions even when another input is present" + +outputFileMultiInputSameInputStaticImplicitFunctionConflictMsg :: T.Text +outputFileMultiInputSameInputStaticImplicitFunctionConflictMsg = "CLI -o rejects same-input implicit-function/static-global collisions even when another input is present" + +outputFileMultiInputSameInputInternalLinkageConflictMsg :: T.Text +outputFileMultiInputSameInputInternalLinkageConflictMsg = "CLI -o rejects same-input object/function collisions involving internal linkage even when another input is present" + +outputFileMultiInputTentativeGlobalMsg :: T.Text +outputFileMultiInputTentativeGlobalMsg = "CLI -o coalesces tentative globals across multiple inputs" + +outputFileMultiInputTentativeArrayMsg :: T.Text +outputFileMultiInputTentativeArrayMsg = "CLI -o coalesces tentative array declarations across multiple inputs" + +outputFileMultiInputTentativeArrayDecayRetypeMsg :: T.Text +outputFileMultiInputTentativeArrayDecayRetypeMsg = "CLI -o retypes earlier array-decay uses after cross-input tentative-array completion" + +outputFileMultiInputTentativeIncompleteArrayMsg :: T.Text +outputFileMultiInputTentativeIncompleteArrayMsg = "CLI -o materializes merged tentative incomplete arrays as one element" + +outputFileMultiInputTentativeNestedIncompleteArrayMsg :: T.Text +outputFileMultiInputTentativeNestedIncompleteArrayMsg = "CLI -o rejects address arithmetic on tentative nested arrays before any cross-input merge" + +outputFileMultiInputTentativeNestedArrayExtentInferenceMsg :: T.Text +outputFileMultiInputTentativeNestedArrayExtentInferenceMsg = "CLI -o keeps each input bound to its own incomplete tentative nested-array use sites" + +outputFileMultiInputTentativeArrayRankConflictMsg :: T.Text +outputFileMultiInputTentativeArrayRankConflictMsg = "CLI -o rejects tentative array merges that change array rank across multiple inputs" + +outputFileMultiInputTentativeArrayInnerExtentConflictMsg :: T.Text +outputFileMultiInputTentativeArrayInnerExtentConflictMsg = "CLI -o rejects tentative array merges that disagree on inner extents across multiple inputs" + +outputFileMultiInputTentativeArrayUseSiteMsg :: T.Text +outputFileMultiInputTentativeArrayUseSiteMsg = "CLI -o rejects sizeof on tentative arrays before cross-input completion" + +outputFileMultiInputTentativeArrayAddressUseSiteMsg :: T.Text +outputFileMultiInputTentativeArrayAddressUseSiteMsg = "CLI -o rejects address-based pointer arithmetic on tentative arrays before cross-input completion" + +outputFileMultiInputTentativeArrayInitializerRetypeMsg :: T.Text +outputFileMultiInputTentativeArrayInitializerRetypeMsg = "CLI -o rejects global initializers that depend on later cross-input tentative-array completion" + +outputFileMultiInputStaticMsg :: T.Text +outputFileMultiInputStaticMsg = "CLI -o namespaces internal-linkage symbols across multiple inputs" + +outputFileMultiInputStaticFunctionMsg :: T.Text +outputFileMultiInputStaticFunctionMsg = "CLI -o namespaces internal-linkage functions across multiple inputs" + +outputFileMultiInputStaticFunctionPointerMsg :: T.Text +outputFileMultiInputStaticFunctionPointerMsg = "CLI -o namespaces internal-linkage function designators across multiple inputs" + +outputFilePreservesExistingModeMsg :: T.Text +outputFilePreservesExistingModeMsg = "CLI -o preserves the existing output file mode when replacing it" + +outputFileClearsSpecialBitsMsg :: T.Text +outputFileClearsSpecialBitsMsg = "CLI -o clears setuid/setgid/sticky bits when replacing an existing output" + +outputFileFollowsSymlinkTargetMsg :: T.Text +outputFileFollowsSymlinkTargetMsg = "CLI -o updates symlink targets without replacing the symlink itself" + +outputFileSpecialPathDevNullMsg :: T.Text +outputFileSpecialPathDevNullMsg = "CLI -o writes directly to special output paths such as /dev/null" + +outputFileSamePathMsg :: T.Text +outputFileSamePathMsg = "CLI -o rejects same-path input/output aliases before overwriting source files" + +outputFileHardLinkAliasMsg :: T.Text +outputFileHardLinkAliasMsg = "CLI -o rejects hard-linked input/output aliases before overwriting source files" + +outputFileParseFailurePreservesExistingOutputMsg :: T.Text +outputFileParseFailurePreservesExistingOutputMsg = "CLI -o preserves existing outputs when parsing fails before opening the destination" + +outputFileReadFailurePreservesExistingOutputMsg :: T.Text +outputFileReadFailurePreservesExistingOutputMsg = "CLI -o preserves existing outputs when reading an input fails before opening the destination" + +outputFileOpenFailurePreservesExistingOutputMsg :: T.Text +outputFileOpenFailurePreservesExistingOutputMsg = "CLI -o preserves existing outputs when opening the destination fails" + +outputFileReadOnlyParentWritableTargetMsg :: T.Text +outputFileReadOnlyParentWritableTargetMsg = "CLI -o falls back to in-place writes when an existing output is writable but its parent directory is not" + +outputFileReadOnlyParentWriteOnlyTargetMsg :: T.Text +outputFileReadOnlyParentWriteOnlyTargetMsg = "CLI -o falls back to in-place writes when an existing write-only output has a read-only parent directory" + +outputFileHardLinkedRenameReplacementPreservesAliasMsg :: T.Text +outputFileHardLinkedRenameReplacementPreservesAliasMsg = "CLI -o replaces hard-linked outputs via rename without rewriting sibling aliases" + +outputFileReadOnlyParentHardLinkAliasPreservesExistingOutputMsg :: T.Text +outputFileReadOnlyParentHardLinkAliasPreservesExistingOutputMsg = "CLI -o refuses read-only-parent fallback writes that would overwrite hard-linked aliases" + +outputFileReadOnlyParentWriteFailurePreservesExistingOutputMsg :: T.Text +outputFileReadOnlyParentWriteFailurePreservesExistingOutputMsg = "CLI -o preserves existing outputs when fallback writes fail under a read-only parent directory" + +outputFileWriteFailurePreservesExistingOutputMsg :: T.Text +outputFileWriteFailurePreservesExistingOutputMsg = "CLI -o preserves existing outputs when asm emission fails after opening the replacement file" + +outputFileFreshOutputRestrictiveUmaskMsg :: T.Text +outputFileFreshOutputRestrictiveUmaskMsg = "CLI -o creates fresh outputs under restrictive umasks and applies the final mode after writing" + +runAsmMsg :: T.Text +runAsmMsg = "CLI -r keeps asm off stdout and still produces a runnable binary" + +runAsmSingleInputImplicitFunctionConflictMsg :: T.Text +runAsmSingleInputImplicitFunctionConflictMsg = "CLI -r rejects single-input implicit-function/global collisions before invoking the assembler" + +runAsmSpecialPathDevNullMsg :: T.Text +runAsmSpecialPathDevNullMsg = "CLI -r links directly to special output paths such as /dev/null" + +runAsmPreservesExecutableBitsMsg :: T.Text +runAsmPreservesExecutableBitsMsg = "CLI -r preserves execute bits when replacing a non-executable output" + +runAsmPreservesExistingExecuteMaskMsg :: T.Text +runAsmPreservesExistingExecuteMaskMsg = "CLI -r preserves the existing execute mask when replacing a private executable" + +runAsmRestoresOwnerExecuteBitMsg :: T.Text +runAsmRestoresOwnerExecuteBitMsg = "CLI -r restores owner execute when replacing outputs that were executable only for group/other" + +runAsmFreshOutputInPlaceLinkDriverMsg :: T.Text +runAsmFreshOutputInPlaceLinkDriverMsg = "CLI -r preserves execute bits for fresh outputs when the link driver rewrites -o in place" + +runAsmProbePreservesPrecreatedOutputMsg :: T.Text +runAsmProbePreservesPrecreatedOutputMsg = "CLI -r probes link drivers against a pre-created output file" + +runAsmClearsSpecialBitsMsg :: T.Text +runAsmClearsSpecialBitsMsg = "CLI -r clears setuid/setgid/sticky bits when replacing an existing output" + +runAsmLinkUsesResolvedDriverMsg :: T.Text +runAsmLinkUsesResolvedDriverMsg = "CLI -r reuses the resolved HTCC_ASSEMBLER driver when linking" + +runAsmBareLocalAssemblerPathMsg :: T.Text +runAsmBareLocalAssemblerPathMsg = "CLI -r prefers PATH bare HTCC_ASSEMBLER drivers over ./" + +runAsmQuotedCompilerMsg :: T.Text +runAsmQuotedCompilerMsg = "CLI -r quotes assembler paths selected from HTCC_ASSEMBLER" + +runAsmWrappedAssemblerMsg :: T.Text +runAsmWrappedAssemblerMsg = "CLI -r preserves wrapper args selected from HTCC_ASSEMBLER" + +runAsmWrappedAssemblerFirstWordDriverMsg :: T.Text +runAsmWrappedAssemblerFirstWordDriverMsg = "CLI -r resolves only the first HTCC_ASSEMBLER shell word as the driver executable" + +runAsmWrappedAssemblerProbeFallbackMsg :: T.Text +runAsmWrappedAssemblerProbeFallbackMsg = "CLI -r accepts wrapper commands whose probe flags fail when assemble/link forwarding still works" + +runAsmWrappedAssemblerHostMetadataFallbackMsg :: T.Text +runAsmWrappedAssemblerHostMetadataFallbackMsg = "CLI -r accepts wrapped drivers whose metadata probes report the host target while assemble/link forwarding stays x86_64-ELF" + +runAsmLeadingEnvAssignmentMsg :: T.Text +runAsmLeadingEnvAssignmentMsg = "CLI -r applies leading PATH env assignments in HTCC_ASSEMBLER before resolving the driver" + +runAsmLeadingEnvAssignmentWithoutEnvPathMsg :: T.Text +runAsmLeadingEnvAssignmentWithoutEnvPathMsg = "CLI -r executes PATH-assigned HTCC_ASSEMBLER drivers without depending on env in the parent PATH" + +runAsmLeadingEnvAssignmentPreservesPathOverrideMsg :: T.Text +runAsmLeadingEnvAssignmentPreservesPathOverrideMsg = "CLI -r preserves leading PATH env assignments in HTCC_ASSEMBLER exactly during invocation" + +runAsmEnvPathOverrideEmptyEntryMsg :: T.Text +runAsmEnvPathOverrideEmptyEntryMsg = "CLI -r keeps empty PATH entries in HTCC_ASSEMBLER overrides when resolving bare drivers" + +runAsmEnvPathOverrideNoLocalFallbackMsg :: T.Text +runAsmEnvPathOverrideNoLocalFallbackMsg = "CLI -r does not fall back to ./ when HTCC_ASSEMBLER overrides PATH" + +runAsmQuotedBackslashArgMsg :: T.Text +runAsmQuotedBackslashArgMsg = "CLI -r preserves backslashes in quoted HTCC_ASSEMBLER args" + +runAsmIgnoresCcMsg :: T.Text +runAsmIgnoresCcMsg = "CLI -r ignores inherited CC and falls back to gcc" + +runAsmGccPrefersPathMsg :: T.Text +runAsmGccPrefersPathMsg = "CLI -r prefers PATH gcc over ./gcc when HTCC_ASSEMBLER is unset" + +runAsmFailurePreservesExistingOutputMsg :: T.Text +runAsmFailurePreservesExistingOutputMsg = "CLI -r preserves existing outputs when the assembler command fails before linking" + +runAsmParseFailurePreservesExistingOutputMsg :: T.Text +runAsmParseFailurePreservesExistingOutputMsg = "CLI -r preserves existing outputs when parsing fails before assembler invocation" + +runAsmReadFailurePreservesExistingOutputMsg :: T.Text +runAsmReadFailurePreservesExistingOutputMsg = "CLI -r preserves existing outputs when reading an input fails before assembler invocation" + +runAsmReadOnlyParentWritableTargetMsg :: T.Text +runAsmReadOnlyParentWritableTargetMsg = "CLI -r falls back to in-place linking when an existing output is writable but its parent directory is not" + +runAsmReadOnlyParentWriteOnlyTargetMsg :: T.Text +runAsmReadOnlyParentWriteOnlyTargetMsg = "CLI -r falls back to in-place linking when an existing write-only output has a read-only parent directory" + +runAsmReadOnlyParentExecutableOnlyTargetMsg :: T.Text +runAsmReadOnlyParentExecutableOnlyTargetMsg = "CLI -r falls back to in-place linking when an existing executable-only output has a read-only parent directory" + +runAsmHardLinkedRenameReplacementPreservesAliasMsg :: T.Text +runAsmHardLinkedRenameReplacementPreservesAliasMsg = "CLI -r replaces hard-linked outputs via rename without rewriting sibling aliases" + +runAsmReadOnlyParentHardLinkAliasPreservesExistingOutputMsg :: T.Text +runAsmReadOnlyParentHardLinkAliasPreservesExistingOutputMsg = "CLI -r refuses read-only-parent fallback linking that would overwrite hard-linked aliases" + +runAsmReadOnlyParentLinkFailurePreservesExistingOutputMsg :: T.Text +runAsmReadOnlyParentLinkFailurePreservesExistingOutputMsg = "CLI -r preserves existing outputs when fallback linking fails under a read-only parent directory" + +runAsmFailurePreservesInputOutputAliasMsg :: T.Text +runAsmFailurePreservesInputOutputAliasMsg = "CLI -r rejects input/output aliasing before invoking the assembler and preserves input files" + +runAsmFailurePreservesHardLinkInputOutputAliasMsg :: T.Text +runAsmFailurePreservesHardLinkInputOutputAliasMsg = "CLI -r rejects hard-linked input/output aliases before invoking the assembler" + +runAsmMalformedAssemblerPreservesExistingOutputMsg :: T.Text +runAsmMalformedAssemblerPreservesExistingOutputMsg = "CLI -r preserves existing outputs when HTCC_ASSEMBLER is malformed" + +runAsmMalformedAssemblerMsg :: T.Text +runAsmMalformedAssemblerMsg = "CLI -r does not leak temp asm files when HTCC_ASSEMBLER is malformed" + +runAsmAcceptsFreeBsdElfTargetDriverMsg :: T.Text +runAsmAcceptsFreeBsdElfTargetDriverMsg = "CLI -r accepts x86_64 FreeBSD targets reported by HTCC_ASSEMBLER drivers" + +runAsmRejectsMissingAssemblerDriverMsg :: T.Text +runAsmRejectsMissingAssemblerDriverMsg = "CLI -r reports a user-facing error when HTCC_ASSEMBLER names a missing command" + +runAsmRejectsAssemblerWithoutLinkDriverMsg :: T.Text +runAsmRejectsAssemblerWithoutLinkDriverMsg = "CLI -r rejects HTCC_ASSEMBLER commands that can assemble but cannot link" + +runAsmRejectsScriptLinkProbeDriverMsg :: T.Text +runAsmRejectsScriptLinkProbeDriverMsg = "CLI -r rejects HTCC_ASSEMBLER commands whose link probe only emits executable scripts" + +runAsmRejectsSharedLinkProbeDriverMsg :: T.Text +runAsmRejectsSharedLinkProbeDriverMsg = "CLI -r rejects HTCC_ASSEMBLER commands whose link probe emits ET_DYN shared-library outputs" + +runAsmRejectsBlobLinkProbeDriverMsg :: T.Text +runAsmRejectsBlobLinkProbeDriverMsg = "CLI -r rejects HTCC_ASSEMBLER commands whose link probe copies an unrelated x86_64 ELF blob" + +runAsmRejectsSymlinkLinkProbeDriverMsg :: T.Text +runAsmRejectsSymlinkLinkProbeDriverMsg = "CLI -r rejects HTCC_ASSEMBLER commands whose link probe leaves the requested output as a symlink" + +runAsmAcceptsMarkerStrippedFinalOutputMsg :: T.Text +runAsmAcceptsMarkerStrippedFinalOutputMsg = "CLI -r accepts valid final x86_64-ELF outputs even when wrapped drivers strip htcc's unreferenced marker" + +runAsmRejectsBogusFinalLinkOutputMsg :: T.Text +runAsmRejectsBogusFinalLinkOutputMsg = "CLI -r revalidates the final linked output even when the HTCC_ASSEMBLER probe succeeded" + +runAsmRejectsExecutableObjectProbeDriverMsg :: T.Text +runAsmRejectsExecutableObjectProbeDriverMsg = "CLI -r rejects HTCC_ASSEMBLER commands whose assembly probe emits non-relocatable x86_64 ELF files" + +runAsmRejectsSymlinkObjectProbeDriverMsg :: T.Text +runAsmRejectsSymlinkObjectProbeDriverMsg = "CLI -r rejects HTCC_ASSEMBLER commands whose assembly probe emits the object file as a symlink" + +runAsmRejectsTouchingLinkDriverMsg :: T.Text +runAsmRejectsTouchingLinkDriverMsg = "CLI -r rejects HTCC_ASSEMBLER commands whose link probe only touches the requested output" + +runAsmRejectsIncompatibleTargetDriverMsg :: T.Text +runAsmRejectsIncompatibleTargetDriverMsg = "CLI -r rejects HTCC_ASSEMBLER drivers that do not target x86_64-ELF" + +runAsmRejectsMetadataSpoofingDriverMsg :: T.Text +runAsmRejectsMetadataSpoofingDriverMsg = "CLI -r rejects HTCC_ASSEMBLER drivers whose metadata target is x86_64-ELF but whose effective assembly probe is not" + +runAsmRejectsWrappedNonElfDriverMsg :: T.Text +runAsmRejectsWrappedNonElfDriverMsg = "CLI -r rejects probe-hiding HTCC_ASSEMBLER wrappers around non-ELF x86_64 drivers" + +runAsmFreshOutputRestrictiveUmaskMsg :: T.Text +runAsmFreshOutputRestrictiveUmaskMsg = "CLI -r creates fresh outputs under restrictive umasks and applies the final mode after linking" + +fakeAssemblerPath :: FilePath +fakeAssemblerPath = "tmp-assembler.sh" + +fakeDriverPath :: FilePath +fakeDriverPath = "tmp-driver.sh" + +fakeCombinedDriverPath :: FilePath +fakeCombinedDriverPath = fakeAssemblerPath <> " " <> fakeDriverPath + +fakeProbeWrapperPath :: FilePath +fakeProbeWrapperPath = "tmp-probe-wrapper.sh" + +fakeHostMetadataWrapperPath :: FilePath +fakeHostMetadataWrapperPath = "tmp-host-metadata-wrapper.sh" + +fakeAssemblerQuotedPath :: FilePath +fakeAssemblerQuotedPath = "tmp assembler.sh" + +fakeAssemblerLogPath :: FilePath +fakeAssemblerLogPath = "tmp-assembler.log" + +fakeDriverLogPath :: FilePath +fakeDriverLogPath = "tmp-driver.log" + +fakeCombinedDriverLogPath :: FilePath +fakeCombinedDriverLogPath = "tmp-combined-driver.log" + +fakeProbeWrapperLogPath :: FilePath +fakeProbeWrapperLogPath = "tmp-probe-wrapper.log" + +fakeHostMetadataWrapperLogPath :: FilePath +fakeHostMetadataWrapperLogPath = "tmp-host-metadata-wrapper.log" + +fakeAssemblerAsmPath :: FilePath +fakeAssemblerAsmPath = "tmp-assembler.s" + +fakeProbeHostAssemblerPath :: FilePath +fakeProbeHostAssemblerPath = "tmp-probe-host-assembler.sh" + +fakeProbeHostAssemblerLogPath :: FilePath +fakeProbeHostAssemblerLogPath = "tmp-probe-host-assembler.log" + +fakeProbeHostAssemblerAsmPath :: FilePath +fakeProbeHostAssemblerAsmPath = "tmp-probe-host-assembler.s" + +fakeProbeHostWrapperPath :: FilePath +fakeProbeHostWrapperPath = "tmp-probe-host-wrapper.sh" + +fakeProbeHostWrapperLogPath :: FilePath +fakeProbeHostWrapperLogPath = "tmp-probe-host-wrapper.log" + +fakeAssemblerWrapperArg :: T.Text +fakeAssemblerWrapperArg = "--wrapper-flag" + +fakeAssemblerBackslashArg :: T.Text +fakeAssemblerBackslashArg = "a\\nb" + +fakeGccPath :: FilePath +fakeGccPath = "gcc" + +fakeBadCcPath :: FilePath +fakeBadCcPath = "tmp-bad-cc.sh" + +fakeBadCcLogPath :: FilePath +fakeBadCcLogPath = "tmp-bad-cc.log" + +fakeHostDriverPath :: FilePath +fakeHostDriverPath = "tmp-host-driver.sh" + +fakeHostDriverLogPath :: FilePath +fakeHostDriverLogPath = "tmp-host-driver.log" + +fakeSpoofedTargetDriverPath :: FilePath +fakeSpoofedTargetDriverPath = "tmp-spoofed-target-driver.sh" + +fakeSpoofedTargetDriverLogPath :: FilePath +fakeSpoofedTargetDriverLogPath = "tmp-spoofed-target-driver.log" + +fakeFreeBsdDriverPath :: FilePath +fakeFreeBsdDriverPath = "tmp-freebsd-driver.sh" + +fakeFreeBsdDriverLogPath :: FilePath +fakeFreeBsdDriverLogPath = "tmp-freebsd-driver.log" + +fakeFreeBsdDriverAsmPath :: FilePath +fakeFreeBsdDriverAsmPath = "tmp-freebsd-driver.s" + +fakeMissingAssemblerDriverPath :: FilePath +fakeMissingAssemblerDriverPath = "tmp-missing-assembler-driver" + +fakeAssembleOnlyDriverPath :: FilePath +fakeAssembleOnlyDriverPath = "tmp-assemble-only-driver.sh" + +fakeAssembleOnlyDriverLogPath :: FilePath +fakeAssembleOnlyDriverLogPath = "tmp-assemble-only-driver.log" + +fakeInPlaceLinkDriverPath :: FilePath +fakeInPlaceLinkDriverPath = "tmp-in-place-link-driver.sh" + +fakeInPlaceLinkDriverLogPath :: FilePath +fakeInPlaceLinkDriverLogPath = "tmp-in-place-link-driver.log" + +fakeProbePrecreatedOutputDriverPath :: FilePath +fakeProbePrecreatedOutputDriverPath = "tmp-probe-precreated-output-driver.sh" + +fakeProbePrecreatedOutputDriverLogPath :: FilePath +fakeProbePrecreatedOutputDriverLogPath = "tmp-probe-precreated-output-driver.log" + +fakeTouchingLinkDriverPath :: FilePath +fakeTouchingLinkDriverPath = "tmp-touching-link-driver.sh" + +fakeTouchingLinkDriverLogPath :: FilePath +fakeTouchingLinkDriverLogPath = "tmp-touching-link-driver.log" + +fakeScriptLinkProbeDriverPath :: FilePath +fakeScriptLinkProbeDriverPath = "tmp-script-link-probe-driver.sh" + +fakeScriptLinkProbeDriverLogPath :: FilePath +fakeScriptLinkProbeDriverLogPath = "tmp-script-link-probe-driver.log" + +fakeSharedLinkProbeDriverPath :: FilePath +fakeSharedLinkProbeDriverPath = "tmp-shared-link-probe-driver.sh" + +fakeSharedLinkProbeDriverLogPath :: FilePath +fakeSharedLinkProbeDriverLogPath = "tmp-shared-link-probe-driver.log" + +fakeBlobLinkProbeDriverPath :: FilePath +fakeBlobLinkProbeDriverPath = "tmp-blob-link-probe-driver.sh" + +fakeBlobLinkProbeDriverLogPath :: FilePath +fakeBlobLinkProbeDriverLogPath = "tmp-blob-link-probe-driver.log" + +fakeSymlinkLinkProbeDriverPath :: FilePath +fakeSymlinkLinkProbeDriverPath = "tmp-symlink-link-probe-driver.sh" + +fakeSymlinkLinkProbeDriverLogPath :: FilePath +fakeSymlinkLinkProbeDriverLogPath = "tmp-symlink-link-probe-driver.log" + +fakeSymlinkLinkProbeTargetPath :: FilePath +fakeSymlinkLinkProbeTargetPath = "tmp-symlink-link-probe-target.bin" + +fakeBogusFinalLinkDriverPath :: FilePath +fakeBogusFinalLinkDriverPath = "tmp-bogus-final-link-driver.sh" + +fakeBogusFinalLinkDriverLogPath :: FilePath +fakeBogusFinalLinkDriverLogPath = "tmp-bogus-final-link-driver.log" + +fakeBogusFinalLinkTargetPath :: FilePath +fakeBogusFinalLinkTargetPath = "tmp-bogus-final-link-target.bin" + +fakeMarkerStrippingFinalLinkDriverPath :: FilePath +fakeMarkerStrippingFinalLinkDriverPath = "tmp-marker-stripping-final-link-driver.sh" + +fakeMarkerStrippingFinalLinkDriverLogPath :: FilePath +fakeMarkerStrippingFinalLinkDriverLogPath = "tmp-marker-stripping-final-link-driver.log" + +fakeExecutableObjectProbeDriverPath :: FilePath +fakeExecutableObjectProbeDriverPath = "tmp-executable-object-probe-driver.sh" + +fakeExecutableObjectProbeDriverLogPath :: FilePath +fakeExecutableObjectProbeDriverLogPath = "tmp-executable-object-probe-driver.log" + +fakeSymlinkObjectProbeDriverPath :: FilePath +fakeSymlinkObjectProbeDriverPath = "tmp-symlink-object-probe-driver.sh" + +fakeSymlinkObjectProbeDriverLogPath :: FilePath +fakeSymlinkObjectProbeDriverLogPath = "tmp-symlink-object-probe-driver.log" + +fakeSymlinkObjectProbeTargetPath :: FilePath +fakeSymlinkObjectProbeTargetPath = "tmp-symlink-object-probe-target.o" + +fakeFailingLinkDriverPath :: FilePath +fakeFailingLinkDriverPath = "tmp-failing-link-driver.sh" + +fakeFailingLinkDriverLogPath :: FilePath +fakeFailingLinkDriverLogPath = "tmp-failing-link-driver.log" + +fakePathBinDir :: FilePath +fakePathBinDir = "tmp-bin" + +fakePathGccPath :: FilePath +fakePathGccPath = fakePathBinDir "gcc" + +fakePathGccLogPath :: FilePath +fakePathGccLogPath = "tmp-path-gcc.log" + +fakePathGccAsmPath :: FilePath +fakePathGccAsmPath = "tmp-path-gcc.s" + +fakePathAssemblerPath :: FilePath +fakePathAssemblerPath = fakePathBinDir fakeAssemblerPath + +fakePathAssemblerLogPath :: FilePath +fakePathAssemblerLogPath = "tmp-path-assembler.log" + +fakePathWrapperLogPath :: FilePath +fakePathWrapperLogPath = "tmp-path-wrapper.log" + +fakeLocalAssemblerLogPath :: FilePath +fakeLocalAssemblerLogPath = "tmp-local-assembler.log" + +fakeHostPathHelperPath :: FilePath +fakeHostPathHelperPath = "tmp-path-helper.sh" + +fakeHostPathHelperLogPath :: FilePath +fakeHostPathHelperLogPath = "tmp-host-path-helper.log" + +fakeHostPathHelperAsmPath :: FilePath +fakeHostPathHelperAsmPath = "tmp-host-path-helper.s" + +fakeLocalGccLogPath :: FilePath +fakeLocalGccLogPath = "tmp-local-gcc.log" + +fakeMalformedAssemblerTmpDir :: FilePath +fakeMalformedAssemblerTmpDir = "tmp-htcc-tmp" + +specialFileModeMask :: FileMode +specialFileModeMask = foldr1 unionFileModes + [ setUserIDMode + , setGroupIDMode + , 0o1000 + ] + +permissionFileModeMask :: FileMode +permissionFileModeMask = foldr1 unionFileModes + [ ownerReadMode + , ownerWriteMode + , ownerExecuteMode + , groupReadMode + , groupWriteMode + , groupExecuteMode + , otherReadMode + , otherWriteMode + , otherExecuteMode + , specialFileModeMask + ] + +permissionBits :: FileMode -> FileMode +permissionBits = intersectFileModes permissionFileModeMask + +probeLinkedOutputWriter :: [T.Text] +probeLinkedOutputWriter = + [ " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\002\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , " cat \"$input\" >> \"$out\"" + , " chmod +x \"$out\"" + ] + +writeFakeAssembler :: FilePath -> IO () +writeFakeAssembler = writeFakeAssemblerWithLogs fakeAssemblerLogPath fakeAssemblerAsmPath + +writeForwardingDriverWrapper :: FilePath -> IO () +writeForwardingDriverWrapper wrapperPath = do + T.writeFile wrapperPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "wrapped=$1" + , "shift" + , "exec ./\"$wrapped\" \"$@\"" + ] + execErrFin $ "chmod +x '" <> T.pack wrapperPath <> "'" + +writeLoggingDriver :: FilePath -> FilePath -> IO () +writeLoggingDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines $ + [ "#!/bin/sh" + , "set -eu" + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "mode=link" + , "out=''" + , "input=''" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if [ \"$arg\" = '-c' ]; then" + , " mode=assemble" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "printf '%s:%s\\n' \"$mode\" \"$*\" >> " <> T.pack logPath + , "test -n \"$out\"" + , "if [ \"$mode\" = 'assemble' ]; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , " cat \"$input\" >> \"$out\"" + , "else" + , " case \"$out\" in" + , " *htcc-probe-*)" + ] + <> probeLinkedOutputWriter + <> [ " ;;" + , " *)" + , " printf '%s\\n' '#!/bin/sh' 'exit 0' > \"$out\"" + , " chmod +x \"$out\"" + , " ;;" + , " esac" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeSpecialOutputDriver :: FilePath -> IO () +writeSpecialOutputDriver driverPath = do + T.writeFile driverPath $ T.unlines $ + [ "#!/bin/sh" + , "set -eu" + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "mode=link" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " mode=assemble" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if [ \"$mode\" = 'assemble' ]; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , " cat \"$input\" >> \"$out\"" + , "else" + , " if [ \"$out\" = '/dev/null' ]; then" + , " : > \"$out\"" + , " else" + , " case \"$out\" in" + , " *htcc-probe-*)" + ] + <> map (" " <>) probeLinkedOutputWriter + <> [ " ;;" + , " *)" + , " printf '%s\\n' '#!/bin/sh' 'exit 0' > \"$out\"" + , " chmod +x \"$out\"" + , " ;;" + , " esac" + , " fi" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeProbeRejectingWrapper :: FilePath -> FilePath -> FilePath -> IO () +writeProbeRejectingWrapper wrapperPath logPath wrappedPath = do + T.writeFile wrapperPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " exit 64" + , " ;;" + , " esac" + , "done" + , "exec ./" <> T.pack wrappedPath <> " \"$@\"" + ] + execErrFin $ "chmod +x '" <> T.pack wrapperPath <> "'" + +writeHostMetadataWrapper :: FilePath -> FilePath -> FilePath -> IO () +writeHostMetadataWrapper wrapperPath logPath wrappedPath = do + T.writeFile wrapperPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'arm64-apple-darwin23.5.0'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "exec ./" <> T.pack wrappedPath <> " \"$@\"" + ] + execErrFin $ "chmod +x '" <> T.pack wrapperPath <> "'" + +writePathLoggingWrapper :: FilePath -> FilePath -> FilePath -> IO () +writePathLoggingWrapper wrapperPath logPath helperName = do + T.writeFile wrapperPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$PATH\" > " <> T.pack logPath + , "exec " <> T.pack helperName <> " \"$@\"" + ] + execErrFin $ "chmod +x '" <> T.pack wrapperPath <> "'" + +shellQuote :: T.Text -> T.Text +shellQuote word = "'" <> T.replace "'" "'\"'\"'" word <> "'" + +writeExecutableProxy :: FilePath -> FilePath -> IO () +writeExecutableProxy proxyPath targetPath = do + T.writeFile proxyPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "exec " <> shellQuote (T.pack targetPath) <> " \"$@\"" + ] + execErrFin $ "chmod +x '" <> T.pack proxyPath <> "'" + +writeFakeAssemblerWithLogs :: FilePath -> FilePath -> FilePath -> IO () +writeFakeAssemblerWithLogs = writeFakeAssemblerWithTarget "x86_64-linux-gnu" + +writeFakeAssemblerWithTarget :: T.Text -> FilePath -> FilePath -> FilePath -> IO () +writeFakeAssemblerWithTarget targetTriple logPath asmPath assemblerPath = do + T.writeFile assemblerPath $ T.unlines $ + [ "#!/bin/sh" + , "set -eu" + , "copy_file() {" + , " src=$1" + , " dst=$2" + , " while IFS= read -r line || [ -n \"$line\" ]; do" + , " printf '%s\\n' \"$line\"" + , " done < \"$src\" > \"$dst\"" + , "}" + , "read_file() {" + , " while IFS= read -r line || [ -n \"$line\" ]; do" + , " printf '%s\\n' \"$line\"" + , " done < \"$1\"" + , "}" + , "write_probe_object() {" + ] + <> probeObjectWriter + <> [ "}" + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' '" <> targetTriple <> "'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "assemble=false" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " assemble=true" + , " expect_lang=true" + , " ;;" + , " -c)" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "if $assemble; then" + , " printf '%s\\n' \"$@\" > " <> T.pack logPath + , " test -n \"$out\"" + , " test -n \"$input\"" + , " copy_file \"$input\" " <> T.pack asmPath + , " input_contents=$(read_file \"$input\")" + , " case \"$input_contents\" in" + , " *\".intel_syntax noprefix\"*) : ;;" + , " *) exit 98 ;;" + , " esac" + , " case \"$input_contents\" in" + , " *\"main:\"*) : ;;" + , " *) exit 98 ;;" + , " esac" + , " while [ \"$1\" != '-x' ]; do" + , " shift" + , " done" + , "fi" + , "test -n \"$out\"" + , "if $assemble; then" + , " write_probe_object \"$out\"" + , "else" + , " case \"$out\" in" + , " *htcc-probe-*)" + ] + <> probeLinkedOutputWriter + <> [ " ;;" + , " *)" + , " printf '%s\\n' '#!/bin/sh' 'exit 0' > \"$out\"" + , " /bin/chmod +x \"$out\"" + , " ;;" + , " esac" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack assemblerPath <> "'" + where + normalizedTarget = T.toLower targetTriple + emitsElfObject = + not $ any (`T.isInfixOf` normalizedTarget) + [ "apple" + , "cygwin" + , "darwin" + , "mingw" + , "msvc" + , "windows" + ] + + probeObjectWriter + | emitsElfObject = + [ " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$1\"" + , " cat \"$input\" >> \"$1\"" + ] + | otherwise = + [ " printf 'MZfake-object\\n' > \"$1\"" + ] + +writeFailingCompiler :: FilePath -> FilePath -> IO () +writeFailingCompiler compilerPath logPath = do + T.writeFile compilerPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "printf '%s\\n' \"$@\" > " <> T.pack logPath + , "exit 97" + ] + execErrFin $ "chmod +x '" <> T.pack compilerPath <> "'" + +writeAssembleOnlyDriver :: FilePath -> FilePath -> IO () +writeAssembleOnlyDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "assemble=false" + , "out=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " assemble=true" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if $assemble; then" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , "else" + , " exit 97" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeInPlaceLinkDriver :: FilePath -> FilePath -> IO () +writeInPlaceLinkDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines $ + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "mode=link" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " mode=assemble" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if [ \"$mode\" = 'assemble' ]; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , " cat \"$input\" >> \"$out\"" + , "else" + , " case \"$out\" in" + , " *htcc-probe-*)" + ] + <> probeLinkedOutputWriter + <> [ " ;;" + , " *)" + , " if [ -e \"$out\" ]; then" + , " printf '%s\\n' '#!/bin/sh' 'exit 0' > \"$out\"" + , " else" + , " printf '%s\\n' '#!/bin/sh' 'exit 0' > \"$out\"" + , " chmod +x \"$out\"" + , " fi" + , " ;;" + , " esac" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeProbePrecreatedOutputDriver :: FilePath -> FilePath -> IO () +writeProbePrecreatedOutputDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines $ + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "mode=link" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " mode=assemble" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if [ \"$mode\" = 'assemble' ]; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , " cat \"$input\" >> \"$out\"" + , "else" + , " test -e \"$out\"" + , " case \"$out\" in" + , " *htcc-probe-*)" + ] + <> probeLinkedOutputWriter + <> [ " ;;" + , " *)" + , " printf '%s\\n' '#!/bin/sh' 'exit 0' > \"$out\"" + , " chmod +x \"$out\"" + , " ;;" + , " esac" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeScriptLinkProbeDriver :: FilePath -> FilePath -> IO () +writeScriptLinkProbeDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "assemble=false" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " assemble=true" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if $assemble; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , "else" + , " printf '%s\\n' '#!/bin/sh' 'exit 0' > \"$out\"" + , " chmod +x \"$out\"" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeSharedLinkProbeDriver :: FilePath -> FilePath -> IO () +writeSharedLinkProbeDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "assemble=false" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " assemble=true" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "test -n \"$input\"" + , "if $assemble; then" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , "else" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\003\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , "fi" + , "cat \"$input\" >> \"$out\"" + , "if ! $assemble; then" + , " chmod +x \"$out\"" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeBlobLinkProbeDriver :: FilePath -> FilePath -> IO () +writeBlobLinkProbeDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "assemble=false" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " assemble=true" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if $assemble; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , "else" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\002\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , " printf '%s' 'unrelated-probe-blob' >> \"$out\"" + , " chmod +x \"$out\"" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeTouchingLinkDriver :: FilePath -> FilePath -> IO () +writeTouchingLinkDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "assemble=false" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " assemble=true" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if $assemble; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , "else" + , " : > \"$out\"" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeSymlinkLinkProbeDriver :: FilePath -> FilePath -> FilePath -> IO () +writeSymlinkLinkProbeDriver driverPath logPath targetPath = do + T.writeFile driverPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "assemble=false" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " assemble=true" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if $assemble; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , " cat \"$input\" >> \"$out\"" + , "else" + , " test -n \"$input\"" + , " target=\"$(pwd)/" <> T.pack targetPath <> "\"" + , " rm -f \"$target\" \"$out\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\002\\000\\076\\000\\001\\000\\000\\000' > \"$target\"" + , " chmod 000 \"$target\"" + , " ln -sf \"$target\" \"$out\"" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeBogusFinalLinkDriver :: FilePath -> FilePath -> FilePath -> IO () +writeBogusFinalLinkDriver driverPath logPath targetPath = do + T.writeFile driverPath $ T.unlines $ + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "mode=link" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " mode=assemble" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if [ \"$mode\" = 'assemble' ]; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , " cat \"$input\" >> \"$out\"" + , "else" + , " case \"$out\" in" + , " *htcc-probe-*)" + ] + <> probeLinkedOutputWriter + <> [ " target=\"$(pwd)/" <> T.pack targetPath <> "\"" + , " cat \"$out\" > \"$target\"" + , " chmod +x \"$target\"" + , " ;;" + , " *)" + , " test -n \"$input\"" + , " target=\"$(pwd)/" <> T.pack targetPath <> "\"" + , " test -f \"$target\"" + , " cat \"$target\" > \"$out\"" + , " chmod +x \"$out\"" + , " ;;" + , " esac" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeMarkerStrippingFinalLinkDriver :: FilePath -> FilePath -> IO () +writeMarkerStrippingFinalLinkDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines $ + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "mode=link" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " mode=assemble" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if [ \"$mode\" = 'assemble' ]; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , " cat \"$input\" >> \"$out\"" + , "else" + , " case \"$out\" in" + , " *htcc-probe-*)" + ] + <> probeLinkedOutputWriter + <> [ " ;;" + , " *)" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\002\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , " chmod +x \"$out\"" + , " ;;" + , " esac" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeExecutableObjectProbeDriver :: FilePath -> FilePath -> IO () +writeExecutableObjectProbeDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines $ + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "assemble=false" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " assemble=true" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if $assemble; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\002\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , " cat \"$input\" >> \"$out\"" + , "else" + , " case \"$out\" in" + , " *htcc-probe-*)" + ] + <> probeLinkedOutputWriter + <> [ " ;;" + , " *)" + , " printf '%s\\n' '#!/bin/sh' 'exit 0' > \"$out\"" + , " chmod +x \"$out\"" + , " ;;" + , " esac" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeSymlinkObjectProbeDriver :: FilePath -> FilePath -> FilePath -> IO () +writeSymlinkObjectProbeDriver driverPath logPath targetPath = do + T.writeFile driverPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "assemble=false" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " assemble=true" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if $assemble; then" + , " test -n \"$input\"" + , " target=\"$(pwd)/" <> T.pack targetPath <> "\"" + , " rm -f \"$target\" \"$out\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$target\"" + , " cat \"$input\" >> \"$target\"" + , " ln -sf \"$target\" \"$out\"" + , "else" + , " printf '%s\\n' '#!/bin/sh' 'exit 0' > \"$out\"" + , " chmod +x \"$out\"" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeFailingLinkDriver :: FilePath -> FilePath -> IO () +writeFailingLinkDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "assemble=false" + , "out=''" + , "input=''" + , "expect_lang=false" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_lang; then" + , " expect_lang=false" + , " continue" + , " fi" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -x)" + , " assemble=true" + , " expect_lang=true" + , " ;;" + , " -o)" + , " expect_out=true" + , " ;;" + , " -*)" + , " ;;" + , " *)" + , " input=\"$arg\"" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "if $assemble; then" + , " test -n \"$input\"" + , " printf '\\177ELF\\002\\001\\001\\000\\000\\000\\000\\000\\000\\000\\000\\000\\001\\000\\076\\000\\001\\000\\000\\000' > \"$out\"" + , "else" + , " case \"$out\" in" + , " *tmp-read-only.out*.htcc-*)" + , " : > \"$out\"" + , " exit 97" + , " ;;" + , " *)" + , " printf '%s\\n' '#!/bin/sh' 'exit 0' > \"$out\"" + , " chmod +x \"$out\"" + , " ;;" + , " esac" + , "fi" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeHostTargetDriver :: FilePath -> FilePath -> IO () +writeHostTargetDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'arm64-apple-darwin23.5.0'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "out=''" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -o)" + , " expect_out=true" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "printf 'MZfake-object\\n' > \"$out\"" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +writeMetadataSpoofingDriver :: FilePath -> FilePath -> IO () +writeMetadataSpoofingDriver driverPath logPath = do + T.writeFile driverPath $ T.unlines + [ "#!/bin/sh" + , "set -eu" + , "printf '%s\\n' \"$*\" >> " <> T.pack logPath + , "for arg in \"$@\"; do" + , " case \"$arg\" in" + , " -dumpmachine|-print-target-triple)" + , " printf '%s\\n' 'x86_64-linux-gnu'" + , " exit 0" + , " ;;" + , " esac" + , "done" + , "out=''" + , "expect_out=false" + , "for arg in \"$@\"; do" + , " if $expect_out; then" + , " out=\"$arg\"" + , " expect_out=false" + , " continue" + , " fi" + , " case \"$arg\" in" + , " -o)" + , " expect_out=true" + , " ;;" + , " esac" + , "done" + , "test -n \"$out\"" + , "printf 'MZfake-object\\n' > \"$out\"" + ] + execErrFin $ "chmod +x '" <> T.pack driverPath <> "'" + +mkResult :: T.Text -> Bool -> T.Text -> (Either T.Text T.Text, String) +mkResult msg ok details = + ( if ok then Right msg else Left details + , T.unpack msg + ) + +outputFileTest :: IO (Either T.Text T.Text, String) +outputFileTest = flip finally (clean ["tmp.out", "tmp.s"]) $ do + htccCmd <- htccCommand + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , htccCmd + , " -o tmp.s /dev/stdin > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ ".L.return.main:" + , ".L.label.main.done:" + , ".L.case.main." + ] + ok = T.null stdoutLeak && hasRequiredLabels + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + ] + return $ mkResult outputFileMsg ok details + +outputFileSingleInputStaticTest :: IO (Either T.Text T.Text, String) +outputFileSingleInputStaticTest = flip finally (clean ["tmp.out", "tmp.s", "tmp.o", "tmp-single.c"]) $ do + htccCmd <- htccCommand + T.writeFile "tmp-single.c" $ T.unlines + [ "static int helper;" + , "int main() { helper = 1; return helper; }" + ] + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s tmp-single.c > tmp.out" + ] + assemblerCommand ["-x", "assembler", "-c", "-o", "tmp.o", "tmp.s"] >>= execErrFin + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + let hasOriginalStaticLabel = "\nhelper:" `T.isInfixOf` asm + hasNamespacedStaticLabel = ".L.internal." `T.isInfixOf` asm + ok = T.null stdoutLeak && hasOriginalStaticLabel && not hasNamespacedStaticLabel + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasOriginalStaticLabel: " <> T.pack (show hasOriginalStaticLabel) + , "hasNamespacedStaticLabel: " <> T.pack (show hasNamespacedStaticLabel) + ] + return $ mkResult outputFileSingleInputStaticMsg ok details + +outputFileSingleInputImplicitFunctionTest :: IO (Either T.Text T.Text, String) +outputFileSingleInputImplicitFunctionTest = flip finally (clean ["tmp.out", "tmp.s", "tmp-single.c"]) $ do + htccCmd <- htccCommand + T.writeFile "tmp-single.c" $ + T.unlines + [ "int main() { return foo(); }" + ] + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s tmp-single.c > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + let hasMainLabel = "\nmain:" `T.isInfixOf` asm + hasFooCall = + any (`T.isInfixOf` asm) + [ "call foo" + , "call \"foo\"" + ] + ok = T.null stdoutLeak && hasMainLabel && hasFooCall + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasMainLabel: " <> T.pack (show hasMainLabel) + , "hasFooCall: " <> T.pack (show hasFooCall) + ] + return $ mkResult outputFileSingleInputImplicitFunctionMsg ok details + +outputFileSingleInputImplicitFunctionConflictTest :: IO (Either T.Text T.Text, String) +outputFileSingleInputImplicitFunctionConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-single.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + inputPath = "tmp-single.c" + expectedError = "multiple external definitions in multi-input -o mode: foo" + T.writeFile inputPath $ T.unlines + [ "int foo;" + , "int main(void) { return foo(); }" + ] + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && not targetExists && hasExpectedError + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileSingleInputImplicitFunctionConflictMsg ok details + +outputFileSingleInputStaticImplicitFunctionConflictTest :: IO (Either T.Text T.Text, String) +outputFileSingleInputStaticImplicitFunctionConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-single.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + inputPath = "tmp-single.c" + expectedError = "multiple external definitions in multi-input -o mode: foo" + T.writeFile inputPath $ T.unlines + [ "static int foo;" + , "int main(void) { return foo(); }" + ] + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && not targetExists && hasExpectedError + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileSingleInputStaticImplicitFunctionConflictMsg ok details + +outputFileSingleInputPrototypeRetypeTest :: IO (Either T.Text T.Text, String) +outputFileSingleInputPrototypeRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-single.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + inputPath = "tmp-single.c" + expectedError = "too many arguments to function call" + T.writeFile inputPath $ T.unlines + [ "int foo();" + , "int main(void) { return foo(1); }" + , "int foo(void) { return 0; }" + ] + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileSingleInputPrototypeRetypeMsg ok details + +stdoutSingleInputImplicitFunctionConflictTest :: IO (Either T.Text T.Text, String) +stdoutSingleInputImplicitFunctionConflictTest = + flip finally (clean ["tmp.err", "tmp.s", "tmp-single.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + inputPath = "tmp-single.c" + expectedError = "multiple external definitions in multi-input -o mode: foo" + T.writeFile inputPath $ T.unlines + [ "int foo;" + , "int main(void) { return foo(); }" + ] + result <- exec $ mconcat + [ htccCmd + , " " + , T.pack inputPath + , " > " + , T.pack target + , " 2> tmp.err" + ] + asm <- T.readFile target + stderrOut <- T.readFile "tmp.err" + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null asm && hasExpectedError + details = T.unlines + [ "asm:" + , asm + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult stdoutSingleInputImplicitFunctionConflictMsg ok details + +stdoutMultiInputStaticFunctionTest :: IO (Either T.Text T.Text, String) +stdoutMultiInputStaticFunctionTest = + flip finally (clean ["tmp.err", "tmp.s", "tmp.o", "tmp-foo.c", "tmp-bar.c"]) $ do + htccCmd <- htccCommand + T.writeFile "tmp-foo.c" $ T.unlines + [ "static int helper(void) { return 1; }" + , "int foo(void) { return helper(); }" + ] + T.writeFile "tmp-bar.c" $ T.unlines + [ "static int helper(void) { return 2; }" + , "int bar(void) { return helper(); }" + ] + result <- exec $ mconcat + [ htccCmd + , " tmp-foo.c tmp-bar.c > tmp.s 2> tmp.err" + ] + assemblerCommand ["-x", "assembler", "-c", "-o", "tmp.o", "tmp.s"] >>= execErrFin + stderrOut <- T.readFile "tmp.err" + asm <- T.readFile "tmp.s" + let succeeded = exitCode (const False) True result + hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , ".L.return.foo:" + , "bar:" + , ".L.return.bar:" + , ".L.internal.0.helper:" + , ".L.internal.1.helper:" + ] + hasOriginalHelperLabel = "\nhelper:" `T.isInfixOf` asm + ok = succeeded && T.null stderrOut && hasRequiredLabels && not hasOriginalHelperLabel + details = T.unlines + [ "stderr:" + , stderrOut + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "hasOriginalHelperLabel: " <> T.pack (show hasOriginalHelperLabel) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult stdoutMultiInputStaticFunctionMsg ok details + +stdoutMultiInputImplicitFunctionDefinitionWarningTest :: IO (Either T.Text T.Text, String) +stdoutMultiInputImplicitFunctionDefinitionWarningTest = + flip finally (clean ["tmp.err", "tmp.s", "tmp-caller.c", "tmp-def.c", "tmp"]) $ do + htccCmd <- htccCommand + let callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + T.writeFile callerPath "int main(void) { return foo(1) != 1; }" + T.writeFile defPath "int foo(int x) { return x; }" + result <- exec $ mconcat + [ htccCmd + , " " + , T.pack callerPath + , " " + , T.pack defPath + , " > tmp.s 2> tmp.err" + ] + linkCmd <- assemblerCommand ["tmp.s", "-o", "tmp"] + execErrFin linkCmd + stderrOut <- T.readFile "tmp.err" + asm <- T.readFile "tmp.s" + runResult <- exec "./tmp" + let succeeded = exitCode (const False) True result + hasSuppressedWarning = not $ "the function 'foo' is not declared." `T.isInfixOf` stderrOut + hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , "main:" + ] + ok = + succeeded + && T.null stderrOut + && hasSuppressedWarning + && hasRequiredLabels + && exitCode (const False) True runResult + details = T.unlines + [ "stderr:" + , stderrOut + , "hasSuppressedWarning: " <> T.pack (show hasSuppressedWarning) + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "runExitCode: " <> T.pack (show runResult) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult stdoutMultiInputImplicitFunctionDefinitionWarningMsg ok details + +stdoutMultiInputImplicitFunctionUnresolvedWarningTest :: IO (Either T.Text T.Text, String) +stdoutMultiInputImplicitFunctionUnresolvedWarningTest = + flip finally (clean ["tmp.err", "tmp.s", "tmp-caller.c", "tmp-other.c"]) $ do + htccCmd <- htccCommand + let callerPath = "tmp-caller.c" + otherPath = "tmp-other.c" + expectedWarning = "warning: the function 'foo' is not declared." + T.writeFile callerPath "int main(void) { return foo(1) != 1; }" + T.writeFile otherPath "int helper(void) { return 0; }" + result <- exec $ mconcat + [ htccCmd + , " " + , T.pack callerPath + , " " + , T.pack otherPath + , " > tmp.s 2> tmp.err" + ] + stderrOut <- T.readFile "tmp.err" + asm <- T.readFile "tmp.s" + let succeeded = exitCode (const False) True result + hasExpectedWarning = expectedWarning `T.isInfixOf` stderrOut + hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "helper:" + , "main:" + ] + ok = succeeded && hasExpectedWarning && hasRequiredLabels + details = T.unlines + [ "stderr:" + , stderrOut + , "hasExpectedWarning: " <> T.pack (show hasExpectedWarning) + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult stdoutMultiInputImplicitFunctionUnresolvedWarningMsg ok details + +stdoutMultiInputParseFailurePreservesWarningsTest :: IO (Either T.Text T.Text, String) +stdoutMultiInputParseFailurePreservesWarningsTest = + flip finally (clean ["tmp.err", "tmp.s", "tmp-caller.c", "tmp-bad.c"]) $ do + htccCmd <- htccCommand + let callerPath = "tmp-caller.c" + badPath = "tmp-bad.c" + expectedWarning = "warning: the function 'foo' is not declared." + T.writeFile callerPath "int main(void) { return foo(1) != 1; }" + T.writeFile badPath "int broken( { return 0; }" + result <- exec $ mconcat + [ htccCmd + , " " + , T.pack callerPath + , " " + , T.pack badPath + , " > tmp.s 2> tmp.err" + ] + asm <- T.readFile "tmp.s" + stderrOut <- T.readFile "tmp.err" + let failed = exitCode (const True) False result + hasExpectedWarning = expectedWarning `T.isInfixOf` stderrOut + mentionsBadInput = T.pack badPath `T.isInfixOf` stderrOut + ok = failed && T.null asm && hasExpectedWarning && mentionsBadInput + details = T.unlines + [ "asm:" + , asm + , "stderr:" + , stderrOut + , "hasExpectedWarning: " <> T.pack (show hasExpectedWarning) + , "mentionsBadInput: " <> T.pack (show mentionsBadInput) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult stdoutMultiInputParseFailurePreservesWarningsMsg ok details + +stdoutMultiInputPrototypeOnlyArityRetypeTest :: IO (Either T.Text T.Text, String) +stdoutMultiInputPrototypeOnlyArityRetypeTest = + flip finally (clean ["tmp.err", "tmp.s", "tmp-caller.c", "tmp-proto.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + protoPath = "tmp-proto.c" + expectedError = "too few arguments to function call" + T.writeFile callerPath $ T.unlines + [ "int foo();" + , "int main(void) { return foo(); }" + ] + T.writeFile protoPath "int foo(int);" + result <- exec $ mconcat + [ htccCmd + , " " + , T.pack callerPath + , " " + , T.pack protoPath + , " > " + , T.pack target + , " 2> tmp.err" + ] + asm <- T.readFile target + stderrOut <- T.readFile "tmp.err" + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null asm && hasExpectedError + details = T.unlines + [ "asm:" + , asm + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult stdoutMultiInputPrototypeOnlyArityRetypeMsg ok details + +stdoutMultiInputParameterIndirectFunctionPointerArityRetypeTest :: IO (Either T.Text T.Text, String) +stdoutMultiInputParameterIndirectFunctionPointerArityRetypeTest = + flip finally (clean ["tmp.err", "tmp.s", "tmp-def.c", "tmp-proto.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + defPath = "tmp-def.c" + protoPath = "tmp-proto.c" + expectedError = "too many arguments to function call" + T.writeFile defPath $ T.unlines + [ "int g(int (*fp)()) { return fp(1, 2); }" + , "int main(void) { return 0; }" + ] + T.writeFile protoPath "int g(int (*fp)(int));" + result <- exec $ mconcat + [ htccCmd + , " " + , T.pack defPath + , " " + , T.pack protoPath + , " > " + , T.pack target + , " 2> tmp.err" + ] + asm <- T.readFile target + stderrOut <- T.readFile "tmp.err" + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null asm && hasExpectedError + details = T.unlines + [ "asm:" + , asm + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult stdoutMultiInputParameterIndirectFunctionPointerArityRetypeMsg ok details + +outputFileMultiInputTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTest = flip finally (clean ["tmp.out", "tmp.s", "tmp.o", "tmp-foo.c", "tmp-bar.c"]) $ do + htccCmd <- htccCommand + T.writeFile "tmp-foo.c" "char* foo() { return \"foo\"; }" + T.writeFile "tmp-bar.c" "char* bar() { return \"bar\"; }" + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s tmp-foo.c tmp-bar.c > tmp.out" + ] + assemblerCommand ["-x", "assembler", "-c", "-o", "tmp.o", "tmp.s"] >>= execErrFin + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , ".L.return.foo:" + , "bar:" + , ".L.return.bar:" + , ".L.data.0:" + , ".L.data.1:" + ] + hasUniqueLiteralLabels = + T.count ".L.data.0:" asm == 1 + && T.count ".L.data.1:" asm == 1 + ok = T.null stdoutLeak && hasRequiredLabels && hasUniqueLiteralLabels + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "hasUniqueLiteralLabels: " <> T.pack (show hasUniqueLiteralLabels) + ] + return $ mkResult outputFileMultiInputMsg ok details + +outputFileMultiInputFunctionDeclarationConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputFunctionDeclarationConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-decl.c", "tmp-global.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + declPath = "tmp-decl.c" + globalPath = "tmp-global.c" + expectedError = "multiple external definitions in multi-input -o mode: foo" + clean ["tmp.out", "tmp.err", target, declPath, globalPath] + T.writeFile declPath $ T.unlines + [ "int foo(void);" + , "int main() { return foo(); }" + ] + T.writeFile globalPath "int foo;" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack declPath + , " " + , T.pack globalPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputFunctionDeclarationConflictMsg ok details + +outputFileMultiInputImplicitFunctionConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputImplicitFunctionConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-global.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + globalPath = "tmp-global.c" + expectedError = "multiple external definitions in multi-input -o mode: foo" + clean ["tmp.out", "tmp.err", target, callerPath, globalPath] + T.writeFile callerPath "int main() { return foo(); }" + T.writeFile globalPath "int foo;" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack globalPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputImplicitFunctionConflictMsg ok details + +outputFileMultiInputConflictPreservesWarningsTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputConflictPreservesWarningsTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-dup-a.c", "tmp-dup-b.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + dupAPath = "tmp-dup-a.c" + dupBPath = "tmp-dup-b.c" + expectedWarning = "warning: the function 'bar' is not declared." + expectedError = "multiple external definitions in multi-input -o mode: foo" + clean ["tmp.out", "tmp.err", target, callerPath, dupAPath, dupBPath] + T.writeFile callerPath "int main(void) { return bar(); }" + T.writeFile dupAPath "int foo = 1;" + T.writeFile dupBPath "int foo = 2;" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack dupAPath + , " " + , T.pack dupBPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedWarning = expectedWarning `T.isInfixOf` stderrOut + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && hasExpectedWarning + && hasExpectedError + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedWarning: " <> T.pack (show hasExpectedWarning) + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputConflictPreservesWarningsMsg ok details + +outputFileMultiInputReadFailurePreservesWarningsTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputReadFailurePreservesWarningsTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-missing.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + missingPath = "tmp-missing.c" + expectedWarning = "warning: the function 'foo' is not declared." + clean ["tmp.out", "tmp.err", target, callerPath, missingPath] + T.writeFile target "stale output" + T.writeFile callerPath "int main(void) { return foo(1) != 1; }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack missingPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + targetContents <- if targetExists then T.readFile target else pure "" + let failed = exitCode (const True) False result + hasExpectedWarning = expectedWarning `T.isInfixOf` stderrOut + mentionsMissingInput = T.pack missingPath `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && targetExists + && targetContents == "stale output" + && hasExpectedWarning + && mentionsMissingInput + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "targetUnchanged: " <> T.pack (show (targetContents == "stale output")) + , "hasExpectedWarning: " <> T.pack (show hasExpectedWarning) + , "mentionsMissingInput: " <> T.pack (show mentionsMissingInput) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputReadFailurePreservesWarningsMsg ok details + +outputFileMultiInputImplicitFunctionTypeConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputImplicitFunctionTypeConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + expectedError = "conflicting external function declarations in multi-input -o mode: foo" + clean ["tmp.out", "tmp.err", target, callerPath, defPath] + T.writeFile callerPath "int main() { return foo(); }" + T.writeFile defPath "long foo(void) { return 0; }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputImplicitFunctionTypeConflictMsg ok details + +outputFileMultiInputImplicitFunctionTypeConflictReverseOrderTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputImplicitFunctionTypeConflictReverseOrderTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + expectedError = "conflicting external function declarations in multi-input -o mode: foo" + clean ["tmp.out", "tmp.err", target, callerPath, defPath] + T.writeFile defPath "long foo(void) { return 0; }" + T.writeFile callerPath "int main() { return foo(); }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack defPath + , " " + , T.pack callerPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputImplicitFunctionTypeConflictReverseOrderMsg ok details + +outputFileMultiInputFunctionTypeConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputFunctionTypeConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-decl.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + declPath = "tmp-decl.c" + defPath = "tmp-def.c" + expectedError = "conflicting external function declarations in multi-input -o mode: foo" + clean ["tmp.out", "tmp.err", target, declPath, defPath] + T.writeFile declPath $ T.unlines + [ "int foo(void);" + , "int main() { return foo(); }" + ] + T.writeFile defPath "long foo(void) { return 0; }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack declPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputFunctionTypeConflictMsg ok details + +outputFileMultiInputFunctionPointerRedeclarationConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputFunctionPointerRedeclarationConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-decl.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + declPath = "tmp-decl.c" + defPath = "tmp-def.c" + expectedError = "conflicting external declarations in multi-input -o mode: p" + clean ["tmp.out", "tmp.err", target, declPath, defPath] + T.writeFile declPath $ T.unlines + [ "int *p;" + , "int main(void) { return p != 0; }" + ] + T.writeFile defPath "int (*p)(void);" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack declPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputFunctionPointerRedeclarationConflictMsg ok details + +outputFileMultiInputAdjustedFunctionParamTypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputAdjustedFunctionParamTypeTest = + flip finally (clean ["tmp.out", "tmp.s", "tmp-decl.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + declPath = "tmp-decl.c" + defPath = "tmp-def.c" + clean ["tmp.out", target, declPath, defPath] + T.writeFile declPath $ T.unlines + [ "int take_array(int xs[]);" + , "int take_cb(int cb());" + , "int main(void) { return 0; }" + ] + T.writeFile defPath $ T.unlines + [ "int take_array(int *xs) { return 0; }" + , "int take_cb(int (*cb)()) { return 0; }" + ] + execErrFin $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack declPath + , " " + , T.pack defPath + , " > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile target + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "take_array:" + , "take_cb:" + , "main:" + ] + ok = T.null stdoutLeak && hasRequiredLabels + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + ] + return $ mkResult outputFileMultiInputAdjustedFunctionParamTypeMsg ok details + +outputFileMultiInputCompatiblePrototypeMergeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputCompatiblePrototypeMergeTest = + flip finally (clean ["tmp", "tmp.out", "tmp.s", "tmp-use.c", "tmp-proto.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + usePath = "tmp-use.c" + protoPath = "tmp-proto.c" + expectedError = "conflicting external function declarations in multi-input -o mode: f" + clean ["tmp", "tmp.out", target, usePath, protoPath] + T.writeFile usePath $ T.unlines + [ "int (*f(void))[4];" + , "int main(void) { return sizeof *f(); }" + ] + T.writeFile protoPath "int (*f(void))[];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack usePath + , " " + , T.pack protoPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputCompatiblePrototypeMergeMsg ok details + +outputFileMultiInputRepeatedPrototypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputRepeatedPrototypeTest = + flip finally (clean ["tmp.out", "tmp.s", "tmp-decl.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let declPath = "tmp-decl.c" + defPath = "tmp-def.c" + T.writeFile declPath $ T.unlines + [ "int foo(void);" + , "int foo(void);" + , "int main() { return foo() != 42; }" + ] + T.writeFile defPath "int foo(void) { return 42; }" + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s " + , T.pack declPath + , " " + , T.pack defPath + , " > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , "main:" + ] + fooLabelCount = T.count "\nfoo:" $ "\n" <> asm + ok = T.null stdoutLeak && hasRequiredLabels && fooLabelCount == 1 + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "fooLabelCount: " <> T.pack (show fooLabelCount) + ] + return $ mkResult outputFileMultiInputRepeatedPrototypeMsg ok details + +outputFileMultiInputPrototypeOnlyArityRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputPrototypeOnlyArityRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-proto.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + protoPath = "tmp-proto.c" + expectedError = "too few arguments to function call" + T.writeFile callerPath $ T.unlines + [ "int foo();" + , "int main(void) { return foo(); }" + ] + T.writeFile protoPath "int foo(int);" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack protoPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputPrototypeOnlyArityRetypeMsg ok details + +outputFileMultiInputSignedIntRedeclarationTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputSignedIntRedeclarationTest = + flip finally (clean ["tmp.out", "tmp.s", "tmp-decl.c", "tmp-def.c", "tmp"]) $ do + htccCmd <- htccCommand + let declPath = "tmp-decl.c" + defPath = "tmp-def.c" + T.writeFile declPath $ T.unlines + [ "int foo(void);" + , "int x;" + , "int main(void) { return foo() != 42 || x != 0; }" + ] + T.writeFile defPath $ T.unlines + [ "signed foo(void) { return 42; }" + , "signed x;" + ] + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s " + , T.pack declPath + , " " + , T.pack defPath + , " > tmp.out" + ] + linkCmd <- assemblerCommand ["tmp.s", "-o", "tmp"] + execErrFin linkCmd + stdoutLeak <- T.readFile "tmp.out" + result <- exec "./tmp" + asm <- T.readFile "tmp.s" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , "x:" + , "main:" + ] + fooLabelCount = T.count "\nfoo:" $ "\n" <> asm + xLabelCount = T.count "\nx:" $ "\n" <> asm + ok = + T.null stdoutLeak + && exitCode (const False) True result + && hasRequiredLabels + && fooLabelCount == 1 + && xLabelCount == 1 + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "fooLabelCount: " <> T.pack (show fooLabelCount) + , "xLabelCount: " <> T.pack (show xLabelCount) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputSignedIntRedeclarationMsg ok details + +outputFileMultiInputOldStyleDeclarationTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputOldStyleDeclarationTest = + flip finally (clean ["tmp.out", "tmp.s", "tmp-decl.c", "tmp-def.c", "tmp"]) $ do + htccCmd <- htccCommand + let declPath = "tmp-decl.c" + defPath = "tmp-def.c" + T.writeFile declPath $ T.unlines + [ "int foo();" + , "int main(void) { return foo(1) != 1; }" + ] + T.writeFile defPath "int foo(int x) { return x; }" + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s " + , T.pack declPath + , " " + , T.pack defPath + , " > tmp.out" + ] + linkCmd <- assemblerCommand ["tmp.s", "-o", "tmp"] + execErrFin linkCmd + stdoutLeak <- T.readFile "tmp.out" + result <- exec "./tmp" + asm <- T.readFile "tmp.s" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , "main:" + ] + ok = T.null stdoutLeak && exitCode (const False) True result && hasRequiredLabels + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputOldStyleDeclarationMsg ok details + +outputFileMultiInputOldStylePromotionConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputOldStylePromotionConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-decl.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + declPath = "tmp-decl.c" + defPath = "tmp-def.c" + expectedError = "conflicting external function declarations in multi-input -o mode: foo" + clean ["tmp.out", "tmp.err", target, declPath, defPath] + T.writeFile declPath $ T.unlines + [ "int foo();" + , "int main(void) { return 0; }" + ] + T.writeFile defPath "int foo(char x) { return x; }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack declPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputOldStylePromotionConflictMsg ok details + +outputFileMultiInputVoidPrototypeConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputVoidPrototypeConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-decl.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + declPath = "tmp-decl.c" + defPath = "tmp-def.c" + expectedError = "conflicting external function declarations in multi-input -o mode: foo" + clean ["tmp.out", "tmp.err", target, declPath, defPath] + T.writeFile declPath $ T.unlines + [ "int foo(void);" + , "int main(void) { return 0; }" + ] + T.writeFile defPath "int foo(int x) { return x; }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack declPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputVoidPrototypeConflictMsg ok details + +outputFileMultiInputImplicitFunctionDefinitionTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputImplicitFunctionDefinitionTest = + flip finally (clean ["tmp.out", "tmp.s", "tmp-caller.c", "tmp-def.c", "tmp"]) $ do + htccCmd <- htccCommand + let callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + T.writeFile callerPath "int main(void) { return foo(1) != 1; }" + T.writeFile defPath "int foo(int x) { return x; }" + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s " + , T.pack callerPath + , " " + , T.pack defPath + , " > tmp.out" + ] + linkCmd <- assemblerCommand ["tmp.s", "-o", "tmp"] + execErrFin linkCmd + stdoutLeak <- T.readFile "tmp.out" + result <- exec "./tmp" + asm <- T.readFile "tmp.s" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , "main:" + ] + ok = T.null stdoutLeak && exitCode (const False) True result && hasRequiredLabels + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputImplicitFunctionDefinitionMsg ok details + +outputFileMultiInputDeferredIncompletePointeeUseTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputDeferredIncompletePointeeUseTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-use.c", "tmp-def.c", "tmp"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + usePath = "tmp-use.c" + defPath = "tmp-def.c" + expectedError = "conflicting external function declarations in multi-input -o mode: f" + T.writeFile usePath $ T.unlines + [ "int (*f(void))[];" + , "int *g(void) { return *(f() + 1); }" + , "int main(void) { return sizeof *f() != 16 || _Alignof *f() != 4 || g()[0] != 5; }" + ] + T.writeFile defPath $ T.unlines + [ "int a[8] = { 0, 0, 0, 0, 5 };" + , "int (*f(void))[4] { return &a; }" + ] + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack usePath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputDeferredIncompletePointeeUseMsg ok details + +outputFileMultiInputDeferredIncompletePointerAddSubAssignRejectTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputDeferredIncompletePointerAddSubAssignRejectTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-use.c", "tmp-decl.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + usePath = "tmp-use.c" + declPath = "tmp-decl.c" + expectedError = "invalid use of pointer to incomplete type" + T.writeFile usePath $ T.unlines + [ "int (*f(void))[];" + , "int main(void) { int (*p)[] = f(); p += 1; return 0; }" + ] + T.writeFile declPath "int (*f(void))[];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack usePath + , " " + , T.pack declPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputDeferredIncompletePointerAddSubAssignRejectMsg ok details + +outputFileMultiInputDeferredIncompletePointerIncDecRejectTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputDeferredIncompletePointerIncDecRejectTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-use.c", "tmp-decl.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + usePath = "tmp-use.c" + declPath = "tmp-decl.c" + expectedError = "invalid use of pointer to incomplete type" + T.writeFile usePath $ T.unlines + [ "int (*f(void))[];" + , "int main(void) { int (*p)[] = f(); ++p; return 0; }" + ] + T.writeFile declPath "int (*f(void))[];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack usePath + , " " + , T.pack declPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputDeferredIncompletePointerIncDecRejectMsg ok details + +outputFileMultiInputImplicitFunctionArityRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputImplicitFunctionArityRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + expectedError = "too few arguments to function call" + T.writeFile callerPath "int main(void) { return foo(); }" + T.writeFile defPath "int foo(int x) { return x; }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputImplicitFunctionArityRetypeMsg ok details + +outputFileMultiInputImplicitFunctionObjectPointerRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputImplicitFunctionObjectPointerRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + expectedError = "invalid argument type to function call" + T.writeFile callerPath "int main(void) { return foo(1); }" + T.writeFile defPath "int foo(int *p) { return p != 0; }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputImplicitFunctionObjectPointerRetypeMsg ok details + +outputFileMultiInputImplicitFunctionObjectPointerMismatchRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputImplicitFunctionObjectPointerMismatchRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + expectedError = "invalid argument type to function call" + T.writeFile callerPath $ T.unlines + [ "int main(void) {" + , " int *x = 0;" + , " int **pp = &x;" + , " return foo(pp);" + , "}" + ] + T.writeFile defPath "int foo(char **p) { return p != 0; }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputImplicitFunctionObjectPointerMismatchRetypeMsg ok details + +outputFileMultiInputIndirectFunctionPointerArityRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputIndirectFunctionPointerArityRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-decl.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + declPath = "tmp-decl.c" + expectedError = "too few arguments to function call" + T.writeFile callerPath $ T.unlines + [ "int (*fp)();" + , "int main(void) { return fp(); }" + ] + T.writeFile declPath "int (*fp)(int);" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack declPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputIndirectFunctionPointerArityRetypeMsg ok details + +outputFileMultiInputParameterSizeofRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputParameterSizeofRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-def.c", "tmp-proto.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + defPath = "tmp-def.c" + protoPath = "tmp-proto.c" + expectedError = "conflicting external function declarations in multi-input -o mode: f" + T.writeFile defPath $ T.unlines + [ "int f(int (*p)[]) { return sizeof(*p); }" + , "int main(void) { return 0; }" + ] + T.writeFile protoPath "int f(int (*p)[4]);" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack defPath + , " " + , T.pack protoPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputParameterSizeofRetypeMsg ok details + +outputFileMultiInputIndirectFunctionPointerVoidRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputIndirectFunctionPointerVoidRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-decl.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + declPath = "tmp-decl.c" + expectedError = "too many arguments to function call" + T.writeFile callerPath $ T.unlines + [ "int (*fp)();" + , "int main(void) { return fp(1); }" + ] + T.writeFile declPath "int (*fp)(void);" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack declPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputIndirectFunctionPointerVoidRetypeMsg ok details + +outputFileMultiInputImplicitFunctionVoidRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputImplicitFunctionVoidRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + expectedError = "too many arguments to function call" + T.writeFile callerPath "int main(void) { return foo(1); }" + T.writeFile defPath "int foo(void) { return 0; }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputImplicitFunctionVoidRetypeMsg ok details + +outputFileMultiInputFunctionDesignatorAssignmentRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputFunctionDesignatorAssignmentRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-proto.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + protoPath = "tmp-proto.c" + expectedError = "invalid operands to assignment" + T.writeFile callerPath $ T.unlines + [ "int foo();" + , "int main(void) {" + , " int (*p)(void);" + , " p = foo;" + , " return 0;" + , "}" + ] + T.writeFile protoPath "int foo(int);" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack protoPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputFunctionDesignatorAssignmentRetypeMsg ok details + +outputFileMultiInputFunctionDesignatorReturnRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputFunctionDesignatorReturnRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-proto.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + protoPath = "tmp-proto.c" + expectedError = "invalid return type" + T.writeFile callerPath $ T.unlines + [ "int foo();" + , "int (*g(void))(void) { return foo; }" + ] + T.writeFile protoPath "int foo(int);" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack protoPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputFunctionDesignatorReturnRetypeMsg ok details + +outputFileMultiInputObjectPointerReturnRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputObjectPointerReturnRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + expectedError = "invalid return type" + T.writeFile callerPath $ T.unlines + [ "int a[];" + , "int (*f(void))[3] { return &a; }" + , "int main(void) { return 0; }" + ] + T.writeFile defPath "int a[4];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputObjectPointerReturnRetypeMsg ok details + +outputFileMultiInputFunctionDesignatorInitializerRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputFunctionDesignatorInitializerRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-proto.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + protoPath = "tmp-proto.c" + expectedError = "invalid initializer for scalar object" + T.writeFile callerPath $ T.unlines + [ "int foo();" + , "int (*p)(void) = foo;" + , "int main(void) { return 0; }" + ] + T.writeFile protoPath "int foo(int);" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack protoPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputFunctionDesignatorInitializerRetypeMsg ok details + +outputFileMultiInputFunctionDesignatorInitializerParamRefinementRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputFunctionDesignatorInitializerParamRefinementRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-proto.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + protoPath = "tmp-proto.c" + expectedError = "conflicting external function declarations in multi-input -o mode: take" + T.writeFile callerPath $ T.unlines + [ "int take(int (*p)[]);" + , "int (*fp)(int (*arg)[]) = take;" + , "int main(void) { return 0; }" + ] + T.writeFile protoPath "int take(int (*p)[4]);" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack protoPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputFunctionDesignatorInitializerParamRefinementRetypeMsg ok details + +outputFileMultiInputObjectPointerAssignmentRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputObjectPointerAssignmentRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + expectedError = "invalid operands to assignment" + T.writeFile callerPath $ T.unlines + [ "int x[];" + , "int main(void) {" + , " int (*p)[5];" + , " p = &x;" + , " return 0;" + , "}" + ] + T.writeFile defPath "int x[4];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputObjectPointerAssignmentRetypeMsg ok details + +outputFileMultiInputObjectPointerInitializerRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputObjectPointerInitializerRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + expectedError = "invalid initializer for scalar object" + T.writeFile callerPath $ T.unlines + [ "int x[];" + , "int (*p)[5] = &x;" + , "int main(void) { return 0; }" + ] + T.writeFile defPath "int x[4];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputObjectPointerInitializerRetypeMsg ok details + +outputFileMultiInputPointerPointeeArrayConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputPointerPointeeArrayConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-decl.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + declPath = "tmp-decl.c" + defPath = "tmp-def.c" + expectedError = "conflicting external declarations in multi-input -o mode: p" + T.writeFile declPath $ T.unlines + [ "int (*p)[3];" + , "int main(void) { return 0; }" + ] + T.writeFile defPath "int (*p)[4];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack declPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputPointerPointeeArrayConflictMsg ok details + +outputFileMultiInputAggregateFunctionDesignatorInitializerTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputAggregateFunctionDesignatorInitializerTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-def.c", "tmp"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + defPath = "tmp-def.c" + T.writeFile callerPath $ T.unlines + [ "int foo(void);" + , "int (*fps[1])(void) = { foo };" + , "int main(void) { return fps[0](); }" + ] + T.writeFile defPath "int foo(void) { return 0; }" + execErrFin $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + linkCmd <- assemblerCommand ["tmp.s", "-o", "tmp"] + execErrFin linkCmd + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + asm <- T.readFile target + result <- exec "./tmp" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , "fps:" + , "main:" + ] + ok = T.null stdoutLeak && T.null stderrOut && exitCode (const False) True result && hasRequiredLabels + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputAggregateFunctionDesignatorInitializerMsg ok details + +outputFileMultiInputSameInputImplicitFunctionConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputSameInputImplicitFunctionConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-other.c", "tmp.o"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + otherPath = "tmp-other.c" + expectedError = "multiple external definitions in multi-input -o mode: foo" + T.writeFile callerPath $ T.unlines + [ "int foo;" + , "int main(void) { return foo(); }" + ] + T.writeFile otherPath "int helper(void) { return 0; }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack otherPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + let ok = failed && T.null stdoutLeak && not targetExists && hasExpectedError + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputSameInputImplicitFunctionConflictMsg ok details + +outputFileMultiInputSameInputFunctionDeclarationConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputSameInputFunctionDeclarationConflictTest = + flip finally (clean ["tmp-forward.out", "tmp-forward.err", "tmp-forward.s", "tmp-forward.c", "tmp-forward.o", "tmp-reverse.out", "tmp-reverse.err", "tmp-reverse.s", "tmp-reverse.c", "tmp-reverse.o", "tmp-other.c"]) $ do + htccCmd <- htccCommand + let otherPath = "tmp-other.c" + expectedError = "multiple external definitions in multi-input -o mode: foo" + runCase target declPath stdoutPath stderrPath objPath declarations = do + clean [target, declPath, stdoutPath, stderrPath, objPath] + T.writeFile declPath $ T.unlines declarations + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack declPath + , " " + , T.pack otherPath + , " > " + , T.pack stdoutPath + , " 2> " + , T.pack stderrPath + ] + stdoutLeak <- T.readFile stdoutPath + stderrOut <- T.readFile stderrPath + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + let ok = failed && T.null stdoutLeak && not targetExists && hasExpectedError + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + pure (ok, details) + T.writeFile otherPath "int helper(void) { return 0; }" + (forwardOk, forwardDetails) <- + runCase + "tmp-forward.s" + "tmp-forward.c" + "tmp-forward.out" + "tmp-forward.err" + "tmp-forward.o" + [ "int foo(void);" + , "int foo;" + , "int main(void) { return 0; }" + ] + (reverseOk, reverseDetails) <- + runCase + "tmp-reverse.s" + "tmp-reverse.c" + "tmp-reverse.out" + "tmp-reverse.err" + "tmp-reverse.o" + [ "int foo;" + , "int foo(void);" + , "int main(void) { return 0; }" + ] + let ok = forwardOk && reverseOk + details = T.unlines + [ "forward:" + , forwardDetails + , "reverse:" + , reverseDetails + ] + return $ mkResult outputFileMultiInputSameInputFunctionDeclarationConflictMsg ok details + +outputFileMultiInputSameInputStaticImplicitFunctionConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputSameInputStaticImplicitFunctionConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-caller.c", "tmp-other.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + callerPath = "tmp-caller.c" + otherPath = "tmp-other.c" + expectedError = "multiple external definitions in multi-input -o mode: foo" + T.writeFile callerPath $ T.unlines + [ "static int foo;" + , "int main(void) { return foo(); }" + ] + T.writeFile otherPath "int helper(void) { return 0; }" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack callerPath + , " " + , T.pack otherPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && not targetExists && hasExpectedError + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputSameInputStaticImplicitFunctionConflictMsg ok details + +outputFileMultiInputSameInputInternalLinkageConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputSameInputInternalLinkageConflictTest = + flip finally + (clean + [ "tmp-static-static.out" + , "tmp-static-static.err" + , "tmp-static-static.s" + , "tmp-static-static.c" + , "tmp-static-extern-forward.out" + , "tmp-static-extern-forward.err" + , "tmp-static-extern-forward.s" + , "tmp-static-extern-forward.c" + , "tmp-static-extern-reverse.out" + , "tmp-static-extern-reverse.err" + , "tmp-static-extern-reverse.s" + , "tmp-static-extern-reverse.c" + , "tmp-other.c" + ] + ) $ do + htccCmd <- htccCommand + let otherPath = "tmp-other.c" + expectedError = "multiple external definitions in multi-input -o mode: foo" + runCase target sourcePath stdoutPath stderrPath declarations = do + clean [target, sourcePath, stdoutPath, stderrPath] + T.writeFile sourcePath $ T.unlines declarations + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack sourcePath + , " " + , T.pack otherPath + , " > " + , T.pack stdoutPath + , " 2> " + , T.pack stderrPath + ] + stdoutLeak <- T.readFile stdoutPath + stderrOut <- T.readFile stderrPath + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && not targetExists && hasExpectedError + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + pure (ok, details) + T.writeFile otherPath "int helper(void) { return 0; }" + (staticStaticOk, staticStaticDetails) <- + runCase + "tmp-static-static.s" + "tmp-static-static.c" + "tmp-static-static.out" + "tmp-static-static.err" + [ "static int foo;" + , "static int foo(void) { return 1; }" + , "int main(void) { return 0; }" + ] + (staticExternForwardOk, staticExternForwardDetails) <- + runCase + "tmp-static-extern-forward.s" + "tmp-static-extern-forward.c" + "tmp-static-extern-forward.out" + "tmp-static-extern-forward.err" + [ "static int foo(void) { return 1; }" + , "int foo;" + , "int main(void) { return foo; }" + ] + (staticExternReverseOk, staticExternReverseDetails) <- + runCase + "tmp-static-extern-reverse.s" + "tmp-static-extern-reverse.c" + "tmp-static-extern-reverse.out" + "tmp-static-extern-reverse.err" + [ "int foo;" + , "static int foo(void) { return 1; }" + , "int main(void) { return foo; }" + ] + let ok = staticStaticOk && staticExternForwardOk && staticExternReverseOk + details = T.unlines + [ "static-static:" + , staticStaticDetails + , "static-extern-forward:" + , staticExternForwardDetails + , "static-extern-reverse:" + , staticExternReverseDetails + ] + return $ mkResult outputFileMultiInputSameInputInternalLinkageConflictMsg ok details + +outputFileMultiInputTentativeGlobalTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTentativeGlobalTest = + flip finally (clean ["tmp.out", "tmp.s", "tmp.o", "tmp-foo.c", "tmp-bar.c"]) $ do + htccCmd <- htccCommand + T.writeFile "tmp-foo.c" $ T.unlines + [ "int x;" + , "int* foo() { return &x; }" + ] + T.writeFile "tmp-bar.c" $ T.unlines + [ "int x;" + , "int bar() { x = 42; return x; }" + ] + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s tmp-foo.c tmp-bar.c > tmp.out" + ] + assemblerCommand ["-x", "assembler", "-c", "-o", "tmp.o", "tmp.s"] >>= execErrFin + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , "bar:" + ] + tentativeLabelCount = T.count "\nx:" $ "\n" <> asm + ok = T.null stdoutLeak && hasRequiredLabels && tentativeLabelCount == 1 + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "tentativeLabelCount: " <> T.pack (show tentativeLabelCount) + ] + return $ mkResult outputFileMultiInputTentativeGlobalMsg ok details + +outputFileMultiInputTentativeArrayTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTentativeArrayTest = + flip finally (clean ["tmp.out", "tmp.s", "tmp-decl.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let declPath = "tmp-decl.c" + defPath = "tmp-def.c" + T.writeFile declPath $ T.unlines + [ "int x[];" + , "int foo(void) { return 0; }" + ] + T.writeFile defPath $ T.unlines + [ "int x[4];" + , "int main() { return 0; }" + ] + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s " + , T.pack declPath + , " " + , T.pack defPath + , " > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , "main:" + ] + tentativeLabelCount = T.count "\nx:" $ "\n" <> asm + hasCompletedArraySize = "x:\n\t.zero 16" `T.isInfixOf` asm + ok = + T.null stdoutLeak + && hasRequiredLabels + && tentativeLabelCount == 1 + && hasCompletedArraySize + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "tentativeLabelCount: " <> T.pack (show tentativeLabelCount) + , "hasCompletedArraySize: " <> T.pack (show hasCompletedArraySize) + ] + return $ mkResult outputFileMultiInputTentativeArrayMsg ok details + +outputFileMultiInputTentativeArrayDecayRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTentativeArrayDecayRetypeTest = + flip finally (clean ["tmp.out", "tmp.s", "tmp-use.c", "tmp-def.c"]) $ do + htccCmd <- htccCommand + let usePath = "tmp-use.c" + defPath = "tmp-def.c" + fSection asm = snd $ T.breakOn "\nf:\n" ("\n" <> asm) + T.writeFile usePath $ T.unlines + [ "int x[];" + , "int *f(void) { return x; }" + ] + T.writeFile defPath "int x[2];" + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s " + , T.pack usePath + , " " + , T.pack defPath + , " > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + let functionAsm = fSection asm + hasRetypedDecay = + all (`T.isInfixOf` functionAsm) + [ "f:" + , "push offset x" + , "pop rax" + , "jmp .L.return.f" + ] + loadsScalarElement = "movsxd rax, dword ptr [rax]" `T.isInfixOf` functionAsm + ok = T.null stdoutLeak && hasRetypedDecay && not loadsScalarElement + details = T.unlines + [ "stdout:" + , stdoutLeak + , "functionAsm:" + , functionAsm + , "hasRetypedDecay: " <> T.pack (show hasRetypedDecay) + , "loadsScalarElement: " <> T.pack (show loadsScalarElement) + ] + return $ mkResult outputFileMultiInputTentativeArrayDecayRetypeMsg ok details + +externalBoolLowByteNormalizationTest :: IO (Int, String) +externalBoolLowByteNormalizationTest = + flip finally (clean ["tmp", "tmp.s", "tmp-bool-ext.o", "tmp-bool-ext.s", "tmp-bool-main.c"]) $ do + let description = "external _Bool calls normalize only the low byte of rax" + htccCmd <- htccCommand + T.writeFile "tmp-bool-main.c" $ T.unlines + [ "_Bool test_bool_low_byte_zero(void);" + , "int main(void) {" + , " _Bool (*fp)(void);" + , " fp = test_bool_low_byte_zero;" + , " return test_bool_low_byte_zero() != 0 || fp() != 0;" + , "}" + ] + T.writeFile "tmp-bool-ext.s" $ T.unlines + [ ".intel_syntax noprefix" + , ".global test_bool_low_byte_zero" + , "test_bool_low_byte_zero:" + , " mov rax, 256" + , " ret" + ] + execErrFin $ mconcat + [ htccCmd + , " tmp-bool-main.c > tmp.s" + ] + assemblerCommand ["-x", "assembler", "-c", "-o", "tmp-bool-ext.o", "tmp-bool-ext.s"] >>= execErrFin + assemblerCommand ["tmp-bool-ext.o", "tmp.s", "-o", "tmp"] >>= execErrFin + exitCode (\status -> (status, description)) (0, description) <$> exec "./tmp" + +externalBoolParameterLowByteNormalizationTest :: IO (Int, String) +externalBoolParameterLowByteNormalizationTest = + flip finally (clean ["tmp", "tmp.s", "tmp-bool-param-ext.o", "tmp-bool-param-ext.s", "tmp-bool-param-main.c"]) $ do + let description = "external callers normalize only the low byte of incoming _Bool parameters" + htccCmd <- htccCommand + T.writeFile "tmp-bool-param-main.c" $ T.unlines + [ "int takes_bool_reg(_Bool x) {" + , " return x;" + , "}" + , "int takes_bool_stack(long a, long b, long c, long d, long e, long f, _Bool g) {" + , " return g;" + , "}" + ] + T.writeFile "tmp-bool-param-ext.s" $ T.unlines + [ ".intel_syntax noprefix" + , ".global main" + , "main:" + , " push rbp" + , " mov rbp, rsp" + , " sub rsp, 16" + , " mov rdi, 256" + , " call takes_bool_reg" + , " mov [rbp-8], rax" + , " sub rsp, 8" + , " push 256" + , " mov r9, 6" + , " mov r8, 5" + , " mov rcx, 4" + , " mov rdx, 3" + , " mov rsi, 2" + , " mov rdi, 1" + , " call takes_bool_stack" + , " add rsp, 16" + , " mov rdx, [rbp-8]" + , " or rax, rdx" + , " leave" + , " ret" + ] + execErrFin $ mconcat + [ htccCmd + , " tmp-bool-param-main.c > tmp.s" + ] + assemblerCommand ["-x", "assembler", "-c", "-o", "tmp-bool-param-ext.o", "tmp-bool-param-ext.s"] >>= execErrFin + assemblerCommand ["tmp-bool-param-ext.o", "tmp.s", "-o", "tmp"] >>= execErrFin + exitCode (\status -> (status, description)) (0, description) <$> exec "./tmp" + +externalIntegralReturnNormalizationTest :: IO (Int, String) +externalIntegralReturnNormalizationTest = + flip finally (clean ["tmp", "tmp.s", "tmp-int-ret-ext.o", "tmp-int-ret-ext.s", "tmp-int-ret-main.c"]) $ do + let description = "external direct and indirect calls truncate signed char/short/int return values" + htccCmd <- htccCommand + T.writeFile "tmp-int-ret-main.c" $ T.unlines + [ "char ret_char(void);" + , "short ret_short(void);" + , "int ret_int(void);" + , "int main(void) {" + , " char (*char_fp)(void);" + , " short (*short_fp)(void);" + , " int (*int_fp)(void);" + , " char_fp = ret_char;" + , " short_fp = ret_short;" + , " int_fp = ret_int;" + , " return ret_char() != -1" + , " || char_fp() != -1" + , " || ret_short() != -1" + , " || short_fp() != -1" + , " || ret_int() != -1" + , " || int_fp() != -1;" + , "}" + ] + T.writeFile "tmp-int-ret-ext.s" $ T.unlines + [ ".intel_syntax noprefix" + , ".global ret_char" + , "ret_char:" + , " mov eax, 0x123456ff" + , " ret" + , ".global ret_short" + , "ret_short:" + , " mov eax, 0x1234ffff" + , " ret" + , ".global ret_int" + , "ret_int:" + , " mov eax, -1" + , " ret" + ] + execErrFin $ mconcat + [ htccCmd + , " tmp-int-ret-main.c > tmp.s" + ] + assemblerCommand ["-x", "assembler", "-c", "-o", "tmp-int-ret-ext.o", "tmp-int-ret-ext.s"] >>= execErrFin + assemblerCommand ["tmp-int-ret-ext.o", "tmp.s", "-o", "tmp"] >>= execErrFin + exitCode (\status -> (status, description)) (0, description) <$> exec "./tmp" + +outputFileMultiInputTentativeIncompleteArrayTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTentativeIncompleteArrayTest = + flip finally (clean ["tmp", "tmp.out", "tmp.s", "tmp-foo.c", "tmp-bar.c"]) $ do + htccCmd <- htccCommand + T.writeFile "tmp-foo.c" $ T.unlines + [ "int x[];" + , "int *foo(void) { return x; }" + ] + T.writeFile "tmp-bar.c" $ T.unlines + [ "int x[];" + , "int *foo(void);" + , "int main(void) { x[0] = 1; return foo() != x || x[0] != 1; }" + ] + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s tmp-foo.c tmp-bar.c > tmp.out" + ] + linkCmd <- assemblerCommand ["tmp.s", "-o", "tmp"] + execErrFin linkCmd + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + runResult <- exec "./tmp" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , "main:" + ] + tentativeLabelCount = T.count "\nx:" $ "\n" <> asm + hasMaterializedArraySize = "x:\n\t.zero 4" `T.isInfixOf` asm + exitStatus = exitCode id 0 runResult + ok = + T.null stdoutLeak + && hasRequiredLabels + && tentativeLabelCount == 1 + && hasMaterializedArraySize + && exitStatus == 0 + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "tentativeLabelCount: " <> T.pack (show tentativeLabelCount) + , "hasMaterializedArraySize: " <> T.pack (show hasMaterializedArraySize) + , "exitStatus: " <> T.pack (show exitStatus) + ] + return $ mkResult outputFileMultiInputTentativeIncompleteArrayMsg ok details + +outputFileMultiInputTentativeNestedIncompleteArrayTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTentativeNestedIncompleteArrayTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-use.c", "tmp-decl.c", "tmp"]) $ do + htccCmd <- htccCommand + let usePath = "tmp-use.c" + declPath = "tmp-decl.c" + target = "tmp.s" + expectedError = "invalid use of pointer to incomplete type" + T.writeFile usePath $ T.unlines + [ "int x[][4];" + , "int main(void) { return ((char*)(&x + 1)) - ((char*)&x); }" + ] + T.writeFile declPath "int x[][4];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack usePath + , " " + , T.pack declPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputTentativeNestedIncompleteArrayMsg ok details + +outputFileMultiInputTentativeNestedArrayExtentInferenceTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTentativeNestedArrayExtentInferenceTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-use.c", "tmp-def.c", "tmp"]) $ do + htccCmd <- htccCommand + let usePath = "tmp-use.c" + defPath = "tmp-def.c" + target = "tmp.s" + expectedError = "invalid use of pointer to incomplete type" + T.writeFile usePath $ T.unlines + [ "int x[][4];" + , "int main(void) { return ((char*)(&x + 1)) - ((char*)&x); }" + ] + T.writeFile defPath "int x[2][4];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack usePath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputTentativeNestedArrayExtentInferenceMsg ok details + +outputFileMultiInputTentativeArrayRankConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTentativeArrayRankConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-foo.c", "tmp-bar.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + fooPath = "tmp-foo.c" + barPath = "tmp-bar.c" + expectedError = "conflicting external declarations in multi-input -o mode: x" + T.writeFile fooPath $ T.unlines + [ "int x[];" + , "int foo(void) { return 0; }" + ] + T.writeFile barPath $ T.unlines + [ "int x[2][4];" + , "int main(void) { return 0; }" + ] + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack fooPath + , " " + , T.pack barPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputTentativeArrayRankConflictMsg ok details + +outputFileMultiInputTentativeArrayInnerExtentConflictTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTentativeArrayInnerExtentConflictTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-foo.c", "tmp-bar.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + fooPath = "tmp-foo.c" + barPath = "tmp-bar.c" + expectedError = "conflicting external declarations in multi-input -o mode: x" + T.writeFile fooPath $ T.unlines + [ "int x[][3];" + , "int foo(void) { return 0; }" + ] + T.writeFile barPath $ T.unlines + [ "int x[][4];" + , "int main(void) { return 0; }" + ] + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack fooPath + , " " + , T.pack barPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputTentativeArrayInnerExtentConflictMsg ok details + +outputFileMultiInputTentativeArrayUseSiteTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTentativeArrayUseSiteTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-use.c", "tmp-def.c", "tmp"]) $ do + htccCmd <- htccCommand + let usePath = "tmp-use.c" + defPath = "tmp-def.c" + target = "tmp.s" + expectedError = "invalid application of 'sizeof' to incomplete type" + T.writeFile usePath $ T.unlines + [ "int x[];" + , "int main(void) { return sizeof x / sizeof x[0]; }" + ] + T.writeFile defPath "int x[4];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack usePath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputTentativeArrayUseSiteMsg ok details + +outputFileMultiInputTentativeArrayAddressUseSiteTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTentativeArrayAddressUseSiteTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-use.c", "tmp-def.c", "tmp"]) $ do + htccCmd <- htccCommand + let usePath = "tmp-use.c" + defPath = "tmp-def.c" + target = "tmp.s" + expectedError = "invalid use of pointer to incomplete type" + T.writeFile usePath $ T.unlines + [ "int x[];" + , "int main(void) { return ((char*)(&x + 1)) - ((char*)&x); }" + ] + T.writeFile defPath "int x[4];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack usePath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputTentativeArrayAddressUseSiteMsg ok details + +outputFileMultiInputTentativeArrayInitializerRetypeTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputTentativeArrayInitializerRetypeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-use.c", "tmp-def.c", "tmp"]) $ do + htccCmd <- htccCommand + let usePath = "tmp-use.c" + defPath = "tmp-def.c" + target = "tmp.s" + expectedError = "invalid application of 'sizeof' to incomplete type" + T.writeFile usePath $ T.unlines + [ "int x[];" + , "int y = sizeof x;" + , "char *p = (char*)(&x + 1);" + , "int main(void) { return y == 4 && p == ((char*)&x) + 4; }" + ] + T.writeFile defPath "int x[4];" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack usePath + , " " + , T.pack defPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + hasNoPointerArithmeticError = not ("invalid use of pointer to incomplete type" `T.isInfixOf` stderrOut) + ok = failed && T.null stdoutLeak && hasExpectedError && hasNoPointerArithmeticError && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "hasNoPointerArithmeticError: " <> T.pack (show hasNoPointerArithmeticError) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileMultiInputTentativeArrayInitializerRetypeMsg ok details + +outputFileMultiInputStaticTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputStaticTest = flip finally (clean ["tmp.out", "tmp.s", "tmp.o", "tmp-foo.c", "tmp-bar.c"]) $ do + htccCmd <- htccCommand + T.writeFile "tmp-foo.c" $ T.unlines + [ "static int helper;" + , "int foo() { helper = 1; return helper; }" + ] + T.writeFile "tmp-bar.c" $ T.unlines + [ "static int helper;" + , "int bar() { helper = 2; return helper; }" + ] + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s tmp-foo.c tmp-bar.c > tmp.out" + ] + assemblerCommand ["-x", "assembler", "-c", "-o", "tmp.o", "tmp.s"] >>= execErrFin + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , ".L.return.foo:" + , "bar:" + , ".L.return.bar:" + ] + hasOriginalStaticLabel = "\nhelper:" `T.isInfixOf` asm + ok = T.null stdoutLeak && hasRequiredLabels && not hasOriginalStaticLabel + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "hasOriginalStaticLabel: " <> T.pack (show hasOriginalStaticLabel) + ] + return $ mkResult outputFileMultiInputStaticMsg ok details + +outputFileMultiInputStaticFunctionTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputStaticFunctionTest = flip finally (clean ["tmp.out", "tmp.s", "tmp.o", "tmp-foo.c", "tmp-bar.c"]) $ do + htccCmd <- htccCommand + T.writeFile "tmp-foo.c" $ T.unlines + [ "static int helper(void) { return 1; }" + , "int foo(void) { return helper(); }" + ] + T.writeFile "tmp-bar.c" $ T.unlines + [ "static int helper(void) { return 2; }" + , "int bar(void) { return helper(); }" + ] + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s tmp-foo.c tmp-bar.c > tmp.out" + ] + assemblerCommand ["-x", "assembler", "-c", "-o", "tmp.o", "tmp.s"] >>= execErrFin + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ "foo:" + , ".L.return.foo:" + , "bar:" + , ".L.return.bar:" + , ".L.internal.0.helper:" + , ".L.internal.1.helper:" + ] + hasOriginalHelperLabel = "\nhelper:" `T.isInfixOf` asm + ok = T.null stdoutLeak && hasRequiredLabels && not hasOriginalHelperLabel + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "hasOriginalHelperLabel: " <> T.pack (show hasOriginalHelperLabel) + ] + return $ mkResult outputFileMultiInputStaticFunctionMsg ok details + +outputFileMultiInputStaticFunctionPointerTest :: IO (Either T.Text T.Text, String) +outputFileMultiInputStaticFunctionPointerTest = + flip finally (clean ["tmp.out", "tmp.s", "tmp-foo.c", "tmp-bar.c", "tmp"]) $ do + htccCmd <- htccCommand + T.writeFile "tmp-foo.c" $ T.unlines + [ "static int helper(void) { return 1; }" + , "int foo(void) { int (*fp)(void); fp = helper; return helper != 0 && fp != 0; }" + ] + T.writeFile "tmp-bar.c" $ T.unlines + [ "int foo(void);" + , "static int helper(void) { return 2; }" + , "int bar(void) { int (*fp)(void); fp = helper; return helper != 0 && fp != 0; }" + , "int main(void) { return foo() + bar(); }" + ] + execErrFin $ mconcat + [ htccCmd + , " -o tmp.s tmp-foo.c tmp-bar.c > tmp.out" + ] + linkCmd <- assemblerCommand ["tmp.s", "-o", "tmp"] + execErrFin linkCmd + stdoutLeak <- T.readFile "tmp.out" + asm <- T.readFile "tmp.s" + let hasRequiredLabels = + all (`T.isInfixOf` asm) + [ ".L.internal.0.helper:" + , ".L.internal.1.helper:" + ] + runResult <- exec "./tmp" + let exitStatus = exitCode id 0 runResult + ok = T.null stdoutLeak && hasRequiredLabels && exitStatus == 2 + details = T.unlines + [ "stdout:" + , stdoutLeak + , "hasRequiredLabels: " <> T.pack (show hasRequiredLabels) + , "exitStatus: " <> T.pack (show exitStatus) + ] + return $ mkResult outputFileMultiInputStaticFunctionPointerMsg ok details + +outputFilePreservesExistingModeTest :: IO (Either T.Text T.Text, String) +outputFilePreservesExistingModeTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp-mode-input.c", "tmp-mode.s"]) $ do + htccCmd <- htccCommand + let target = "tmp-mode.s" + inputPath = "tmp-mode-input.c" + originalMode = foldr1 unionFileModes + [ ownerReadMode + , groupReadMode + , otherReadMode + ] + clean ["tmp.out", "tmp.err", inputPath, target] + T.writeFile inputPath source + T.writeFile target "stale output" + setFileMode target originalMode + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + asm <- T.readFile target + replacedMode <- fileMode <$> getFileStatus target + let replacedPermissions = permissionBits replacedMode + let succeeded = exitCode (const False) True result + hasAsm = all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".global main" + , ".L.return.main:" + ] + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && replacedPermissions == originalMode + && hasAsm + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "modePreserved: " <> T.pack (show (replacedPermissions == originalMode)) + , "replacedMode: " <> T.pack (show replacedMode) + , "replacedPermissions: " <> T.pack (show replacedPermissions) + , "hasAsm: " <> T.pack (show hasAsm) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFilePreservesExistingModeMsg ok details + +outputFileClearsSpecialBitsTest :: IO (Either T.Text T.Text, String) +outputFileClearsSpecialBitsTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp-special-input.c", "tmp-special.s"]) $ do + htccCmd <- htccCommand + let target = "tmp-special.s" + inputPath = "tmp-special-input.c" + originalMode = foldr1 unionFileModes + [ ownerReadMode + , ownerWriteMode + , groupReadMode + , otherReadMode + , specialFileModeMask + ] + clean ["tmp.out", "tmp.err", inputPath, target] + T.writeFile inputPath source + T.writeFile target "stale output" + setFileMode target originalMode + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + asm <- T.readFile target + replacedMode <- fileMode <$> getFileStatus target + let specialBitsCleared = intersectFileModes replacedMode specialFileModeMask == 0 + hasAsm = all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".global main" + , ".L.return.main:" + ] + succeeded = exitCode (const False) True result + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && specialBitsCleared + && hasAsm + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "specialBitsCleared: " <> T.pack (show specialBitsCleared) + , "replacedMode: " <> T.pack (show replacedMode) + , "hasAsm: " <> T.pack (show hasAsm) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileClearsSpecialBitsMsg ok details + +outputFileFollowsSymlinkTargetTest :: IO (Either T.Text T.Text, String) +outputFileFollowsSymlinkTargetTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp-link-output.s", "tmp-link-input.c", "tmp-link-target.s"]) $ do + htccCmd <- htccCommand + let target = "tmp-link-target.s" + linkPath = "tmp-link-output.s" + inputPath = "tmp-link-input.c" + clean ["tmp.out", "tmp.err", linkPath, inputPath, target] + T.writeFile inputPath source + T.writeFile target "stale output" + execErrFin $ "ln -s '" <> T.pack target <> "' '" <> T.pack linkPath <> "'" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack linkPath + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetContents <- T.readFile target + linkStatus <- getSymbolicLinkStatus linkPath + let succeeded = exitCode (const False) True result + linkStillSymlink = isSymbolicLink linkStatus + targetUpdated = all (`T.isInfixOf` targetContents) + [ ".intel_syntax noprefix" + , ".global main" + , ".L.return.main:" + ] + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && linkStillSymlink + && targetUpdated + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "linkStillSymlink: " <> T.pack (show linkStillSymlink) + , "targetUpdated: " <> T.pack (show targetUpdated) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileFollowsSymlinkTargetMsg ok details + +outputFileSpecialPathDevNullTest :: IO (Either T.Text T.Text, String) +outputFileSpecialPathDevNullTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp-devnull-input.c"]) $ do + htccCmd <- htccCommand + let inputPath = "tmp-devnull-input.c" + clean ["tmp.out", "tmp.err", inputPath] + T.writeFile inputPath source + result <- exec $ mconcat + [ htccCmd + , " -o /dev/null " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + let succeeded = exitCode (const False) True result + ok = succeeded && T.null stdoutLeak && T.null stderrOut + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileSpecialPathDevNullMsg ok details + +outputFileSamePathTest :: IO (Either T.Text T.Text, String) +outputFileSamePathTest = flip finally (clean ["tmp.out", "tmp.err", "tmp-same.c"]) $ do + htccCmd <- htccCommand + T.writeFile "tmp-same.c" source + result <- exec $ mconcat + [ htccCmd + , " -o tmp-same.c tmp-same.c > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + contents <- T.readFile "tmp-same.c" + let failed = exitCode (const True) False result + hasAliasError = "-o output path must not overwrite an input file" `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && contents == source && hasAliasError + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "inputUnchanged: " <> T.pack (show (contents == source)) + , "hasAliasError: " <> T.pack (show hasAliasError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileSamePathMsg ok details + +outputFileHardLinkAliasTest :: IO (Either T.Text T.Text, String) +outputFileHardLinkAliasTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp-source.c", "tmp-source-link.c"]) $ do + htccCmd <- htccCommand + T.writeFile "tmp-source.c" source + execErrFin "ln tmp-source.c tmp-source-link.c" + result <- exec $ mconcat + [ htccCmd + , " -o tmp-source-link.c tmp-source.c > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + inputContents <- T.readFile "tmp-source.c" + outputContents <- T.readFile "tmp-source-link.c" + let failed = exitCode (const True) False result + hasAliasError = "-o output path must not overwrite an input file" `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && inputContents == source + && outputContents == source + && hasAliasError + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "inputUnchanged: " <> T.pack (show (inputContents == source)) + , "outputUnchanged: " <> T.pack (show (outputContents == source)) + , "hasAliasError: " <> T.pack (show hasAliasError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileHardLinkAliasMsg ok details + +outputFileParseFailurePreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +outputFileParseFailurePreservesExistingOutputTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-parse-error.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + inputPath = "tmp-parse-error.c" + clean [target, inputPath, "tmp.out", "tmp.err"] + T.writeFile target "stale output" + T.writeFile inputPath parseFailureSource + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + inputContents <- T.readFile inputPath + targetExists <- doesFileExist target + targetContents <- if targetExists then T.readFile target else pure "" + let failed = exitCode (const True) False result + mentionsInput = T.pack inputPath `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && targetExists + && targetContents == "stale output" + && inputContents == parseFailureSource + && mentionsInput + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "targetUnchanged: " <> T.pack (show (targetContents == "stale output")) + , "inputUnchanged: " <> T.pack (show (inputContents == parseFailureSource)) + , "mentionsInput: " <> T.pack (show mentionsInput) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileParseFailurePreservesExistingOutputMsg ok details + +outputFileReadFailurePreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +outputFileReadFailurePreservesExistingOutputTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp.s", "tmp-missing.c"]) $ do + htccCmd <- htccCommand + let target = "tmp.s" + inputPath = "tmp-missing.c" + clean [target, inputPath, "tmp.out", "tmp.err"] + T.writeFile target "stale output" + result <- exec $ mconcat + [ htccCmd + , " -o " + , T.pack target + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + inputExists <- doesFileExist inputPath + targetExists <- doesFileExist target + targetContents <- if targetExists then T.readFile target else pure "" + let failed = exitCode (const True) False result + mentionsInput = T.pack inputPath `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && targetExists + && targetContents == "stale output" + && not inputExists + && mentionsInput + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "targetUnchanged: " <> T.pack (show (targetContents == "stale output")) + , "inputExists: " <> T.pack (show inputExists) + , "mentionsInput: " <> T.pack (show mentionsInput) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileReadFailurePreservesExistingOutputMsg ok details + +outputFileOpenFailurePreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +outputFileOpenFailurePreservesExistingOutputTest = + flip finally cleanupReadOnlyOutputDir $ do + htccCmd <- htccCommand + let targetDir = "tmp-read-only-dir" + target = targetDir "tmp-read-only.s" + clean [targetDir, "tmp.out", "tmp.err"] + createDirectoryIfMissing False targetDir + T.writeFile target "stale output" + execErrFin $ "chmod 555 '" <> T.pack targetDir <> "'" + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , htccCmd + , " -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + targetContents <- if targetExists then T.readFile target else pure "" + let failed = exitCode (const True) False result + hasPermissionError = "permission" `T.isInfixOf` T.toLower stderrOut + ok = + failed + && T.null stdoutLeak + && targetExists + && targetContents == "stale output" + && hasPermissionError + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "targetUnchanged: " <> T.pack (show (targetContents == "stale output")) + , "hasPermissionError: " <> T.pack (show hasPermissionError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileOpenFailurePreservesExistingOutputMsg ok details + where + cleanupReadOnlyOutputDir = do + let targetDir = "tmp-read-only-dir" + _ <- exec $ "chmod 755 '" <> T.pack targetDir <> "' > /dev/null 2>&1" + clean [targetDir, "tmp.out", "tmp.err"] + +outputFileHardLinkedRenameReplacementPreservesAliasTest :: IO (Either T.Text T.Text, String) +outputFileHardLinkedRenameReplacementPreservesAliasTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp-hard-link-output.s", "tmp-hard-link-output-link.s"]) $ do + htccCmd <- htccCommand + let target = "tmp-hard-link-output.s" + alias = "tmp-hard-link-output-link.s" + staleOutput = "stale output\n" + clean [target, alias, "tmp.out", "tmp.err"] + T.writeFile target staleOutput + execErrFin $ "ln '" <> T.pack target <> "' '" <> T.pack alias <> "'" + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , htccCmd + , " -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + aliasExists <- doesFileExist alias + targetContents <- if targetExists then T.readFile target else pure "" + aliasContents <- if aliasExists then T.readFile alias else pure "" + let succeeded = exitCode (const False) True result + targetUpdated = + targetContents /= staleOutput + && all (`T.isInfixOf` targetContents) + [ ".intel_syntax noprefix" + , ".global main" + , ".L.return.main:" + ] + aliasPreserved = aliasContents == staleOutput + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && targetExists + && aliasExists + && targetUpdated + && aliasPreserved + details = T.unlines + [ "target: " <> T.pack target + , "alias: " <> T.pack alias + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "aliasExists: " <> T.pack (show aliasExists) + , "targetUpdated: " <> T.pack (show targetUpdated) + , "aliasPreserved: " <> T.pack (show aliasPreserved) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileHardLinkedRenameReplacementPreservesAliasMsg ok details + +outputFileReadOnlyParentWritableTargetTest :: IO (Either T.Text T.Text, String) +outputFileReadOnlyParentWritableTargetTest = + flip finally cleanupReadOnlyOutputDir $ do + htccCmd <- htccCommand + let targetDir = "tmp-read-only-dir" + target = targetDir "tmp-read-only.s" + targetMode = foldr1 unionFileModes + [ ownerReadMode + , ownerWriteMode + , groupReadMode + , otherReadMode + ] + clean [targetDir, "tmp.out", "tmp.err"] + createDirectoryIfMissing False targetDir + T.writeFile target "stale output" + setFileMode target targetMode + execErrFin $ "chmod 555 '" <> T.pack targetDir <> "'" + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , htccCmd + , " -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + asm <- T.readFile target + let succeeded = exitCode (const False) True result + hasAsm = all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".global main" + , ".L.return.main:" + ] + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && hasAsm + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasAsm: " <> T.pack (show hasAsm) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileReadOnlyParentWritableTargetMsg ok details + where + cleanupReadOnlyOutputDir = do + let targetDir = "tmp-read-only-dir" + _ <- exec $ "chmod 755 '" <> T.pack targetDir <> "' > /dev/null 2>&1" + clean [targetDir, "tmp.out", "tmp.err"] + +outputFileReadOnlyParentWriteOnlyTargetTest :: IO (Either T.Text T.Text, String) +outputFileReadOnlyParentWriteOnlyTargetTest = + flip finally cleanupReadOnlyOutputDir $ do + htccCmd <- htccCommand + let targetDir = "tmp-read-only-dir" + target = targetDir "tmp-write-only.s" + targetMode = ownerWriteMode + clean [targetDir, "tmp.out", "tmp.err"] + createDirectoryIfMissing False targetDir + T.writeFile target "stale output" + setFileMode target targetMode + execErrFin $ "chmod 555 '" <> T.pack targetDir <> "'" + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , htccCmd + , " -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + replacedMode <- if targetExists then fileMode <$> getFileStatus target else pure 0 + execErrFin $ "chmod 755 '" <> T.pack targetDir <> "'" + when targetExists $ + setFileMode target $ targetMode `unionFileModes` ownerReadMode + asm <- if targetExists then T.readFile target else pure "" + let replacedPermissions = permissionBits replacedMode + let succeeded = exitCode (const False) True result + hasAsm = all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".global main" + , ".L.return.main:" + ] + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && targetExists + && replacedPermissions == targetMode + && hasAsm + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "replacedMode: " <> T.pack (show replacedMode) + , "replacedPermissions: " <> T.pack (show replacedPermissions) + , "hasAsm: " <> T.pack (show hasAsm) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileReadOnlyParentWriteOnlyTargetMsg ok details + where + cleanupReadOnlyOutputDir = do + let targetDir = "tmp-read-only-dir" + _ <- exec $ "chmod 755 '" <> T.pack targetDir <> "' > /dev/null 2>&1" + clean [targetDir, "tmp.out", "tmp.err"] + +outputFileReadOnlyParentHardLinkAliasPreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +outputFileReadOnlyParentHardLinkAliasPreservesExistingOutputTest = + flip finally cleanupReadOnlyOutputDir $ do + htccCmd <- htccCommand + let targetDir = "tmp-read-only-dir" + target = targetDir "tmp-read-only.s" + alias = targetDir "tmp-read-only-link.s" + expectedError = "hard-linked output" + staleOutput = "stale output" + clean [targetDir, "tmp.out", "tmp.err"] + createDirectoryIfMissing False targetDir + T.writeFile target staleOutput + execErrFin $ "ln '" <> T.pack target <> "' '" <> T.pack alias <> "'" + execErrFin $ "chmod 555 '" <> T.pack targetDir <> "'" + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , htccCmd + , " -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + aliasExists <- doesFileExist alias + execErrFin $ "chmod 755 '" <> T.pack targetDir <> "'" + targetContents <- if targetExists then T.readFile target else pure "" + aliasContents <- if aliasExists then T.readFile alias else pure "" + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + preservedTarget = targetContents == staleOutput + preservedAlias = aliasContents == staleOutput + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && targetExists + && aliasExists + && preservedTarget + && preservedAlias + details = T.unlines + [ "target: " <> T.pack target + , "alias: " <> T.pack alias + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "aliasExists: " <> T.pack (show aliasExists) + , "preservedTarget: " <> T.pack (show preservedTarget) + , "preservedAlias: " <> T.pack (show preservedAlias) + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileReadOnlyParentHardLinkAliasPreservesExistingOutputMsg ok details + where + cleanupReadOnlyOutputDir = do + let targetDir = "tmp-read-only-dir" + _ <- exec $ "chmod 755 '" <> T.pack targetDir <> "' > /dev/null 2>&1" + clean [targetDir, "tmp.out", "tmp.err"] + +outputFileReadOnlyParentWriteFailurePreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +outputFileReadOnlyParentWriteFailurePreservesExistingOutputTest = + flip finally cleanupReadOnlyOutputDir $ do + htccCmd <- htccCommand + let targetDir = "tmp-read-only-dir" + target = targetDir "tmp-read-only.s" + inputPath = "tmp-large.c" + targetMode = foldr1 unionFileModes + [ ownerReadMode + , ownerWriteMode + , groupReadMode + , otherReadMode + ] + clean [targetDir, inputPath, "tmp.out", "tmp.err"] + createDirectoryIfMissing False targetDir + T.writeFile target "stale output" + setFileMode target targetMode + T.writeFile inputPath writeFailureSource + execErrFin $ "chmod 555 '" <> T.pack targetDir <> "'" + result <- exec $ mconcat + [ "sh -c \"ulimit -f 1; " + , htccCmd + , " -o " + , T.pack target + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err\"" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + targetContents <- if targetExists then T.readFile target else pure "" + let failed = exitCode (const True) False result + ok = + failed + && T.null stdoutLeak + && targetExists + && targetContents == "stale output" + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "targetUnchanged: " <> T.pack (show (targetContents == "stale output")) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileReadOnlyParentWriteFailurePreservesExistingOutputMsg ok details + where + cleanupReadOnlyOutputDir = do + let targetDir = "tmp-read-only-dir" + _ <- exec $ "chmod 755 '" <> T.pack targetDir <> "' > /dev/null 2>&1" + clean [targetDir, "tmp-large.c", "tmp.out", "tmp.err"] + +outputFileWriteFailurePreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +outputFileWriteFailurePreservesExistingOutputTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp-limit.s", "tmp-large.c"]) $ do + htccCmd <- htccCommand + let target = "tmp-limit.s" + inputPath = "tmp-large.c" + clean [target, inputPath, "tmp.out", "tmp.err"] + T.writeFile target "stale output" + T.writeFile inputPath writeFailureSource + result <- exec $ mconcat + [ "sh -c \"ulimit -f 1; " + , htccCmd + , " -o " + , T.pack target + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err\"" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + targetContents <- if targetExists then T.readFile target else pure "" + let failed = exitCode (const True) False result + ok = + failed + && T.null stdoutLeak + && targetExists + && targetContents == "stale output" + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "targetUnchanged: " <> T.pack (show (targetContents == "stale output")) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileWriteFailurePreservesExistingOutputMsg ok details + +outputFileFreshOutputRestrictiveUmaskTest :: IO (Either T.Text T.Text, String) +outputFileFreshOutputRestrictiveUmaskTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp-umask-input.c", "tmp-umask.s"]) $ do + htccCmd <- htccCommand + let target = "tmp-umask.s" + inputPath = "tmp-umask-input.c" + expectedMode = foldr1 unionFileModes + [ ownerReadMode + , groupReadMode + , otherReadMode + ] + clean [target, inputPath, "tmp.out", "tmp.err"] + T.writeFile inputPath source + result <- exec $ mconcat + [ "sh -c \"umask 0222; " + , htccCmd + , " -o " + , T.pack target + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err\"" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + asm <- if targetExists then T.readFile target else pure "" + replacedMode <- if targetExists then fileMode <$> getFileStatus target else pure 0 + let replacedPermissions = permissionBits replacedMode + let succeeded = exitCode (const False) True result + hasAsm = all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".global main" + , ".L.return.main:" + ] + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && targetExists + && replacedPermissions == expectedMode + && hasAsm + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "replacedMode: " <> T.pack (show replacedMode) + , "replacedPermissions: " <> T.pack (show replacedPermissions) + , "expectedMode: " <> T.pack (show expectedMode) + , "hasAsm: " <> T.pack (show hasAsm) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult outputFileFreshOutputRestrictiveUmaskMsg ok details + +runAsmTest :: IO (Either T.Text T.Text, String) +runAsmTest = flip finally (clean ["tmp", "tmp.out", fakeAssemblerPath, fakeAssemblerLogPath, fakeAssemblerAsmPath]) $ do + htccCmd <- htccCommand + writeFakeAssembler fakeAssemblerPath + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./tmp-assembler.sh " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + compilerArgs <- T.lines <$> T.readFile fakeAssemblerLogPath + asm <- T.readFile fakeAssemblerAsmPath + result <- exec "./tmp" + let compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ "-x" + , "assembler" + , "-c" + , "-o" + ] + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ranOk = exitCode (const False) True result + ok = T.null stdoutLeak && compilerSawExpectedArgs && hasRequiredAsm && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "compilerArgs:" + , T.unlines compilerArgs + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmMsg ok details + +runAsmSingleInputImplicitFunctionConflictTest :: IO (Either T.Text T.Text, String) +runAsmSingleInputImplicitFunctionConflictTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", "tmp-single.c", fakeAssemblerPath, fakeAssemblerLogPath, fakeAssemblerAsmPath]) $ do + htccCmd <- htccCommand + let target = "tmp" + inputPath = "tmp-single.c" + expectedError = "multiple external definitions in multi-input -o mode: foo" + writeFakeAssembler fakeAssemblerPath + T.writeFile inputPath $ T.unlines + [ "int foo;" + , "int main(void) { return foo(); }" + ] + result <- exec $ mconcat + [ "HTCC_ASSEMBLER=./tmp-assembler.sh " + , htccCmd + , " -r -o " + , T.pack target + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + driverLogExists <- doesFileExist fakeAssemblerLogPath + driverInvocations <- if driverLogExists then T.lines <$> T.readFile fakeAssemblerLogPath else pure [] + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && hasExpectedError && not targetExists && null driverInvocations + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "driverInvocations:" + , T.unlines driverInvocations + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmSingleInputImplicitFunctionConflictMsg ok details + +runAsmSpecialPathDevNullTest :: IO (Either T.Text T.Text, String) +runAsmSpecialPathDevNullTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp-devnull-run.c", fakeDriverPath]) $ do + htccCmd <- htccCommand + let inputPath = "tmp-devnull-run.c" + clean ["tmp.out", "tmp.err", inputPath, fakeDriverPath] + writeSpecialOutputDriver fakeDriverPath + T.writeFile inputPath source + result <- exec $ mconcat + [ "HTCC_ASSEMBLER=./" + , T.pack fakeDriverPath + , " " + , htccCmd + , " -r -o /dev/null " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + let succeeded = exitCode (const False) True result + ok = succeeded && T.null stdoutLeak && T.null stderrOut + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmSpecialPathDevNullMsg ok details + +runAsmPreservesExecutableBitsTest :: IO (Either T.Text T.Text, String) +runAsmPreservesExecutableBitsTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath, fakeAssemblerAsmPath]) $ do + htccCmd <- htccCommand + let target = "tmp" + originalMode = foldr1 unionFileModes + [ ownerReadMode + , ownerWriteMode + , groupReadMode + , otherReadMode + ] + executeModeMask = foldr1 unionFileModes + [ ownerExecuteMode + , groupExecuteMode + , otherExecuteMode + ] + expectedMode = originalMode `unionFileModes` ownerExecuteMode + writeFakeAssembler fakeAssemblerPath + T.writeFile target "stale output" + setFileMode target originalMode + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./tmp-assembler.sh " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + replacedMode <- fileMode <$> getFileStatus target + let replacedPermissions = permissionBits replacedMode + setFileMode target $ replacedMode `unionFileModes` ownerReadMode `unionFileModes` ownerExecuteMode + programResult <- exec "./tmp" + let replacedExecuteMode = intersectFileModes replacedMode executeModeMask + ranOk = exitCode (const False) True programResult + succeeded = exitCode (const False) True result + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && replacedPermissions == expectedMode + && replacedExecuteMode == ownerExecuteMode + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "replacedMode: " <> T.pack (show replacedMode) + , "replacedPermissions: " <> T.pack (show replacedPermissions) + , "replacedExecuteMode: " <> T.pack (show replacedExecuteMode) + , "expectedMode: " <> T.pack (show expectedMode) + , "compileExitCode: " <> T.pack (show result) + , "runExitCode: " <> T.pack (show programResult) + ] + return $ mkResult runAsmPreservesExecutableBitsMsg ok details + +runAsmPreservesExistingExecuteMaskTest :: IO (Either T.Text T.Text, String) +runAsmPreservesExistingExecuteMaskTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath, fakeAssemblerAsmPath]) $ do + htccCmd <- htccCommand + let target = "tmp" + originalMode = foldr1 unionFileModes + [ ownerReadMode + , ownerWriteMode + , ownerExecuteMode + ] + executeModeMask = foldr1 unionFileModes + [ ownerExecuteMode + , groupExecuteMode + , otherExecuteMode + ] + writeFakeAssembler fakeAssemblerPath + T.writeFile target "stale output" + setFileMode target originalMode + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./tmp-assembler.sh " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + replacedMode <- fileMode <$> getFileStatus target + let replacedPermissions = permissionBits replacedMode + setFileMode target $ replacedMode `unionFileModes` ownerReadMode `unionFileModes` ownerExecuteMode + programResult <- exec "./tmp" + let replacedExecuteMode = intersectFileModes replacedMode executeModeMask + succeeded = exitCode (const False) True result + ranOk = exitCode (const False) True programResult + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && replacedPermissions == originalMode + && replacedExecuteMode == ownerExecuteMode + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "replacedMode: " <> T.pack (show replacedMode) + , "replacedPermissions: " <> T.pack (show replacedPermissions) + , "replacedExecuteMode: " <> T.pack (show replacedExecuteMode) + , "compileExitCode: " <> T.pack (show result) + , "runExitCode: " <> T.pack (show programResult) + ] + return $ mkResult runAsmPreservesExistingExecuteMaskMsg ok details + +runAsmRestoresOwnerExecuteBitTest :: IO (Either T.Text T.Text, String) +runAsmRestoresOwnerExecuteBitTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath, fakeAssemblerAsmPath]) $ do + htccCmd <- htccCommand + let target = "tmp" + originalMode = foldr1 unionFileModes + [ groupReadMode + , groupExecuteMode + , otherReadMode + , otherExecuteMode + ] + executeModeMask = foldr1 unionFileModes + [ ownerExecuteMode + , groupExecuteMode + , otherExecuteMode + ] + expectedMode = originalMode `unionFileModes` ownerExecuteMode + expectedExecuteMode = executeModeMask + writeFakeAssembler fakeAssemblerPath + T.writeFile target "stale output" + setFileMode target originalMode + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./tmp-assembler.sh " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + replacedMode <- fileMode <$> getFileStatus target + let replacedPermissions = permissionBits replacedMode + setFileMode target $ replacedMode `unionFileModes` ownerReadMode `unionFileModes` ownerExecuteMode + programResult <- exec "./tmp" + let replacedExecuteMode = intersectFileModes replacedMode executeModeMask + succeeded = exitCode (const False) True result + ranOk = exitCode (const False) True programResult + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && replacedPermissions == expectedMode + && replacedExecuteMode == expectedExecuteMode + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "replacedMode: " <> T.pack (show replacedMode) + , "replacedPermissions: " <> T.pack (show replacedPermissions) + , "replacedExecuteMode: " <> T.pack (show replacedExecuteMode) + , "expectedMode: " <> T.pack (show expectedMode) + , "expectedExecuteMode: " <> T.pack (show expectedExecuteMode) + , "compileExitCode: " <> T.pack (show result) + , "runExitCode: " <> T.pack (show programResult) + ] + return $ mkResult runAsmRestoresOwnerExecuteBitMsg ok details + +runAsmFreshOutputInPlaceLinkDriverTest :: IO (Either T.Text T.Text, String) +runAsmFreshOutputInPlaceLinkDriverTest = + flip finally (clean ["tmp-in-place-bin", "tmp.out", "tmp.err", fakeInPlaceLinkDriverPath, fakeInPlaceLinkDriverLogPath]) $ do + htccCmd <- htccCommand + let target = "tmp-in-place-bin" + executeModeMask = foldr1 unionFileModes + [ ownerExecuteMode + , groupExecuteMode + , otherExecuteMode + ] + writeInPlaceLinkDriver fakeInPlaceLinkDriverPath fakeInPlaceLinkDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeInPlaceLinkDriverPath + , " " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + replacedMode <- if targetExists then fileMode <$> getFileStatus target else pure 0 + driverInvocations <- T.lines <$> T.readFile fakeInPlaceLinkDriverLogPath + programResult <- if targetExists then Just <$> exec (T.pack $ "./" <> target) else pure Nothing + let hasExecuteBits = intersectFileModes replacedMode executeModeMask /= 0 + sawLinkProbe = any ("-no-pie -o" `T.isInfixOf`) driverInvocations + succeeded = exitCode (const False) True result + ranOk = maybe False (exitCode (const False) True) programResult + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && targetExists + && hasExecuteBits + && sawLinkProbe + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "targetExists: " <> T.pack (show targetExists) + , "hasExecuteBits: " <> T.pack (show hasExecuteBits) + , "replacedMode: " <> T.pack (show replacedMode) + , "sawLinkProbe: " <> T.pack (show sawLinkProbe) + , "compileExitCode: " <> T.pack (show result) + , "runExitCode: " <> maybe "not-run" (T.pack . show) programResult + ] + return $ mkResult runAsmFreshOutputInPlaceLinkDriverMsg ok details + +runAsmProbePreservesPrecreatedOutputTest :: IO (Either T.Text T.Text, String) +runAsmProbePreservesPrecreatedOutputTest = + flip finally (clean ["tmp-probe-bin", "tmp.out", "tmp.err", fakeProbePrecreatedOutputDriverPath, fakeProbePrecreatedOutputDriverLogPath]) $ do + htccCmd <- htccCommand + let target = "tmp-probe-bin" + writeProbePrecreatedOutputDriver fakeProbePrecreatedOutputDriverPath fakeProbePrecreatedOutputDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeProbePrecreatedOutputDriverPath + , " " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + driverInvocations <- T.lines <$> T.readFile fakeProbePrecreatedOutputDriverLogPath + programResult <- if targetExists then Just <$> exec (T.pack $ "./" <> target) else pure Nothing + let sawLinkProbe = any ("-no-pie -o" `T.isInfixOf`) driverInvocations + succeeded = exitCode (const False) True result + ranOk = maybe False (exitCode (const False) True) programResult + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && targetExists + && sawLinkProbe + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "targetExists: " <> T.pack (show targetExists) + , "sawLinkProbe: " <> T.pack (show sawLinkProbe) + , "compileExitCode: " <> T.pack (show result) + , "runExitCode: " <> maybe "not-run" (T.pack . show) programResult + ] + return $ mkResult runAsmProbePreservesPrecreatedOutputMsg ok details + +runAsmClearsSpecialBitsTest :: IO (Either T.Text T.Text, String) +runAsmClearsSpecialBitsTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath, fakeAssemblerAsmPath]) $ do + htccCmd <- htccCommand + let target = "tmp" + originalMode = foldr1 unionFileModes + [ ownerReadMode + , ownerWriteMode + , groupReadMode + , otherReadMode + , specialFileModeMask + ] + writeFakeAssembler fakeAssemblerPath + T.writeFile target "stale output" + setFileMode target originalMode + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./tmp-assembler.sh " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + replacedMode <- fileMode <$> getFileStatus target + programResult <- exec "./tmp" + let specialBitsCleared = intersectFileModes replacedMode specialFileModeMask == 0 + succeeded = exitCode (const False) True result + ranOk = exitCode (const False) True programResult + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && specialBitsCleared + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "specialBitsCleared: " <> T.pack (show specialBitsCleared) + , "replacedMode: " <> T.pack (show replacedMode) + , "compileExitCode: " <> T.pack (show result) + , "runExitCode: " <> T.pack (show programResult) + ] + return $ mkResult runAsmClearsSpecialBitsMsg ok details + +runAsmLinkUsesResolvedDriverTest :: IO (Either T.Text T.Text, String) +runAsmLinkUsesResolvedDriverTest = + flip finally (clean ["tmp", "tmp.out", fakeDriverPath, fakeDriverLogPath]) $ do + htccCmd <- htccCommand + writeLoggingDriver fakeDriverPath fakeDriverLogPath + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + driverInvocations <- T.lines <$> T.readFile fakeDriverLogPath + result <- exec "./tmp" + let sawAssembleInvocation = + any + (\line -> "assemble:" `T.isPrefixOf` line && "-x assembler -c" `T.isInfixOf` line) + driverInvocations + sawLinkInvocation = + any + (\line -> "link:" `T.isPrefixOf` line && "-no-pie -o " `T.isInfixOf` line) + driverInvocations + ranOk = exitCode (const False) True result + ok = T.null stdoutLeak && sawAssembleInvocation && sawLinkInvocation && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "driverInvocations:" + , T.unlines driverInvocations + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmLinkUsesResolvedDriverMsg ok details + +runAsmBareLocalAssemblerPathTest :: IO (Either T.Text T.Text, String) +runAsmBareLocalAssemblerPathTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , fakeAssemblerPath + , fakeAssemblerAsmPath + , fakePathBinDir + , fakePathAssemblerLogPath + , fakeLocalAssemblerLogPath + ] + ) $ do + htccCmd <- htccCommand + createDirectoryIfMissing False fakePathBinDir + writeFakeAssemblerWithLogs fakePathAssemblerLogPath fakeAssemblerAsmPath fakePathAssemblerPath + writeFailingCompiler fakeAssemblerPath fakeLocalAssemblerLogPath + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , "PATH=./" + , T.pack fakePathBinDir + , ":$PATH " + , "HTCC_ASSEMBLER=tmp-assembler.sh " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + compilerArgs <- T.lines <$> T.readFile fakePathAssemblerLogPath + asm <- T.readFile fakeAssemblerAsmPath + localAssemblerWasInvoked <- doesFileExist fakeLocalAssemblerLogPath + result <- exec "./tmp" + let compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ "-x" + , "assembler" + , "-c" + , "-o" + ] + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ranOk = exitCode (const False) True result + ok = T.null stdoutLeak && compilerSawExpectedArgs && hasRequiredAsm && ranOk && not localAssemblerWasInvoked + details = T.unlines + [ "stdout:" + , stdoutLeak + , "compilerArgs:" + , T.unlines compilerArgs + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "localAssemblerWasInvoked: " <> T.pack (show localAssemblerWasInvoked) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmBareLocalAssemblerPathMsg ok details + +runAsmQuotedCompilerTest :: IO (Either T.Text T.Text, String) +runAsmQuotedCompilerTest = flip finally (clean ["tmp", "tmp.out", fakeAssemblerQuotedPath, fakeAssemblerLogPath, fakeAssemblerAsmPath]) $ do + htccCmd <- htccCommand + writeFakeAssembler fakeAssemblerQuotedPath + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER='./" + , T.pack fakeAssemblerQuotedPath + , "' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + compilerArgs <- T.lines <$> T.readFile fakeAssemblerLogPath + asm <- T.readFile fakeAssemblerAsmPath + result <- exec "./tmp" + let compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ "-x" + , "assembler" + , "-c" + , "-o" + ] + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ranOk = exitCode (const False) True result + ok = T.null stdoutLeak && compilerSawExpectedArgs && hasRequiredAsm && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "compilerArgs:" + , T.unlines compilerArgs + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmQuotedCompilerMsg ok details + +runAsmWrappedAssemblerTest :: IO (Either T.Text T.Text, String) +runAsmWrappedAssemblerTest = flip finally (clean ["tmp", "tmp.out", fakeAssemblerPath, fakeAssemblerLogPath, fakeAssemblerAsmPath]) $ do + htccCmd <- htccCommand + writeFakeAssembler fakeAssemblerPath + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER='./tmp-assembler.sh " + , fakeAssemblerWrapperArg + , "' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + compilerArgs <- T.lines <$> T.readFile fakeAssemblerLogPath + asm <- T.readFile fakeAssemblerAsmPath + result <- exec "./tmp" + let compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ fakeAssemblerWrapperArg + , "-x" + , "assembler" + , "-c" + , "-o" + ] + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ranOk = exitCode (const False) True result + ok = T.null stdoutLeak && compilerSawExpectedArgs && hasRequiredAsm && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "compilerArgs:" + , T.unlines compilerArgs + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmWrappedAssemblerMsg ok details + +runAsmWrappedAssemblerFirstWordDriverTest :: IO (Either T.Text T.Text, String) +runAsmWrappedAssemblerFirstWordDriverTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , "tmp.err" + , fakeAssemblerPath + , fakeDriverPath + , fakeDriverLogPath + , fakeCombinedDriverPath + , fakeCombinedDriverLogPath + ] + ) $ do + htccCmd <- htccCommand + writeForwardingDriverWrapper fakeAssemblerPath + writeLoggingDriver fakeDriverPath fakeDriverLogPath + writeFailingCompiler fakeCombinedDriverPath fakeCombinedDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "PATH=.:$PATH " + , "HTCC_ASSEMBLER='" + , T.pack fakeAssemblerPath + , " " + , T.pack fakeDriverPath + , "' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + driverInvocations <- do + logExists <- doesFileExist fakeDriverLogPath + if logExists + then T.lines <$> T.readFile fakeDriverLogPath + else pure [] + combinedDriverWasInvoked <- doesFileExist fakeCombinedDriverLogPath + outputExists <- doesFileExist "tmp" + ranOk <- if outputExists + then exitCode (const False) True <$> exec "./tmp" + else pure False + let sawAssembleInvocation = any ("assemble:" `T.isPrefixOf`) driverInvocations + sawLinkInvocation = any ("link:" `T.isPrefixOf`) driverInvocations + ok = + exitCode (const False) True result + && T.null stdoutLeak + && T.null stderrOut + && sawAssembleInvocation + && sawLinkInvocation + && not combinedDriverWasInvoked + && outputExists + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "combinedDriverWasInvoked: " <> T.pack (show combinedDriverWasInvoked) + , "outputExists: " <> T.pack (show outputExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmWrappedAssemblerFirstWordDriverMsg ok details + +runAsmWrappedAssemblerProbeFallbackTest :: IO (Either T.Text T.Text, String) +runAsmWrappedAssemblerProbeFallbackTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , fakeAssemblerPath + , fakeAssemblerLogPath + , fakeAssemblerAsmPath + , fakeProbeWrapperPath + , fakeProbeWrapperLogPath + ] + ) $ do + htccCmd <- htccCommand + writeFakeAssembler fakeAssemblerPath + writeProbeRejectingWrapper fakeProbeWrapperPath fakeProbeWrapperLogPath fakeAssemblerPath + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER='./" + , T.pack fakeProbeWrapperPath + , " " + , fakeAssemblerWrapperArg + , "' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + wrapperInvocations <- T.lines <$> T.readFile fakeProbeWrapperLogPath + compilerArgs <- T.lines <$> T.readFile fakeAssemblerLogPath + asm <- T.readFile fakeAssemblerAsmPath + result <- exec "./tmp" + let sawProbeAttempt = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + wrapperInvocations + compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ fakeAssemblerWrapperArg + , "-x" + , "assembler" + , "-c" + , "-o" + ] + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ranOk = exitCode (const False) True result + ok = + T.null stdoutLeak + && sawProbeAttempt + && compilerSawExpectedArgs + && hasRequiredAsm + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "wrapperInvocations:" + , T.unlines wrapperInvocations + , "compilerArgs:" + , T.unlines compilerArgs + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmWrappedAssemblerProbeFallbackMsg ok details + +runAsmWrappedAssemblerHostMetadataFallbackTest :: IO (Either T.Text T.Text, String) +runAsmWrappedAssemblerHostMetadataFallbackTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , "tmp.err" + , fakeAssemblerPath + , fakeAssemblerLogPath + , fakeAssemblerAsmPath + , fakeHostMetadataWrapperPath + , fakeHostMetadataWrapperLogPath + ] + ) $ do + htccCmd <- htccCommand + writeFakeAssembler fakeAssemblerPath + writeHostMetadataWrapper fakeHostMetadataWrapperPath fakeHostMetadataWrapperLogPath fakeAssemblerPath + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER='./" + , T.pack fakeHostMetadataWrapperPath + , "' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + wrapperInvocations <- T.lines <$> T.readFile fakeHostMetadataWrapperLogPath + compilerArgs <- T.lines <$> T.readFile fakeAssemblerLogPath + asm <- T.readFile fakeAssemblerAsmPath + result <- exec "./tmp" + let sawHostMetadataProbe = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + wrapperInvocations + compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ "-x" + , "assembler" + , "-c" + , "-o" + ] + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ranOk = exitCode (const False) True result + ok = + T.null stdoutLeak + && T.null stderrOut + && sawHostMetadataProbe + && compilerSawExpectedArgs + && hasRequiredAsm + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "wrapperInvocations:" + , T.unlines wrapperInvocations + , "compilerArgs:" + , T.unlines compilerArgs + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "runExitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmWrappedAssemblerHostMetadataFallbackMsg ok details + +runAsmLeadingEnvAssignmentTest :: IO (Either T.Text T.Text, String) +runAsmLeadingEnvAssignmentTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , fakeAssemblerPath + , fakeAssemblerAsmPath + , fakePathBinDir + , fakePathAssemblerLogPath + , fakeLocalAssemblerLogPath + ] + ) $ do + htccCmd <- htccCommand + createDirectoryIfMissing False fakePathBinDir + writeFakeAssemblerWithLogs fakePathAssemblerLogPath fakeAssemblerAsmPath fakePathAssemblerPath + writeFailingCompiler fakeAssemblerPath fakeLocalAssemblerLogPath + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , "PATH=.:$PATH " + , "HTCC_ASSEMBLER='PATH=./" + , T.pack fakePathBinDir + , " tmp-assembler.sh' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + compilerArgs <- T.lines <$> T.readFile fakePathAssemblerLogPath + asm <- T.readFile fakeAssemblerAsmPath + localAssemblerWasInvoked <- doesFileExist fakeLocalAssemblerLogPath + result <- exec "./tmp" + let compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ "-x" + , "assembler" + , "-c" + , "-o" + ] + envAssignmentPassedAsArg = + any ("PATH=./" `T.isPrefixOf`) compilerArgs + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ranOk = exitCode (const False) True result + ok = + T.null stdoutLeak + && compilerSawExpectedArgs + && not envAssignmentPassedAsArg + && not localAssemblerWasInvoked + && hasRequiredAsm + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "compilerArgs:" + , T.unlines compilerArgs + , "envAssignmentPassedAsArg: " <> T.pack (show envAssignmentPassedAsArg) + , "localAssemblerWasInvoked: " <> T.pack (show localAssemblerWasInvoked) + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmLeadingEnvAssignmentMsg ok details + +runAsmLeadingEnvAssignmentWithoutEnvPathTest :: IO (Either T.Text T.Text, String) +runAsmLeadingEnvAssignmentWithoutEnvPathTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , "tmp.err" + , fakePathBinDir + , fakePathAssemblerLogPath + , fakeAssemblerAsmPath + ] + ) $ do + htccCmd <- htccCommand + createDirectoryIfMissing False fakePathBinDir + writeFakeAssemblerWithLogs fakePathAssemblerLogPath fakeAssemblerAsmPath fakePathAssemblerPath + catPath <- maybe (ioError $ userError "missing cat executable for test") pure + =<< findExecutable "cat" + writeExecutableProxy (fakePathBinDir "cat") catPath + chmodPath <- maybe (ioError $ userError "missing chmod executable for test") pure + =<< findExecutable "chmod" + writeExecutableProxy (fakePathBinDir "chmod") chmodPath + when (htccCmd == "stack exec htcc --") $ do + stackPath <- maybe (ioError $ userError "missing stack executable for test") pure + =<< findExecutable "stack" + writeExecutableProxy (fakePathBinDir "stack") stackPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "PATH=./" + , T.pack fakePathBinDir + , " " + , "HTCC_ASSEMBLER='PATH=./" + , T.pack fakePathBinDir + , " tmp-assembler.sh' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + compilerArgs <- T.lines <$> T.readFile fakePathAssemblerLogPath + asm <- T.readFile fakeAssemblerAsmPath + outputExists <- doesFileExist "tmp" + ranOk <- if outputExists + then exitCode (const False) True <$> exec "./tmp" + else pure False + let compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ "-x" + , "assembler" + , "-c" + , "-o" + ] + envAssignmentPassedAsArg = + any ("PATH=./" `T.isPrefixOf`) compilerArgs + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ok = + T.null stdoutLeak + && T.null stderrOut + && compilerSawExpectedArgs + && not envAssignmentPassedAsArg + && hasRequiredAsm + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "compilerArgs:" + , T.unlines compilerArgs + , "envAssignmentPassedAsArg: " <> T.pack (show envAssignmentPassedAsArg) + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "outputExists: " <> T.pack (show outputExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmLeadingEnvAssignmentWithoutEnvPathMsg ok details + +runAsmLeadingEnvAssignmentPreservesPathOverrideTest :: IO (Either T.Text T.Text, String) +runAsmLeadingEnvAssignmentPreservesPathOverrideTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , "tmp.err" + , fakePathBinDir + , fakePathWrapperLogPath + , fakeHostPathHelperPath + , fakeHostPathHelperLogPath + , fakeHostPathHelperAsmPath + ] + ) $ do + htccCmd <- htccCommand + createDirectoryIfMissing False fakePathBinDir + writePathLoggingWrapper fakePathAssemblerPath fakePathWrapperLogPath fakeHostPathHelperPath + writeFakeAssemblerWithLogs fakeHostPathHelperLogPath fakeHostPathHelperAsmPath fakeHostPathHelperPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "PATH=.:$PATH " + , "HTCC_ASSEMBLER='PATH=./" + , T.pack fakePathBinDir + , " " + , T.pack fakeAssemblerPath + , "' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + wrapperPathValue <- do + wrapperLogExists <- doesFileExist fakePathWrapperLogPath + if wrapperLogExists + then T.strip <$> T.readFile fakePathWrapperLogPath + else pure "" + hostHelperWasInvoked <- doesFileExist fakeHostPathHelperLogPath + outputExists <- doesFileExist "tmp" + let failedAsExpected = exitCode (const True) False result + hasExpectedError = + "failed to determine an x86_64-ELF target from HTCC_ASSEMBLER" + `T.isInfixOf` stderrOut + preservedExactPath = wrapperPathValue == T.pack ("./" <> fakePathBinDir) + ok = + T.null stdoutLeak + && failedAsExpected + && hasExpectedError + && preservedExactPath + && not hostHelperWasInvoked + && not outputExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "wrapperPath:" + , wrapperPathValue + , "preservedExactPath: " <> T.pack (show preservedExactPath) + , "hostHelperWasInvoked: " <> T.pack (show hostHelperWasInvoked) + , "outputExists: " <> T.pack (show outputExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmLeadingEnvAssignmentPreservesPathOverrideMsg ok details + +runAsmEnvPathOverrideEmptyEntryTest :: IO (Either T.Text T.Text, String) +runAsmEnvPathOverrideEmptyEntryTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , "tmp.err" + , fakeAssemblerPath + , fakeAssemblerLogPath + , fakeAssemblerAsmPath + ] + ) $ do + htccCmd <- htccCommand + writeFakeAssembler fakeAssemblerPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER='PATH= " + , T.pack fakeAssemblerPath + , "' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + compilerArgs <- do + logExists <- doesFileExist fakeAssemblerLogPath + if logExists + then T.lines <$> T.readFile fakeAssemblerLogPath + else pure [] + asm <- do + asmExists <- doesFileExist fakeAssemblerAsmPath + if asmExists + then T.readFile fakeAssemblerAsmPath + else pure "" + outputExists <- doesFileExist "tmp" + ranOk <- if outputExists + then exitCode (const False) True <$> exec "./tmp" + else pure False + let compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ "-x" + , "assembler" + , "-c" + , "-o" + ] + envAssignmentPassedAsArg = + any ("PATH=" `T.isPrefixOf`) compilerArgs + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ok = + T.null stdoutLeak + && T.null stderrOut + && compilerSawExpectedArgs + && not envAssignmentPassedAsArg + && hasRequiredAsm + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "compilerArgs:" + , T.unlines compilerArgs + , "envAssignmentPassedAsArg: " <> T.pack (show envAssignmentPassedAsArg) + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "outputExists: " <> T.pack (show outputExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmEnvPathOverrideEmptyEntryMsg ok details + +runAsmEnvPathOverrideNoLocalFallbackTest :: IO (Either T.Text T.Text, String) +runAsmEnvPathOverrideNoLocalFallbackTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , "tmp.err" + , fakeAssemblerPath + , fakePathBinDir + , fakeLocalAssemblerLogPath + ] + ) $ do + htccCmd <- htccCommand + createDirectoryIfMissing False fakePathBinDir + writeFailingCompiler fakeAssemblerPath fakeLocalAssemblerLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER='PATH=./" + , T.pack fakePathBinDir + , " tmp-assembler.sh' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + localAssemblerWasInvoked <- doesFileExist fakeLocalAssemblerLogPath + outputExists <- doesFileExist "tmp" + let failedAsExpected = exitCode (const True) False result + hasExpectedError = + "failed to determine an x86_64-ELF target from HTCC_ASSEMBLER" + `T.isInfixOf` stderrOut + ok = + T.null stdoutLeak + && failedAsExpected + && hasExpectedError + && not localAssemblerWasInvoked + && not outputExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "localAssemblerWasInvoked: " <> T.pack (show localAssemblerWasInvoked) + , "outputExists: " <> T.pack (show outputExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmEnvPathOverrideNoLocalFallbackMsg ok details + +runAsmQuotedBackslashArgTest :: IO (Either T.Text T.Text, String) +runAsmQuotedBackslashArgTest = flip finally (clean ["tmp", "tmp.out", fakeAssemblerPath, fakeAssemblerLogPath, fakeAssemblerAsmPath]) $ do + htccCmd <- htccCommand + writeFakeAssembler fakeAssemblerPath + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER='./tmp-assembler.sh \"" + , fakeAssemblerBackslashArg + , "\"' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + compilerArgs <- T.lines <$> T.readFile fakeAssemblerLogPath + asm <- T.readFile fakeAssemblerAsmPath + result <- exec "./tmp" + let compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ fakeAssemblerBackslashArg + , "-x" + , "assembler" + , "-c" + , "-o" + ] + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ranOk = exitCode (const False) True result + ok = T.null stdoutLeak && compilerSawExpectedArgs && hasRequiredAsm && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "compilerArgs:" + , T.unlines compilerArgs + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmQuotedBackslashArgMsg ok details + +runAsmIgnoresCcTest :: IO (Either T.Text T.Text, String) +runAsmIgnoresCcTest = flip finally (clean ["tmp", "tmp.out", fakeGccPath, fakeBadCcPath, fakeBadCcLogPath, fakeAssemblerLogPath, fakeAssemblerAsmPath]) $ do + htccCmd <- htccCommand + writeFakeAssembler fakeGccPath + writeFailingCompiler fakeBadCcPath fakeBadCcLogPath + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , "PATH=.:$PATH " + , "CC='./tmp-bad-cc.sh " + , fakeAssemblerWrapperArg + , "' " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + compilerArgs <- T.lines <$> T.readFile fakeAssemblerLogPath + asm <- T.readFile fakeAssemblerAsmPath + ccWasInvoked <- doesFileExist fakeBadCcLogPath + result <- exec "./tmp" + let compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ "-x" + , "assembler" + , "-c" + , "-o" + ] + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ranOk = exitCode (const False) True result + ok = T.null stdoutLeak && compilerSawExpectedArgs && hasRequiredAsm && ranOk && not ccWasInvoked + details = T.unlines + [ "stdout:" + , stdoutLeak + , "compilerArgs:" + , T.unlines compilerArgs + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "ccWasInvoked: " <> T.pack (show ccWasInvoked) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmIgnoresCcMsg ok details + +runAsmGccPrefersPathTest :: IO (Either T.Text T.Text, String) +runAsmGccPrefersPathTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , fakeGccPath + , fakePathBinDir + , fakePathGccLogPath + , fakePathGccAsmPath + , fakeLocalGccLogPath + ] + ) $ do + (ok, details) <- runAsmGccPrefersPathScenario + return $ mkResult runAsmGccPrefersPathMsg ok details + +runAsmGccPrefersPathScenario :: IO (Bool, T.Text) +runAsmGccPrefersPathScenario = do + htccCmd <- htccCommand + clean ["tmp", "tmp.out", fakeGccPath, fakePathBinDir, fakePathGccLogPath, fakePathGccAsmPath, fakeLocalGccLogPath] + createDirectoryIfMissing False fakePathBinDir + writeFakeAssemblerWithLogs fakePathGccLogPath fakePathGccAsmPath fakePathGccPath + writeFailingCompiler fakeGccPath fakeLocalGccLogPath + execErrFin $ mconcat + [ "echo '" + , source + , "' | " + , "PATH=./" + , T.pack fakePathBinDir + , ":$PATH " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out" + ] + stdoutLeak <- T.readFile "tmp.out" + compilerArgs <- T.lines <$> T.readFile fakePathGccLogPath + asm <- T.readFile fakePathGccAsmPath + localGccWasInvoked <- doesFileExist fakeLocalGccLogPath + result <- exec "./tmp" + let compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ "-x" + , "assembler" + , "-c" + , "-o" + ] + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + ranOk = exitCode (const False) True result + ok = T.null stdoutLeak && compilerSawExpectedArgs && hasRequiredAsm && ranOk && not localGccWasInvoked + details = T.unlines + [ "stdout:" + , stdoutLeak + , "compilerArgs:" + , T.unlines compilerArgs + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "localGccWasInvoked: " <> T.pack (show localGccWasInvoked) + , "exitCode: " <> T.pack (show result) + ] + pure (ok, details) + +runAsmFailurePreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +runAsmFailurePreservesExistingOutputTest = + flip finally + (clean ["tmp", "tmp.out", "tmp.err", "a.out", fakeBadCcPath, fakeBadCcLogPath]) $ do + htccCmd <- htccCommand + writeFailingCompiler fakeBadCcPath fakeBadCcLogPath + defaultResult <- runAsmFailurePreservesExistingOutputScenario htccCmd "" "a.out" + explicitResult <- runAsmFailurePreservesExistingOutputScenario htccCmd " -o tmp" "tmp" + let ok = resultOk defaultResult && resultOk explicitResult + details = T.unlines + [ "[default]" + , resultDetails defaultResult + , "[explicit]" + , resultDetails explicitResult + ] + return $ mkResult runAsmFailurePreservesExistingOutputMsg ok details + where + resultOk (x, _) = x + resultDetails (_, x) = x + +runAsmFailurePreservesExistingOutputScenario :: T.Text -> T.Text -> FilePath -> IO (Bool, T.Text) +runAsmFailurePreservesExistingOutputScenario htccCmd outputArgs target = do + clean [target, "tmp.out", "tmp.err", fakeBadCcLogPath] + T.writeFile target "stale output" + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeBadCcPath + , " " + , htccCmd + , " -r" + , outputArgs + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + targetContents <- if targetExists then T.readFile target else pure "" + compilerArgs <- do + hasLog <- doesFileExist fakeBadCcLogPath + if hasLog + then T.lines <$> T.readFile fakeBadCcLogPath + else pure [] + let failed = exitCode (const True) False result + compilerInvoked = not $ null compilerArgs + compilerSawAssembleFlags = all (`elem` compilerArgs) ["-x", "assembler", "-c", "-o"] + ok = + failed + && T.null stdoutLeak + && targetExists + && targetContents == "stale output" + && compilerInvoked + && compilerSawAssembleFlags + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "compilerArgs:" + , T.unlines compilerArgs + , "compilerInvoked: " <> T.pack (show compilerInvoked) + , "compilerSawAssembleFlags: " <> T.pack (show compilerSawAssembleFlags) + , "targetExists: " <> T.pack (show targetExists) + , "targetUnchanged: " <> T.pack (show (targetContents == "stale output")) + , "exitCode: " <> T.pack (show result) + ] + pure (ok, details) + +runAsmParseFailurePreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +runAsmParseFailurePreservesExistingOutputTest = + flip finally + (clean ["tmp", "tmp.out", "tmp.err", "a.out", "tmp-parse-error.c", fakeBadCcPath, fakeBadCcLogPath]) $ do + htccCmd <- htccCommand + writeFailingCompiler fakeBadCcPath fakeBadCcLogPath + defaultResult <- runAsmParseFailurePreservesExistingOutputScenario htccCmd "" "a.out" + explicitResult <- runAsmParseFailurePreservesExistingOutputScenario htccCmd " -o tmp" "tmp" + let ok = resultOk defaultResult && resultOk explicitResult + details = T.unlines + [ "[default]" + , resultDetails defaultResult + , "[explicit]" + , resultDetails explicitResult + ] + return $ mkResult runAsmParseFailurePreservesExistingOutputMsg ok details + where + resultOk (x, _) = x + resultDetails (_, x) = x + +runAsmParseFailurePreservesExistingOutputScenario :: T.Text -> T.Text -> FilePath -> IO (Bool, T.Text) +runAsmParseFailurePreservesExistingOutputScenario htccCmd outputArgs target = do + let inputPath = "tmp-parse-error.c" + clean [target, inputPath, "tmp.out", "tmp.err", fakeBadCcLogPath] + T.writeFile target "stale output" + T.writeFile inputPath parseFailureSource + result <- exec $ mconcat + [ "HTCC_ASSEMBLER=./" + , T.pack fakeBadCcPath + , " " + , htccCmd + , " -r" + , outputArgs + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + inputContents <- T.readFile inputPath + targetExists <- doesFileExist target + targetContents <- if targetExists then T.readFile target else pure "" + compilerInvoked <- doesFileExist fakeBadCcLogPath + let failed = exitCode (const True) False result + mentionsInput = T.pack inputPath `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && targetExists + && targetContents == "stale output" + && inputContents == parseFailureSource + && not compilerInvoked + && mentionsInput + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "targetUnchanged: " <> T.pack (show (targetContents == "stale output")) + , "inputUnchanged: " <> T.pack (show (inputContents == parseFailureSource)) + , "compilerInvoked: " <> T.pack (show compilerInvoked) + , "mentionsInput: " <> T.pack (show mentionsInput) + , "exitCode: " <> T.pack (show result) + ] + pure (ok, details) + +runAsmReadFailurePreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +runAsmReadFailurePreservesExistingOutputTest = + flip finally + (clean ["tmp", "tmp.out", "tmp.err", "a.out", "tmp-missing.c", fakeBadCcPath, fakeBadCcLogPath]) $ do + htccCmd <- htccCommand + writeFailingCompiler fakeBadCcPath fakeBadCcLogPath + defaultResult <- runAsmReadFailurePreservesExistingOutputScenario htccCmd "" "a.out" + explicitResult <- runAsmReadFailurePreservesExistingOutputScenario htccCmd " -o tmp" "tmp" + let ok = resultOk defaultResult && resultOk explicitResult + details = T.unlines + [ "[default]" + , resultDetails defaultResult + , "[explicit]" + , resultDetails explicitResult + ] + return $ mkResult runAsmReadFailurePreservesExistingOutputMsg ok details + where + resultOk (x, _) = x + resultDetails (_, x) = x + +runAsmReadFailurePreservesExistingOutputScenario :: T.Text -> T.Text -> FilePath -> IO (Bool, T.Text) +runAsmReadFailurePreservesExistingOutputScenario htccCmd outputArgs target = do + let inputPath = "tmp-missing.c" + clean [target, inputPath, "tmp.out", "tmp.err", fakeBadCcLogPath] + T.writeFile target "stale output" + result <- exec $ mconcat + [ "HTCC_ASSEMBLER=./" + , T.pack fakeBadCcPath + , " " + , htccCmd + , " -r" + , outputArgs + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + inputExists <- doesFileExist inputPath + targetExists <- doesFileExist target + targetContents <- if targetExists then T.readFile target else pure "" + compilerInvoked <- doesFileExist fakeBadCcLogPath + let failed = exitCode (const True) False result + mentionsInput = T.pack inputPath `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && targetExists + && targetContents == "stale output" + && not inputExists + && not compilerInvoked + && mentionsInput + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "targetUnchanged: " <> T.pack (show (targetContents == "stale output")) + , "inputExists: " <> T.pack (show inputExists) + , "compilerInvoked: " <> T.pack (show compilerInvoked) + , "mentionsInput: " <> T.pack (show mentionsInput) + , "exitCode: " <> T.pack (show result) + ] + pure (ok, details) + +runAsmHardLinkedRenameReplacementPreservesAliasTest :: IO (Either T.Text T.Text, String) +runAsmHardLinkedRenameReplacementPreservesAliasTest = + flip finally (clean ["tmp.out", "tmp.err", "tmp-hard-link-output.out", "tmp-hard-link-output-link.out", fakeAssemblerPath, fakeAssemblerLogPath]) $ do + htccCmd <- htccCommand + let target = "tmp-hard-link-output.out" + alias = "tmp-hard-link-output-link.out" + staleTarget = "#!/bin/sh\nexit 99\n" + clean [target, alias, "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath] + writeLoggingDriver fakeAssemblerPath fakeAssemblerLogPath + T.writeFile target staleTarget + execErrFin $ "ln '" <> T.pack target <> "' '" <> T.pack alias <> "'" + setFileMode target $ ownerReadMode `unionFileModes` ownerWriteMode `unionFileModes` ownerExecuteMode + result <- exec $ mconcat + [ "echo '" + , source + , "' | HTCC_ASSEMBLER=./" + , T.pack fakeAssemblerPath + , " " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + aliasExists <- doesFileExist alias + driverInvocations <- do + hasLog <- doesFileExist fakeAssemblerLogPath + if hasLog + then T.lines <$> T.readFile fakeAssemblerLogPath + else pure [] + targetContents <- if targetExists then T.readFile target else pure "" + aliasContents <- if aliasExists then T.readFile alias else pure "" + targetRunResult <- if targetExists then Just <$> exec ("./" <> T.pack target) else pure Nothing + aliasRunResult <- if aliasExists then Just <$> exec ("./" <> T.pack alias) else pure Nothing + let succeeded = exitCode (const False) True result + targetUpdated = targetContents /= staleTarget + aliasPreserved = aliasContents == staleTarget + targetRuns = maybe False (exitCode (== 0) False) targetRunResult + aliasStillRuns = maybe False (exitCode (== 99) False) aliasRunResult + driverInvoked = not $ null driverInvocations + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && targetExists + && aliasExists + && targetUpdated + && aliasPreserved + && targetRuns + && aliasStillRuns + && driverInvoked + details = T.unlines + [ "target: " <> T.pack target + , "alias: " <> T.pack alias + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "targetExists: " <> T.pack (show targetExists) + , "aliasExists: " <> T.pack (show aliasExists) + , "targetUpdated: " <> T.pack (show targetUpdated) + , "aliasPreserved: " <> T.pack (show aliasPreserved) + , "targetRunExitCode: " <> maybe "not-run" (T.pack . show) targetRunResult + , "aliasRunExitCode: " <> maybe "not-run" (T.pack . show) aliasRunResult + , "driverInvoked: " <> T.pack (show driverInvoked) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmHardLinkedRenameReplacementPreservesAliasMsg ok details + +runAsmReadOnlyParentWritableTargetTest :: IO (Either T.Text T.Text, String) +runAsmReadOnlyParentWritableTargetTest = + flip finally cleanupReadOnlyOutputDir $ do + htccCmd <- htccCommand + let targetDir = "tmp-read-only-dir" + target = targetDir "tmp-read-only.out" + targetMode = foldr1 unionFileModes + [ ownerReadMode + , ownerWriteMode + , groupReadMode + , otherReadMode + ] + clean [targetDir, "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath] + writeLoggingDriver fakeAssemblerPath fakeAssemblerLogPath + createDirectoryIfMissing False targetDir + T.writeFile target "#!/bin/sh\nexit 99\n" + setFileMode target targetMode + execErrFin $ "chmod 555 '" <> T.pack targetDir <> "'" + result <- exec $ mconcat + [ "echo '" + , source + , "' | HTCC_ASSEMBLER=./" + , T.pack fakeAssemblerPath + , " " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetContents <- T.readFile target + runResult <- exec $ "./" <> T.pack target + let succeeded = exitCode (const False) True result + ranOk = exitCode (const False) True runResult + targetUpdated = + all (`T.isInfixOf` targetContents) + [ "#!/bin/sh" + , "exit 0" + ] + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && targetUpdated + && ranOk + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetUpdated: " <> T.pack (show targetUpdated) + , "runExitCode: " <> T.pack (show runResult) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmReadOnlyParentWritableTargetMsg ok details + where + cleanupReadOnlyOutputDir = do + let targetDir = "tmp-read-only-dir" + _ <- exec $ "chmod 755 '" <> T.pack targetDir <> "' > /dev/null 2>&1" + clean [targetDir, "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath] + +runAsmReadOnlyParentWriteOnlyTargetTest :: IO (Either T.Text T.Text, String) +runAsmReadOnlyParentWriteOnlyTargetTest = + flip finally cleanupReadOnlyOutputDir $ do + htccCmd <- htccCommand + let targetDir = "tmp-read-only-dir" + target = targetDir "tmp-write-only.out" + targetMode = ownerWriteMode + expectedMode = ownerWriteMode `unionFileModes` ownerExecuteMode + clean [targetDir, "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath] + writeLoggingDriver fakeAssemblerPath fakeAssemblerLogPath + createDirectoryIfMissing False targetDir + T.writeFile target "#!/bin/sh\nexit 99\n" + setFileMode target targetMode + execErrFin $ "chmod 555 '" <> T.pack targetDir <> "'" + result <- exec $ mconcat + [ "echo '" + , source + , "' | HTCC_ASSEMBLER=./" + , T.pack fakeAssemblerPath + , " " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + replacedMode <- if targetExists then fileMode <$> getFileStatus target else pure 0 + execErrFin $ "chmod 755 '" <> T.pack targetDir <> "'" + when targetExists $ + setFileMode target $ replacedMode `unionFileModes` ownerReadMode `unionFileModes` ownerExecuteMode + targetContents <- if targetExists then T.readFile target else pure "" + runResult <- if targetExists then Just <$> exec ("./" <> T.pack target) else pure Nothing + let replacedPermissions = permissionBits replacedMode + let succeeded = exitCode (const False) True result + ranOk = maybe False (exitCode (const False) True) runResult + targetUpdated = + all (`T.isInfixOf` targetContents) + [ "#!/bin/sh" + , "exit 0" + ] + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && targetExists + && replacedPermissions == expectedMode + && targetUpdated + && ranOk + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "replacedMode: " <> T.pack (show replacedMode) + , "replacedPermissions: " <> T.pack (show replacedPermissions) + , "targetUpdated: " <> T.pack (show targetUpdated) + , "runExitCode: " <> maybe "not-run" (T.pack . show) runResult + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmReadOnlyParentWriteOnlyTargetMsg ok details + where + cleanupReadOnlyOutputDir = do + let targetDir = "tmp-read-only-dir" + _ <- exec $ "chmod 755 '" <> T.pack targetDir <> "' > /dev/null 2>&1" + clean [targetDir, "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath] + +runAsmReadOnlyParentExecutableOnlyTargetTest :: IO (Either T.Text T.Text, String) +runAsmReadOnlyParentExecutableOnlyTargetTest = + flip finally cleanupReadOnlyOutputDir $ do + htccCmd <- htccCommand + let targetDir = "tmp-read-only-dir" + target = targetDir "tmp-exec-only.out" + targetMode = 0o555 + clean [targetDir, "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath] + writeLoggingDriver fakeAssemblerPath fakeAssemblerLogPath + createDirectoryIfMissing False targetDir + T.writeFile target "#!/bin/sh\nexit 99\n" + setFileMode target targetMode + execErrFin $ "chmod 555 '" <> T.pack targetDir <> "'" + result <- exec $ mconcat + [ "echo '" + , source + , "' | HTCC_ASSEMBLER=./" + , T.pack fakeAssemblerPath + , " " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + replacedMode <- if targetExists then fileMode <$> getFileStatus target else pure 0 + targetContents <- if targetExists then T.readFile target else pure "" + runResult <- if targetExists then Just <$> exec ("./" <> T.pack target) else pure Nothing + let replacedPermissions = permissionBits replacedMode + let succeeded = exitCode (const False) True result + ranOk = maybe False (exitCode (const False) True) runResult + targetUpdated = + all (`T.isInfixOf` targetContents) + [ "#!/bin/sh" + , "exit 0" + ] + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && targetExists + && replacedPermissions == targetMode + && targetUpdated + && ranOk + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "replacedMode: " <> T.pack (show replacedMode) + , "replacedPermissions: " <> T.pack (show replacedPermissions) + , "targetUpdated: " <> T.pack (show targetUpdated) + , "runExitCode: " <> maybe "not-run" (T.pack . show) runResult + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmReadOnlyParentExecutableOnlyTargetMsg ok details + where + cleanupReadOnlyOutputDir = do + let targetDir = "tmp-read-only-dir" + _ <- exec $ "chmod 755 '" <> T.pack targetDir <> "' > /dev/null 2>&1" + clean [targetDir, "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath] + +runAsmReadOnlyParentHardLinkAliasPreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +runAsmReadOnlyParentHardLinkAliasPreservesExistingOutputTest = + flip finally cleanupReadOnlyOutputDir $ do + htccCmd <- htccCommand + let targetDir = "tmp-read-only-dir" + target = targetDir "tmp-read-only.out" + alias = targetDir "tmp-read-only-link.out" + expectedError = "hard-linked output" + staleTarget = "#!/bin/sh\nexit 99\n" + clean [targetDir, "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath] + writeLoggingDriver fakeAssemblerPath fakeAssemblerLogPath + createDirectoryIfMissing False targetDir + T.writeFile target staleTarget + execErrFin $ "ln '" <> T.pack target <> "' '" <> T.pack alias <> "'" + setFileMode target $ ownerReadMode `unionFileModes` ownerWriteMode `unionFileModes` ownerExecuteMode + execErrFin $ "chmod 555 '" <> T.pack targetDir <> "'" + result <- exec $ mconcat + [ "echo '" + , source + , "' | HTCC_ASSEMBLER=./" + , T.pack fakeAssemblerPath + , " " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + aliasExists <- doesFileExist alias + driverInvocations <- do + hasLog <- doesFileExist fakeAssemblerLogPath + if hasLog + then T.lines <$> T.readFile fakeAssemblerLogPath + else pure [] + execErrFin $ "chmod 755 '" <> T.pack targetDir <> "'" + targetContents <- if targetExists then T.readFile target else pure "" + aliasContents <- if aliasExists then T.readFile alias else pure "" + targetRunResult <- if targetExists then Just <$> exec ("./" <> T.pack target) else pure Nothing + aliasRunResult <- if aliasExists then Just <$> exec ("./" <> T.pack alias) else pure Nothing + let failed = exitCode (const True) False result + hasExpectedError = expectedError `T.isInfixOf` stderrOut + preservedTarget = targetContents == staleTarget + preservedAlias = aliasContents == staleTarget + targetStillRuns = maybe False (exitCode (== 99) False) targetRunResult + aliasStillRuns = maybe False (exitCode (== 99) False) aliasRunResult + driverInvoked = not $ null driverInvocations + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && targetExists + && aliasExists + && preservedTarget + && preservedAlias + && targetStillRuns + && aliasStillRuns + && driverInvoked + details = T.unlines + [ "target: " <> T.pack target + , "alias: " <> T.pack alias + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "targetExists: " <> T.pack (show targetExists) + , "aliasExists: " <> T.pack (show aliasExists) + , "preservedTarget: " <> T.pack (show preservedTarget) + , "preservedAlias: " <> T.pack (show preservedAlias) + , "targetRunExitCode: " <> maybe "not-run" (T.pack . show) targetRunResult + , "aliasRunExitCode: " <> maybe "not-run" (T.pack . show) aliasRunResult + , "driverInvoked: " <> T.pack (show driverInvoked) + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmReadOnlyParentHardLinkAliasPreservesExistingOutputMsg ok details + where + cleanupReadOnlyOutputDir = do + let targetDir = "tmp-read-only-dir" + _ <- exec $ "chmod 755 '" <> T.pack targetDir <> "' > /dev/null 2>&1" + clean [targetDir, "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath] + +runAsmReadOnlyParentLinkFailurePreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +runAsmReadOnlyParentLinkFailurePreservesExistingOutputTest = + flip finally cleanupReadOnlyOutputDir $ do + htccCmd <- htccCommand + let targetDir = "tmp-read-only-dir" + target = targetDir "tmp-read-only.out" + targetMode = foldr1 unionFileModes + [ ownerReadMode + , ownerWriteMode + , ownerExecuteMode + , groupReadMode + , otherReadMode + ] + clean [targetDir, "tmp.out", "tmp.err", fakeFailingLinkDriverPath, fakeFailingLinkDriverLogPath] + writeFailingLinkDriver fakeFailingLinkDriverPath fakeFailingLinkDriverLogPath + createDirectoryIfMissing False targetDir + T.writeFile target "#!/bin/sh\nexit 99\n" + setFileMode target targetMode + execErrFin $ "chmod 555 '" <> T.pack targetDir <> "'" + result <- exec $ mconcat + [ "echo '" + , source + , "' | HTCC_ASSEMBLER=./" + , T.pack fakeFailingLinkDriverPath + , " " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + targetContents <- if targetExists then T.readFile target else pure "" + programResult <- if targetExists then Just <$> exec ("./" <> T.pack target) else pure Nothing + driverInvocations <- do + hasLog <- doesFileExist fakeFailingLinkDriverLogPath + if hasLog + then T.lines <$> T.readFile fakeFailingLinkDriverLogPath + else pure [] + let failed = exitCode (const True) False result + attemptedStagedLink = + any (\line -> "tmp-read-only.out" `T.isInfixOf` line && ".htcc-" `T.isInfixOf` line) driverInvocations + preservedTarget = targetContents == "#!/bin/sh\nexit 99\n" + staleTargetRan = maybe False (exitCode (== 99) False) programResult + ok = + failed + && T.null stdoutLeak + && targetExists + && preservedTarget + && staleTargetRan + && attemptedStagedLink + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "targetExists: " <> T.pack (show targetExists) + , "preservedTarget: " <> T.pack (show preservedTarget) + , "staleTargetRan: " <> T.pack (show staleTargetRan) + , "attemptedStagedLink: " <> T.pack (show attemptedStagedLink) + , "runExitCode: " <> T.pack (show programResult) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmReadOnlyParentLinkFailurePreservesExistingOutputMsg ok details + where + cleanupReadOnlyOutputDir = do + let targetDir = "tmp-read-only-dir" + _ <- exec $ "chmod 755 '" <> T.pack targetDir <> "' > /dev/null 2>&1" + clean [targetDir, "tmp.out", "tmp.err", fakeFailingLinkDriverPath, fakeFailingLinkDriverLogPath] + +runAsmFailurePreservesInputOutputAliasTest :: IO (Either T.Text T.Text, String) +runAsmFailurePreservesInputOutputAliasTest = + flip finally + (clean ["tmp.out", "tmp.err", "a.out", "tmp-source.c", fakeBadCcPath, fakeBadCcLogPath]) $ do + htccCmd <- htccCommand + writeFailingCompiler fakeBadCcPath fakeBadCcLogPath + defaultResult <- runAsmFailurePreservesInputOutputAliasScenario htccCmd "" "a.out" + explicitResult <- runAsmFailurePreservesInputOutputAliasScenario htccCmd " -o tmp-source.c" "tmp-source.c" + let ok = resultOk defaultResult && resultOk explicitResult + details = T.unlines + [ "[default]" + , resultDetails defaultResult + , "[explicit]" + , resultDetails explicitResult + ] + return $ mkResult runAsmFailurePreservesInputOutputAliasMsg ok details + where + resultOk (x, _) = x + resultDetails (_, x) = x + +runAsmFailurePreservesInputOutputAliasScenario :: T.Text -> T.Text -> FilePath -> IO (Bool, T.Text) +runAsmFailurePreservesInputOutputAliasScenario htccCmd outputArgs inputPath = do + clean [inputPath, "tmp.out", "tmp.err", fakeBadCcLogPath] + T.writeFile inputPath source + result <- exec $ mconcat + [ "HTCC_ASSEMBLER=./" + , T.pack fakeBadCcPath + , " " + , htccCmd + , " -r" + , outputArgs + , " " + , T.pack inputPath + , " > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + inputExists <- doesFileExist inputPath + inputContents <- if inputExists then T.readFile inputPath else pure "" + compilerArgs <- do + hasLog <- doesFileExist fakeBadCcLogPath + if hasLog + then T.lines <$> T.readFile fakeBadCcLogPath + else pure [] + let failed = exitCode (const True) False result + compilerInvoked = not $ null compilerArgs + hasAliasError = "-r output path must not overwrite an input file" `T.isInfixOf` stderrOut + ok = failed && T.null stdoutLeak && inputExists && inputContents == source && not compilerInvoked && hasAliasError + details = T.unlines + [ "inputPath: " <> T.pack inputPath + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "compilerArgs:" + , T.unlines compilerArgs + , "inputExists: " <> T.pack (show inputExists) + , "inputUnchanged: " <> T.pack (show (inputContents == source)) + , "compilerInvoked: " <> T.pack (show compilerInvoked) + , "hasAliasError: " <> T.pack (show hasAliasError) + , "exitCode: " <> T.pack (show result) + ] + pure (ok, details) + +runAsmFailurePreservesHardLinkInputOutputAliasTest :: IO (Either T.Text T.Text, String) +runAsmFailurePreservesHardLinkInputOutputAliasTest = + flip finally + (clean ["tmp.out", "tmp.err", "tmp-source.c", "tmp-source-link.c", fakeBadCcPath, fakeBadCcLogPath]) $ do + htccCmd <- htccCommand + writeFailingCompiler fakeBadCcPath fakeBadCcLogPath + (ok, details) <- runAsmFailurePreservesHardLinkInputOutputAliasScenario htccCmd + return $ mkResult runAsmFailurePreservesHardLinkInputOutputAliasMsg ok details + +runAsmFailurePreservesHardLinkInputOutputAliasScenario :: T.Text -> IO (Bool, T.Text) +runAsmFailurePreservesHardLinkInputOutputAliasScenario htccCmd = do + clean ["tmp-source.c", "tmp-source-link.c", "tmp.out", "tmp.err", fakeBadCcLogPath] + T.writeFile "tmp-source.c" source + execErrFin "ln tmp-source.c tmp-source-link.c" + result <- exec $ mconcat + [ "HTCC_ASSEMBLER=./" + , T.pack fakeBadCcPath + , " " + , htccCmd + , " -r -o tmp-source-link.c tmp-source.c > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + inputExists <- doesFileExist "tmp-source.c" + outputExists <- doesFileExist "tmp-source-link.c" + inputContents <- if inputExists then T.readFile "tmp-source.c" else pure "" + outputContents <- if outputExists then T.readFile "tmp-source-link.c" else pure "" + compilerArgs <- do + hasLog <- doesFileExist fakeBadCcLogPath + if hasLog + then T.lines <$> T.readFile fakeBadCcLogPath + else pure [] + let failed = exitCode (const True) False result + compilerInvoked = not $ null compilerArgs + hasAliasError = "-r output path must not overwrite an input file" `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && inputExists + && outputExists + && inputContents == source + && outputContents == source + && not compilerInvoked + && hasAliasError + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "compilerArgs:" + , T.unlines compilerArgs + , "inputExists: " <> T.pack (show inputExists) + , "outputExists: " <> T.pack (show outputExists) + , "inputUnchanged: " <> T.pack (show (inputContents == source)) + , "outputUnchanged: " <> T.pack (show (outputContents == source)) + , "compilerInvoked: " <> T.pack (show compilerInvoked) + , "hasAliasError: " <> T.pack (show hasAliasError) + , "exitCode: " <> T.pack (show result) + ] + pure (ok, details) + +runAsmMalformedAssemblerPreservesExistingOutputTest :: IO (Either T.Text T.Text, String) +runAsmMalformedAssemblerPreservesExistingOutputTest = + flip finally + (clean ["tmp", "tmp.out", "tmp.err", "a.out"]) $ do + htccCmd <- htccCommand + defaultResult <- runAsmMalformedAssemblerPreservesExistingOutputScenario htccCmd "" "a.out" + explicitResult <- runAsmMalformedAssemblerPreservesExistingOutputScenario htccCmd " -o tmp" "tmp" + let ok = resultOk defaultResult && resultOk explicitResult + details = T.unlines + [ "[default]" + , resultDetails defaultResult + , "[explicit]" + , resultDetails explicitResult + ] + return $ mkResult runAsmMalformedAssemblerPreservesExistingOutputMsg ok details + where + resultOk (x, _) = x + resultDetails (_, x) = x + +runAsmMalformedAssemblerPreservesExistingOutputScenario :: T.Text -> T.Text -> FilePath -> IO (Bool, T.Text) +runAsmMalformedAssemblerPreservesExistingOutputScenario htccCmd outputArgs target = do + clean [target, "tmp.out", "tmp.err"] + T.writeFile target "stale output" + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=\"'\" " + , htccCmd + , " -r" + , outputArgs + , " /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + targetContents <- if targetExists then T.readFile target else pure "" + let failed = exitCode (const True) False result + ok = failed && T.null stdoutLeak && targetExists && targetContents == "stale output" + details = T.unlines + [ "target: " <> T.pack target + , "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "targetUnchanged: " <> T.pack (show (targetContents == "stale output")) + , "exitCode: " <> T.pack (show result) + ] + pure (ok, details) + +runAsmMalformedAssemblerTest :: IO (Either T.Text T.Text, String) +runAsmMalformedAssemblerTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeMalformedAssemblerTmpDir]) $ do + htccCmd <- htccCommand + createDirectoryIfMissing False fakeMalformedAssemblerTmpDir + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "TMPDIR=./" + , T.pack fakeMalformedAssemblerTmpDir + , " " + , "HTCC_ASSEMBLER=\"'\" " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + tmpFiles <- listDirectory fakeMalformedAssemblerTmpDir + let failed = exitCode (const True) False result + ok = failed && T.null stdoutLeak && null tmpFiles + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "tmpFiles:" + , T.pack (show tmpFiles) + , "exitCode: " <> T.pack (show result) + ] + pure $ mkResult runAsmMalformedAssemblerMsg ok details + +runAsmAcceptsFreeBsdElfTargetDriverTest :: IO (Either T.Text T.Text, String) +runAsmAcceptsFreeBsdElfTargetDriverTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeFreeBsdDriverPath, fakeFreeBsdDriverLogPath, fakeFreeBsdDriverAsmPath]) $ do + htccCmd <- htccCommand + writeFakeAssemblerWithTarget "x86_64-unknown-freebsd13.2" fakeFreeBsdDriverLogPath fakeFreeBsdDriverAsmPath fakeFreeBsdDriverPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeFreeBsdDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + compilerArgs <- T.lines <$> T.readFile fakeFreeBsdDriverLogPath + asm <- T.readFile fakeFreeBsdDriverAsmPath + programResult <- exec "./tmp" + let compilerSawExpectedArgs = + all (`elem` compilerArgs) + [ "-x" + , "assembler" + , "-c" + , "-o" + ] + hasRequiredAsm = + all (`T.isInfixOf` asm) + [ ".intel_syntax noprefix" + , ".L.return.main:" + , ".L.label.main.done:" + ] + succeeded = exitCode (const False) True result + ranOk = exitCode (const False) True programResult + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && compilerSawExpectedArgs + && hasRequiredAsm + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "compilerArgs:" + , T.unlines compilerArgs + , "hasRequiredAsm: " <> T.pack (show hasRequiredAsm) + , "compileExitCode: " <> T.pack (show result) + , "runExitCode: " <> T.pack (show programResult) + ] + return $ mkResult runAsmAcceptsFreeBsdElfTargetDriverMsg ok details + +runAsmRejectsMissingAssemblerDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsMissingAssemblerDriverTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeMissingAssemblerDriverPath]) $ do + htccCmd <- htccCommand + clean [fakeMissingAssemblerDriverPath] + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=" + , T.pack fakeMissingAssemblerDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + let failed = exitCode (const True) False result + hasExpectedError = + "failed to determine an x86_64-ELF target from HTCC_ASSEMBLER" `T.isInfixOf` stderrOut + leakedRawProcessException = + "readCreateProcessWithExitCode" `T.isInfixOf` stderrOut + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && not leakedRawProcessException + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "leakedRawProcessException: " <> T.pack (show leakedRawProcessException) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsMissingAssemblerDriverMsg ok details + +runAsmRejectsAssemblerWithoutLinkDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsAssemblerWithoutLinkDriverTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeAssembleOnlyDriverPath, fakeAssembleOnlyDriverLogPath]) $ do + htccCmd <- htccCommand + writeAssembleOnlyDriver fakeAssembleOnlyDriverPath fakeAssembleOnlyDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeAssembleOnlyDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + driverInvocations <- T.lines <$> T.readFile fakeAssembleOnlyDriverLogPath + let failed = exitCode (const True) False result + hasExpectedError = + "failed a link probe for -r" `T.isInfixOf` stderrOut + && "supports both assembly and linking for -r" `T.isInfixOf` stderrOut + sawMetadataProbe = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + driverInvocations + sawAssemblyProbe = any ("-x assembler -c -o" `T.isInfixOf`) driverInvocations + sawLinkProbe = any ("-no-pie -o" `T.isInfixOf`) driverInvocations + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && sawMetadataProbe + && sawAssemblyProbe + && sawLinkProbe + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "sawMetadataProbe: " <> T.pack (show sawMetadataProbe) + , "sawAssemblyProbe: " <> T.pack (show sawAssemblyProbe) + , "sawLinkProbe: " <> T.pack (show sawLinkProbe) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsAssemblerWithoutLinkDriverMsg ok details + +runAsmRejectsScriptLinkProbeDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsScriptLinkProbeDriverTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeScriptLinkProbeDriverPath, fakeScriptLinkProbeDriverLogPath]) $ do + htccCmd <- htccCommand + writeScriptLinkProbeDriver fakeScriptLinkProbeDriverPath fakeScriptLinkProbeDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeScriptLinkProbeDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + driverInvocations <- T.lines <$> T.readFile fakeScriptLinkProbeDriverLogPath + let failed = exitCode (const True) False result + hasExpectedError = + "failed a link probe for -r" `T.isInfixOf` stderrOut + && "supports both assembly and linking for -r" `T.isInfixOf` stderrOut + sawMetadataProbe = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + driverInvocations + sawAssemblyProbe = any ("-x assembler -c -o" `T.isInfixOf`) driverInvocations + sawLinkProbe = any ("-no-pie -o" `T.isInfixOf`) driverInvocations + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && sawMetadataProbe + && sawAssemblyProbe + && sawLinkProbe + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "sawMetadataProbe: " <> T.pack (show sawMetadataProbe) + , "sawAssemblyProbe: " <> T.pack (show sawAssemblyProbe) + , "sawLinkProbe: " <> T.pack (show sawLinkProbe) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsScriptLinkProbeDriverMsg ok details + +runAsmRejectsSharedLinkProbeDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsSharedLinkProbeDriverTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeSharedLinkProbeDriverPath, fakeSharedLinkProbeDriverLogPath]) $ do + htccCmd <- htccCommand + writeSharedLinkProbeDriver fakeSharedLinkProbeDriverPath fakeSharedLinkProbeDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeSharedLinkProbeDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + driverInvocations <- T.lines <$> T.readFile fakeSharedLinkProbeDriverLogPath + let failed = exitCode (const True) False result + hasExpectedError = + "failed a link probe for -r" `T.isInfixOf` stderrOut + && "supports both assembly and linking for -r" `T.isInfixOf` stderrOut + sawMetadataProbe = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + driverInvocations + sawAssemblyProbe = any ("-x assembler -c -o" `T.isInfixOf`) driverInvocations + sawLinkProbe = any ("-no-pie -o" `T.isInfixOf`) driverInvocations + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && sawMetadataProbe + && sawAssemblyProbe + && sawLinkProbe + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "sawMetadataProbe: " <> T.pack (show sawMetadataProbe) + , "sawAssemblyProbe: " <> T.pack (show sawAssemblyProbe) + , "sawLinkProbe: " <> T.pack (show sawLinkProbe) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsSharedLinkProbeDriverMsg ok details + +runAsmRejectsBlobLinkProbeDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsBlobLinkProbeDriverTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeBlobLinkProbeDriverPath, fakeBlobLinkProbeDriverLogPath]) $ do + htccCmd <- htccCommand + writeBlobLinkProbeDriver fakeBlobLinkProbeDriverPath fakeBlobLinkProbeDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeBlobLinkProbeDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + driverInvocations <- T.lines <$> T.readFile fakeBlobLinkProbeDriverLogPath + let failed = exitCode (const True) False result + hasExpectedError = + "failed a link probe for -r" `T.isInfixOf` stderrOut + && "supports both assembly and linking for -r" `T.isInfixOf` stderrOut + sawMetadataProbe = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + driverInvocations + sawAssemblyProbe = any ("-x assembler -c -o" `T.isInfixOf`) driverInvocations + sawLinkProbe = any ("-no-pie -o" `T.isInfixOf`) driverInvocations + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && sawMetadataProbe + && sawAssemblyProbe + && sawLinkProbe + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "sawMetadataProbe: " <> T.pack (show sawMetadataProbe) + , "sawAssemblyProbe: " <> T.pack (show sawAssemblyProbe) + , "sawLinkProbe: " <> T.pack (show sawLinkProbe) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsBlobLinkProbeDriverMsg ok details + +runAsmRejectsSymlinkLinkProbeDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsSymlinkLinkProbeDriverTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , "tmp.err" + , fakeSymlinkLinkProbeDriverPath + , fakeSymlinkLinkProbeDriverLogPath + , fakeSymlinkLinkProbeTargetPath + ]) + $ do + htccCmd <- htccCommand + writeSymlinkLinkProbeDriver + fakeSymlinkLinkProbeDriverPath + fakeSymlinkLinkProbeDriverLogPath + fakeSymlinkLinkProbeTargetPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeSymlinkLinkProbeDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + driverInvocations <- T.lines <$> T.readFile fakeSymlinkLinkProbeDriverLogPath + let failed = exitCode (const True) False result + hasExpectedError = + "failed a link probe for -r" `T.isInfixOf` stderrOut + && "supports both assembly and linking for -r" `T.isInfixOf` stderrOut + sawMetadataProbe = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + driverInvocations + sawAssemblyProbe = any ("-x assembler -c -o" `T.isInfixOf`) driverInvocations + sawLinkProbe = any ("-no-pie -o" `T.isInfixOf`) driverInvocations + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && sawMetadataProbe + && sawAssemblyProbe + && sawLinkProbe + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "sawMetadataProbe: " <> T.pack (show sawMetadataProbe) + , "sawAssemblyProbe: " <> T.pack (show sawAssemblyProbe) + , "sawLinkProbe: " <> T.pack (show sawLinkProbe) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsSymlinkLinkProbeDriverMsg ok details + +runAsmAcceptsMarkerStrippedFinalOutputTest :: IO (Either T.Text T.Text, String) +runAsmAcceptsMarkerStrippedFinalOutputTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , "tmp.err" + , fakeMarkerStrippingFinalLinkDriverPath + , fakeMarkerStrippingFinalLinkDriverLogPath + ]) + $ do + htccCmd <- htccCommand + writeMarkerStrippingFinalLinkDriver + fakeMarkerStrippingFinalLinkDriverPath + fakeMarkerStrippingFinalLinkDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeMarkerStrippingFinalLinkDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + driverInvocations <- T.lines <$> T.readFile fakeMarkerStrippingFinalLinkDriverLogPath + targetMode <- if targetExists then permissionBits . fileMode <$> getFileStatus "tmp" else pure 0 + let succeeded = exitCode (const False) True result + sawProbeLink = + any + (\line -> + "-no-pie -o" `T.isInfixOf` line + && "htcc-probe-" `T.isInfixOf` line + ) + driverInvocations + sawFinalLink = + any + (\line -> + "-no-pie -o" `T.isInfixOf` line + && "tmp.htcc-" `T.isInfixOf` line + ) + driverInvocations + targetIsExecutable = + intersectFileModes targetMode ownerExecuteMode /= 0 + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && targetExists + && targetIsExecutable + && sawProbeLink + && sawFinalLink + let details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "targetExists: " <> T.pack (show targetExists) + , "targetIsExecutable: " <> T.pack (show targetIsExecutable) + , "sawProbeLink: " <> T.pack (show sawProbeLink) + , "sawFinalLink: " <> T.pack (show sawFinalLink) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmAcceptsMarkerStrippedFinalOutputMsg ok details + +runAsmRejectsBogusFinalLinkOutputTest :: IO (Either T.Text T.Text, String) +runAsmRejectsBogusFinalLinkOutputTest = + flip finally + (clean + [ "tmp-final-link.out" + , "tmp.out" + , "tmp.err" + , fakeBogusFinalLinkDriverPath + , fakeBogusFinalLinkDriverLogPath + , fakeBogusFinalLinkTargetPath + ]) + $ do + htccCmd <- htccCommand + writeBogusFinalLinkDriver + fakeBogusFinalLinkDriverPath + fakeBogusFinalLinkDriverLogPath + fakeBogusFinalLinkTargetPath + T.writeFile "tmp-final-link.out" "#!/bin/sh\nexit 99\n" + setFileMode "tmp-final-link.out" permissionFileModeMask + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeBogusFinalLinkDriverPath + , " " + , htccCmd + , " -r -o tmp-final-link.out /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp-final-link.out" + driverInvocations <- T.lines <$> T.readFile fakeBogusFinalLinkDriverLogPath + targetContents <- if targetExists then T.readFile "tmp-final-link.out" else pure "" + targetRunResult <- if targetExists then Just <$> exec "./tmp-final-link.out" else pure Nothing + let failed = exitCode (const True) False result + hasExpectedError = + "non-runnable final output for -r" `T.isInfixOf` stderrOut + sawProbeLink = any ("-no-pie -o" `T.isInfixOf`) $ + filter ("htcc-probe-" `T.isInfixOf`) driverInvocations + sawFinalLink = + any + (\line -> + "-no-pie -o" `T.isInfixOf` line + && "tmp-final-link.out.htcc-" `T.isInfixOf` line + ) + driverInvocations + preservedTarget = targetContents == "#!/bin/sh\nexit 99\n" + targetStillRuns = maybe False (exitCode (== 99) False) targetRunResult + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && targetExists + && preservedTarget + && targetStillRuns + && sawProbeLink + && sawFinalLink + let details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "targetExists: " <> T.pack (show targetExists) + , "preservedTarget: " <> T.pack (show preservedTarget) + , "targetRunExitCode: " <> maybe "not-run" (T.pack . show) targetRunResult + , "sawProbeLink: " <> T.pack (show sawProbeLink) + , "sawFinalLink: " <> T.pack (show sawFinalLink) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsBogusFinalLinkOutputMsg ok details + +runAsmRejectsExecutableObjectProbeDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsExecutableObjectProbeDriverTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , "tmp.err" + , fakeExecutableObjectProbeDriverPath + , fakeExecutableObjectProbeDriverLogPath + ]) + $ do + htccCmd <- htccCommand + writeExecutableObjectProbeDriver + fakeExecutableObjectProbeDriverPath + fakeExecutableObjectProbeDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeExecutableObjectProbeDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + driverInvocations <- T.lines <$> T.readFile fakeExecutableObjectProbeDriverLogPath + let failed = exitCode (const True) False result + hasExpectedError = + "HTCC_ASSEMBLER must target x86_64-ELF for -r" `T.isInfixOf` stderrOut + && "non-relocatable x86_64-ELF file" `T.isInfixOf` stderrOut + sawMetadataProbe = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + driverInvocations + sawAssemblyProbe = any ("-x assembler -c -o" `T.isInfixOf`) driverInvocations + sawLinkProbe = any ("-no-pie -o" `T.isInfixOf`) driverInvocations + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && sawMetadataProbe + && sawAssemblyProbe + && not sawLinkProbe + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "sawMetadataProbe: " <> T.pack (show sawMetadataProbe) + , "sawAssemblyProbe: " <> T.pack (show sawAssemblyProbe) + , "sawLinkProbe: " <> T.pack (show sawLinkProbe) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsExecutableObjectProbeDriverMsg ok details + +runAsmRejectsSymlinkObjectProbeDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsSymlinkObjectProbeDriverTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , "tmp.err" + , fakeSymlinkObjectProbeDriverPath + , fakeSymlinkObjectProbeDriverLogPath + , fakeSymlinkObjectProbeTargetPath + ]) + $ do + htccCmd <- htccCommand + writeSymlinkObjectProbeDriver + fakeSymlinkObjectProbeDriverPath + fakeSymlinkObjectProbeDriverLogPath + fakeSymlinkObjectProbeTargetPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeSymlinkObjectProbeDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + driverInvocations <- T.lines <$> T.readFile fakeSymlinkObjectProbeDriverLogPath + let failed = exitCode (const True) False result + hasExpectedError = + "failed an x86_64-ELF assembly probe for -r" `T.isInfixOf` stderrOut + sawMetadataProbe = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + driverInvocations + sawAssemblyProbe = any ("-x assembler -c -o" `T.isInfixOf`) driverInvocations + sawLinkProbe = any ("-no-pie -o" `T.isInfixOf`) driverInvocations + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && sawMetadataProbe + && sawAssemblyProbe + && not sawLinkProbe + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "sawMetadataProbe: " <> T.pack (show sawMetadataProbe) + , "sawAssemblyProbe: " <> T.pack (show sawAssemblyProbe) + , "sawLinkProbe: " <> T.pack (show sawLinkProbe) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsSymlinkObjectProbeDriverMsg ok details + +runAsmRejectsTouchingLinkDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsTouchingLinkDriverTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeTouchingLinkDriverPath, fakeTouchingLinkDriverLogPath]) $ do + htccCmd <- htccCommand + writeTouchingLinkDriver fakeTouchingLinkDriverPath fakeTouchingLinkDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeTouchingLinkDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + driverInvocations <- T.lines <$> T.readFile fakeTouchingLinkDriverLogPath + let failed = exitCode (const True) False result + hasExpectedError = + "failed a link probe for -r" `T.isInfixOf` stderrOut + && "supports both assembly and linking for -r" `T.isInfixOf` stderrOut + sawMetadataProbe = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + driverInvocations + sawAssemblyProbe = any ("-x assembler -c -o" `T.isInfixOf`) driverInvocations + sawLinkProbe = any ("-no-pie -o" `T.isInfixOf`) driverInvocations + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && sawMetadataProbe + && sawAssemblyProbe + && sawLinkProbe + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "sawMetadataProbe: " <> T.pack (show sawMetadataProbe) + , "sawAssemblyProbe: " <> T.pack (show sawAssemblyProbe) + , "sawLinkProbe: " <> T.pack (show sawLinkProbe) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsTouchingLinkDriverMsg ok details + +runAsmRejectsIncompatibleTargetDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsIncompatibleTargetDriverTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeHostDriverPath, fakeHostDriverLogPath]) $ do + htccCmd <- htccCommand + writeHostTargetDriver fakeHostDriverPath fakeHostDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeHostDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + driverArgs <- T.lines <$> T.readFile fakeHostDriverLogPath + let failed = exitCode (const True) False result + hasExpectedError = "HTCC_ASSEMBLER must target x86_64-ELF for -r" `T.isInfixOf` stderrOut + sawMetadataProbe = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + driverArgs + sawAssemblyProbe = + any + (\line -> + "-x assembler -c -o" `T.isInfixOf` line + ) + driverArgs + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && not targetExists + && sawMetadataProbe + && sawAssemblyProbe + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverArgs:" + , T.unlines driverArgs + , "targetExists: " <> T.pack (show targetExists) + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "sawMetadataProbe: " <> T.pack (show sawMetadataProbe) + , "sawAssemblyProbe: " <> T.pack (show sawAssemblyProbe) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsIncompatibleTargetDriverMsg ok details + +runAsmRejectsMetadataSpoofingDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsMetadataSpoofingDriverTest = + flip finally (clean ["tmp", "tmp.out", "tmp.err", fakeSpoofedTargetDriverPath, fakeSpoofedTargetDriverLogPath]) $ do + htccCmd <- htccCommand + writeMetadataSpoofingDriver fakeSpoofedTargetDriverPath fakeSpoofedTargetDriverLogPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeSpoofedTargetDriverPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + driverInvocations <- T.lines <$> T.readFile fakeSpoofedTargetDriverLogPath + let failed = exitCode (const True) False result + hasExpectedError = "HTCC_ASSEMBLER must target x86_64-ELF for -r" `T.isInfixOf` stderrOut + detectedNonElfObject = "non-ELF object file" `T.isInfixOf` stderrOut + sawMetadataProbe = any (`elem` ["-dumpmachine", "-print-target-triple"]) driverInvocations + sawAssemblyProbe = any ("-x assembler -c -o" `T.isInfixOf`) driverInvocations + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && detectedNonElfObject + && sawMetadataProbe + && sawAssemblyProbe + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "driverInvocations:" + , T.unlines driverInvocations + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "detectedNonElfObject: " <> T.pack (show detectedNonElfObject) + , "sawMetadataProbe: " <> T.pack (show sawMetadataProbe) + , "sawAssemblyProbe: " <> T.pack (show sawAssemblyProbe) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsMetadataSpoofingDriverMsg ok details + +runAsmRejectsWrappedNonElfDriverTest :: IO (Either T.Text T.Text, String) +runAsmRejectsWrappedNonElfDriverTest = + flip finally + (clean + [ "tmp" + , "tmp.out" + , "tmp.err" + , fakeProbeHostAssemblerPath + , fakeProbeHostAssemblerLogPath + , fakeProbeHostAssemblerAsmPath + , fakeProbeHostWrapperPath + , fakeProbeHostWrapperLogPath + ] + ) $ do + htccCmd <- htccCommand + writeFakeAssemblerWithTarget + "x86_64-w64-mingw32" + fakeProbeHostAssemblerLogPath + fakeProbeHostAssemblerAsmPath + fakeProbeHostAssemblerPath + writeProbeRejectingWrapper fakeProbeHostWrapperPath fakeProbeHostWrapperLogPath fakeProbeHostAssemblerPath + result <- exec $ mconcat + [ "echo '" + , source + , "' | " + , "HTCC_ASSEMBLER=./" + , T.pack fakeProbeHostWrapperPath + , " " + , htccCmd + , " -r -o tmp /dev/stdin > tmp.out 2> tmp.err" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist "tmp" + wrapperArgs <- T.lines <$> T.readFile fakeProbeHostWrapperLogPath + assemblerArgs <- T.lines <$> T.readFile fakeProbeHostAssemblerLogPath + let failed = exitCode (const True) False result + hasExpectedError = "HTCC_ASSEMBLER must target x86_64-ELF for -r" `T.isInfixOf` stderrOut + detectedNonElfObject = "non-ELF object file" `T.isInfixOf` stderrOut + sawProbeAttempt = + any + (\line -> + "-dumpmachine" `T.isInfixOf` line + || "-print-target-triple" `T.isInfixOf` line + ) + wrapperArgs + sawProbeAssemble = + all (`elem` assemblerArgs) + [ "-x" + , "assembler" + , "-c" + , "-o" + ] + ok = + failed + && T.null stdoutLeak + && hasExpectedError + && detectedNonElfObject + && sawProbeAttempt + && sawProbeAssemble + && not targetExists + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "wrapperArgs:" + , T.unlines wrapperArgs + , "assemblerArgs:" + , T.unlines assemblerArgs + , "hasExpectedError: " <> T.pack (show hasExpectedError) + , "detectedNonElfObject: " <> T.pack (show detectedNonElfObject) + , "sawProbeAttempt: " <> T.pack (show sawProbeAttempt) + , "sawProbeAssemble: " <> T.pack (show sawProbeAssemble) + , "targetExists: " <> T.pack (show targetExists) + , "exitCode: " <> T.pack (show result) + ] + return $ mkResult runAsmRejectsWrappedNonElfDriverMsg ok details + +runAsmFreshOutputRestrictiveUmaskTest :: IO (Either T.Text T.Text, String) +runAsmFreshOutputRestrictiveUmaskTest = + flip finally (clean ["tmp-umask-bin", "tmp.out", "tmp.err", fakeAssemblerPath, fakeAssemblerLogPath, fakeAssemblerAsmPath]) $ do + htccCmd <- htccCommand + let target = "tmp-umask-bin" + expectedMode = foldr1 unionFileModes + [ ownerReadMode + , groupReadMode + , otherReadMode + , ownerExecuteMode + ] + writeFakeAssembler fakeAssemblerPath + result <- exec $ mconcat + [ "sh -c \"umask 0222; echo '" + , source + , "' | HTCC_ASSEMBLER=./tmp-assembler.sh " + , htccCmd + , " -r -o " + , T.pack target + , " /dev/stdin > tmp.out 2> tmp.err\"" + ] + stdoutLeak <- T.readFile "tmp.out" + stderrOut <- T.readFile "tmp.err" + targetExists <- doesFileExist target + replacedMode <- if targetExists then fileMode <$> getFileStatus target else pure 0 + let replacedPermissions = permissionBits replacedMode + programResult <- if targetExists then Just <$> exec "./tmp-umask-bin" else pure Nothing + let succeeded = exitCode (const False) True result + ranOk = maybe False (exitCode (const False) True) programResult + ok = + succeeded + && T.null stdoutLeak + && T.null stderrOut + && targetExists + && replacedPermissions == expectedMode + && ranOk + details = T.unlines + [ "stdout:" + , stdoutLeak + , "stderr:" + , stderrOut + , "targetExists: " <> T.pack (show targetExists) + , "replacedMode: " <> T.pack (show replacedMode) + , "replacedPermissions: " <> T.pack (show replacedPermissions) + , "expectedMode: " <> T.pack (show expectedMode) + , "compileExitCode: " <> T.pack (show result) + , "runExitCode: " <> maybe "not-run" (T.pack . show) programResult + ] + return $ mkResult runAsmFreshOutputRestrictiveUmaskMsg ok details diff --git a/test/Tests/SubProcTests/LinkFuncRet.hs b/test/Tests/SubProcTests/LinkFuncRet.hs index ed085dd..e939dfc 100644 --- a/test/Tests/SubProcTests/LinkFuncRet.hs +++ b/test/Tests/SubProcTests/LinkFuncRet.hs @@ -11,19 +11,20 @@ import Tests.Utils test :: String -> [String] -> IO (Int, String) test x fnames = let obj = map (++".o") fnames in flip finally (clean $ ["tmp", "tmp.s"] ++ obj) $ do + htccCmd <- htccCommand + linkCmd <- assemblerCommand $ obj ++ ["tmp.s", "-o", "tmp"] execErrFin $ mconcat [ "echo \'" , T.pack x - , "\' | stack exec htcc -- /dev/stdin > tmp.s" - ] - forM_ fnames $ \fname -> execErrFin $ mconcat - [ "cc -c test/Tests/csrc/externals/" - , T.pack fname - , ".c" - ] - execErrFin $ mconcat - [ "gcc " - , T.pack (unwords obj) - , " tmp.s -o tmp" + , "\' | " + , htccCmd + , " /dev/stdin > tmp.s" ] + forM_ fnames $ \fname -> + assemblerCommand + [ "-c" + , "test/Tests/csrc/externals/" <> fname <> ".c" + ] + >>= execErrFin + execErrFin linkCmd exitCode (,x) (0, x) <$> exec "./tmp" diff --git a/test/Tests/SubProcTests/LinkFuncStdOut.hs b/test/Tests/SubProcTests/LinkFuncStdOut.hs index 933a7b8..d8ed3f1 100644 --- a/test/Tests/SubProcTests/LinkFuncStdOut.hs +++ b/test/Tests/SubProcTests/LinkFuncStdOut.hs @@ -12,20 +12,21 @@ import Tests.Utils test :: String -> [String] -> IO (Either T.Text T.Text, String) test x fnames = let obj = map (++".o") fnames in flip finally (clean $ ["tmp", "tmp.s"] ++ obj) $ do + htccCmd <- htccCommand + linkCmd <- assemblerCommand $ obj ++ ["tmp.s", "-o", "tmp"] execErrFin $ mconcat [ "echo \'" , T.pack x - , "\' | stack exec htcc -- /dev/stdin > tmp.s" + , "\' | " + , htccCmd + , " /dev/stdin > tmp.s" ] - forM_ fnames $ \fname -> execErrFin $ mconcat - [ "cc -c test/Tests/csrc/externals/" - , T.pack fname - , ".c" - ] - execErrFin $ mconcat - [ "gcc " - , T.pack (unwords obj) - , " tmp.s -o tmp" - ] - maybe (Left "The command did not execute successfully", x) ((, x) . Right) + forM_ fnames $ \fname -> + assemblerCommand + [ "-c" + , "test/Tests/csrc/externals/" <> fname <> ".c" + ] + >>= execErrFin + execErrFin linkCmd + maybe (Left "The command did not execute successfully", x) ((, x) . Right) <$> execStdOut "./tmp" diff --git a/test/Tests/SubProcTests/StatementEqual.hs b/test/Tests/SubProcTests/StatementEqual.hs index 9f5883f..2b9419d 100644 --- a/test/Tests/SubProcTests/StatementEqual.hs +++ b/test/Tests/SubProcTests/StatementEqual.hs @@ -9,12 +9,17 @@ import Tests.Utils test :: String -> IO (Int, String) test x = flip finally (clean ["tmp"]) $ do + htccCmd <- htccCommand + asmCmd <- assemblerCommand ["-no-pie", "-x", "assembler", "-o", "tmp", "-"] execErrFin $ mconcat [ "echo '" , T.pack x - , "' | stack exec htcc -- /dev/stdin | gcc -no-pie -xassembler -o tmp -" + , "' | " + , htccCmd + , " /dev/stdin | " + , asmCmd ] exec "./tmp" - >>= exitCode - (\ec -> (ec, x) <$ (putStr x *> putStrLn " [Compiling]")) + >>= exitCode + (\ec -> (ec, x) <$ (putStr x *> putStrLn " [Compiling]")) (return (0, x)) diff --git a/test/Tests/Utils.hs b/test/Tests/Utils.hs index f7557d4..6c86685 100644 --- a/test/Tests/Utils.hs +++ b/test/Tests/Utils.hs @@ -9,28 +9,46 @@ module Tests.Utils ( , exec , execStdOut , execErrFin + , assemblerCommand + , assemblerCommandPrefix + , htccCommand , clean ) where import qualified Control.Foldl as F import Control.Monad (void, when, zipWithM) import Data.Bool (bool) +import Data.Char (isAlpha, isAlphaNum, isSpace) import Data.Functor ((<&>)) import qualified Data.Text as DT import System.Directory (doesDirectoryExist, doesFileExist, + executable, getPermissions, removeDirectoryRecursive, removeFile) +import System.Environment (lookupEnv) +import System.FilePath (searchPathSeparator, ()) import Test.Hspec (parallel) import Test.Hspec.Contrib.HUnit (fromHUnitTest) import Test.Hspec.Core.Runner (Config (..), defaultConfig, evaluateSummary, runSpec) import Test.HUnit (Test (..), (~:), (~?=)) +import qualified Text.Parsec as Parsec import qualified Turtle as T cfg :: Config cfg = defaultConfig { configPrintCpuTime = True } +data CompilerCommand = CompilerCommand + { compilerEnvOverrides :: [(String, String)] + , compilerExecutable :: FilePath + , compilerArguments :: [String] + } + runTests :: Test -> IO () -runTests ts = runSpec (parallel $ fromHUnitTest ts) cfg +runTests ts = runSpec (parallel $ fromHUnitTest ts) cfg + >>= evaluateSummary + +runTestsSequential :: Test -> IO () +runTestsSequential ts = runSpec (fromHUnitTest ts) cfg >>= evaluateSummary exitCode :: (Int -> a) -> a -> T.ExitCode -> a @@ -41,22 +59,169 @@ exec :: T.MonadIO m => DT.Text -> m T.ExitCode exec = flip T.shell T.empty execStdOut :: T.MonadIO m => DT.Text -> m (Maybe T.Text) -execStdOut cmd = fmap T.lineToText +execStdOut cmd = fmap T.lineToText <$> T.fold (T.inshell cmd T.empty) F.head execErrFin :: T.MonadIO m => DT.Text -> m () execErrFin cmd = T.shell cmd T.empty >>= exitCode (\x -> void $ T.die (cmd <> " failed with exit code: " <> T.repr x)) (return ()) +htccCommand :: IO DT.Text +htccCommand = maybe "stack exec htcc --" DT.pack <$> lookupEnv "HTCC_BIN" + +assemblerCommand :: [String] -> IO DT.Text +assemblerCommand args = + renderShellWords . (++ args) <$> resolvedAssemblerWords + +assemblerCommandPrefix :: IO DT.Text +assemblerCommandPrefix = + renderShellWords <$> resolvedAssemblerWords + runTestsEx :: (Eq a, Show a) => [(IO (a, String), a)] -> IO () runTestsEx ts = putStrLn "\n\n== Unit Tests started ==" *> zipWithM f ts ms - >>= runTests . TestList + >>= runTestsSequential . TestList where ms = take (length ts) $ iterate (+1) (1 :: Int) - f (t, e) i = t + f (t, e) i = t <&> \(ec, t') -> (~:) ("test: #" ++ show i ++ ": " ++ t' ++ "\"") $ (~?= e) ec clean :: [FilePath] -> IO () clean = mapM_ $ \x -> (>>=) (doesFileExist x) $ flip bool (removeFile x) $ doesDirectoryExist x >>= flip when (removeDirectoryRecursive x) + +resolvedAssemblerWords :: IO [String] +resolvedAssemblerWords = do + compiler <- resolveCompilerCommand =<< resolveAssemblerSpec + pure $ + map (\(name, value) -> name <> "=" <> value) (compilerEnvOverrides compiler) + <> [compilerExecutable compiler] + <> compilerArguments compiler + +resolveAssemblerSpec :: IO String +resolveAssemblerSpec = + pure . maybe "gcc" id . nonEmptyEnv =<< lookupEnv "HTCC_ASSEMBLER" + +nonEmptyEnv :: Maybe String -> Maybe String +nonEmptyEnv (Just s) | all isSpace s = Nothing +nonEmptyEnv x = x + +renderShellWords :: [String] -> DT.Text +renderShellWords = DT.unwords . map shellQuote + +shellQuote :: String -> DT.Text +shellQuote word = "'" <> DT.replace "'" "'\"'\"'" (DT.pack word) <> "'" + +shellWords :: String -> Either String [String] +shellWords commandLine = + either (Left . show) Right $ Parsec.parse shellParser "" commandLine + where + shellParser = skipSpaces *> Parsec.sepEndBy word spaces <* Parsec.eof + skipSpaces = Parsec.skipMany $ Parsec.satisfy isSpace + spaces = Parsec.skipMany1 $ Parsec.satisfy isSpace + word = concat <$> Parsec.many1 chunk + chunk = Parsec.choice [singleQuoted, doubleQuoted, escaped, bare] + singleQuoted = Parsec.char '\'' *> Parsec.manyTill Parsec.anyChar (Parsec.char '\'') + doubleQuoted = concat <$> (Parsec.char '"' *> Parsec.manyTill doubleChunk (Parsec.char '"')) + doubleChunk = Parsec.choice [doubleEscaped, pure <$> Parsec.noneOf "\""] + doubleEscaped = do + _ <- Parsec.char '\\' + c <- Parsec.anyChar + pure $ case c of + '\\' -> "\\" + '"' -> "\"" + '`' -> "`" + '$' -> "$" + '\n' -> "" + _ -> ['\\', c] + escaped = Parsec.char '\\' *> (pure <$> Parsec.anyChar) + bare = Parsec.many1 $ Parsec.noneOf "'\"\\ \t\r\n" + +resolveCompilerCommand :: String -> IO CompilerCommand +resolveCompilerCommand compiler = do + parts <- case shellWords compiler of + Left parseErr -> ioError . userError $ + "failed to parse compiler command " <> show compiler <> ": " <> parseErr + Right [] -> ioError . userError $ + "empty compiler command: " <> show compiler + Right xs -> pure xs + let (envAssignments, compilerParts) = span isEnvironmentAssignmentWord parts + when (null compilerParts) . ioError . userError $ + "empty compiler command: " <> show compiler + let envOverrides = map splitEnvironmentAssignment envAssignments + resolvedPrefix <- findExecutablePrefix envOverrides compilerParts + pure $ + case resolvedPrefix of + Just (compilerLen, resolvedCompiler) -> + CompilerCommand + { compilerEnvOverrides = envOverrides + , compilerExecutable = resolvedCompiler + , compilerArguments = drop compilerLen compilerParts + } + Nothing -> + CompilerCommand + { compilerEnvOverrides = envOverrides + , compilerExecutable = head compilerParts + , compilerArguments = tail compilerParts + } + where + isEnvironmentAssignmentWord word = case span (/= '=') word of + ([], _) -> False + (name, '=':_) -> + let startsLikeIdentifier c = isAlpha c || c == '_' + in startsLikeIdentifier (head name) && all (\c -> isAlphaNum c || c == '_') name + _ -> False + + splitEnvironmentAssignment word = case span (/= '=') word of + (name, '=':value) -> (name, value) + _ -> error "internal compiler error" + + findExecutablePrefix _ [] = pure Nothing + findExecutablePrefix envOverrides' (cmd:_) = do + resolved <- resolveExecutableCommand envOverrides' cmd + pure $ fmap (\resolvedCmd -> (1, resolvedCmd)) resolved + + resolveExecutableCommand envOverrides' cmd = + if hasExplicitPath cmd + then localExecutablePath cmd + else + firstResolved $ + [findExecutableInSearchPath envOverrides' cmd] + <> [localExecutablePath cmd | not (hasOverriddenSearchPath envOverrides')] + + findExecutableInSearchPath envOverrides' cmd = do + pathValue <- maybe + (maybe "" id <$> lookupEnv "PATH") + pure + (lookup "PATH" envOverrides') + firstResolved $ + map (localExecutablePath . searchPathCommand cmd) $ + searchPathEntries pathValue + + searchPathCommand cmd "" = cmd + searchPathCommand cmd dir = dir cmd + + searchPathEntries pathValue = case break (== searchPathSeparator) pathValue of + (dir, []) -> [dir] + (dir, _:remain) -> dir : searchPathEntries remain + + localExecutablePath cmd = do + isLocalFile <- doesFileExist cmd + isLocalExec <- if isLocalFile then executable <$> getPermissions cmd else pure False + pure $ + if isLocalExec + then Just $ normalizeLocalExecutablePath cmd + else Nothing + + hasExplicitPath = any (`elem` ['/', '\\']) + + hasOverriddenSearchPath = any ((== "PATH") . fst) + + firstResolved [] = pure Nothing + firstResolved (resolvePath : resolvePaths) = do + resolved <- resolvePath + maybe (firstResolved resolvePaths) (pure . Just) resolved + + normalizeLocalExecutablePath cmd + | hasExplicitPath cmd = cmd + | otherwise = "./" <> cmd diff --git a/test/Tests/csrc/externals/test_bool_arg.c b/test/Tests/csrc/externals/test_bool_arg.c new file mode 100644 index 0000000..4cd274b --- /dev/null +++ b/test/Tests/csrc/externals/test_bool_arg.c @@ -0,0 +1,4 @@ +int test_bool_arg(_Bool x) +{ + return x; +} diff --git a/test/Tests/csrc/self/array/basic.c b/test/Tests/csrc/self/array/basic.c index c8f5ed8..0aa5870 100644 --- a/test/Tests/csrc/self/array/basic.c +++ b/test/Tests/csrc/self/array/basic.c @@ -7,7 +7,6 @@ int printf(); int exit(); int strcmp(char* p, char* q); int test_num; -int; int gr[3]; int (*gpa)[3]; diff --git a/test/Tests/csrc/self/array/string.c b/test/Tests/csrc/self/array/string.c index 629db25..e1fb1cb 100644 --- a/test/Tests/csrc/self/array/string.c +++ b/test/Tests/csrc/self/array/string.c @@ -33,8 +33,10 @@ int main() assert('e', ({ char s[] = "hoge"; s[3]; }), "({ char s[] = \"hoge\"; s[3]; })"); assert(0, ({ char s[] = "hoge"; s[4]; }), "({ char s[] = \"hoge\"; s[4]; })"); assert(0, ({ char s1[] = "hoge"; char s2[] = "hoge"; strcmp(s1, s2); }), "({ char s1[] = \"hoge\"; char s2[] = \"hoge\"; strcmp(s1, s2); })"); - assert(1, ({ char s1[] = "a"; char s2[] = "b"; 0 < strcmp(s1, s2); }), "({ char s1[] = \"a\"; char s2[] = \"b\"; 0 < strcmp(s1, s2); })"); + assert(0, ({ char s1[] = "a"; char s2[] = "b"; 0 < strcmp(s1, s2); }), "({ char s1[] = \"a\"; char s2[] = \"b\"; 0 < strcmp(s1, s2); })"); assert(5, ({ char s[] = "hoge"; sizeof s; }), "({ char s[] = \"hoge\"; sizeof s; })"); + assert(3, ({ char s[3] = "abc"; sizeof s; }), "({ char s[3] = \"abc\"; sizeof s; })"); + assert('c', ({ char s[3] = "abc"; s[2]; }), "({ char s[3] = \"abc\"; s[2]; })"); assert('a', ({ char str[2][4] = { "abc", "def" }; str[0][0]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][0]; })"); assert('b', ({ char str[2][4] = { "abc", "def" }; str[0][1]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][1]; })"); assert('c', ({ char str[2][4] = { "abc", "def" }; str[0][2]; }), "({ char str[2][4] = { \"abc\", \"def\" }; str[0][2]; })"); @@ -51,6 +53,8 @@ int main() assert('e', ({ char str[][4] = { "abc", "def" }; str[1][1]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[1][1]; })"); assert('f', ({ char str[][4] = { "abc", "def" }; str[1][2]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[1][2]; })"); assert(0, ({ char str[][4] = { "abc", "def" }; str[1][3]; }), "({ char str[][4] = { \"abc\", \"def\" }; str[1][3]; })"); + assert(3, ({ char str[][3] = { "abc" }; sizeof str[0]; }), "({ char str[][3] = { \"abc\" }; sizeof str[0]; })"); + assert('c', ({ char str[][3] = { "abc" }; str[0][2]; }), "({ char str[][3] = { \"abc\" }; str[0][2]; })"); assert(92, "\\"[0], "\"\\\\\"[0]"); printf("All tests are passed!\n"); diff --git a/test/Tests/csrc/self/expressions/cast.c b/test/Tests/csrc/self/expressions/cast.c index a5f22d3..30f2f75 100644 --- a/test/Tests/csrc/self/expressions/cast.c +++ b/test/Tests/csrc/self/expressions/cast.c @@ -24,10 +24,10 @@ int main() printf(">>>> tests: expressions/cast\n"); test_num = 1; - assert(4, sizeof((int)'a')); - assert(1, sizeof((char)42)); - assert(8, sizeof((int*)42)); - assert(8, sizeof((char*)42)); + assert(4, sizeof((int)'a'), "sizeof((int)'a')"); + assert(1, sizeof((char)42), "sizeof((char)42)"); + assert(8, sizeof((int*)42), "sizeof((int*)42)"); + assert(8, sizeof((char*)42), "sizeof((char*)42)"); printf("All tests are passed!\n"); return 0; diff --git a/test/Tests/csrc/self/expressions/operators.c b/test/Tests/csrc/self/expressions/operators.c index 8ca2e0f..0a13513 100644 --- a/test/Tests/csrc/self/expressions/operators.c +++ b/test/Tests/csrc/self/expressions/operators.c @@ -115,8 +115,8 @@ int main() assert(1, ({ int a = 1; sizeof(a = 2); a; }), "({ int a = 1; sizeof(a = 2); a; })"); assert(24, ({ char* x[3]; sizeof x; }), "({ char* x[3]; sizeof x; })"); assert(8, ({ char (*x)[3]; sizeof x; }), "({ char (*x)[3]; sizeof x; })"); - assert(1, sizeof main, "sizeof main"); - assert(1, sizeof assert, "sizeof assert"); + assert(8, sizeof &main, "sizeof &main"); + assert(8, sizeof &assert, "sizeof &assert"); assert(8, sizeof(void (*)()), "sizeof(void (*)())"); assert(8, sizeof(int (*)(void)), "sizeof(int (*)(void))"); assert(8, sizeof(int (*)(int, int)), "sizeof(int (*)(int, int))");