Add GHC version info

Fix prettyprinter version conflict

.gitignore

@@ -21,3 +21,7 @@ cabal.project.local
 cabal.project.local~
 .HTF/
 .ghc.environment.*
+
+# Windows12 output files
+*.ll
+*.s

README.md

@@ -0,0 +1,23 @@
+# Windows12
+A C-like compiled programming language implemented in Haskell.
+
+## Usage
+Note: You must have version 9.0 of the Haskell compiler GHC installed. Otherwise
+Cabal will not be able to obtain the necessary dependencies.
+
+It is recommended to use the provided `shell.nix` file to create the proper
+environment. Alternatively, you can run the project from the supplied
+binaries in the [releases](https://gitea.mregirouard.com/eta357/Windows-12-Compiler/releases)
+section.
+
+```shell
+cabal run windows12 <input file> out.ll
+llc out.ll -o out.s
+gcc out.s -o out
+./out
+```
+
+## Running Tests
+```shell
+cabal run windows12-qc
+```

cabal.project

@@ -0,0 +1,7 @@
+-- Needed to get a working version of llvm-hs-pretty
+-- The one on hackage is broken with this version of GHC
+source-repository-package
+    type: git
+    location: https://github.com/rumkeller/llvm-hs-pretty.git
+
+packages: ./windows12.cabal

shell.nix

@@ -0,0 +1,10 @@
+let
+  pkgs = import <nixpkgs> {};
+in
+pkgs.mkShell {
+  buildInputs = [
+    pkgs.haskell.compiler.ghc90
+    pkgs.cabal-install
+    pkgs.llvm_18
+  ];
+}

src/Main.hs

@@ -3,13 +3,31 @@
 module Main where
 
 import qualified Data.Text.IO as T
-import Prettyprinter
+import qualified Data.Text.Lazy.IO as TL
+import Data.Text.Lazy (toStrict, unpack)
+import Data.String.Conversions (cs)
+import Data.Text.Prettyprint.Doc (pretty)
 import Text.Megaparsec (parse)
 import Windows12.Parser (programP)
+import System.Environment (getArgs)
+import LLVM.Pretty
+import Windows12.Ast
+import Windows12.Semant (convert)
+import Windows12.CodeGen (codegen)
+
 
 main :: IO ()
 main = do
-  test <- T.readFile "test/hello.w12"
-  case parse programP "test/hello.w12" test of
-    Left err -> print err
-    Right ast -> print (pretty ast)
+  args <- getArgs
+
+  if length args /= 2
+    then putStrLn "Usage: windows12 <input file> <output file>"
+    else do
+      let [inputFile, outputFile] = args
+      test <- T.readFile inputFile
+      case parse programP inputFile test of
+        Left err -> print err
+        Right ast ->
+          case convert ast of
+            Left err -> putStrLn err
+            Right ast -> TL.writeFile outputFile (ppllvm (codegen (cs inputFile) ast))

src/QuickCheckTests.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Test.QuickCheck
+
+import Windows12.Ast
+import Windows12.Parser (programP)
+import Text.Megaparsec (parse)
+
+import Data.String.Conversions (cs)
+
+import Data.Text
+import Data.Text.Internal
+import Data.Text.Prettyprint.Doc (pretty)
+
+main :: IO ()
+main = quickCheck prop_print_parse
+
+-- Ensure that pretty-printing and parsing are inverses
+prop_print_parse :: Program -> Bool
+prop_print_parse p = Right p == (parse programP "" (cs (show (pretty p))))
+
+instance Arbitrary Data.Text.Internal.Text where
+  arbitrary = listOf1 (elements ['a'..'z']) >>= return . Data.Text.pack
+
+instance Arbitrary BinOp where
+  arbitrary = elements [Add, Sub, Mul, Div, Mod, Eq, Ne, Lt, Gt, Le, Ge, And, Or,
+    BitAnd, BitOr, BitXor, ShiftL, ShiftR]
+
+instance Arbitrary UnOp where
+  arbitrary = elements [Neg, Not, BitNot]
+
+instance Arbitrary AssignOp where
+  arbitrary = elements [BaseAssign, AddAssign, SubAssign, MulAssign, DivAssign,
+    ModAssign, BitAndAssign, BitOrAssign, BitXorAssign, ShiftLAssign, ShiftRAssign]
+
+instance Arbitrary Expr where
+  arbitrary = oneof
+    [ Id <$> arbitrary
+    , IntLit <$> arbitrary
+    , UIntLit <$> arbitrary
+    , FloatLit <$> arbitrary
+    , StrLit <$> arbitrary
+    , BoolLit <$> arbitrary
+    , CharLit <$> arbitrary
+    , BinOp <$> arbitrary <*> arbitrary <*> arbitrary
+    , UnOp <$> arbitrary <*> arbitrary
+    , Call <$> arbitrary <*> arbitrary
+    , Index <$> arbitrary <*> arbitrary
+    , Member <$> arbitrary <*> arbitrary
+    , Cast <$> arbitrary <*> arbitrary
+    , Sizeof <$> arbitrary
+    , StructInit <$> arbitrary <*> arbitrary
+    ]
+
+instance Arbitrary Stmt where
+  arbitrary = oneof
+    [ Expr <$> arbitrary
+    , Return <$> arbitrary
+    , If <$> arbitrary <*> arbitrary <*> arbitrary
+    , While <$> arbitrary <*> arbitrary
+    , Assign <$> arbitrary <*> arbitrary <*> arbitrary
+    , Block <$> arbitrary
+    , Var <$> arbitrary <*> arbitrary <*> arbitrary
+    ]
+
+-- Massively simplified types: No pointers, void, structs, enums
+instance Arbitrary Type where
+    arbitrary = elements [IntType, UIntType, FloatType, StrType, BoolType,
+      CharType, PtrType IntType, ArrayType IntType]
+
+instance Arbitrary Bind where
+    arbitrary = Bind <$> arbitrary <*> arbitrary
+
+instance Arbitrary TLStruct where
+    arbitrary = Struct <$> arbitrary <*> arbitrary
+
+-- ensure the enum has at least one field
+instance Arbitrary TLEnum where
+    arbitrary = Enum <$> arbitrary <*> listOf1 arbitrary
+
+instance Arbitrary TLFunc where
+    arbitrary = Func <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary TL where
+    arbitrary = oneof
+      [ TLStruct <$> arbitrary
+      , TLEnum <$> arbitrary
+      , TLFunc <$> arbitrary
+      ]
+
+instance Arbitrary Program where
+    arbitrary = Program <$> arbitrary <*> arbitrary <*> arbitrary

src/Windows12.hs

@@ -3,3 +3,6 @@ module Windows12 where
 import Windows12.Ast
 import Windows12.Lexer
 import Windows12.Parser
+import Windows12.CodeGen
+import Windows12.TAst
+import Windows12.Semant

src/Windows12/Ast.hs

@@ -3,7 +3,7 @@
 module Windows12.Ast where
 
 import Data.Text (Text)
-import Prettyprinter
+import Data.Text.Prettyprint.Doc
 
 data BinOp
   = Add
@@ -192,14 +192,14 @@ instance Pretty Bind where
   pretty (Bind n t) = pretty n <+> ":" <+> pretty t
 
 instance Pretty TLStruct where
-  pretty (Struct n fields) = "struct" <+> pretty n <+> prettyBlock fields
+  pretty (Struct n fields) = "struct" <+> pretty n <+> prettyFields fields
 
 instance Pretty TLEnum where
-  pretty (Enum n fields) = "enum" <+> pretty n <+> prettyBlock fields
+  pretty (Enum n fields) = "enum" <+> pretty n <+> prettyFields fields
 
 instance Pretty TLFunc where
   pretty (Func n args ret body) =
-    pretty n <> parens (hsep (punctuate comma (map pretty args))) <+> "->" <+> pretty ret <+> prettyBlock body
+    "fn " <> pretty n <> parens (hsep (punctuate comma (map pretty args))) <+> "->" <+> pretty ret <+> prettyBlock body
 
 instance Pretty TL where
   pretty (TLStruct s) = pretty s
@@ -209,5 +209,8 @@ instance Pretty TL where
 instance Pretty Program where
   pretty (Program structs enums funcs) = vsep (map pretty structs) <> line <> vsep (map pretty enums) <> line <> vsep (map pretty funcs)
 
+prettyFields :: (Pretty a) => [a] -> Doc ann
+prettyFields fields = lbrace <> line <> indent 4 (vsep (punctuate comma (map pretty fields))) <> line <> rbrace
+
 prettyBlock :: (Pretty a) => [a] -> Doc ann
 prettyBlock stmts = lbrace <> line <> indent 4 (vsep (map pretty stmts)) <> line <> rbrace

src/Windows12/CodeGen.hs

@@ -0,0 +1,346 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Windows12.CodeGen where
+
+import Windows12.Ast (BinOp(..), UnOp(..), AssignOp(..), Type(..),
+    Bind(..), TLStruct(..), TLEnum(..))
+import Windows12.TAst
+
+import LLVM.AST hiding (ArrayType, VoidType, Call, function)
+import LLVM.AST.Type (i32, i1, i8, double, ptr, void)
+import qualified LLVM.AST.Constant as C
+import LLVM.IRBuilder hiding (double, IRBuilder, ModuleBuilder)
+import LLVM.AST.Typed (typeOf)
+import LLVM.Prelude (ShortByteString)
+
+import qualified LLVM.AST.IntegerPredicate as IP
+import qualified LLVM.AST.FloatingPointPredicate as FP
+
+import Control.Monad.State hiding (void)
+
+import Data.Text (Text, unpack)
+import Data.String.Conversions
+import Data.String
+
+-- Global program context, used to keep track of operands
+data Ctx =  Ctx { operands :: [(Text, Operand)],
+                  structs :: [TLStruct],
+                  enums :: [TLEnum],
+                  strings :: [(Text, Operand)] }
+    deriving (Eq, Show)
+
+type ModuleBuilder = ModuleBuilderT (State Ctx)
+type IRBuilder = IRBuilderT ModuleBuilder
+
+-- Allow easy string conversion
+instance ConvertibleStrings Text ShortByteString where
+  convertString = Data.String.fromString . Data.Text.unpack
+
+-- Put an operand into the context with a name
+createOperand :: MonadState Ctx m => Text -> Operand -> m ()
+createOperand name op = do
+  ctx <- get
+  put $ ctx { operands = (name, op) : operands ctx }
+
+-- Take in a source file name, the AST, and return the LLVM IR module
+codegen :: Text -> TProgram -> Module
+codegen filename (TProgram structs enums funcs) = 
+    flip evalState (Ctx [] [] [] [])
+    $ buildModuleT (cs filename)
+    $ do
+        printf <- externVarArgs (mkName "printf") [ptr i8] i32
+        createOperand "printf" printf
+        mapM_ emitTypeDef structs
+        mapM_ codegenFunc funcs
+
+-- Given a struct name, search the context for the struct and return its fields
+getStructFields :: MonadState Ctx m => Text -> m [Bind]
+getStructFields name = do
+  ctx <- get
+  case filter (\(Struct n _) -> n == name) (structs ctx) of
+    [] -> error $ "Struct " ++ show name ++ " not found. Valid structs: " ++ show (map (\(Struct n _) -> n) (structs ctx))
+    [Struct _ fields] -> return fields
+    _ -> error $ "Multiple structs with name " ++ show name
+
+-- Convert a Windows12 type to an LLVM type
+convertType :: MonadState Ctx m => Windows12.Ast.Type -> m LLVM.AST.Type
+convertType IntType = return i32
+convertType UIntType = return i32
+convertType FloatType = return double
+convertType StrType = convertType (PtrType CharType)
+convertType BoolType = return i1
+convertType CharType = return i8
+convertType (PtrType t) = ptr <$> convertType t
+convertType (ArrayType t) = convertType (PtrType t)
+convertType (StructType name) = do
+  fields <- getStructFields name
+  types <- mapM (convertType . bindType) fields
+  return $ StructureType True types -- True indicates packed
+convertType (EnumType name) = return i32
+convertType VoidType = return void
+
+-- Get the size of a type in bytes
+size :: MonadState Ctx m => Windows12.Ast.Type -> m Int
+size IntType = return 4
+size UIntType = return 4
+size FloatType = return 8
+size StrType = size (PtrType CharType)
+size BoolType = return 1
+size CharType = return 1
+size (PtrType _) = return 4
+size (ArrayType t) = size (PtrType t)
+size (StructType name) = do
+  fields <- getStructFields name
+  sizes <- mapM (size . bindType) fields
+  return $ sum sizes
+size (EnumType _) = return 8
+size VoidType = return 0
+
+-- CodeGen for LValues
+codegenLVal :: TLVal -> IRBuilder Operand
+codegenLVal (t, (TId name)) = do
+  ctx <- get
+  case lookup name (operands ctx) of
+    Just op -> return op
+    Nothing -> error $ "Variable " ++ show name ++ " not found"
+
+-- TODO support members of members
+codegenLVal ((StructType t), (LTMember ((_, TId sName)) field)) = do
+    ctx <- get
+    case lookup sName (operands ctx) of
+        Just struct -> do
+            fields <- getStructFields t
+            offset <- structFieldOffset (Struct sName fields) field
+            gep struct [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 (fromIntegral offset))]
+        Nothing -> error $ "Struct " ++ show sName ++ " not found"
+
+codeGenLVal (t, (TDeref e)) = codegenExpr e
+
+codeGenLVal (t, _) = error "Unimplemented or invalid LValue"
+
+-- Given a struct and a field name, return the offset of the field in the struct.
+-- In LLVM each field is actually size 1
+structFieldOffset :: MonadState Ctx m => TLStruct -> Text -> m Int
+structFieldOffset (Struct name fields) field = do
+    return $ length $ takeWhile (\(Bind n _) -> n /= field) fields
+
+-- CodeGen for expressions
+codegenExpr :: TExpr -> IRBuilder Operand
+codegenExpr (t, (TVar name)) = flip load 0 =<< codegenLVal (t, (TId name))
+codegenExpr (t, (TIntLit i)) = return $ ConstantOperand (C.Int 32 (fromIntegral i))
+codegenExpr (t, (TUIntLit i)) = return $ ConstantOperand (C.Int 32 (fromIntegral i))
+codegenExpr (t, (TFloatLit f)) = undefined -- TODO floats
+codegenExpr (t, (TStrLit s)) = do
+    strs <- gets strings
+    case lookup s strs of
+        -- If the string is already in the context, return it
+        Just str -> return str
+        -- Otherwise, create a new global string and add it to the context
+        Nothing -> do
+            let str_name = mkName ("str." <> show (length strs))
+            op <- globalStringPtr (cs s) str_name
+            modify $ \ctx -> ctx { strings = (s, (ConstantOperand op)) : strs }
+            return (ConstantOperand op)
+codegenExpr (t, (TBoolLit b)) = return $ ConstantOperand (C.Int 1 (if b then 1 else 0))
+codegenExpr (t, (TCharLit c)) = return $ ConstantOperand (C.Int 8 (fromIntegral (fromEnum c)))
+
+codegenExpr (t, (TBinOp op lhs rhs)) = do
+    lhs' <- codegenExpr lhs
+    rhs' <- codegenExpr rhs
+
+    -- TODO pointers, floating points
+    case op of
+        Windows12.Ast.Add -> case (typeOf lhs', typeOf rhs') of
+            (IntegerType 32, IntegerType 32) -> add lhs' rhs'
+            _ -> error "Invalid types for add"
+        Windows12.Ast.Sub -> case (typeOf lhs', typeOf rhs') of
+            (IntegerType 32, IntegerType 32) -> sub lhs' rhs'
+            _ -> error "Invalid types for sub"
+        Windows12.Ast.Mul -> case (typeOf lhs', typeOf rhs') of
+            (IntegerType 32, IntegerType 32) -> mul lhs' rhs'
+            _ -> error "Invalid types for mul"
+        Windows12.Ast.Div -> case (typeOf lhs', typeOf rhs') of
+            (IntegerType 32, IntegerType 32) -> sdiv lhs' rhs'
+            _ -> error "Invalid types for div"
+        Windows12.Ast.Mod -> case (typeOf lhs', typeOf rhs') of
+            (IntegerType 32, IntegerType 32) -> srem lhs' rhs'
+            _ -> error "Invalid types for mod"
+        Windows12.Ast.Eq -> case (typeOf lhs', typeOf rhs') of
+            (IntegerType 32, IntegerType 32) -> icmp IP.EQ lhs' rhs'
+            _ -> error "Invalid types for eq"
+        Windows12.Ast.Ne -> case (typeOf lhs', typeOf rhs') of
+            (IntegerType 32, IntegerType 32) -> icmp IP.NE lhs' rhs'
+            _ -> error "Invalid types for ne"
+        Windows12.Ast.Lt -> case (typeOf lhs', typeOf rhs') of
+            (IntegerType 32, IntegerType 32) -> icmp IP.SLT lhs' rhs'
+            _ -> error "Invalid types for lt"
+        Windows12.Ast.Gt -> case (typeOf lhs', typeOf rhs') of
+            (IntegerType 32, IntegerType 32) -> icmp IP.SGT lhs' rhs'
+            _ -> error "Invalid types for gt"
+        Windows12.Ast.Le -> case (typeOf lhs', typeOf rhs') of
+            (IntegerType 32, IntegerType 32) -> icmp IP.SLE lhs' rhs'
+            _ -> error "Invalid types for le"
+        Windows12.Ast.Ge -> case (typeOf lhs', typeOf rhs') of
+            (IntegerType 32, IntegerType 32) -> icmp IP.SGE lhs' rhs'
+            _ -> error "Invalid types for ge"
+
+        other -> error $ "Operator " ++ show other ++ " not implemented"
+
+codegenExpr (t, (TUnOp op e)) = undefined -- TODO handle unary operators
+
+-- Function calls: look up the function in operands, then call it with the args
+codegenExpr (t, (TCall f args)) = do
+    ctx <- get
+    f <- case lookup f (operands ctx) of
+        Just f -> return f
+        Nothing -> error $ "Function " ++ show f ++ " not found"
+    args <- mapM (fmap (, []) . codegenExpr) args
+    call f args
+
+codegenExpr (t, (TIndex arr idx))  = undefined -- TODO arrays
+
+-- Get the address of the struct field and load it
+codegenExpr (t, (TMember ((StructType sName), (TVar sVarName)) m)) = do
+    ctx <- get
+    case lookup sVarName (operands ctx) of
+        Just struct -> do
+            fields <- getStructFields sName
+            offset <- structFieldOffset (Struct sVarName fields) m
+            addr <- gep struct [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 (fromIntegral offset))]
+            load addr 0
+        Nothing -> error $ "Struct operand " ++ show sVarName ++ " not found"
+
+codegenExpr (_, (TCast t e)) = undefined -- TODO casts
+
+codegenExpr (_, (TSizeof t)) = ConstantOperand . C.Int 32 . fromIntegral <$> size t
+
+mkTerminator :: IRBuilder () -> IRBuilder ()
+mkTerminator instr = do
+ check <- hasTerminator
+ unless check instr
+
+-- Codegen for statements
+codegenStmt :: TStmt -> IRBuilder ()
+
+-- For expression statements, just evaluate the expression and discard the result
+codegenStmt (TExprStmt e) = do
+    _expr <- codegenExpr e
+    return ()
+
+codegenStmt (TReturn e) = ret =<< codegenExpr e
+
+-- Generate if statements, with a merge block at the end
+codegenStmt (TIf cond t f) = mdo
+    cond' <- codegenExpr cond
+    condBr cond' then' else'
+
+    then' <- block `named` "then"
+    codegenStmt (TBlock t)
+    mkTerminator $ br merge
+
+    else' <- block `named` "else"
+    codegenStmt (case f of
+        Just f' -> TBlock f'
+        Nothing -> TBlock [])
+    mkTerminator $ br merge
+
+    merge <- block `named` "merge"
+    return ()
+
+-- Generate while loops, with a merge block at the end
+codegenStmt (TWhile cond body) = mdo
+    br condBlock
+    condBlock <- block `named` "cond"
+    cond' <- codegenExpr cond
+    condBr cond' loop end
+
+    loop <- block `named` "loop"
+    codegenStmt (TBlock body)
+    mkTerminator $ br condBlock
+
+    end <- block `named` "end"
+    return ()
+
+codegenStmt (TAssign BaseAssign l e) = do
+    op <- codegenExpr e
+    var <- codegenLVal l
+    store var 0 op
+
+codegenStmt (TAssign AddAssign l e) = do
+    op <- codegenExpr e
+    var <- codegenLVal l
+    val <- load var 0
+    store var 0 =<< add val op
+
+codegenStmt (TAssign SubAssign l e) = do
+    op <- codegenExpr e
+    var <- codegenLVal l
+    val <- load var 0
+    store var 0 =<< sub val op
+
+-- A block is just a list of statements
+codegenStmt (TBlock stmts) = mapM_ codegenStmt stmts
+
+-- Since the vars are already allocated by genBody, we just need to assign the value
+codegenStmt (TDeclVar name t (Just e)) = codegenStmt (TAssign BaseAssign (t, (TId name)) e)
+
+-- Do nothing with variable declaration if no expression is given
+-- This is because allocation is done already
+codegenStmt (TDeclVar name _ Nothing) = return ()
+
+codegenStmt s = error $ "Unimplemented or invalid statement " ++ show s
+
+-- Generate code for a function
+-- First create the function, then allocate space for the arguments and locals
+codegenFunc :: TTLFunc -> ModuleBuilder ()
+codegenFunc func@(TTLFunc name args retType body) = mdo
+    createOperand name f
+    (f, strs) <- do
+        params' <- mapM mkParam args
+        retType' <- convertType retType
+        f <- function (mkName (cs name)) params' retType' genBody
+        strs <- gets strings
+        return (f, strs)
+    modify $ \ctx -> ctx { strings = strs }
+  where
+    mkParam (Bind name t) = (,) <$> convertType t <*> pure (ParameterName (cs name))
+
+    genBody :: [Operand] -> IRBuilder ()
+    genBody ops = do
+        forM_ (zip ops args) $ \(op, (Bind name t)) -> do
+            addr <- alloca (typeOf op) Nothing 0
+            store addr 0 op
+            createOperand name addr
+
+        forM_ (getLocals func) $ \(Bind name t) -> do
+            ltype <- convertType t
+            addr <- alloca ltype Nothing 0
+            createOperand name addr
+
+        codegenStmt (TBlock body)
+
+-- Given a function, get all the local variables
+-- Used so allocation can be done before the function body
+getLocals :: TTLFunc -> [Bind]
+getLocals (TTLFunc _ args _ body) = blockGetLocals body
+
+blockGetLocals :: [TStmt] -> [Bind]
+blockGetLocals = concatMap stmtGetLocals
+
+stmtGetLocals :: TStmt -> [Bind]
+stmtGetLocals (TDeclVar n t _) = [Bind n t]
+stmtGetLocals (TBlock stmts) = blockGetLocals stmts
+stmtGetLocals (TIf _ t f) = blockGetLocals t ++ maybe [] blockGetLocals f
+stmtGetLocals (TWhile _ body) = blockGetLocals body
+stmtGetLocals _ = []
+
+-- Create structs
+emitTypeDef :: TLStruct -> ModuleBuilder LLVM.AST.Type
+emitTypeDef (Struct name fields) = do
+    modify $ \ctx -> ctx { structs = Struct name fields : structs ctx }
+    sType <- convertType (StructType name)
+    typedef (mkName (cs ("struct." <> name))) (Just sType)

