feat: type check completed

design/sa.md

@@ -7,11 +7,11 @@
 每个阶段本身不会因为检测到错误而中断，因此会尽量收集足够多的错误。但是一个阶段结束时如果产生了错误，那么编译应该结束并报错，输出的AST有错，无法继续编译。
 
 1. Name Resolution：确保程序没有使用未定义的变量或符号，并且没有冲突的重复定义。需要提前包含库函数的符号。
-2. Type Checking：确保程序没有类型错误，并提供足够的类型标注，尤其需要标注类型转换
+2. Type Checking：确保程序没有类型错误，并提供足够的类型标注，尤其需要标注类型转换 
     * 函数`putf`的参数处理需要额外的手段介入，但是目前的functional tests没有找到使用该函数的测例，所以打算等到功能大致实现完成再做。
-    * 初值检查和整理：尤其是数组初值的整理，需要根据类型信息丢弃(警告)和补0。
 3. Constant Computation：计算所有编译期常量并标注在AST上
     * 需要上一阶段标注的类型信息。由于类型检查通过，所以只需要判断是否是常量即可，然后根据规则计算。
+    * 初值检查和整理：尤其是数组初值的整理，需要根据类型信息丢弃(警告)和补0。
     * 检查数组常量的左值，不能有修改的代码。
 4. 基本块、DAG、优化、代码生成等其他阶段，目前还是先用LLVM吧，可以直接从AST生成LLVM IR，后端以后慢慢写。
 

src/SysY/AST/Basic.hs

@@ -38,6 +38,11 @@ data FuncDef = FuncDef FuncType Ident [FuncFParam] Block
 data FuncType = FVoid | FInt | FFloat
     deriving (Eq, Show)
 
+funcType2TermType :: FuncType -> TermType
+funcType2TermType FVoid = TermVoid
+funcType2TermType FInt = TermBType BInt
+funcType2TermType FFloat = TermBType BFloat
+
 data FuncFParam = FuncFParam BType Ident Int [TypedExp]
     deriving (Eq, Show)
 

src/SysY/StaticAnalysis.hs

@@ -18,15 +18,40 @@ import Prelude hiding (error)
 import SysY.AST.Basic
 import Control.Monad.State
 
+import Control.Monad.Except
+import Control.Monad (when)
+import Control.Lens
 
 
-checkNameRes :: CompUnit -> State SAContext ()
-checkNameRes comp_unit = runSAEffectsPure $ SysY.StaticAnalysis.NameRes.check_comp_unit comp_unit
+checkNameRes :: State (CompUnit, SAContext) ()
+checkNameRes = do
+    comp_unit <- gets fst
+    zoom _2 $ do
+        runSAEffectsPure $ SysY.StaticAnalysis.NameRes.check_comp_unit comp_unit
 
+checkType :: State (CompUnit, SAContext) ()
+checkType = do
+    comp_unit <- gets fst
+    comp_unit' <- zoom _2 $ do
+        runSAEffectsPure $ SysY.StaticAnalysis.TypeCheck.check_comp_unit comp_unit
+    _1 .= comp_unit'
+
+terminate_if_has_error :: ExceptT () (State (CompUnit, SAContext)) ()
+terminate_if_has_error = do
+    e <- lift (zoom _2 has_error)
+    when e $ throwError ()
+    lift $ zoom _2 reset_symbols
+
+static_analysis_inner :: ExceptT () (State (CompUnit, SAContext)) ()
+static_analysis_inner = do
+    lift $ checkNameRes
+    terminate_if_has_error
+    lift $ checkType
+    terminate_if_has_error
 
 static_analysis :: CompUnit -> ([String], CompUnit) -- TODO: rewrite for effect stack
 static_analysis c = do
