MODULE {TigerSem} {} {} INCLUDE "TigerAS.ag" imports { import TigerAS import Control.Monad(mplus) import Data.List(sort) import Data.Maybe(fromMaybe) import qualified Data.Sequence as Seq import Data.Sequence(Seq, (><), singleton,empty) import Data.Foldable(toList) import Data.Map(Map,unionWith,keys,insert,elems,mapWithKey) import qualified Data.Map as Map(lookup,empty,fromList,insert) import TigerError } -- nil only for records -- overloading of <> = -- type def is neither void nor nil { type Errors = Seq Error union a b = unionWith const a b type TypeEnv = Map TypeIdent (Pos, TYPE) type VarEnv = Map VarIdent (Pos,VarType) type TypeSyns = Map TypeIdent (Pos,TypeIdent) --type RecordEnv = Map TypeRef (Map VarIdent TypeRef) --type ArrayEnv = Map TypeRef TypeRef data VarType = VarType TYPE | FunType [TYPE] -- argument types TYPE -- return type {- loopCounterType,errorType, emptyRecType, voidType, intType, strType :: TYPE loopCounterType = (-6) errorType = (-5) emptyRecType = (-4) voidType = (-3) intType = (-2) strType = (-1) -} {- unaryOps = fromList [("-", (intType,intType))] binaryOps = fromList [ (o,iii) | o <- ["*", "/", "+", "-" ,">=", "<=", "=", "<>", "<", ">","&","|" ]] where iii = (intType,intType,intType) -} initTypeEnv = Map.fromList (map toIdent [ ("int", INT) , ("string", STRING) ]) toIdent (n,t) = (Id n noPos,(noPos, t)) initVarEnv = Map.fromList (map toIdent [ ("print" , procedure [STRING]) , ("flush" , procedure [] ) , ("exit" , procedure [INT] ) , ("getchar" , function [] STRING ) , ("ord" , function [STRING] INT ) , ("chr" , function [INT] STRING ) , ("size" , function [STRING] INT ) , ("substring", function [STRING, INT, INT] STRING ) , ("concat" , function [STRING, STRING] STRING ) , ("not" , function [INT] INT ) ]) procedure args = FunType args VOID function args res = FunType args res findType env n = case lookupIdent n env of Just x -> (empty, x) Nothing -> (singleton (UndeclaredType n), ERROR) findVar env n = case lookupIdent n env of Just x -> case x of VarType t -> (empty, t) FunType _ _ -> (singleton (NotVarType n), ERROR) Nothing -> (singleton (UndeclaredVar n), ERROR) findFunction env n = case lookupIdent n env of Just x -> case x of VarType t -> (singleton (NotFunType n), [], ERROR) FunType a r -> (empty, a,r) Nothing -> (singleton (UndeclaredFun n), [], ERROR) lookupIdent :: Ident -> Map Ident (Pos,a) -> Maybe a lookupIdent i env = fmap snd (Map.lookup i env) compilerError msg = error ("compiler error: " ++ msg) } SEM Program [ || errors : {[Error]}] | Program lhs.errors = toList @expr.errors expr.errors = empty ATTR Declarations DeclGroup TypeDecs TypeDec FunDecs FunDec LValue Expr Args AssignField AssignFields [ | errors : Errors | ] ATTR LValue Expr Args AssignField AssignFields FunDec FunDecs [ varEnv:VarEnv || ] ATTR LValue Expr Args AssignField AssignFields FunDec FunDecs TypeDec TypeDecs [ typeEnv:TypeEnv || ] ATTR DeclGroup Declarations [ | varEnv:VarEnv typeEnv:TypeEnv | ] SEM Program | Program expr.varEnv = initVarEnv .typeEnv = initTypeEnv ATTR Declarations DeclGroup TypeDecs TypeDec FunDecs FunDec LValue Expr Args AssignField AssignFields [ | typecounter:Int | ] SEM Program | Program expr.typecounter = 10 -- Type declaration groups ATTR TypeDecs [ | | typedecs:{(TypeEnv, TypeSyns)} ] ATTR TypeDec [ | typedecs:{(TypeEnv, TypeSyns)} | ] SEM TypeDecs | Cons lhs.typedecs = @hd.typedecs hd .typedecs = @tl.typedecs | Nil lhs.typedecs = (Map.empty,Map.empty) SEM TypeDec | TypeDec loc.(errs,typedecs) = let (env,syns) = @lhs.typedecs in case lookupPos @ident env `mplus` lookupPos @ident syns of Just pos -> (singleton (DuplicateType @ident pos ), @lhs.typedecs) Nothing -> case @tp of Var nm -> (empty, (env, insertIdent @ident nm syns) ) Array t -> let (err,t') = findType @lhs.typeEnv t tp = ARRAY @ident @lhs.typecounter t' in (err, (insertIdent @ident tp env, syns)) Record fs -> let (err,fs') = recordFields @lhs.typeEnv fs tp = RECORD @ident @lhs.typecounter fs' in (err, (insertIdent @ident tp env, syns)) lhs.typecounter = @lhs.typecounter + 1 .errors = @lhs.errors >< @errs SEM DeclGroup | TypeDecs loc.(errs,typeEnv) = addTypeDecls @decs.typedecs @lhs.typeEnv decs.errors = @lhs.errors >< @errs { recordFields :: TypeEnv -> [TypedVar] -> (Errors,Map Ident (Pos,TYPE)) recordFields tenv tvs = foldr field (empty,Map.empty) tvs where field (TypedVar v t) ~(es,fs) = case lookupPos v fs of Just p -> (es >< singleton (DupRecordFieldDecl v p),fs) Nothing -> let (err,t') = findType tenv t in (es >< err,insertIdent v t' fs) lookupPos :: Ident -> Map Ident (Pos,a) -> Maybe Pos lookupPos i env = fmap fst (Map.lookup i env) insertIdent :: Ident -> a -> Map Ident (Pos,a) -> Map Ident (Pos,a) insertIdent i@(Id n p) val = insert i (p,val) addTypeDecls :: (TypeEnv,TypeSyns) -> TypeEnv -> (Errors,TypeEnv) addTypeDecls (new,syns) env = (errors, fmap (snd.snd) resolve `union` rest) where rest = new `union` env errors = foldr (><) empty (map (fst.snd) (elems resolve)) resolve :: Map Ident ([Ident],(Seq Error,(Pos,TYPE))) resolve = mapWithKey find syns where find l (p,v) = case Map.lookup v resolve of Just ~(vs,~(_,b)) -> (v:vs, if v `elem` vs then (singleton (CyclicType l) ,(p,ERROR) ) else (empty,(p, snd b)) ) Nothing -> let (es,tp) = findType rest v in ([], (es, (p,tp))) } -- Function declaration groups ATTR FunDecs [ | | fundecs:VarEnv ] ATTR FunDec [ | fundecs:VarEnv | ] SEM FunDecs | Cons lhs.fundecs = @hd.fundecs hd .fundecs = @tl.fundecs | Nil lhs.fundecs = Map.empty SEM FunDec | FunDec loc.(err1,fundecs) = case lookupPos @ident @lhs.fundecs of Just pos -> (singleton (DuplicateFun @ident pos ), @lhs.fundecs) Nothing -> (empty, insertIdent @ident (FunType @atps @ret) @lhs.fundecs) loc.(err2,argEnv,atps) = let f (TypedVar n t) ~(errs,env,tps) = let (e1,tp) = findType @lhs.typeEnv t (e2,en) = case lookupPos n env of Just p -> (singleton (DuplicateArg @ident n p), env) Nothing -> (empty, insertIdent n (VarType tp) env) in(e1 >< e2 >< errs,en,tp:tps) in foldr f (empty,Map.empty,[]) @argTps .(err3,ret) = case @retTp of Just tp -> findType @lhs.typeEnv tp Nothing -> (empty,VOID) body.varEnv = @argEnv `union` @lhs.varEnv .errors = @lhs.errors >< @err1 >< @err2 >< @err3 SEM DeclGroup | FunDecs loc.varEnv = @decs.fundecs `union` @lhs.varEnv -- Var Declarations SEM DeclGroup | VarDec lhs.varEnv = insertIdent @ident (VarType @theType) @lhs.varEnv loc.(errs,theType) = case @tp of Just t -> findType @lhs.typeEnv t Nothing -> case @expr.tp of NIL -> (singleton (UnknownType (getPos @ident)),ERROR) VOID -> (singleton (InitWithVoid (getPos @ident)),ERROR) _ -> (empty,@expr.tp) expr.expect = @theType .errors = @lhs.errors >< @errs SEM Expr | For body.varEnv = insertIdent @ident (VarType LOOPCOUNTER) @lhs.varEnv ATTR Expr LValue [ expect:{TYPE} || tp : {TYPE} ] SEM Program | Program expr.expect = @expr.tp SEM FunDec | FunDec body.expect = @ret { arrayComponentType :: Pos -> TYPE -> (Errors,TYPE) arrayComponentType _ ERROR = (empty,ERROR) arrayComponentType _ (ARRAY _ _ c) = (empty,c) arrayComponentType p tp = (singleton (NotArrayType p),ERROR) recordFieldType :: Pos -> Map VarIdent (Pos,TYPE) -> Ident -> (Errors,TYPE) recordFieldType p fields ident = case lookupIdent ident fields of Nothing -> (singleton (NoSuchField p ident), ERROR) Just t -> (empty,t) recordType :: Pos -> TYPE -> (Errors,Map Ident (Pos,TYPE)) recordType _ ERROR = (empty,Map.empty) recordType p (RECORD n _ fs) = (empty,fs) recordType p NIL = (singleton (UnknownType p),Map.empty) recordType p tp = (singleton (NotRecordType p),Map.empty) match a b = maybe False (const True) (meet a b) meet a ERROR = Just a meet ERROR b = Just b meet LOOPCOUNTER INT = Just LOOPCOUNTER meet INT LOOPCOUNTER = Just LOOPCOUNTER meet a@(RECORD _ _ _) NIL = Just a meet NIL b@(RECORD _ _ _) = Just b meet a b | a == b = Just a | otherwise = Nothing meetErr a b = case meet a b of Nothing -> (singleton (TypeMisMatch a b), ERROR) Just t -> (empty, t) --Nil? } SEM LValue | Sub loc.(err,tp) = arrayComponentType @pos @expr.tp index.expect = INT expr.expect = case @tp of ERROR -> ERROR ; _ -> @expr.tp expr.errors = @lhs.errors >< @err >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) --check expect == tp | Dot loc.(err1,fieldEnv) = recordType @pos @expr.tp .(err2,tp) = recordFieldType @pos @fieldEnv @ident expr.expect = case @tp of ERROR -> ERROR ; _ -> @expr.tp expr.errors = @lhs.errors >< @err1 >< @err2 >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) -- expect == tp | Ident loc.(errs,tp) = findVar @lhs.varEnv @ident lhs.errors = @lhs.errors >< @errs >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) -- check expect == tp SEM Expr | LValue loc.tp = if @lvalue.tp == LOOPCOUNTER then INT else @lvalue.tp lvalue.expect = @lhs.expect | IntLit loc.tp = INT lhs.errors = @lhs.errors >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) | StringLit loc.tp = STRING lhs.errors = @lhs.errors >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) -- check expect == tp | Skip loc.tp = VOID lhs.errors = @lhs.errors >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) -- check expect == tp | Nil loc.tp = NIL lhs.errors = @lhs.errors >< (if @lhs.expect == NIL then singleton (UnknownType @pos) else empty ) >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) -- check expect is a recordType | Break loc.tp = VOID lhs.errors = @lhs.errors >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) -- check expect == VOID | Sequence loc.tp = @right.tp left.expect = @left.tp left.errors = @lhs.errors >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) -- check expect == tp SEM Expr | While loc.tp = VOID cond.expect = INT body.expect = VOID -- check lhs.expect == VOID cond.errors = @lhs.errors >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) | For loc.tp = VOID hi.expect = INT low.expect = INT body.expect = VOID -- check lhs.expect == VOID low.errors = @lhs.errors >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) | If loc.tp = @expectType loc.(err,expectType) = @thenPart.tp `meetErr` @elsePart.tp -- `meet` @lhs.expect cond.expect = INT elsePart.expect = @expectType thenPart.expect = @expectType cond.errors = @lhs.errors >< @err >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) | Let lhs.tp = @body.tp body.expect = @lhs.expect | Assign loc.tp = VOID .(err,expType) = @lvalue.tp `meetErr` @expr.tp lvalue.expect = @expType expr.expect = @expType --check lhs.expect == VOID --check lhs.tp /= LOOPCOUNTER lvalue.errors = @lhs.errors >< @err >< (if @lvalue.tp == LOOPCOUNTER then singleton (AssignLoopcounter @pos) else empty ) >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) | Op left.expect = @expect right.expect = @expect loc.tp = INT .(err, expect) = let check | @op `elem` ["+","-","*","/","|","&"] = (empty,INT) | @op `elem` [">=", "<=", "<", ">"] = let (e,tp) = meetErr @left.tp @right.tp in if tp `elem` [INT,STRING,ERROR] then (e,tp) else (e>"] = let (e,tp) = meetErr @left.tp @right.tp in if tp == NIL then (e>< @err >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) | UnOp loc.(tp,expect) = case @op of "-" -> (INT,INT) _ -> compilerError ("unknown unary operator: " ++ @op) expr.errors = @lhs.errors >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) SEM Expr | Apply loc.(errs,argTps,retTp) = findFunction @lhs.varEnv @ident lhs.tp = @retTp args.expects = @argTps ++ repeat ERROR args.errors = @lhs.errors >< @errs >< (case compare @args.size (length @argTps) of LT -> singleton (TooFewArguments @ident) GT -> singleton (TooManyArguments @ident) EQ -> empty) >< if match @lhs.expect @retTp then empty else singleton (TypeMisMatch @lhs.expect @retTp) -- check lhs.expect == retTp -- check @args.size == length @argTps | ArrayVal loc.(err1,tp) = findType @lhs.typeEnv @ident .(err2,compTp) = arrayComponentType (getPos @ident) @tp size.expect = INT init.expect = @compTp init.errors = @lhs.errors >< @err1 >< @err2 >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) -- check lhs.expect == tp | RecordVal loc.(err1,tp) = findType @lhs.typeEnv @ident .(err2,fieldEnv) = recordType (getPos @ident) @tp loc.(err3, expFields) = let f i ~(err,ts) = case recordFieldType (getPos i) @fieldEnv i of (e,t) -> (err>< @err1 >< @err2 >< @err3 >< @notInit >< if match @lhs.expect @tp then empty else singleton (TypeMisMatch @lhs.expect @tp) ATTR Args [ expects:{[TYPE]} || size : Int] SEM Args | Nil lhs.size = 0 | Cons hd.expect = head @lhs.expects tl.expects = tail @lhs.expects lhs.size = 1 + @tl.size ATTR AssignField [ expect:{TYPE} || name : {VarIdent} ] ATTR AssignFields [ expects:{[TYPE]} || names : {[VarIdent]} ] SEM AssignField | AssignField lhs.name = @ident SEM AssignFields | Nil lhs.names = [] | Cons lhs.names = @hd.name : @tl.names hd.expect = head @lhs.expects tl.expects = tail @lhs.expects