diff --git a/src/QuickCheckTests.hs b/src/QuickCheckTests.hs index 7f7f977..7b1929f 100644 --- a/src/QuickCheckTests.hs +++ b/src/QuickCheckTests.hs @@ -35,6 +35,14 @@ instance Arbitrary AssignOp where arbitrary = elements [BaseAssign, AddAssign, SubAssign, MulAssign, DivAssign, ModAssign, BitAndAssign, BitOrAssign, BitXorAssign, ShiftLAssign, ShiftRAssign] +instance Arbitrary LVal where + arbitrary = oneof + [ LId <$> arbitrary + , LIndex <$> arbitrary <*> arbitrary + , LDeref <$> arbitrary + , LMember <$> arbitrary <*> arbitrary + ] + instance Arbitrary Expr where arbitrary = oneof [ Id <$> arbitrary diff --git a/src/Windows12/Ast.hs b/src/Windows12/Ast.hs index 8af3f5b..28ebb3d 100644 --- a/src/Windows12/Ast.hs +++ b/src/Windows12/Ast.hs @@ -48,6 +48,13 @@ data AssignOp | ShiftRAssign deriving (Show, Eq) +data LVal + = LId Text + | LIndex Expr Expr + | LDeref Expr + | LMember Expr Text + deriving (Show, Eq) + data Expr = Id Text | IntLit Int @@ -71,7 +78,7 @@ data Stmt | Return Expr | If Expr [Stmt] (Maybe [Stmt]) | While Expr [Stmt] - | Assign AssignOp Expr Expr + | Assign AssignOp LVal Expr | Block [Stmt] | Var Text (Maybe Type) (Maybe Expr) deriving (Show, Eq) @@ -149,6 +156,12 @@ instance Pretty AssignOp where pretty ShiftLAssign = "<<=" pretty ShiftRAssign = ">>=" +instance Pretty LVal where + pretty (LId x) = pretty (Id x) + pretty (LIndex arr idx) = pretty (Index arr idx) + pretty (LDeref e) = pretty (UnOp Deref e) + pretty (LMember e m) = pretty (Member e m) + instance Pretty Expr where pretty (Id x) = pretty x pretty (IntLit x) = pretty x diff --git a/src/Windows12/CodeGen.hs b/src/Windows12/CodeGen.hs index 13b850e..ea3db76 100644 --- a/src/Windows12/CodeGen.hs +++ b/src/Windows12/CodeGen.hs @@ -101,15 +101,15 @@ size VoidType = return 0 -- CodeGen for LValues -codegenLVal :: Expr -> IRBuilder Operand -codegenLVal (Id name) = do +codegenLVal :: LVal -> IRBuilder Operand +codegenLVal (LId name) = do ctx <- get case lookup name (operands ctx) of Just (_type, op) -> return op Nothing -> error $ "Variable " ++ show name ++ " not found" -- TODO support members of members -codegenLVal (Member (Id sName) field) = do +codegenLVal (LMember (Id sName) field) = do ctx <- get case lookup sName (operands ctx) of Just ((Just (StructType op_type)), struct) -> do @@ -128,7 +128,7 @@ structFieldOffset (Struct name fields) field = do -- CodeGen for expressions codegenExpr :: Expr -> IRBuilder Operand -codegenExpr (Id name) = flip load 0 =<< codegenLVal (Id name) +codegenExpr (Id name) = flip load 0 =<< codegenLVal (LId name) -- TODO (?) codegenExpr (IntLit i) = return $ ConstantOperand (C.Int 32 (fromIntegral i)) codegenExpr (UIntLit i) = return $ ConstantOperand (C.Int 32 (fromIntegral i)) codegenExpr (FloatLit f) = undefined -- TODO floats @@ -287,7 +287,7 @@ codegenStmt (Assign SubAssign l e) = do codegenStmt (Block stmts) = mapM_ codegenStmt stmts -- Since the vars are already allocated by genBody, we just need to assign the value -codegenStmt (Var name t (Just e)) = codegenStmt (Assign BaseAssign (Id name) e) +codegenStmt (Var name t (Just e)) = codegenStmt (Assign BaseAssign (LId name) e) -- TODO (?) -- Do nothing with variable declaration if no expression is given -- This is because allocation is done already diff --git a/src/Windows12/Parser.hs b/src/Windows12/Parser.hs index 8b3c2f8..d09f800 100644 --- a/src/Windows12/Parser.hs +++ b/src/Windows12/Parser.hs @@ -6,6 +6,7 @@ import Control.Monad.Combinators.Expr import Text.Megaparsec import Windows12.Ast import Windows12.Lexer +import Data.Text.Prettyprint.Doc (pretty) opTable :: [[Operator Parser Expr]] opTable = @@ -82,6 +83,20 @@ termP = exprP :: Parser Expr exprP = makeExprParser termP opTable +exprToLVal :: Expr -> Maybe LVal +exprToLVal (Id x) = Just (LId x) +exprToLVal (Index arr idx) = Just (LIndex arr idx) +exprToLVal (UnOp Deref e) = Just (LDeref e) +exprToLVal (Member e m) = Just (LMember e m) +exprToLVal _ = Nothing + +lvalP :: Parser LVal +lvalP = do + e <- exprP + case exprToLVal e of + Just lv -> pure lv + Nothing -> fail $ "Invalid l-value: " ++ show (pretty e) ++ " (" ++ show e ++ ")" + structP :: Parser TLStruct structP = do reserved "struct" @@ -104,7 +119,7 @@ typeP = do assignP :: Parser Stmt assignP = do - lhs <- exprP + lhs <- lvalP op <- AddAssign <$ symbol "+=" <|> SubAssign <$ symbol "-="