src/Windows12/Parser.hs

@@ -117,7 +117,7 @@ stmtP :: Parser Stmt
 stmtP =
   Return <$> (reserved "return" *> exprP <* symbol ";")
     <|> (If <$> (reserved "if" *> exprP) <*> braces (many stmtP) <*> optional (reserved "else" *> braces (many stmtP)))
-    <|> (While <$> (reserved "while" *> parens exprP) <*> braces (many stmtP))
+    <|> (While <$> (reserved "while" *> exprP) <*> braces (many stmtP))
     <|> (Var <$> (reserved "var" *> identifier) <*> optional (symbol ":" *> typeP) <*> optional (symbol "=" *> exprP) <* symbol ";")
     <|> try assignP
     <|> Expr <$> exprP <* symbol ";"

src/Windows12/Semant.hs

@@ -0,0 +1,263 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Windows12.Semant where
+
+import Data.Text (Text)
+
+import Control.Monad.State
+
+import Data.List (find)
+
+import Windows12.Ast as Ast
+import Windows12.TAst as TAst
+
+suppliedFuncs :: [Text]
+suppliedFuncs = ["printf"]
+
+-- Convert an Ast to a TAst
+-- Performs type inference and type checking
+
+data Ctx = Ctx { structs :: [TLStruct],
+                 enums :: [TLEnum],
+                 funcs :: [TTLFunc],
+                 vars :: [(Text, Type)] }
+    deriving (Eq, Show)
+
+-- Main conversion function. May return an error message if the program
+-- is not well-typed.
+convert :: Ast.Program -> Either String TAst.TProgram
+convert (Ast.Program structs enums funcs) = do
+    let ctx = Ctx structs enums [] []
+    let (funcs', _) = runState (mapM convertFunc funcs) ctx
+    return $ TAst.TProgram structs enums funcs'
+
+-- Convert a TLFunc (Top Level Function) to a TTLFunc (Typed Top Level Function)
+-- Note that the function must be added to the context before converting statements
+-- of the function. This is because the function may call itself recursively.
+-- After converting the function, the function's statements are converted
+-- and added to the context.
+convertFunc :: MonadState Ctx m => Ast.TLFunc -> m TAst.TTLFunc
+convertFunc (Ast.Func name args retType body) = do
+    args' <- mapM (\(Bind name t) -> return (name, t)) args
+    oldFuncs <- gets funcs
+    modify (\ctx -> ctx { funcs = funcs ctx ++ [TTLFunc name args retType []], vars = args' })
+    body' <- mapM convertStmt body
+    ctx <- get
+    let func = (last $ funcs ctx) { TAst.funcBody = body' }
+    put $ ctx { funcs = oldFuncs ++ [func] }
+    return func
+
+-- Convert a statement
+convertStmt :: MonadState Ctx m => Ast.Stmt -> m TAst.TStmt
+
+convertStmt (Ast.Expr expr) = do
+    expr' <- convertExpr expr
+    return $ TAst.TExprStmt expr'
+
+convertStmt (Ast.Return expr) = do
+    expr' <- convertExpr expr
+    return $ TAst.TReturn expr'
+
+convertStmt (Ast.If cond thenStmts elseStmts) = do
+    thenStmts' <- mapM convertStmt thenStmts
+    elseStmts' <- mapM convertStmt $ maybe [] id elseStmts
+    cond' <- convertExpr cond
+    return $ TAst.TIf cond' thenStmts' (Just elseStmts')
+
+convertStmt (Ast.While cond stmts) = do
+    stmts' <- mapM convertStmt stmts
+    cond' <- convertExpr cond
+    return $ TAst.TWhile cond' stmts'
+
+convertStmt (Ast.Assign op lval expr) = do
+    lval' <- convertLVal lval
+    expr' <- convertExpr expr
+    return $ TAst.TAssign op lval' expr'
+
+convertStmt (Ast.Block stmts) = do
+    stmts' <- mapM convertStmt stmts
+    return $ TAst.TBlock stmts'
+
+convertStmt (Ast.Var name (Just t) maybeExpr) = do
+    expr' <- maybe (return Nothing) (fmap Just . convertExpr) maybeExpr
+    modify (\ctx -> ctx { vars = (name, t) : vars ctx })
+    return $ TAst.TDeclVar name t expr'
+
+-- TODO
+convertStmt (Ast.Var name Nothing maybeExpr) = error "Type inference not implemented"
+
+-- Convert an expression to an LValue
+-- Only certain expressions are allowed as LValues
+convertLVal :: MonadState Ctx m => Ast.Expr -> m TAst.TLVal
+convertLVal (Ast.Id name) = do
+    ctx <- get
+    case lookup name (vars ctx) of
+        Just t -> return (t, TAst.TId name)
+        Nothing -> error $ "Variable " ++ show name ++ " not in scope"
+
+convertLVal (Ast.Index arr idx) = do
+    arr' <- convertLVal arr
+    idx' <- convertExpr idx
+    return (fst arr', TAst.LTIndex arr' idx')
+
+convertLVal (Ast.Member e (Id m)) = do
+    e' <- convertLVal e
+    return (fst e', TAst.LTMember e' m)
+
+convertLVal (Ast.Member e m) = do error $ "Invalid member access " ++ show m ++ " on " ++ show e
+
+convertLVal (Ast.UnOp Ast.Deref e) = error "Dereferencing not implemented"
+
+convertLVal e = do error $ "Invalid or unimplemented LValue " ++ show e
+
+-- Convert an expression
+convertExpr :: MonadState Ctx m => Ast.Expr -> m TAst.TExpr
+convertExpr (Ast.Id name) = do
+    ctx <- get
+    case lookup name (vars ctx) of
+        Just t -> return (t, TAst.TVar name)
+        Nothing -> error $ "Variable " ++ show name ++ " not in scope"
+
+convertExpr (Ast.IntLit x) = return (IntType, TAst.TIntLit x)
+convertExpr (Ast.UIntLit x) = return (UIntType, TAst.TUIntLit x)
+convertExpr (Ast.FloatLit x) = return (FloatType, TAst.TFloatLit x)
+convertExpr (Ast.StrLit x) = return (StrType, TAst.TStrLit x)
+convertExpr (Ast.BoolLit x) = return (BoolType, TAst.TBoolLit x)
+convertExpr (Ast.CharLit x) = return (CharType, TAst.TCharLit x)
+
+convertExpr (Ast.BinOp Add l r) = arithOp Add l r
+convertExpr (Ast.BinOp Sub l r) = arithOp Sub l r
+convertExpr (Ast.BinOp Mul l r) = arithOp Mul l r
+convertExpr (Ast.BinOp Div l r) = arithOp Div l r
+convertExpr (Ast.BinOp Mod l r) = arithOp Mod l r
+
+convertExpr (Ast.BinOp Eq l r) = compOp Eq l r
+convertExpr (Ast.BinOp Ne l r) = compOp Ne l r
+convertExpr (Ast.BinOp Lt l r) = compOp Lt l r
+convertExpr (Ast.BinOp Gt l r) = compOp Gt l r
+convertExpr (Ast.BinOp Le l r) = compOp Le l r
+convertExpr (Ast.BinOp Ge l r) = compOp Ge l r
+
+convertExpr (Ast.BinOp And l r) = boolOp And l r
+convertExpr (Ast.BinOp Or l r) = boolOp Or l r
+
+convertExpr (Ast.BinOp BitAnd l r) = bitOp BitAnd l r
+convertExpr (Ast.BinOp BitOr l r) = bitOp BitOr l r
+convertExpr (Ast.BinOp BitXor l r) = bitOp BitXor l r
+
+convertExpr (Ast.BinOp ShiftL l r) = shiftOp ShiftL l r
+convertExpr (Ast.BinOp ShiftR l r) = shiftOp ShiftR l r
+
+convertExpr (Ast.UnOp Neg e) = do
+    e' <- convertExpr e
+    if fst e' `elem` [IntType, UIntType, FloatType]
+        then return (fst e', TAst.TUnOp Neg e')
+        else error $ "Type mismatch: " ++ show e
+
+convertExpr (Ast.UnOp Not e) = do
+    e' <- convertExpr e
+    if fst e' == BoolType
+        then return (BoolType, TAst.TUnOp Not e')
+        else error $ "Type mismatch: " ++ show e
+
+convertExpr (Ast.UnOp BitNot e) = undefined
+convertExpr (Ast.UnOp Deref e) = undefined
+convertExpr (Ast.UnOp AddrOf e) = undefined
+
+-- TODO type check function return
+-- TODO ensure returns on all paths
+-- Lower priority since LLVM checks this also
+convertExpr (Ast.Call (Id f) args) = do
+    ctx <- get
+    if f == "printf"
+        then do
+            args' <- mapM convertExpr args
+            return (IntType, TAst.TCall "printf" args')
+        else case find (\(TTLFunc n a r _) -> n == f) (funcs ctx) of
+            Just t -> do
+                args' <- mapM convertExpr args
+                if length args' == length (TAst.funcArgs t) && all (\(t1, t2) -> t1 == t2) (zip (map fst args') (map bindType (TAst.funcArgs t)))
+                    then return (TAst.funcRetType t, TAst.TCall f args')
+                    else error $ "Type mismatch in call to " ++ show f
+            Nothing -> error $ "Function " ++ show f ++ " not in scope. Available functions: " ++ show (map TAst.funcName (funcs ctx))
+
+convertExpr (Ast.Index arr idx) = do
+    arr' <- convertExpr arr
+    idx' <- convertExpr idx
+    case fst arr' of
+        ArrayType t -> if fst idx' == IntType
+            then return (t, TAst.TIndex arr' idx')
+            else error $ "Index must be an integer: " ++ show idx
+        _ -> error $ "Indexing non-array: " ++ show arr
+
+convertExpr (Ast.Cast t e) = do
+    e' <- convertExpr e
+    return (t, TAst.TCast t e')
+
+convertExpr (Ast.Sizeof t) = return (IntType, TAst.TSizeof t)
+
+convertExpr (Ast.Member e (Id m)) = do
+    e' <- convertExpr e
+    case fst e' of
+        StructType name -> do
+            ctx <- get
+            case find (\(Struct n _) -> n == name) (structs ctx) of
+                Just (Struct _ binds) -> case find (\(Bind n t) -> n == m) binds of
+                    Just (Bind _ t) -> return (t, TAst.TMember e' m)
+                    Nothing -> error $ "Field " ++ show m ++ " not in struct " ++ show name
+                Nothing -> error $ "Struct " ++ show name ++ " not in scope"
+        _ -> error $ "Member access on non-struct " ++ show e
+
+convertExpr (Ast.StructInit name fields) = do
+    ctx <- get
+    case find (\(Struct n _) -> n == name) (structs ctx) of
+        Just (Struct _ binds) -> do
+            fields' <- mapM (\(n, e) -> do
+                e' <- convertExpr e
+                case find (\(Bind n' t) -> n == n') binds of
+                    Just (Bind _ t) -> if fst e' == t
+                        then return (n, e')
+                        else error $ "Type mismatch in struct initialization: " ++ show e
+                    Nothing -> error $ "Field " ++ show n ++ " not in struct " ++ show name) fields
+                
+            return (StructType name, TAst.TStructInit name fields')
+        Nothing -> error $ "Struct " ++ show name ++ " not in scope"
+
+convertExpr e = error $ "Invalid or Unimplemented conversion for expression " ++ show e
+
+-- Ensure that the types of the left and right expressions are the same
+-- and return the type of the result
+arithOp :: MonadState Ctx m => Ast.BinOp -> Ast.Expr -> Ast.Expr -> m TAst.TExpr
+arithOp o l r = do
+    l' <- convertExpr l
+    r' <- convertExpr r
+    if fst l' == fst r'
+        then return (fst l', TAst.TBinOp o l' r')
+        else error $ "Type mismatch: " ++ show l ++ " and " ++ show r
+
+-- Ensure that the types of the left and right expressions are the same
+-- and return a boolean type
+compOp :: MonadState Ctx m => Ast.BinOp -> Ast.Expr -> Ast.Expr -> m TAst.TExpr
+compOp o l r = do
+    l' <- convertExpr l
+    r' <- convertExpr r
+    if fst l' == fst r'
+        then return (BoolType, TAst.TBinOp o l' r')
+        else error $ "Type mismatch: " ++ show l ++ " and " ++ show r
+
+-- Ensure that the types of both expressions are boolean
+-- and return a boolean type
+boolOp :: MonadState Ctx m => Ast.BinOp -> Ast.Expr -> Ast.Expr -> m TAst.TExpr
+boolOp o l r = do
+    l' <- convertExpr l
+    r' <- convertExpr r
+    if fst l' == fst r' && fst l' == BoolType
+        then return (BoolType, TAst.TBinOp o l' r')
+        else error $ "Type mismatch: " ++ show l ++ " and " ++ show r
+
+bitOp :: MonadState Ctx m => Ast.BinOp -> Ast.Expr -> Ast.Expr -> m TAst.TExpr
+bitOp o l r = do error $ "Bit operations not implemented"
+
+shiftOp :: MonadState Ctx m => Ast.BinOp -> Ast.Expr -> Ast.Expr -> m TAst.TExpr
+shiftOp o l r = do error $ "Shift operations not implemented"

src/Windows12/TAst.hs

@@ -0,0 +1,54 @@
+module Windows12.TAst where
+
+import Data.Text (Text)
+
+import Windows12.Ast as Ast
+
+-- "Typed AST". A second AST that contains more type information
+-- Makes verification easier, and is needed to determine type
+-- of structs when accessing members in CodeGen
+
+type TExpr = (Type, TExpr')
+
+data TExpr'
+  = TVar Text
+  | TIntLit Int
+  | TUIntLit Word
+  | TFloatLit Double
+  | TStrLit Text
+  | TBoolLit Bool
+  | TCharLit Char
+  | TBinOp BinOp TExpr TExpr
+  | TUnOp UnOp TExpr
+  | TCall Text [TExpr]
+  | TIndex TExpr TExpr
+  | TMember TExpr Text
+  | TCast Type TExpr
+  | TSizeof Type
+  | TStructInit Text [(Text, TExpr)]
+  deriving (Show, Eq)
+
+type TLVal = (Type, TLVal')
+
+data TLVal'
+  = TDeref TExpr 
+  | TId Text 
+  | LTIndex TLVal TExpr
+  | LTMember TLVal Text
+  deriving (Show, Eq)
+
+data TStmt
+  = TExprStmt TExpr
+  | TReturn TExpr
+  | TIf TExpr [TStmt] (Maybe [TStmt])
+  | TWhile TExpr [TStmt]
+  | TAssign AssignOp TLVal TExpr
+  | TBlock [TStmt]
+  | TDeclVar Text Type (Maybe TExpr)
+  deriving (Show, Eq)
+
+data TTLFunc = TTLFunc {funcName :: Text, funcArgs :: [Bind], funcRetType :: Type, funcBody :: [TStmt]}
+  deriving (Show, Eq)
+
+data TProgram = TProgram [TLStruct] [TLEnum] [TTLFunc]
+  deriving (Show, Eq)

test/arith.w12

@@ -0,0 +1,43 @@
+fn factorial(n: int) -> int {
+	var result: int;
+
+	if n == 0 {
+		result = 1;
+	} else {
+		result = n * factorial(n - 1);
+	}
+
+	return result;
+}
+
+fn is_positive(n: int) -> bool {
+	return n > 0;
+}
+
+fn main() -> int {
+	var a: int = 5;
+	printf("a = %d\n", a);
+
+	var b: int = 3;
+	printf("b = %d\n", b);
+
+	var c: int = (a + b) * 2 - 1;
+	c += factorial(5);
+
+	printf("c = %d\n", c);
+
+	while c > 0 {
+		printf("c = %d\n", c);
+
+		if c > 50 {
+			printf("c is greater than 50\n");
+		} else {
+			printf("c is less than or equal to 50\n");
+		}
+
+		c -= 16;
+	}
+
+	printf("End result: %d\n", c);
+	return 0;
+}

test/bad.w12

@@ -0,0 +1 @@
+function test() {}

test/basic-structs.w12

@@ -0,0 +1,21 @@
+struct Test {
+    a: int,
+	b: char,
+}
+
+fn main() -> int {
+	var t: Test;
+	t.a = 5;
+	t.b = 'a';
+
+	printf("t.a = %d\n", t.a);
+	printf("t.b = %c\n", t.b);
+
+	t.a += 3;
+	t.b = 'b';
+
+	printf("t.a = %d\n", t.a);
+	printf("t.b = %c\n", t.b);
+
+	return 0;
+}

test/fib.w12

@@ -0,0 +1,38 @@
+fn rec_fib(n: int) -> int {
+	if n <= 1 {
+		return n;
+	}
+
+	return rec_fib(n - 1) + rec_fib(n - 2);
+}
+
+fn loop_fib(n: int) -> int {
+	var a: int = 0;
+	var b: int = 1;
+	var i: int = 0;
+
+	while i < n {
+		var c: int = a + b;
+		a = b;
+		b = c;
+		i += 1;
+	}
+
+	return a;
+}
+
+fn main() -> int {
+	var n: int = 20;
+	var rec_result: int = rec_fib(n);
+	var loop_result: int = loop_fib(n);
+	printf("Fibonacci of %d via recursion is %d\n", n, rec_result);
+	printf("Fibonacci of %d via loop is %d\n", n, loop_result);
+
+	if rec_result == loop_result {
+		printf("Results match\n");
+	} else {
+		printf("Results do not match\n");
+	}
+
+	return 0;
+}

test/functions.w12

@@ -0,0 +1,32 @@
+fn mult3(a: int, b: int, c: int) -> int {
+	return a * b * c;
+}
+
+fn loop_test() -> int {
+	var i: int = 0;
+	var result: int = 0;
+
+	while i < 10 {
+		printf("i = %d\n", i);
+		result += i;
+		i += 1;
+	}
+
+	return result;
+}
+
+fn main() -> int {
+	var a: int = 5;
+	var b: int = 3;
+	var c: int = 2;
+
+	var result: int = mult3(a, b, c);
+	printf("Result: %d\n", result);
+
+	result = loop_test();
+	printf("Result: %d\n", result);
+
+	return 0;
+}
+
+

windows12.cabal

@@ -68,6 +68,9 @@ executable windows12
         Windows12.Ast
         Windows12.Lexer
         Windows12.Parser
+        Windows12.CodeGen
+        Windows12.TAst
+        Windows12.Semant
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
@@ -76,10 +79,46 @@ executable windows12
     build-depends:
         base >= 4.15.1 && < 4.16,
         llvm-hs-pure >= 9.0.0 && < 9.1,
+        llvm-hs-pretty >= 0.9.0 && < 0.10,
         megaparsec >= 9.6.1 && < 9.7,
         text >= 1.2.5 && < 1.3,
         parser-combinators >= 1.3.0 && < 1.4,
-        prettyprinter >= 1.7.1 && < 1.8,
+        prettyprinter >= 1.5.1 && < 1.6,
+        string-conversions >= 0.4.0 && < 0.5,
+        mtl >= 2.2.2 && < 2.3,
+
+    -- Directories containing source files.
+    hs-source-dirs:   src
+
+    -- Base language which the package is written in.
+    default-language: Haskell2010
+
+executable windows12-qc
+    -- Import common warning flags.
+    import:           warnings
+
+    -- .hs or .lhs file containing the Main module.
+    main-is:          QuickCheckTests.hs
+
+    -- Modules included in this executable, other than Main.
+    other-modules:
+        Windows12.Ast
+        Windows12.Lexer
+        Windows12.Parser
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    -- Other library packages from which modules are imported.
+    build-depends:
+        base >= 4.15.1 && < 4.16,
+        megaparsec >= 9.6.1 && < 9.7,
+        text >= 1.2.5 && < 1.3,
+        parser-combinators >= 1.3.0 && < 1.4,
+        prettyprinter >= 1.5.1 && < 1.6,
+        string-conversions >= 0.4.0 && < 0.5,
+        mtl >= 2.2.2 && < 2.3,
+        QuickCheck >= 2.14.2 && < 2.15,
 
     -- Directories containing source files.
     hs-source-dirs:   src