-    let SAContext ws es _ _ = execState (checkNameRes c) defaultSAContext
-    -- mapM_ print es
+    let ex = runExceptT static_analysis_inner
+    let (c', SAContext ws es _ _) = execState ex (c, defaultSAContext)
     (es, c)
 

src/SysY/StaticAnalysis/Basic.hs

@@ -5,7 +5,7 @@
 {-# LANGUAGE TypeApplications #-}
 module SysY.StaticAnalysis.Basic (
     SAEffects, warn, SysY.StaticAnalysis.Basic.error, withScope, newFunc, findFunc, newSymbol, findSymbol,
-    SymInfo(..), FuncInfo(..), SAContext(..), defaultSAContext, runSAEffectsPure, lib_functions
+    SymInfo(..), FuncInfo(..), SAContext(..), defaultSAContext, runSAEffectsPure, reset_symbols, has_error
 ) where
 import SysY.AST (Ident, TermType, ConstVal, TermType(..), BType(..))
 import Polysemy
@@ -43,14 +43,24 @@ data SAContext = SAContext
     }
 makeLenses ''SAContext
 
+lib_funcs :: [(Ident, FuncInfo)]
+lib_funcs = zip (fmap funcName lib_functions) lib_functions
+
 defaultSAContext :: SAContext
 defaultSAContext = SAContext
     { _warnings = []
     , _errors = []
     , _symbols = [Map.empty] -- top level scope
     , _functions = Map.fromList lib_funcs
     }
-    where lib_funcs = zip (fmap funcName lib_functions) lib_functions
+
+reset_symbols :: State SAContext ()
+reset_symbols = do
+    symbols .= [Map.empty]
+    functions .= Map.fromList lib_funcs
+
+has_error :: State SAContext Bool
+has_error = uses errors (not . Prelude.null)
 
 append_warning :: String -> State SAContext ()
 append_warning w = warnings %= (w <|) -- this version of lens does not have `<|=`

src/SysY/StaticAnalysis/NameRes.hs

@@ -62,8 +62,8 @@ check_exp (ExpCall name args) = do
     assert_function name
     mapM_ check_typed_exp args
 
-check_block :: Member SAEffects r => Block -> Sem r ()
-check_block (Block items) = withScope $ mapM_ check_block_item items
+check_block_unscoped :: Member SAEffects r => Block -> Sem r ()
+check_block_unscoped (Block items) = mapM_ check_block_item items
     where
         check_block_item (BlockItemDecl decl) = check_decl decl
         check_block_item (BlockItemStmt stmt) = check_stmt stmt
@@ -72,7 +72,7 @@ check_stmt :: Member SAEffects r => Stmt -> Sem r ()
 check_stmt (StmtLVal lval e) = check_lval lval >> check_typed_exp e
 check_stmt (StmtExp Nothing) = pure ()
 check_stmt (StmtExp (Just e)) = check_typed_exp e
-check_stmt (StmtBlock block) = check_block block
+check_stmt (StmtBlock block) = withScope $ check_block_unscoped block
 check_stmt (StmtIf cond then' Nothing) = check_typed_exp cond >> check_stmt then'
 check_stmt (StmtIf cond then' (Just else')) = check_typed_exp cond >> check_stmt then' >> check_stmt else'
 check_stmt (StmtWhile cond do') = check_typed_exp cond >> check_stmt do'
@@ -117,7 +117,7 @@ check_func (FuncDef _ name args block) = do
     new_function name -- insert function symbol so it can be recursive
     withScope $ do -- function scope
         mapM_ check_fparam args
-        check_block block -- block scope
+        check_block_unscoped block -- block scope
 
 check_top_level :: Member SAEffects r => TopLevel -> Sem r ()
 check_top_level (TLDecl decl) = check_decl decl

src/SysY/StaticAnalysis/TypeCheck.hs

@@ -4,25 +4,23 @@
 {-# LANGUAGE FunctionalDependencies #-}
 
 module SysY.StaticAnalysis.TypeCheck (
-
+    check_comp_unit
 ) where
 import SysY.AST
 import Polysemy
 import Text.Printf (printf)
-import Control.Monad (unless, zipWithM)
+import Control.Monad (unless, zipWithM, when)
 import SysY.StaticAnalysis.Basic as SA
 import Prelude hiding (error)
 import qualified Prelude as Pre
+import Data.Functor (($>))
 
 arith_op :: [Optr]
 arith_op = [Plus, Minus, Mul, Div]
 comp_op :: [Optr]
 comp_op = [Lt, Gt, Le, Ge, Eq, Ne]
-cond_op :: [Optr]
-cond_op = [LAnd, LOr]
-
--- lift_typed :: (TermType, Exp) -> TypedExp
--- lift_typed (t, e) = (Just t, e)
+-- cond_op :: [Optr]
+-- cond_op = [LAnd, LOr]
 
 typeInfer' :: Member SAEffects r => TypedExp -> Sem r (TermType, TypedExp)
 typeInfer' (RawExp e) = do
@@ -45,23 +43,14 @@ findTypeDecl name = do
         Nothing -> assert_name_resolution
         Just (SymInfo _ t _, _) -> pure t
 
-
--- | We assert that name resolution has succeeded, so type checking can safely panic when there're unexpected cases,
--- so in which cases compiler code should checked.
---
--- This functions cannot return `TermVoid`.
--- 
--- `TermAny` being returned indicates type inference has failed.
--- But caller should not generate error message in this case. The inference which failed is responsible to do that.
-typeInfer :: Member SAEffects r => Exp -> Sem r (TermType, Exp)
-typeInfer (ExpLVal (LVal name indexers)) = do
+check_lval :: Member SAEffects r => LVal -> Sem r (TermType, LVal)
+check_lval (LVal name indexers) = do
     carrier_type <- findTypeDecl name
-    if null indexers then pure (carrier_type, ExpLVal (LVal name indexers))
+    if null indexers then pure (carrier_type, LVal name indexers)
     else do
-        indexers_ <- mapM typeInfer_ indexers
-        indexers__ <- mapM (typeCheck_ex (TermBType BInt)) indexers_
-        let val = LVal name indexers__
-        let def = pure $ (TermAny, ExpLVal val)
+        indexers' <- check_indexers indexers
+        let val = LVal name indexers'
+        let def = pure (TermAny, val)
         case carrier_type of
             TermAny -> assert_name_resolution
             TermVoid -> Pre.error "Impossible. Symbol cannot be of void"
@@ -71,16 +60,27 @@ typeInfer (ExpLVal (LVal name indexers)) = do
             TermArray type_ dimensions -> do
                 if length dimensions < length indexers
                     then do
-                        error "Indexers cannot be more than dimensions of array type"
+                        error "Indexers cannot be of more dimensions than of array type"
                         def
                     else do
                         let new_dimensions = drop (length indexers) dimensions
                         if null new_dimensions
-                            then pure $ (TermBType type_, ExpLVal val)
+                            then pure $ (TermBType type_, val)
                             else do
                                 let new_type = TermArray type_ new_dimensions
-                                pure $ (new_type, ExpLVal val)
+                                pure $ (new_type, val)
 
+-- | We assert that name resolution has succeeded, so type checking can safely panic when there're unexpected cases,
+-- so in which cases compiler code should checked.
+--
+-- This functions cannot return `TermVoid`.
+-- 
+-- `TermAny` being returned indicates type inference has failed.
+-- But caller should not generate error message in this case. The inference which failed is responsible to do that.
+typeInfer :: Member SAEffects r => Exp -> Sem r (TermType, Exp)
+typeInfer (ExpLVal lval) = do
+    (type_, lval') <- check_lval lval
+    pure (type_, ExpLVal lval')
 typeInfer ((ExpNum (IntConst i))) = pure $ (TermBType BInt, ExpNum (IntConst i))
 typeInfer ((ExpNum (FloatConst f))) = pure $ (TermBType BFloat, ExpNum (FloatConst f))
 typeInfer ((ExpOpUnary op oprd)) = do
@@ -171,6 +171,9 @@ typeInfer ((ExpCall name args)) = do
             pure $ (ret_type, ExpCall name new_args)
 
 
+check_indexers :: Member SAEffects r => [TypedExp] -> Sem r [TypedExp]
+check_indexers = mapM (typeCheck_ex (TermBType BInt))
+
 typeCheck_im :: Member SAEffects r => TermType -> TypedExp -> Sem r TypedExp
 typeCheck_im = typeCheck True
 typeCheck_ex :: Member SAEffects r => TermType -> TypedExp -> Sem r TypedExp
@@ -181,29 +184,132 @@ typeCheck implicit_conv t (RawExp e) = do
     (type_, e_) <- typeInfer e
     typeCheck implicit_conv t (TypedExp type_ e_)
 typeCheck implicit_conv t (TypedExp o e) = do -- combine the two cases
-    if implicit_conv then
-        if (o, t) `elem` typeImplicitConv then
-            pure $ ConvExp t (TypedExp o e)
+    if t == o then
+        pure (TypedExp o e)
+    else
+        if implicit_conv then
+            if (o, t) `elem` typeImplicitConv then
+                pure $ ConvExp t (TypedExp o e)
+            else do
+                error $ printf "Expected type %s, got %s, conversion failed" (show t) (show o)
+                pure (TypedExp o e)
         else do
-            error $ printf "Expected type %s, got %s, conversion failed" (show t) (show o)
+            error $ printf "Expected type %s, got %s" (show t) (show o)
             pure (TypedExp o e)
-    else do
-        unless (t == o) $ error $ printf "Expected type %s, got %s" (show t) (show o)
-        pure (TypedExp o e)
 typeCheck implicit_conv t (ConvExp o e) = do
-    if implicit_conv then
-        if (o, t) `elem` typeImplicitConv then
-            pure $ ConvExp t (ConvExp o e) -- in the case where multiple conversion is needed
+    if t == o then
+        pure (ConvExp o e)
+    else
+        if implicit_conv then
+            if (o, t) `elem` typeImplicitConv then
+                pure $ ConvExp t (ConvExp o e) -- in the case where multiple conversion is needed
+            else do
+                error $ printf "Expected type %s, got %s, conversion failed" (show t) (show o)
+                pure (ConvExp o e)
         else do
-            error $ printf "Expected type %s, got %s, conversion failed" (show t) (show o)
+            error $ printf "Expected type %s, got %s" (show t) (show o)
             pure (ConvExp o e)
-    else do
-        unless (t == o) $ error $ printf "Expected type %s, got %s" (show t) (show o)
-        pure (ConvExp o e)
 
 typeImplicitConv :: [(TermType, TermType)]
 typeImplicitConv = [(TermBType BInt, TermBType BFloat), (TermBType BFloat, TermBType BInt)]
 
+check_typed_exp :: Member SAEffects r => TypedExp -> Sem r TypedExp
+check_typed_exp = typeInfer_
+
+check_decl :: Member SAEffects r => Decl -> Sem r Decl
+check_decl (DeclConst (ConstDecl btype defs)) = do
+    defs_ <- mapM (check_const_def btype) defs
+    pure $ DeclConst (ConstDecl btype defs_)
+check_decl (DeclVar (VarDecl btype defs)) = do
+    defs_ <- mapM (check_var_def btype) defs
+    pure $ DeclVar (VarDecl btype defs_)
+
+check_const_def :: Member SAEffects r => BType -> ConstDef -> Sem r ConstDef
+check_const_def btype (ConstDef name indexers init_) = do
+    indexers' <- check_indexers indexers
+    let type' = gen_type btype (length indexers')
+    init' <- check_const_init_val type' init_ -- check type of init value with unknown dimensions length
+    newSymbol (SymInfo name type' Nothing)
+    pure (ConstDef name indexers' init')
 
--- check_typed_exp :: 
+check_var_def :: Member SAEffects r => BType -> VarDef -> Sem r VarDef
+check_var_def btype (VarDefUninit name indexers) = do
+    indexers' <- check_indexers indexers
+    let type' = gen_type btype (length indexers')
+    newSymbol (SymInfo name type' Nothing)
+    pure (VarDefUninit name indexers')
+check_var_def btype (VarDefInit name indexers init_) = do
+    indexers' <- check_indexers indexers
+    let type' = gen_type btype (length indexers')
+    init' <- check_const_init_val type' init_
+    newSymbol (SymInfo name type' Nothing)
+    pure (VarDefInit name indexers' init')
 
+gen_type :: BType -> Int -> TermType
+gen_type btype indexers = type'
+    where
+        type' = if null dimensions then TermBType btype else TermArray btype dimensions
+        dimensions = replicate indexers Nothing -- all nothing, to be computed and checked in next stage of static analysis
+
+exp_type :: TypedExp -> TermType
+exp_type (RawExp _) = Pre.error "Imposssible. Cannot call `exp_type` on non-checked expression"
+exp_type (TypedExp t _) = t
+exp_type (ConvExp t _) = t
+
+check_block_unscoped :: Member SAEffects r => Block -> Sem r Block
+check_block_unscoped (Block items) = Block <$> mapM check_block_item items
+    where
+        check_block_item (BlockItemDecl decl) = BlockItemDecl <$> check_decl decl
+        check_block_item (BlockItemStmt stmt) = BlockItemStmt <$> check_stmt stmt
+
+check_fparam :: Member SAEffects r => FuncFParam -> Sem r (TermType, FuncFParam)
+check_fparam (FuncFParam btype name dimensions indexers) = do
+    indexers' <- check_indexers indexers
+    let type' = gen_type btype dimensions
+    newSymbol (SymInfo name type' Nothing)
+    pure (type', FuncFParam btype name dimensions indexers')
+
+check_func :: Member SAEffects r => FuncDef -> Sem r FuncDef
+check_func (FuncDef func_type name args block) = do
+    withScope $ do -- function scope
+        args' <- mapM check_fparam args
+        let ret_type = funcType2TermType func_type
+        let arg_types = fst <$> args'
+        newFunc (FuncInfo name ret_type arg_types) -- insert function
+        block' <- check_block_unscoped block -- block scope
+        pure (FuncDef func_type name (snd <$> args') block')
+
+check_top_level :: Member SAEffects r => TopLevel -> Sem r TopLevel
+check_top_level (TLDecl decl) = TLDecl <$> check_decl decl
+check_top_level (TLFun func) = TLFun <$> check_func func
+
+check_comp_unit :: Member SAEffects r => CompUnit -> Sem r CompUnit
+check_comp_unit (CompUnit tops) = CompUnit <$> mapM check_top_level tops
+
+check_stmt :: Member SAEffects r => Stmt -> Sem r Stmt
+check_stmt (StmtLVal lval e) = (StmtLVal . snd <$> check_lval lval) <*> check_typed_exp e
+check_stmt (StmtExp Nothing) = pure (StmtExp Nothing)
+check_stmt (StmtExp (Just e)) = StmtExp . Just <$> check_typed_exp e
+check_stmt (StmtBlock block) = StmtBlock <$> withScope (check_block_unscoped block)
+check_stmt (StmtIf cond then_ Nothing) = StmtIf <$> check_typed_exp cond <*> check_stmt then_ <*> pure Nothing
+check_stmt (StmtIf cond then_ (Just else_)) = StmtIf <$> check_typed_exp cond <*> check_stmt then_ <*> (Just <$> check_stmt else_)
+check_stmt (StmtWhile cond do_) = StmtWhile <$> check_typed_exp cond <*> check_stmt do_
+check_stmt StmtBreak = pure StmtBreak
+check_stmt StmtContinue = pure StmtContinue
+check_stmt (StmtReturn Nothing) = pure (StmtReturn Nothing)
+check_stmt (StmtReturn (Just e)) = StmtReturn . Just <$> check_typed_exp e
+
+check_const_init_val :: Member SAEffects r => TermType -> ConstInitVal -> Sem r ConstInitVal
+check_const_init_val type_ (ci, InitValExp e) = do
+    e' <- check_typed_exp e -- exp is of array type, which is not permitted
+    e'' <- case exp_type e' of
+        TermAny -> pure e'
+        TermBType _ -> typeCheck_im type_ e -- check type implicitly, TODO: float to int in initval is not permitted in SysY2022
+        TermVoid -> error "Initial value cannot be void" $> e'
+        TermArray _ _ -> error "Initial value of array type must be literal" $> e'
+    pure (ci, InitValExp e'')
+check_const_init_val type_ (ci, InitValArray arr) = do
+    case type_ of
+        TermArray _ _ -> pure () -- compile-time constants are computed in next stage
+        _ -> error "Array-like initial value assigned to non-array symbol"
+    pure (ci, InitValArray arr)