never executed always true always false
1 -- Copyright (C) 2018-2024 Jun Zhang <zhangjunphy[at]gmail[dot]com>
2 --
3 -- This file is a part of decafc.
4 --
5 -- decafc is free software: you can redistribute it and/or modify it under the
6 -- terms of the MIT (X11) License as described in the LICENSE file.
7 --
8 -- decafc is distributed in the hope that it will be useful, but WITHOUT ANY
9 -- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
10 -- FOR A PARTICULAR PURPOSE. See the X11 license for more details.
11
12 -- Semantic -- Decaf semantic checker
13 module Semantic
14 ( analyze,
15 SymbolTable (..),
16 SemanticInfo (..),
17 BlockType (..),
18 lookupLocalVariableFromST,
19 lookupLocalMethodFromST,
20 )
21 where
22
23 import AST
24 import Util.Constants
25 import Control.Applicative ((<|>))
26 import Control.Lens (view, (%=), (^.), (.=))
27 import Control.Monad.Except
28 import Control.Monad.State
29 import Control.Monad.Writer.Lazy
30 import Data.Char (ord)
31 import Data.Functor ((<&>))
32 import Data.Generics.Labels
33 import Data.Int (Int64)
34 import Data.List (find)
35 import Data.Map (Map)
36 import Data.Map qualified as Map
37 import Data.Maybe (isJust, isNothing)
38 import Data.Set (Set)
39 import Data.Set qualified as Set
40 import Data.Text (Text)
41 import Data.Text qualified as T
42 import Data.Text.Read qualified as T
43 import Formatting
44 import GHC.Generics (Generic)
45 import Parser qualified as P
46 import Types
47 import Util.SourceLoc qualified as SL
48
49 ---------------------------------------
50 -- Semantic informations and errors
51 ---------------------------------------
52
53 data BlockType = RootBlock | IfBlock | ForBlock | WhileBlock | MethodBlock
54 deriving (Show, Eq)
55
56 -- symbol table definitions
57 data SymbolTable = SymbolTable
58 { scopeID :: ScopeID,
59 parent :: Maybe SymbolTable,
60 importSymbols :: Maybe (Map Name ImportDecl),
61 variableSymbols :: Map Name FieldDecl,
62 methodSymbols :: Maybe (Map Name MethodDecl),
63 arguments :: Maybe (Map Name Argument),
64 blockType :: BlockType,
65 methodSig :: Maybe MethodSig
66 }
67 deriving (Generic)
68
69 instance Show SymbolTable where
70 show (SymbolTable sid p imports variables methods arguments tpe _) =
71 formatToString
72 ("SymbolTable {scopeID=" % int % ", parent=" % shown % ", imports=" % shown % ", variables=" % shown % ", methods=" % shown % ", arguments=" % shown % ", tpe=" % shown)
73 sid
74 (scopeID <$> p)
75 imports
76 variables
77 methods
78 arguments
79 tpe
80
81 data SemanticState = SemanticState
82 { nextScopeID :: ScopeID,
83 currentScopeID :: ScopeID,
84 symbolTables :: Map ScopeID SymbolTable,
85 currentRange :: SL.Range,
86 symbolWrites :: Map ScopeID (Set (ScopeID, Name))
87 }
88 deriving (Show, Generic)
89
90 data SemanticInfo = SemanticInfo
91 { symbolTables :: !(Map ScopeID SymbolTable),
92 symbolWrites :: !(Map ScopeID (Set (ScopeID, Name)))
93 } deriving (Show, Generic)
94
95 -- Monad used for semantic analysis
96 -- Symbol tables are built for every scope, and stored in SemanticState.
97 -- Semantic errors encountered are recorded by the writer monad (WriterT [CompileError]).
98 -- If a serious problem happened such that the analysis has to be aborted, a CompileError
99 -- is thrown as an exception.
100 newtype Semantic a = Semantic {runSemantic :: ExceptT CompileError (WriterT [CompileError] (State SemanticState)) a}
101 deriving (Functor, Applicative, Monad, MonadError CompileError, MonadWriter [CompileError], MonadState SemanticState)
102
103 analyze :: P.Program -> Either [CompileError] (ASTRoot, SemanticInfo)
104 analyze p =
105 let ir = irgenRoot p
106 ((except, errors), state) = (runState $ runWriterT $ runExceptT $ runSemantic ir) initialSemanticState
107 in case except of
108 Left except -> Left [except]
109 _ | not $ null errors -> Left errors
110 Right a -> Right (a, SemanticInfo (state ^. #symbolTables) (state ^. #symbolWrites))
111
112 initialSemanticState :: SemanticState
113 initialSemanticState =
114 let globalST =
115 SymbolTable
116 { scopeID = globalScopeID,
117 parent = Nothing,
118 importSymbols = Just Map.empty,
119 variableSymbols = Map.empty,
120 methodSymbols = Just Map.empty,
121 arguments = Nothing,
122 blockType = RootBlock,
123 methodSig = Nothing
124 }
125 in SemanticState
126 { nextScopeID = globalScopeID + 1,
127 currentScopeID = globalScopeID,
128 symbolTables = Map.fromList [(globalScopeID, globalST)],
129 currentRange = SL.Range (SL.Posn 0 0 0) (SL.Posn 0 0 0),
130 symbolWrites = Map.empty
131 }
132
133 updateCurrentRange :: SL.Range -> Semantic ()
134 updateCurrentRange range = modify (\s -> s {currentRange = range})
135
136 getCurrentRange :: Semantic SL.Range
137 getCurrentRange = gets currentRange
138
139 -- throw exception or store errors
140 throwSemanticException :: Text -> Semantic a
141 throwSemanticException msg = do
142 range <- getCurrentRange
143 throwError $ CompileError (Just range) msg
144
145 addSemanticError :: Text -> Semantic ()
146 addSemanticError msg = do
147 range <- getCurrentRange
148 tell [CompileError (Just range) msg]
149
150 -- find symbol table for global scope
151 getGlobalSymbolTable' :: Semantic SymbolTable
152 getGlobalSymbolTable' = do
153 state <- get
154 case Map.lookup globalScopeID $ state ^. #symbolTables of
155 Nothing -> throwSemanticException "No global symbol table found!"
156 Just t -> return t
157
158 -- find symbol table for current scope
159 getSymbolTable :: Semantic (Maybe SymbolTable)
160 getSymbolTable = do
161 state <- get
162 let id = currentScopeID state
163 return $ Map.lookup id $ state ^. #symbolTables
164
165 getCurrentScopeID :: Semantic Int
166 getCurrentScopeID = gets currentScopeID
167
168 -- find symbol table for current scope
169 -- will throw SemanticException if nothing is found
170 getSymbolTable' :: Semantic SymbolTable
171 getSymbolTable' = do
172 scopeID <- getCurrentScopeID
173 t <- getSymbolTable
174 case t of
175 Nothing ->
176 throwSemanticException $ sformat ("No symble table found for current scope " % int) scopeID
177 Just table -> return table
178
179 getLocalVariables' :: Semantic (Map Name FieldDecl)
180 getLocalVariables' = do
181 variableSymbols <$> getSymbolTable'
182
183 getLocalImports' :: Semantic (Map Name ImportDecl)
184 getLocalImports' = do
185 localST <- getSymbolTable'
186 case importSymbols localST of
187 Nothing -> throwSemanticException $ sformat ("No import table for scope " % int) $ scopeID localST
188 Just t -> return t
189
190 getLocalMethods' :: Semantic (Map Name MethodDecl)
191 getLocalMethods' = do
192 localST <- getSymbolTable'
193 case methodSymbols localST of
194 Nothing -> throwSemanticException $ sformat ("No method table for scope " % int) $ scopeID localST
195 Just t -> return t
196
197 updateSymbolTable :: SymbolTable -> Semantic ()
198 updateSymbolTable t = do
199 state <- get
200 -- ensure the symbol table is present, otherwise throw an exception
201 getSymbolTable'
202 #symbolTables .= Map.insert (currentScopeID state) t (state ^. #symbolTables)
203
204 getMethodSignature :: Semantic (Maybe MethodSig)
205 getMethodSignature = do lookup <$> getSymbolTable'
206 where
207 lookup :: SymbolTable -> Maybe MethodSig
208 lookup SymbolTable {blockType = RootBlock} = Nothing
209 lookup SymbolTable {blockType = MethodBlock, methodSig = sig} = sig
210 lookup SymbolTable {parent = Just p} = lookup p
211
212 getMethodSignature' :: Semantic MethodSig
213 getMethodSignature' = do
214 sig <- getMethodSignature
215 case sig of
216 Nothing -> throwSemanticException "Cannot find signature for current function!"
217 Just s -> return s
218
219 enterScope :: BlockType -> Maybe MethodSig -> Semantic ScopeID
220 enterScope blockType sig = do
221 state <- get
222 parentST <- getSymbolTable
223 let nextID = nextScopeID state
224 args = sig <&> \s -> Map.fromList $ (s ^. #args) <&> (\a -> (a ^. #name, a))
225 localST =
226 SymbolTable
227 { scopeID = nextID,
228 parent = parentST,
229 variableSymbols = Map.empty,
230 importSymbols = Nothing,
231 methodSymbols = Nothing,
232 arguments = args,
233 blockType = blockType,
234 methodSig = sig
235 }
236 put $
237 state
238 { nextScopeID = nextID + 1,
239 currentScopeID = nextID,
240 symbolTables = Map.insert nextID localST $ state ^. #symbolTables
241 }
242 return nextID
243
244 exitScope :: Semantic ()
245 exitScope = do
246 state <- get
247 localST <- getSymbolTable
248 case localST of
249 Nothing ->
250 throwSemanticException $
251 sformat ("No symbol table is associated with scope(" % int % ")!") $
252 currentScopeID state
253 Just table ->
254 case parent table of
255 Nothing ->
256 throwSemanticException "Cannot exit root scope!"
257 Just p ->
258 put $ state {currentScopeID = scopeID p}
259
260 ----------------------------------------------------------------------
261 -- Convert the parser tree into an AST
262 -- Generate symbol tables at the same time.
263 -- Also detects semantic errors.
264 ----------------------------------------------------------------------
265
266 {-
267 Semantic rules to be checked, this will be referenced as Semantic[n]in comments below.
268 1. Identifier duplication.
269 2. Identifier should be declared before used.
270 3. Check for method "main". Also check the parameters and return type.
271 4. Array length should be greater than 0.
272 5. Method call has matching type and number of arguments.
273 6. Method must return something if used in expressions.
274 7. String literals and array variables may not be used as args to non-import methods.
275 8. Method declared without a return type shall return nothing.
276 9. Method return type should match declared type.
277 10. id used as location should name a variable or parameter.
278 11. Method should be declared or imported before used.
279 12. Array location must refer to an array varaible, also the index expression must be of type int.
280 13. Argument of len operator must be an array.
281 14. The expression of 'if' and 'when', as well as the second expression of 'for' must have type 'bool'.
282 15. In a conditional expression (?:):
283 The first expression must have type bool.
284 The alternatives must have the same type.
285 16. The operands of the unary negative operator, arithmetic ops and relational ops must have type int.
286 17. The operands of equal ops must have the same type.
287 18. The operands of the logical not op and conditional op must have type bool.
288 19. The location and expression in an assignment must have the same type.
289 20. The location and expression in an incremental assignment must have type int.
290 21. All break and continue statment must be within a for or while loop.
291 22. All int literals must be in the range of -9223372036854775808 ≤ x ≤ 9223372036854775807
292 (64 bits).
293 -}
294
295 {-
296 Helper functions to manipulate symbol tables.
297 -}
298
299 {- Varaible lookup. -}
300
301 lookupLocalVariableFromST :: Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
302 lookupLocalVariableFromST name st =
303 let f = lookupLocalFieldDecl name st
304 a = lookupArgument name st
305 in (Right <$> f) <|> (Left <$> a)
306 where
307 lookupLocalFieldDecl name st = Map.lookup name $ variableSymbols st
308 lookupArgument name st = arguments st >>= Map.lookup name
309
310 lookupVariable :: Name -> Semantic (Maybe (Either Argument FieldDecl))
311 lookupVariable name = do
312 st <- getSymbolTable
313 return $ st >>= lookup name
314 where
315 lookup name st' =
316 (lookupLocalVariableFromST name st')
317 <|> (parent st' >>= lookup name)
318
319 lookupVariable' :: Name -> Semantic (Either Argument FieldDecl)
320 lookupVariable' name = do
321 v <- lookupVariable name
322 case v of
323 Nothing -> throwSemanticException $ sformat ("Varaible " % stext % " not defined") name
324 Just v -> return v
325
326 lookupVariableScope :: Name -> Semantic (Maybe ScopeID)
327 lookupVariableScope name = do
328 st <- getSymbolTable
329 return $ st >>= lookup name
330 where
331 lookup name st' =
332 (lookupLocalVariableFromST name st' <&> \_ -> st' ^. #scopeID)
333 <|> (parent st' >>= lookup name)
334
335 lookupVariableScope' :: Name -> Semantic ScopeID
336 lookupVariableScope' name = do
337 sid <- lookupVariableScope name
338 case sid of
339 Nothing -> throwSemanticException $ sformat ("Varaible " % stext % " not defined") name
340 Just sid -> return sid
341
342 {- Method lookup. -}
343
344 lookupLocalMethodFromST :: Name -> SymbolTable -> Maybe (Either ImportDecl MethodDecl)
345 lookupLocalMethodFromST name table =
346 let method = do
347 methodTable <- methodSymbols table
348 Map.lookup name methodTable
349 import' = do
350 importTable <- importSymbols table
351 Map.lookup name importTable
352 in (Right <$> method) <|> (Left <$> import')
353
354 lookupMethod :: Name -> Semantic (Maybe (Either ImportDecl MethodDecl))
355 lookupMethod name = do
356 lookup name <$> getSymbolTable'
357 where
358 lookup name table = (lookupLocalMethodFromST name table) <|> (parent table >>= lookup name)
359
360 lookupMethod' :: Name -> Semantic (Either ImportDecl MethodDecl)
361 lookupMethod' name = do
362 m <- lookupMethod name
363 case m of
364 Nothing -> throwSemanticException $ sformat ("Method " % stext % " not found") name
365 Just m' -> return m'
366
367 {- Add variables and methods -}
368
369 addVariableDef :: FieldDecl -> Semantic ()
370 addVariableDef def = do
371 localST <- getSymbolTable'
372 -- Semantic[1]
373 let nm = view #name def
374 when
375 (isJust (lookupLocalVariableFromST nm localST))
376 (addSemanticError $ sformat ("duplicate definition for variable " % stext) nm)
377 let variableSymbols' = Map.insert nm def (variableSymbols localST)
378 newST = localST {variableSymbols = variableSymbols'}
379 -- Semantic[4]
380 case def of
381 (FieldDecl _ (ArrayType _ sz) _)
382 | sz < 0 ->
383 addSemanticError $ sformat ("Invalid size of array " % stext) nm
384 _ -> return ()
385 updateSymbolTable newST
386
387 addImportDef :: ImportDecl -> Semantic ()
388 addImportDef def = do
389 localST <- getSymbolTable'
390 importTable <- getLocalImports'
391 -- Semantic[1]
392 let nm = view #name def
393 when
394 (isJust $ Map.lookup nm importTable)
395 (addSemanticError $ sformat ("duplicate import " % stext) nm)
396 let importSymbols' = Map.insert nm def importTable
397 newST = localST {importSymbols = Just importSymbols'}
398 updateSymbolTable newST
399
400 addMethodDef :: MethodDecl -> Semantic ()
401 addMethodDef def = do
402 localST <- getSymbolTable'
403 methodTable <- getLocalMethods'
404 -- Semantic[1]
405 let nm = def ^. (#sig . #name)
406 when
407 (isJust $ lookupLocalMethodFromST nm localST)
408 (addSemanticError $ sformat ("duplicate definition for method " % stext) nm)
409 let methodSymbols' = Map.insert nm def methodTable
410 newST = localST {methodSymbols = Just methodSymbols'}
411 updateSymbolTable newST
412
413 {-
414 Helper methods to do semantic checks.
415 -}
416
417 -- Semantic[8] and Semantic[9]
418 checkReturnType :: Maybe Expr -> Semantic ()
419 checkReturnType Nothing = do
420 (MethodSig method tpe _) <- getMethodSignature'
421 case tpe of
422 Just t -> addSemanticError $ sformat ("Method " % stext % " expects return type of " % shown % "!") method t
423 _ -> return ()
424 checkReturnType (Just Expr {tpe = tpe'}) = do
425 (MethodSig method tpe _) <- getMethodSignature'
426 case tpe of
427 Nothing -> addSemanticError $ sformat ("Method " % stext % " expects no return value!") method
428 t
429 | t /= tpe ->
430 addSemanticError $
431 sformat
432 ("Method " % stext % " expects return type of " % shown % ", but got " % shown % " instead.")
433 method
434 tpe
435 tpe'
436 _ -> return ()
437
438 -- | Check if content of lit is a valid int64.
439 -- lit should be striped of whitespace from both ends and contains only
440 -- numeric characters or the minus sign '-'.
441 -- -9223372036854775808 ≤ x ≤ 9223372036854775807
442 -- checks Semantic[22].
443 checkInt64Literal :: Text -> Semantic Int64
444 checkInt64Literal lit = do
445 when (T.null lit) $
446 throwSemanticException "Cannot parse int literal from an empty token!"
447 let isNegative = (T.head lit) == '-'
448 -- unless
449 -- ( (isNegative && (T.drop 1 lit) <= "9223372036854775808")
450 -- || (not isNegative && lit <= "9223372036854775807")
451 -- )
452 -- throwSemanticException
453 -- $ printf "Int literal %s is out of bound" lit
454 case T.decimal lit of
455 Right (n, _) -> return n
456 Left msg -> throwSemanticException $ sformat ("cannot parse int literal " % string) msg
457
458 checkBoolLiteral :: Text -> Semantic Bool
459 checkBoolLiteral lit
460 | lit == "true" = return True
461 | lit == "false" = return False
462 | otherwise = do
463 addSemanticError $ sformat ("error parsing bool literal from string " % stext) lit
464 return True
465
466 checkCharLiteral :: Text -> Semantic Char
467 checkCharLiteral lit = do
468 when
469 (T.length lit > 1 || T.null lit)
470 (throwSemanticException $ sformat ("cannot parse char literal from string " % stext) lit)
471 return $ T.head lit
472
473 isInsideLoop :: Semantic Bool
474 isInsideLoop = do
475 lookup <$> getSymbolTable'
476 where
477 lookup SymbolTable {blockType = ForBlock} = True
478 lookup SymbolTable {blockType = WhileBlock} = True
479 lookup SymbolTable {blockType = IfBlock, parent = Nothing} = False
480 lookup SymbolTable {blockType = IfBlock, parent = Just p} = lookup p
481
482 {-
483 Methods to generate ir piece by piece.
484 -}
485
486 irgenRoot :: P.Program -> Semantic ASTRoot
487 irgenRoot (P.Program imports fields methods) = do
488 imports' <- irgenImports imports
489 variables' <- irgenFieldDecls fields
490 methods' <- irgenMethodDecls methods
491
492 -- check method "main"
493 -- Semantic[3]
494 globalTable <- getGlobalSymbolTable'
495 let main = do
496 methodSyms <- methodSymbols globalTable
497 Map.lookup mainMethodName methodSyms
498 mainDecl <- checkMainExist main
499 case mainDecl >>= Just . view #sig of
500 Just (MethodSig _ retType args) -> do
501 checkMainRetType retType
502 checkMainArgsType args
503 Nothing -> return ()
504 return $ ASTRoot imports' variables' methods'
505 where
506 checkMainExist main =
507 case main of
508 Nothing -> do
509 addSemanticError "Method \"main\" not found!"
510 return Nothing
511 Just decl -> return $ Just decl
512 checkMainRetType tpe = case tpe of
513 Nothing -> return ()
514 Just tpe ->
515 addSemanticError $
516 sformat
517 ("Method \"main\" should have return type of void, got " % shown % " instead.")
518 tpe
519 checkMainArgsType args =
520 unless
521 (null args)
522 (addSemanticError "Method \"main\" should have no argument.")
523
524 irgenType :: P.Type -> Type
525 irgenType P.IntType = IntType
526 irgenType P.BoolType = BoolType
527
528 irgenImports :: [SL.Located P.ImportDecl] -> Semantic [ImportDecl]
529 irgenImports [] = return []
530 irgenImports ((SL.LocatedAt range (P.ImportDecl id)) : rest) = do
531 let importSymbol = ImportDecl id range
532 addImportDef importSymbol
533 -- TODO: This kind of recursions potentially lead to stack overflows.
534 -- For now it should do the job. Will try to fix in the future.
535 rest' <- irgenImports rest
536 return $ importSymbol : rest'
537
538 irgenFieldDecls :: [SL.Located P.FieldDecl] -> Semantic [FieldDecl]
539 irgenFieldDecls [] = return []
540 irgenFieldDecls ((SL.LocatedAt pos decl) : rest) = do
541 fields <- sequence $ convertFieldDecl decl
542 vars <- addVariables fields
543 rest' <- irgenFieldDecls rest
544 return (vars ++ rest')
545 where
546 convertFieldDecl (P.FieldDecl tpe elems) =
547 elems <&> \e -> case e of
548 (SL.LocatedAt range (P.ScalarField id)) -> do
549 updateCurrentRange range
550 return $ FieldDecl id (irgenType tpe) pos
551 (SL.LocatedAt range (P.VectorField id size)) -> do
552 updateCurrentRange pos
553 sz <- checkInt64Literal size
554 return $ FieldDecl id (ArrayType (irgenType tpe) sz) pos
555 addVariables [] = return []
556 addVariables (v : vs) = do
557 addVariableDef v
558 vs' <- addVariables vs
559 return (v : vs')
560
561 irgenMethodDecls :: [SL.Located P.MethodDecl] -> Semantic [MethodDecl]
562 irgenMethodDecls [] = return []
563 irgenMethodDecls ((SL.LocatedAt range decl) : rest) = do
564 updateCurrentRange range
565 method <- convertMethodDecl decl
566 -- Semantic[8] and Semantic[9]
567 -- checkMethod method
568 addMethodDef method
569 rest' <- irgenMethodDecls rest
570 return (method : rest')
571 where
572 convertMethodDecl (P.MethodDecl id returnType arguments block) = do
573 let sig = MethodSig id (irgenType <$> returnType) args
574 block <- irgenBlock MethodBlock (Just sig) block
575 return $ MethodDecl sig block range
576 where
577 args =
578 arguments <&> \(SL.LocatedAt range (P.Argument id tpe)) ->
579 Argument id (irgenType tpe) range
580
581 irgenBlock :: BlockType -> Maybe MethodSig -> P.Block -> Semantic Block
582 irgenBlock blockType sig (P.Block fieldDecls statements) = do
583 nextID <- enterScope blockType sig
584 fields <- irgenFieldDecls fieldDecls
585 stmts <- irgenStatements statements
586 let block = Block fields stmts nextID
587 exitScope
588 return block
589
590 irgenLocation :: P.Location -> Semantic Location
591 irgenLocation (P.ScalarLocation id) = do
592 -- Semantic[10] (checked in lookupVariable')
593 def <- lookupVariable' id
594 range <- getCurrentRange
595 let tpe = either (\(Argument _ tpe' _) -> tpe') (\(FieldDecl _ tpe' _) -> tpe') def
596 let sz =
597 either
598 (const Nothing)
599 ( \(FieldDecl _ tpe _) -> case tpe of
600 (ArrayType _ sz') -> Just sz'
601 _ -> Nothing
602 )
603 def
604 -- Semantic[12]
605 case sz of
606 Nothing -> return $ Location id Nothing def tpe range
607 Just v -> return $ Location id Nothing def (ArrayType tpe v) range
608 irgenLocation (P.VectorLocation id expr) = do
609 expr'@(Expr _ indexTpe _) <- irgenExpr expr
610 -- Semantic[10] (checked in lookupVariable')
611 def <- lookupVariable' id
612 range <- getCurrentRange
613 let tpe = either (\(Argument _ tpe' _) -> tpe') (\(FieldDecl _ tpe' _) -> tpe') def
614 let sz =
615 either
616 (const Nothing)
617 ( \(FieldDecl _ tpe _) -> case tpe of
618 (ArrayType _ sz') -> Just sz'
619 _ -> Nothing
620 )
621 def
622 -- Semantic[12]
623 when (indexTpe /= IntType) (addSemanticError "Index must be of int type!")
624 case sz of
625 Nothing -> do
626 addSemanticError $
627 sformat ("Cannot access index of scalar variable " % stext % ".") id
628 return $ Location id Nothing def tpe range
629 Just _ -> return $ Location id (Just expr') def tpe range
630
631 checkAssignType :: Type -> Type -> Bool
632 checkAssignType (ArrayType tpe _) exprType = tpe == exprType
633 checkAssignType locType exprType = locType == exprType
634
635 recordSymbolWrite :: Location -> Semantic ()
636 recordSymbolWrite loc = do
637 sid <- getCurrentScopeID
638 let name = loc ^. #name
639 varScope <- lookupVariableScope' name
640 case typeOfDef (loc ^. #variableDef) of
641 Void -> return ()
642 ArrayType _ _ -> return ()
643 Ptr _ -> return ()
644 _ScalarType -> do
645 let newSet = Set.fromList $ filter (\(s, _) -> s /= 0) [(varScope, name)]
646 #symbolWrites %= Map.insertWith Set.union sid newSet
647
648 irgenAssign :: P.Location -> P.AssignExpr -> Semantic Assignment
649 irgenAssign loc (P.AssignExpr op expr) = do
650 loc'@Location {tpe = tpe} <- irgenLocation loc
651 expr'@Expr {tpe = tpe'} <- irgenExpr expr
652 range <- getCurrentRange
653 -- Semantic[19]
654 unless
655 (checkAssignType tpe tpe')
656 (addSemanticError $ sformat ("Assign statement has different types: " % shown % " and " % shown % "") tpe tpe')
657 let op' = parseAssignOp op
658 -- Semantic[20]
659 when
660 ((op' == IncAssign || op' == DecAssign) && (tpe /= IntType))
661 (addSemanticError "Inc or dec assign only works with int type!")
662 -- Record symbol write to ease cfg construction
663 recordSymbolWrite loc'
664 return $ Assignment loc' op' (Just expr') range
665 irgenAssign loc (P.IncrementExpr op) = do
666 loc'@Location {tpe = tpe} <- irgenLocation loc
667 range <- getCurrentRange
668 let op' = parseAssignOp op
669 -- Semantic[20]
670 when (tpe /= IntType) (addSemanticError "Inc or dec operator only works on int type!")
671 -- Record symbol write to ease cfg construction
672 recordSymbolWrite loc'
673 return $ Assignment loc' op' Nothing range
674
675 irgenStatements :: [SL.Located P.Statement] -> Semantic [Statement]
676 irgenStatements [] = return []
677 irgenStatements ((SL.LocatedAt range s) : xs) = do
678 updateCurrentRange range
679 s' <- irgenStmt s
680 xs' <- irgenStatements xs
681 return (s' : xs')
682
683 irgenMethod :: P.MethodCall -> Semantic MethodCall
684 irgenMethod (P.MethodCall method args') = do
685 -- Semantic[2] and Semantic[11]
686 decl' <- lookupMethod method
687 argsTyped <- traverse irgenImportArg args'
688 range <- getCurrentRange
689 case decl' of
690 Nothing -> do
691 currentMethod <- getMethodSignature
692 case currentMethod of
693 -- Recursive method calling itself
694 (Just (MethodSig name _ formal)) | name == method -> do
695 checkCallingSemantics formal argsTyped
696 return $ MethodCall method argsTyped range
697 _ -> throwSemanticException $ sformat ("method " % stext % " not declared!") method
698 Just decl -> case decl of
699 Left _ -> return $ MethodCall method argsTyped range
700 Right m -> do
701 let formal = m ^. (#sig . #args)
702 -- Semantic[5] and Semantic[7]
703 checkCallingSemantics formal argsTyped
704 return $ MethodCall method argsTyped range
705 where
706 matchPred (Argument _ tpe _, Expr {tpe = tpe'}) = tpe == tpe'
707 argName (Argument name _ _, _) = name
708 checkArgNum formal args =
709 unless
710 (length formal == length args)
711 ( addSemanticError $
712 sformat
713 ("Calling " % stext % " with wrong number of args. Required: " % int % ", supplied: " % int % ".")
714 method
715 (length formal)
716 (length args)
717 )
718 checkArgType formal args =
719 let mismatch = map argName $ filter (not . matchPred) $ zip formal args
720 in unless
721 (null mismatch)
722 ( addSemanticError $
723 sformat
724 ("Calling " % stext % " with wrong type of args: " % shown)
725 method
726 mismatch
727 )
728 arrayOrStringTypePred Expr {tpe = tpe} = case tpe of
729 ArrayType _ _ -> True
730 StringType -> True
731 _ -> False
732 checkForArrayArg args =
733 let arrayArgs = filter arrayOrStringTypePred args
734 in unless
735 (null arrayArgs)
736 ( addSemanticError $
737 sformat
738 ("Argument of array or string type can not be used for method " % stext)
739 method
740 )
741 checkCallingSemantics formal args = do
742 checkArgNum formal args
743 checkArgType formal args
744 checkForArrayArg args
745
746 irgenStmt :: P.Statement -> Semantic Statement
747 irgenStmt (P.AssignStatement loc expr) = do
748 assign <- irgenAssign loc expr
749 range <- getCurrentRange
750 return $ Statement (AssignStmt assign) range
751 irgenStmt (P.MethodCallStatement method) = do
752 method' <- irgenMethod method
753 range <- getCurrentRange
754 return $ Statement (MethodCallStmt method') range
755 irgenStmt (P.IfStatement expr block) = do
756 ifBlock <- irgenBlock IfBlock Nothing block
757 expr'@Expr {tpe = tpe} <- irgenExpr expr
758 range <- getCurrentRange
759 -- Semantic[14]
760 when
761 (tpe /= BoolType)
762 (addSemanticError $ sformat ("The pred of if statment must have type bool, but got " % shown % " instead!") tpe)
763 return $ Statement (IfStmt expr' ifBlock Nothing) range
764 irgenStmt (P.IfElseStatement expr ifBlock elseBlock) = do
765 ifBlock' <- irgenBlock IfBlock Nothing ifBlock
766 elseBlock' <- irgenBlock IfBlock Nothing elseBlock
767 expr'@Expr {tpe = tpe} <- irgenExpr expr
768 range <- getCurrentRange
769 -- Semantic[14]
770 when
771 (tpe /= BoolType)
772 (addSemanticError $ sformat ("The pred of if statment must have type bool, but got " % shown % " instead!") tpe)
773 return $ Statement (IfStmt expr' ifBlock' (Just elseBlock')) range
774 irgenStmt (P.ForStatement counter initExpr predExpr (P.CounterUpdate updateLoc updateExpr) block) = do
775 init <- irgenAssign (P.ScalarLocation counter) (P.AssignExpr "=" initExpr)
776 block' <- irgenBlock ForBlock Nothing block
777 predExpr'@Expr {tpe = tpe} <- irgenExpr predExpr
778 range <- getCurrentRange
779 -- Semantic[14]
780 when
781 (tpe /= BoolType)
782 (addSemanticError $ sformat ("The pred of for statment must have type bool, but got " % shown % " instead!") tpe)
783 update <- irgenAssign updateLoc updateExpr
784 return $ Statement (ForStmt (Just init) predExpr' (Just update) block') range
785 irgenStmt (P.WhileStatement expr block) = do
786 block' <- irgenBlock WhileBlock Nothing block
787 expr'@Expr {tpe = tpe} <- irgenExpr expr
788 range <- getCurrentRange
789 -- Semantic[14]
790 when
791 (tpe /= BoolType)
792 (addSemanticError $ sformat ("The pred of while statment must have type bool, but got " % shown % " instead!") tpe)
793 return $ Statement (ForStmt Nothing expr' Nothing block') range
794 irgenStmt (P.ReturnExprStatement expr) = do
795 expr' <- irgenExpr expr
796 range <- getCurrentRange
797 -- Semantic[8] and Semantic[9]
798 checkReturnType $ Just expr'
799 return $ Statement (ReturnStmt $ Just expr') range
800 irgenStmt P.ReturnVoidStatement = do
801 range <- getCurrentRange
802 -- Semantic[8] and Semantic[9]
803 checkReturnType Nothing
804 return $ Statement (ReturnStmt Nothing) range
805 irgenStmt P.BreakStatement = do
806 range <- getCurrentRange
807 -- Semantic[21]
808 inLoop <- isInsideLoop
809 unless
810 inLoop
811 (addSemanticError "Found break statement outside for or while block!")
812 return $ Statement BreakStmt range
813 irgenStmt P.ContinueStatement = do
814 range <- getCurrentRange
815 -- Semantic[21]
816 inLoop <- isInsideLoop
817 unless
818 inLoop
819 (addSemanticError "Found continue statement outside for or while block!")
820 return $ Statement ContinueStmt range
821
822 {- generate expressions, also do type inference -}
823 irgenExpr :: SL.Located P.Expr -> Semantic Expr
824 irgenExpr (SL.LocatedAt range (P.LocationExpr loc)) = do
825 updateCurrentRange range
826 loc'@Location {tpe = tpe} <- irgenLocation loc
827 return $ Expr (LocationExpr loc') tpe range
828 irgenExpr (SL.LocatedAt range (P.MethodCallExpr method@(P.MethodCall name _))) = do
829 updateCurrentRange range
830 method' <- irgenMethod method
831 m <- lookupMethod' name
832 case m of
833 -- treat import methods as always return int
834 Left _ -> return $ Expr (MethodCallExpr method') IntType range
835 Right (MethodDecl (MethodSig _ tpe _) _ _) -> do
836 case tpe of
837 -- Semantic[6]
838 Nothing ->
839 throwSemanticException $
840 sformat ("Method " % stext % " cannot be used in expressions as it returns nothing!") name
841 Just tpe' -> return $ Expr (MethodCallExpr method') tpe' range
842 irgenExpr (SL.LocatedAt range (P.IntLiteralExpr i)) = do
843 updateCurrentRange range
844 literalVal <- checkInt64Literal i
845 return $ Expr (IntLiteralExpr literalVal) IntType range
846 irgenExpr (SL.LocatedAt range (P.BoolLiteralExpr b)) = do
847 updateCurrentRange range
848 lit <- checkBoolLiteral b
849 return $ Expr (BoolLiteralExpr lit) BoolType range
850 irgenExpr (SL.LocatedAt range (P.CharLiteralExpr c)) = do
851 updateCurrentRange range
852 lit <- checkCharLiteral c
853 return $ Expr (CharLiteralExpr lit) CharType range
854 irgenExpr (SL.LocatedAt range (P.LenExpr id)) = do
855 updateCurrentRange range
856 def <- lookupVariable' id
857 -- Semantic[13]
858 case def of
859 Left (Argument nm _ _) -> addSemanticError $ sformat ("len cannot operate on argument " % stext % "!") nm
860 Right (FieldDecl nm (ArrayType _ _) _) -> return ()
861 Right (FieldDecl nm _ _) -> addSemanticError $ sformat ("len cannot operate on scalar variable " % stext % "!") nm
862 return $ Expr (LengthExpr id) IntType range
863 irgenExpr (SL.LocatedAt range (P.ArithOpExpr op l r)) = do
864 updateCurrentRange range
865 -- Semantic[16]
866 l'@Expr {tpe = ltp} <- irgenExpr l
867 r'@Expr {tpe = rtp} <- irgenExpr r
868 when
869 (ltp /= IntType || rtp /= IntType)
870 (addSemanticError "There can only be integer values in arithmetic expressions.")
871 return $ Expr (ArithOpExpr (parseArithOp op) l' r') IntType range
872 irgenExpr (SL.LocatedAt range (P.RelOpExpr op l r)) = do
873 updateCurrentRange range
874 -- Semantic[16]
875 l'@Expr {tpe = ltp} <- irgenExpr l
876 r'@Expr {tpe = rtp} <- irgenExpr r
877 when
878 (ltp /= IntType || rtp /= IntType)
879 (addSemanticError "There can only be integer values in relational expressions.")
880 return $ Expr (RelOpExpr (parseRelOp op) l' r') BoolType range
881 irgenExpr (SL.LocatedAt range (P.EqOpExpr op l r)) = do
882 updateCurrentRange range
883 -- Semantic[17]
884 l'@Expr {tpe = ltp} <- irgenExpr l
885 r'@Expr {tpe = rtp} <- irgenExpr r
886 when
887 ((ltp, rtp) /= (IntType, IntType) && (ltp, rtp) /= (BoolType, BoolType))
888 (addSemanticError "Can only check equality of expressions with the SAME type!")
889 return $ Expr (EqOpExpr (parseEqOp op) l' r') BoolType range
890 irgenExpr (SL.LocatedAt range (P.CondOpExpr op l r)) = do
891 updateCurrentRange range
892 -- Semantic[18]
893 l'@Expr {tpe = ltp} <- irgenExpr l
894 r'@Expr {tpe = rtp} <- irgenExpr r
895 when
896 (ltp /= BoolType || rtp /= BoolType)
897 (addSemanticError "Conditional ops only accept booleans!")
898 return $ Expr (CondOpExpr (parseCondOp op) l' r') BoolType range
899 irgenExpr (SL.LocatedAt range (P.NegativeExpr expr)) = do
900 updateCurrentRange range
901 -- Semantic[16]
902 expr'@Expr {tpe = tpe} <- irgenExpr expr
903 when
904 (tpe /= IntType)
905 (addSemanticError "Operator \"-\" only accepts integers!")
906 return $ Expr (NegOpExpr Neg expr') IntType range
907 irgenExpr (SL.LocatedAt range (P.NegateExpr expr)) = do
908 updateCurrentRange range
909 -- Semantic[18]
910 expr'@Expr {tpe = tpe} <- irgenExpr expr
911 when
912 (tpe /= BoolType)
913 (addSemanticError "Operator \"!\" only accepts integers!")
914 return $ Expr (NotOpExpr Not expr') BoolType range
915 irgenExpr (SL.LocatedAt range (P.ChoiceExpr pred l r)) = do
916 updateCurrentRange range
917 pred'@Expr {tpe = ptp} <- irgenExpr pred
918 l'@Expr {tpe = ltp} <- irgenExpr l
919 r'@Expr {tpe = rtp} <- irgenExpr r
920 -- Semantic[15]
921 when
922 (ptp /= BoolType)
923 (addSemanticError "Predicate of choice operator must be a boolean!")
924 when
925 (ltp /= rtp)
926 (addSemanticError "Alternatives of choice op should have same type!")
927 return $ Expr (ChoiceOpExpr Choice pred' l' r') ltp range
928 irgenExpr (SL.LocatedAt range (P.ParenExpr expr)) = do
929 updateCurrentRange range
930 irgenExpr expr
931
932 irgenImportArg :: SL.Located P.ImportArg -> Semantic Expr
933 irgenImportArg (SL.LocatedAt range (P.ExprImportArg expr)) = irgenExpr expr
934 irgenImportArg (SL.LocatedAt range (P.StringImportArg arg)) = do
935 updateCurrentRange range
936 return $ Expr (StringLiteralExpr arg) StringType range