-- UUAGC 0.9.5 (src/TigerSem.ag) module TigerSem where import TigerAS import Monad(mplus) import List(sort) import Maybe(fromMaybe) import UU.DData.Map(Map,insert,unionWith,member,elems,findWithDefault, keys, mapWithKey) import UU.DData.Seq import qualified UU.DData.Map as Map(lookup,empty,fromList) import TigerError import TigerTypes import UU.Scanner.Position 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 -> (single (UndeclaredType n), ERROR) findVar env n = case lookupIdent n env of Just x -> case x of VarType t -> (empty, t) FunType _ _ -> (single (NotVarType n), ERROR) Nothing -> (single (UndeclaredVar n), ERROR) findFunction env n = case lookupIdent n env of Just x -> case x of VarType t -> (single (NotFunType n), [], ERROR) FunType a r -> (empty, a,r) Nothing -> (single (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) 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 <> single (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 (single (CyclicType l) ,(p,ERROR) ) else (empty,(p, snd b)) ) Nothing -> let (es,tp) = findType rest v in ([], (es, (p,tp))) arrayComponentType :: Pos -> TYPE -> (Errors,TYPE) arrayComponentType _ ERROR = (empty,ERROR) arrayComponentType _ (ARRAY _ _ c) = (empty,c) arrayComponentType p tp = (single (NotArrayType p),ERROR) recordFieldType :: Pos -> Map VarIdent (Pos,TYPE) -> Ident -> (Errors,TYPE) recordFieldType p fields ident = case lookupIdent ident fields of Nothing -> (single (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 = (single (UnknownType p),Map.empty) recordType p tp = (single (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 -> (single (TypeMisMatch a b), ERROR) Just t -> (empty, t) --Nil? -- Args -------------------------------------------------------- -- cata sem_Args :: Args -> T_Args sem_Args list = (Prelude.foldr sem_Args_Cons sem_Args_Nil (Prelude.map sem_Expr list)) -- semantic domain type T_Args = Errors -> ([TYPE]) -> TypeEnv -> Int -> VarEnv -> ( Errors,Int,Int) sem_Args_Cons :: T_Expr -> T_Args -> T_Args sem_Args_Cons hd_ tl_ = (\ _lhsIerrors _lhsIexpects _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _hdOexpect :: TYPE _tlOexpects :: ([TYPE]) _lhsOsize :: Int _lhsOerrors :: Errors _lhsOtypecounter :: Int _hdOerrors :: Errors _hdOtypeEnv :: TypeEnv _hdOtypecounter :: Int _hdOvarEnv :: VarEnv _tlOerrors :: Errors _tlOtypeEnv :: TypeEnv _tlOtypecounter :: Int _tlOvarEnv :: VarEnv _hdIerrors :: Errors _hdItp :: TYPE _hdItypecounter :: Int _tlIerrors :: Errors _tlIsize :: Int _tlItypecounter :: Int _hdOexpect = head _lhsIexpects _tlOexpects = tail _lhsIexpects _lhsOsize = 1 + _tlIsize _lhsOerrors = _tlIerrors _lhsOtypecounter = _tlItypecounter _hdOerrors = _lhsIerrors _hdOtypeEnv = _lhsItypeEnv _hdOtypecounter = _lhsItypecounter _hdOvarEnv = _lhsIvarEnv _tlOerrors = _hdIerrors _tlOtypeEnv = _lhsItypeEnv _tlOtypecounter = _hdItypecounter _tlOvarEnv = _lhsIvarEnv ( _hdIerrors,_hdItp,_hdItypecounter) = (hd_ _hdOerrors _hdOexpect _hdOtypeEnv _hdOtypecounter _hdOvarEnv) ( _tlIerrors,_tlIsize,_tlItypecounter) = (tl_ _tlOerrors _tlOexpects _tlOtypeEnv _tlOtypecounter _tlOvarEnv) in ( _lhsOerrors,_lhsOsize,_lhsOtypecounter))) sem_Args_Nil :: T_Args sem_Args_Nil = (\ _lhsIerrors _lhsIexpects _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOsize :: Int _lhsOerrors :: Errors _lhsOtypecounter :: Int _lhsOsize = 0 _lhsOerrors = _lhsIerrors _lhsOtypecounter = _lhsItypecounter in ( _lhsOerrors,_lhsOsize,_lhsOtypecounter))) -- AssignField ------------------------------------------------- -- cata sem_AssignField :: AssignField -> T_AssignField sem_AssignField (AssignField _ident _expr) = (sem_AssignField_AssignField _ident (sem_Expr _expr)) -- semantic domain type T_AssignField = Errors -> TYPE -> TypeEnv -> Int -> VarEnv -> ( Errors,VarIdent,Int) sem_AssignField_AssignField :: VarIdent -> T_Expr -> T_AssignField sem_AssignField_AssignField ident_ expr_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOname :: VarIdent _lhsOerrors :: Errors _lhsOtypecounter :: Int _exprOerrors :: Errors _exprOexpect :: TYPE _exprOtypeEnv :: TypeEnv _exprOtypecounter :: Int _exprOvarEnv :: VarEnv _exprIerrors :: Errors _exprItp :: TYPE _exprItypecounter :: Int _lhsOname = ident_ _lhsOerrors = _exprIerrors _lhsOtypecounter = _exprItypecounter _exprOerrors = _lhsIerrors _exprOexpect = _lhsIexpect _exprOtypeEnv = _lhsItypeEnv _exprOtypecounter = _lhsItypecounter _exprOvarEnv = _lhsIvarEnv ( _exprIerrors,_exprItp,_exprItypecounter) = (expr_ _exprOerrors _exprOexpect _exprOtypeEnv _exprOtypecounter _exprOvarEnv) in ( _lhsOerrors,_lhsOname,_lhsOtypecounter))) -- AssignFields ------------------------------------------------ -- cata sem_AssignFields :: AssignFields -> T_AssignFields sem_AssignFields list = (Prelude.foldr sem_AssignFields_Cons sem_AssignFields_Nil (Prelude.map sem_AssignField list)) -- semantic domain type T_AssignFields = Errors -> ([TYPE]) -> TypeEnv -> Int -> VarEnv -> ( Errors,([VarIdent]),Int) sem_AssignFields_Cons :: T_AssignField -> T_AssignFields -> T_AssignFields sem_AssignFields_Cons hd_ tl_ = (\ _lhsIerrors _lhsIexpects _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOnames :: ([VarIdent]) _hdOexpect :: TYPE _tlOexpects :: ([TYPE]) _lhsOerrors :: Errors _lhsOtypecounter :: Int _hdOerrors :: Errors _hdOtypeEnv :: TypeEnv _hdOtypecounter :: Int _hdOvarEnv :: VarEnv _tlOerrors :: Errors _tlOtypeEnv :: TypeEnv _tlOtypecounter :: Int _tlOvarEnv :: VarEnv _hdIerrors :: Errors _hdIname :: VarIdent _hdItypecounter :: Int _tlIerrors :: Errors _tlInames :: ([VarIdent]) _tlItypecounter :: Int _lhsOnames = _hdIname : _tlInames _hdOexpect = head _lhsIexpects _tlOexpects = tail _lhsIexpects _lhsOerrors = _tlIerrors _lhsOtypecounter = _tlItypecounter _hdOerrors = _lhsIerrors _hdOtypeEnv = _lhsItypeEnv _hdOtypecounter = _lhsItypecounter _hdOvarEnv = _lhsIvarEnv _tlOerrors = _hdIerrors _tlOtypeEnv = _lhsItypeEnv _tlOtypecounter = _hdItypecounter _tlOvarEnv = _lhsIvarEnv ( _hdIerrors,_hdIname,_hdItypecounter) = (hd_ _hdOerrors _hdOexpect _hdOtypeEnv _hdOtypecounter _hdOvarEnv) ( _tlIerrors,_tlInames,_tlItypecounter) = (tl_ _tlOerrors _tlOexpects _tlOtypeEnv _tlOtypecounter _tlOvarEnv) in ( _lhsOerrors,_lhsOnames,_lhsOtypecounter))) sem_AssignFields_Nil :: T_AssignFields sem_AssignFields_Nil = (\ _lhsIerrors _lhsIexpects _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOnames :: ([VarIdent]) _lhsOerrors :: Errors _lhsOtypecounter :: Int _lhsOnames = [] _lhsOerrors = _lhsIerrors _lhsOtypecounter = _lhsItypecounter in ( _lhsOerrors,_lhsOnames,_lhsOtypecounter))) -- DeclGroup --------------------------------------------------- -- cata sem_DeclGroup :: DeclGroup -> T_DeclGroup sem_DeclGroup (FunDecs _decs) = (sem_DeclGroup_FunDecs (sem_FunDecs _decs)) sem_DeclGroup (TypeDecs _decs) = (sem_DeclGroup_TypeDecs (sem_TypeDecs _decs)) sem_DeclGroup (VarDec _pos _ident _tp _expr) = (sem_DeclGroup_VarDec _pos _ident _tp (sem_Expr _expr)) -- semantic domain type T_DeclGroup = Errors -> TypeEnv -> Int -> VarEnv -> ( Errors,TypeEnv,Int,VarEnv) sem_DeclGroup_FunDecs :: T_FunDecs -> T_DeclGroup sem_DeclGroup_FunDecs decs_ = (\ _lhsIerrors _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOerrors :: Errors _lhsOtypeEnv :: TypeEnv _lhsOtypecounter :: Int _lhsOvarEnv :: VarEnv _decsOerrors :: Errors _decsOtypeEnv :: TypeEnv _decsOtypecounter :: Int _decsOvarEnv :: VarEnv _decsIerrors :: Errors _decsIfundecs :: VarEnv _decsItypecounter :: Int _varEnv = _decsIfundecs `union` _lhsIvarEnv _lhsOerrors = _decsIerrors _lhsOtypeEnv = _lhsItypeEnv _lhsOtypecounter = _decsItypecounter _lhsOvarEnv = _varEnv _decsOerrors = _lhsIerrors _decsOtypeEnv = _lhsItypeEnv _decsOtypecounter = _lhsItypecounter _decsOvarEnv = _varEnv ( _decsIerrors,_decsIfundecs,_decsItypecounter) = (decs_ _decsOerrors _decsOtypeEnv _decsOtypecounter _decsOvarEnv) in ( _lhsOerrors,_lhsOtypeEnv,_lhsOtypecounter,_lhsOvarEnv))) sem_DeclGroup_TypeDecs :: T_TypeDecs -> T_DeclGroup sem_DeclGroup_TypeDecs decs_ = (\ _lhsIerrors _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _decsOerrors :: Errors _lhsOerrors :: Errors _lhsOtypeEnv :: TypeEnv _lhsOtypecounter :: Int _lhsOvarEnv :: VarEnv _decsOtypeEnv :: TypeEnv _decsOtypecounter :: Int _decsIerrors :: Errors _decsItypecounter :: Int _decsItypedecs :: ((TypeEnv, TypeSyns)) __tup1 = addTypeDecls _decsItypedecs _lhsItypeEnv (_errs,_) = __tup1 (_,_typeEnv) = __tup1 _decsOerrors = _lhsIerrors <> _errs _lhsOerrors = _decsIerrors _lhsOtypeEnv = _typeEnv _lhsOtypecounter = _decsItypecounter _lhsOvarEnv = _lhsIvarEnv _decsOtypeEnv = _typeEnv _decsOtypecounter = _lhsItypecounter ( _decsIerrors,_decsItypecounter,_decsItypedecs) = (decs_ _decsOerrors _decsOtypeEnv _decsOtypecounter) in ( _lhsOerrors,_lhsOtypeEnv,_lhsOtypecounter,_lhsOvarEnv))) sem_DeclGroup_VarDec :: Pos -> VarIdent -> (Maybe TypeIdent) -> T_Expr -> T_DeclGroup sem_DeclGroup_VarDec pos_ ident_ tp_ expr_ = (\ _lhsIerrors _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOvarEnv :: VarEnv _exprOexpect :: TYPE _exprOerrors :: Errors _lhsOerrors :: Errors _lhsOtypeEnv :: TypeEnv _lhsOtypecounter :: Int _exprOtypeEnv :: TypeEnv _exprOtypecounter :: Int _exprOvarEnv :: VarEnv _exprIerrors :: Errors _exprItp :: TYPE _exprItypecounter :: Int _lhsOvarEnv = insertIdent ident_ (VarType _theType) _lhsIvarEnv __tup2 = case tp_ of Just t -> findType _lhsItypeEnv t Nothing -> case _exprItp of NIL -> (single (UnknownType (getPos ident_)),ERROR) VOID -> (single (InitWithVoid (getPos ident_)),ERROR) _ -> (empty,_exprItp) (_errs,_) = __tup2 (_,_theType) = __tup2 _exprOexpect = _theType _exprOerrors = _lhsIerrors <> _errs _lhsOerrors = _exprIerrors _lhsOtypeEnv = _lhsItypeEnv _lhsOtypecounter = _exprItypecounter _exprOtypeEnv = _lhsItypeEnv _exprOtypecounter = _lhsItypecounter _exprOvarEnv = _lhsIvarEnv ( _exprIerrors,_exprItp,_exprItypecounter) = (expr_ _exprOerrors _exprOexpect _exprOtypeEnv _exprOtypecounter _exprOvarEnv) in ( _lhsOerrors,_lhsOtypeEnv,_lhsOtypecounter,_lhsOvarEnv))) -- Declarations ------------------------------------------------ -- cata sem_Declarations :: Declarations -> T_Declarations sem_Declarations list = (Prelude.foldr sem_Declarations_Cons sem_Declarations_Nil (Prelude.map sem_DeclGroup list)) -- semantic domain type T_Declarations = Errors -> TypeEnv -> Int -> VarEnv -> ( Errors,TypeEnv,Int,VarEnv) sem_Declarations_Cons :: T_DeclGroup -> T_Declarations -> T_Declarations sem_Declarations_Cons hd_ tl_ = (\ _lhsIerrors _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOerrors :: Errors _lhsOtypeEnv :: TypeEnv _lhsOtypecounter :: Int _lhsOvarEnv :: VarEnv _hdOerrors :: Errors _hdOtypeEnv :: TypeEnv _hdOtypecounter :: Int _hdOvarEnv :: VarEnv _tlOerrors :: Errors _tlOtypeEnv :: TypeEnv _tlOtypecounter :: Int _tlOvarEnv :: VarEnv _hdIerrors :: Errors _hdItypeEnv :: TypeEnv _hdItypecounter :: Int _hdIvarEnv :: VarEnv _tlIerrors :: Errors _tlItypeEnv :: TypeEnv _tlItypecounter :: Int _tlIvarEnv :: VarEnv _lhsOerrors = _tlIerrors _lhsOtypeEnv = _tlItypeEnv _lhsOtypecounter = _tlItypecounter _lhsOvarEnv = _tlIvarEnv _hdOerrors = _lhsIerrors _hdOtypeEnv = _lhsItypeEnv _hdOtypecounter = _lhsItypecounter _hdOvarEnv = _lhsIvarEnv _tlOerrors = _hdIerrors _tlOtypeEnv = _hdItypeEnv _tlOtypecounter = _hdItypecounter _tlOvarEnv = _hdIvarEnv ( _hdIerrors,_hdItypeEnv,_hdItypecounter,_hdIvarEnv) = (hd_ _hdOerrors _hdOtypeEnv _hdOtypecounter _hdOvarEnv) ( _tlIerrors,_tlItypeEnv,_tlItypecounter,_tlIvarEnv) = (tl_ _tlOerrors _tlOtypeEnv _tlOtypecounter _tlOvarEnv) in ( _lhsOerrors,_lhsOtypeEnv,_lhsOtypecounter,_lhsOvarEnv))) sem_Declarations_Nil :: T_Declarations sem_Declarations_Nil = (\ _lhsIerrors _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOerrors :: Errors _lhsOtypeEnv :: TypeEnv _lhsOtypecounter :: Int _lhsOvarEnv :: VarEnv _lhsOerrors = _lhsIerrors _lhsOtypeEnv = _lhsItypeEnv _lhsOtypecounter = _lhsItypecounter _lhsOvarEnv = _lhsIvarEnv in ( _lhsOerrors,_lhsOtypeEnv,_lhsOtypecounter,_lhsOvarEnv))) -- Expr -------------------------------------------------------- -- cata sem_Expr :: Expr -> T_Expr sem_Expr (Apply _ident _args) = (sem_Expr_Apply _ident (sem_Args _args)) sem_Expr (ArrayVal _ident _size _init) = (sem_Expr_ArrayVal _ident (sem_Expr _size) (sem_Expr _init)) sem_Expr (Assign _lvalue _pos _expr) = (sem_Expr_Assign (sem_LValue _lvalue) _pos (sem_Expr _expr)) sem_Expr (Break _pos) = (sem_Expr_Break _pos) sem_Expr (For _pos _ident _low _hi _body) = (sem_Expr_For _pos _ident (sem_Expr _low) (sem_Expr _hi) (sem_Expr _body)) sem_Expr (If _pos _cond _thenPart _elsePart) = (sem_Expr_If _pos (sem_Expr _cond) (sem_Expr _thenPart) (sem_Expr _elsePart)) sem_Expr (IntLit _value _pos) = (sem_Expr_IntLit _value _pos) sem_Expr (LValue _lvalue) = (sem_Expr_LValue (sem_LValue _lvalue)) sem_Expr (Let _pos _decls _body) = (sem_Expr_Let _pos (sem_Declarations _decls) (sem_Expr _body)) sem_Expr (Nil _pos) = (sem_Expr_Nil _pos) sem_Expr (Op _op _pos _left _right) = (sem_Expr_Op _op _pos (sem_Expr _left) (sem_Expr _right)) sem_Expr (RecordVal _ident _fields) = (sem_Expr_RecordVal _ident (sem_AssignFields _fields)) sem_Expr (Sequence _left _right) = (sem_Expr_Sequence (sem_Expr _left) (sem_Expr _right)) sem_Expr (Skip ) = (sem_Expr_Skip ) sem_Expr (StringLit _value _pos) = (sem_Expr_StringLit _value _pos) sem_Expr (UnOp _pos _op _expr) = (sem_Expr_UnOp _pos _op (sem_Expr _expr)) sem_Expr (While _pos _cond _body) = (sem_Expr_While _pos (sem_Expr _cond) (sem_Expr _body)) -- semantic domain type T_Expr = Errors -> TYPE -> TypeEnv -> Int -> VarEnv -> ( Errors,TYPE,Int) sem_Expr_Apply :: VarIdent -> T_Args -> T_Expr sem_Expr_Apply ident_ args_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOtp :: TYPE _argsOexpects :: ([TYPE]) _argsOerrors :: Errors _lhsOerrors :: Errors _lhsOtypecounter :: Int _argsOtypeEnv :: TypeEnv _argsOtypecounter :: Int _argsOvarEnv :: VarEnv _argsIerrors :: Errors _argsIsize :: Int _argsItypecounter :: Int __tup3 = findFunction _lhsIvarEnv ident_ (_errs,_,_) = __tup3 (_,_argTps,_) = __tup3 (_,_,_retTp) = __tup3 _lhsOtp = _retTp _argsOexpects = _argTps ++ repeat ERROR _argsOerrors = _lhsIerrors <> _errs <> (case compare _argsIsize (length _argTps) of LT -> single (TooFewArguments ident_) GT -> single (TooManyArguments ident_) EQ -> empty) <> if match _lhsIexpect _retTp then empty else single (TypeMisMatch _lhsIexpect _retTp) _lhsOerrors = _argsIerrors _lhsOtypecounter = _argsItypecounter _argsOtypeEnv = _lhsItypeEnv _argsOtypecounter = _lhsItypecounter _argsOvarEnv = _lhsIvarEnv ( _argsIerrors,_argsIsize,_argsItypecounter) = (args_ _argsOerrors _argsOexpects _argsOtypeEnv _argsOtypecounter _argsOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_ArrayVal :: TypeIdent -> T_Expr -> T_Expr -> T_Expr sem_Expr_ArrayVal ident_ size_ init_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _sizeOexpect :: TYPE _initOexpect :: TYPE _initOerrors :: Errors _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _sizeOerrors :: Errors _sizeOtypeEnv :: TypeEnv _sizeOtypecounter :: Int _sizeOvarEnv :: VarEnv _initOtypeEnv :: TypeEnv _initOtypecounter :: Int _initOvarEnv :: VarEnv _sizeIerrors :: Errors _sizeItp :: TYPE _sizeItypecounter :: Int _initIerrors :: Errors _initItp :: TYPE _initItypecounter :: Int __tup4 = findType _lhsItypeEnv ident_ (_err1,_) = __tup4 (_,_tp) = __tup4 __tup5 = arrayComponentType (getPos ident_) _tp (_err2,_) = __tup5 (_,_compTp) = __tup5 _sizeOexpect = INT _initOexpect = _compTp _initOerrors = _lhsIerrors <> _err1 <> _err2 <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOerrors = _initIerrors _lhsOtp = _tp _lhsOtypecounter = _initItypecounter _sizeOerrors = _lhsIerrors _sizeOtypeEnv = _lhsItypeEnv _sizeOtypecounter = _lhsItypecounter _sizeOvarEnv = _lhsIvarEnv _initOtypeEnv = _lhsItypeEnv _initOtypecounter = _sizeItypecounter _initOvarEnv = _lhsIvarEnv ( _sizeIerrors,_sizeItp,_sizeItypecounter) = (size_ _sizeOerrors _sizeOexpect _sizeOtypeEnv _sizeOtypecounter _sizeOvarEnv) ( _initIerrors,_initItp,_initItypecounter) = (init_ _initOerrors _initOexpect _initOtypeEnv _initOtypecounter _initOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_Assign :: T_LValue -> Pos -> T_Expr -> T_Expr sem_Expr_Assign lvalue_ pos_ expr_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lvalueOexpect :: TYPE _exprOexpect :: TYPE _lvalueOerrors :: Errors _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _lvalueOtypeEnv :: TypeEnv _lvalueOtypecounter :: Int _lvalueOvarEnv :: VarEnv _exprOerrors :: Errors _exprOtypeEnv :: TypeEnv _exprOtypecounter :: Int _exprOvarEnv :: VarEnv _lvalueIerrors :: Errors _lvalueItp :: TYPE _lvalueItypecounter :: Int _exprIerrors :: Errors _exprItp :: TYPE _exprItypecounter :: Int _tp = VOID __tup6 = _lvalueItp `meetErr` _exprItp (_err,_) = __tup6 (_,_expType) = __tup6 _lvalueOexpect = _expType _exprOexpect = _expType _lvalueOerrors = _lhsIerrors <> _err <> (if _lvalueItp == LOOPCOUNTER then single (AssignLoopcounter pos_) else empty ) <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOerrors = _exprIerrors _lhsOtp = _tp _lhsOtypecounter = _exprItypecounter _lvalueOtypeEnv = _lhsItypeEnv _lvalueOtypecounter = _lhsItypecounter _lvalueOvarEnv = _lhsIvarEnv _exprOerrors = _lvalueIerrors _exprOtypeEnv = _lhsItypeEnv _exprOtypecounter = _lvalueItypecounter _exprOvarEnv = _lhsIvarEnv ( _lvalueIerrors,_lvalueItp,_lvalueItypecounter) = (lvalue_ _lvalueOerrors _lvalueOexpect _lvalueOtypeEnv _lvalueOtypecounter _lvalueOvarEnv) ( _exprIerrors,_exprItp,_exprItypecounter) = (expr_ _exprOerrors _exprOexpect _exprOtypeEnv _exprOtypecounter _exprOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_Break :: Pos -> T_Expr sem_Expr_Break pos_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _tp = VOID _lhsOerrors = _lhsIerrors <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOtp = _tp _lhsOtypecounter = _lhsItypecounter in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_For :: Pos -> VarIdent -> T_Expr -> T_Expr -> T_Expr -> T_Expr sem_Expr_For pos_ ident_ low_ hi_ body_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _bodyOvarEnv :: VarEnv _hiOexpect :: TYPE _lowOexpect :: TYPE _bodyOexpect :: TYPE _lowOerrors :: Errors _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _lowOtypeEnv :: TypeEnv _lowOtypecounter :: Int _lowOvarEnv :: VarEnv _hiOerrors :: Errors _hiOtypeEnv :: TypeEnv _hiOtypecounter :: Int _hiOvarEnv :: VarEnv _bodyOerrors :: Errors _bodyOtypeEnv :: TypeEnv _bodyOtypecounter :: Int _lowIerrors :: Errors _lowItp :: TYPE _lowItypecounter :: Int _hiIerrors :: Errors _hiItp :: TYPE _hiItypecounter :: Int _bodyIerrors :: Errors _bodyItp :: TYPE _bodyItypecounter :: Int _bodyOvarEnv = insertIdent ident_ (VarType LOOPCOUNTER) _lhsIvarEnv _tp = VOID _hiOexpect = INT _lowOexpect = INT _bodyOexpect = VOID _lowOerrors = _lhsIerrors <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOerrors = _bodyIerrors _lhsOtp = _tp _lhsOtypecounter = _bodyItypecounter _lowOtypeEnv = _lhsItypeEnv _lowOtypecounter = _lhsItypecounter _lowOvarEnv = _lhsIvarEnv _hiOerrors = _lowIerrors _hiOtypeEnv = _lhsItypeEnv _hiOtypecounter = _lowItypecounter _hiOvarEnv = _lhsIvarEnv _bodyOerrors = _hiIerrors _bodyOtypeEnv = _lhsItypeEnv _bodyOtypecounter = _hiItypecounter ( _lowIerrors,_lowItp,_lowItypecounter) = (low_ _lowOerrors _lowOexpect _lowOtypeEnv _lowOtypecounter _lowOvarEnv) ( _hiIerrors,_hiItp,_hiItypecounter) = (hi_ _hiOerrors _hiOexpect _hiOtypeEnv _hiOtypecounter _hiOvarEnv) ( _bodyIerrors,_bodyItp,_bodyItypecounter) = (body_ _bodyOerrors _bodyOexpect _bodyOtypeEnv _bodyOtypecounter _bodyOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_If :: Pos -> T_Expr -> T_Expr -> T_Expr -> T_Expr sem_Expr_If pos_ cond_ thenPart_ elsePart_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _condOexpect :: TYPE _elsePartOexpect :: TYPE _thenPartOexpect :: TYPE _condOerrors :: Errors _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _condOtypeEnv :: TypeEnv _condOtypecounter :: Int _condOvarEnv :: VarEnv _thenPartOerrors :: Errors _thenPartOtypeEnv :: TypeEnv _thenPartOtypecounter :: Int _thenPartOvarEnv :: VarEnv _elsePartOerrors :: Errors _elsePartOtypeEnv :: TypeEnv _elsePartOtypecounter :: Int _elsePartOvarEnv :: VarEnv _condIerrors :: Errors _condItp :: TYPE _condItypecounter :: Int _thenPartIerrors :: Errors _thenPartItp :: TYPE _thenPartItypecounter :: Int _elsePartIerrors :: Errors _elsePartItp :: TYPE _elsePartItypecounter :: Int _tp = _expectType __tup7 = _thenPartItp `meetErr` _elsePartItp (_err,_) = __tup7 (_,_expectType) = __tup7 _condOexpect = INT _elsePartOexpect = _expectType _thenPartOexpect = _expectType _condOerrors = _lhsIerrors <> _err <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOerrors = _elsePartIerrors _lhsOtp = _tp _lhsOtypecounter = _elsePartItypecounter _condOtypeEnv = _lhsItypeEnv _condOtypecounter = _lhsItypecounter _condOvarEnv = _lhsIvarEnv _thenPartOerrors = _condIerrors _thenPartOtypeEnv = _lhsItypeEnv _thenPartOtypecounter = _condItypecounter _thenPartOvarEnv = _lhsIvarEnv _elsePartOerrors = _thenPartIerrors _elsePartOtypeEnv = _lhsItypeEnv _elsePartOtypecounter = _thenPartItypecounter _elsePartOvarEnv = _lhsIvarEnv ( _condIerrors,_condItp,_condItypecounter) = (cond_ _condOerrors _condOexpect _condOtypeEnv _condOtypecounter _condOvarEnv) ( _thenPartIerrors,_thenPartItp,_thenPartItypecounter) = (thenPart_ _thenPartOerrors _thenPartOexpect _thenPartOtypeEnv _thenPartOtypecounter _thenPartOvarEnv) ( _elsePartIerrors,_elsePartItp,_elsePartItypecounter) = (elsePart_ _elsePartOerrors _elsePartOexpect _elsePartOtypeEnv _elsePartOtypecounter _elsePartOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_IntLit :: Integer -> Pos -> T_Expr sem_Expr_IntLit value_ pos_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _tp = INT _lhsOerrors = _lhsIerrors <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOtp = _tp _lhsOtypecounter = _lhsItypecounter in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_LValue :: T_LValue -> T_Expr sem_Expr_LValue lvalue_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lvalueOexpect :: TYPE _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _lvalueOerrors :: Errors _lvalueOtypeEnv :: TypeEnv _lvalueOtypecounter :: Int _lvalueOvarEnv :: VarEnv _lvalueIerrors :: Errors _lvalueItp :: TYPE _lvalueItypecounter :: Int _tp = if _lvalueItp == LOOPCOUNTER then INT else _lvalueItp _lvalueOexpect = _lhsIexpect _lhsOerrors = _lvalueIerrors _lhsOtp = _tp _lhsOtypecounter = _lvalueItypecounter _lvalueOerrors = _lhsIerrors _lvalueOtypeEnv = _lhsItypeEnv _lvalueOtypecounter = _lhsItypecounter _lvalueOvarEnv = _lhsIvarEnv ( _lvalueIerrors,_lvalueItp,_lvalueItypecounter) = (lvalue_ _lvalueOerrors _lvalueOexpect _lvalueOtypeEnv _lvalueOtypecounter _lvalueOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_Let :: Pos -> T_Declarations -> T_Expr -> T_Expr sem_Expr_Let pos_ decls_ body_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOtp :: TYPE _bodyOexpect :: TYPE _lhsOerrors :: Errors _lhsOtypecounter :: Int _declsOerrors :: Errors _declsOtypeEnv :: TypeEnv _declsOtypecounter :: Int _declsOvarEnv :: VarEnv _bodyOerrors :: Errors _bodyOtypeEnv :: TypeEnv _bodyOtypecounter :: Int _bodyOvarEnv :: VarEnv _declsIerrors :: Errors _declsItypeEnv :: TypeEnv _declsItypecounter :: Int _declsIvarEnv :: VarEnv _bodyIerrors :: Errors _bodyItp :: TYPE _bodyItypecounter :: Int _lhsOtp = _bodyItp _bodyOexpect = _lhsIexpect _lhsOerrors = _bodyIerrors _lhsOtypecounter = _bodyItypecounter _declsOerrors = _lhsIerrors _declsOtypeEnv = _lhsItypeEnv _declsOtypecounter = _lhsItypecounter _declsOvarEnv = _lhsIvarEnv _bodyOerrors = _declsIerrors _bodyOtypeEnv = _declsItypeEnv _bodyOtypecounter = _declsItypecounter _bodyOvarEnv = _declsIvarEnv ( _declsIerrors,_declsItypeEnv,_declsItypecounter,_declsIvarEnv) = (decls_ _declsOerrors _declsOtypeEnv _declsOtypecounter _declsOvarEnv) ( _bodyIerrors,_bodyItp,_bodyItypecounter) = (body_ _bodyOerrors _bodyOexpect _bodyOtypeEnv _bodyOtypecounter _bodyOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_Nil :: Pos -> T_Expr sem_Expr_Nil pos_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _tp = NIL _lhsOerrors = _lhsIerrors <> (if _lhsIexpect == NIL then single (UnknownType pos_) else empty ) <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOtp = _tp _lhsOtypecounter = _lhsItypecounter in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_Op :: String -> Pos -> T_Expr -> T_Expr -> T_Expr sem_Expr_Op op_ pos_ left_ right_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _leftOexpect :: TYPE _rightOexpect :: TYPE _leftOerrors :: Errors _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _leftOtypeEnv :: TypeEnv _leftOtypecounter :: Int _leftOvarEnv :: VarEnv _rightOerrors :: Errors _rightOtypeEnv :: TypeEnv _rightOtypecounter :: Int _rightOvarEnv :: VarEnv _leftIerrors :: Errors _leftItp :: TYPE _leftItypecounter :: Int _rightIerrors :: Errors _rightItp :: TYPE _rightItypecounter :: Int _leftOexpect = _expect _rightOexpect = _expect _tp = INT __tup8 = let check | op_ `elem` ["+","-","*","/","|","&"] = (empty,INT) | op_ `elem` [">=", "<=", "<", ">"] = let (e,tp) = meetErr _leftItp _rightItp in if tp `elem` [INT,STRING,ERROR] then (e,tp) else (e<>single(CompareOp pos_ op_),tp) | op_ `elem` [ "=", "<>"] = let (e,tp) = meetErr _leftItp _rightItp in if tp == NIL then (e<>single(UnknownType pos_) ,ERROR) else (e,tp) | otherwise = compilerError ("unknown binary operator: " ++ op_) in check (_err,_) = __tup8 (_,_expect) = __tup8 _leftOerrors = _lhsIerrors <> _err <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOerrors = _rightIerrors _lhsOtp = _tp _lhsOtypecounter = _rightItypecounter _leftOtypeEnv = _lhsItypeEnv _leftOtypecounter = _lhsItypecounter _leftOvarEnv = _lhsIvarEnv _rightOerrors = _leftIerrors _rightOtypeEnv = _lhsItypeEnv _rightOtypecounter = _leftItypecounter _rightOvarEnv = _lhsIvarEnv ( _leftIerrors,_leftItp,_leftItypecounter) = (left_ _leftOerrors _leftOexpect _leftOtypeEnv _leftOtypecounter _leftOvarEnv) ( _rightIerrors,_rightItp,_rightItypecounter) = (right_ _rightOerrors _rightOexpect _rightOtypeEnv _rightOtypecounter _rightOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_RecordVal :: TypeIdent -> T_AssignFields -> T_Expr sem_Expr_RecordVal ident_ fields_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _fieldsOexpects :: ([TYPE]) _fieldsOerrors :: Errors _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _fieldsOtypeEnv :: TypeEnv _fieldsOtypecounter :: Int _fieldsOvarEnv :: VarEnv _fieldsIerrors :: Errors _fieldsInames :: ([VarIdent]) _fieldsItypecounter :: Int __tup9 = findType _lhsItypeEnv ident_ (_err1,_) = __tup9 (_,_tp) = __tup9 __tup10 = recordType (getPos ident_) _tp (_err2,_) = __tup10 (_,_fieldEnv) = __tup10 __tup11 = let f i ~(err,ts) = case recordFieldType (getPos i) _fieldEnv i of (e,t) -> (err<>e,t:ts) in foldr f (empty,[]) _fieldsInames (_err3,_) = __tup11 (_,_expFields) = __tup11 _notInit = foldr cons empty [ FieldNotInit f | f <- keys _fieldEnv, not (f `elem` _fieldsInames)] _fieldsOexpects = _expFields _fieldsOerrors = _lhsIerrors <> _err1 <> _err2 <> _err3 <> _notInit <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOerrors = _fieldsIerrors _lhsOtp = _tp _lhsOtypecounter = _fieldsItypecounter _fieldsOtypeEnv = _lhsItypeEnv _fieldsOtypecounter = _lhsItypecounter _fieldsOvarEnv = _lhsIvarEnv ( _fieldsIerrors,_fieldsInames,_fieldsItypecounter) = (fields_ _fieldsOerrors _fieldsOexpects _fieldsOtypeEnv _fieldsOtypecounter _fieldsOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_Sequence :: T_Expr -> T_Expr -> T_Expr sem_Expr_Sequence left_ right_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _leftOexpect :: TYPE _leftOerrors :: Errors _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _leftOtypeEnv :: TypeEnv _leftOtypecounter :: Int _leftOvarEnv :: VarEnv _rightOerrors :: Errors _rightOexpect :: TYPE _rightOtypeEnv :: TypeEnv _rightOtypecounter :: Int _rightOvarEnv :: VarEnv _leftIerrors :: Errors _leftItp :: TYPE _leftItypecounter :: Int _rightIerrors :: Errors _rightItp :: TYPE _rightItypecounter :: Int _tp = _rightItp _leftOexpect = _leftItp _leftOerrors = _lhsIerrors <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOerrors = _rightIerrors _lhsOtp = _tp _lhsOtypecounter = _rightItypecounter _leftOtypeEnv = _lhsItypeEnv _leftOtypecounter = _lhsItypecounter _leftOvarEnv = _lhsIvarEnv _rightOerrors = _leftIerrors _rightOexpect = _lhsIexpect _rightOtypeEnv = _lhsItypeEnv _rightOtypecounter = _leftItypecounter _rightOvarEnv = _lhsIvarEnv ( _leftIerrors,_leftItp,_leftItypecounter) = (left_ _leftOerrors _leftOexpect _leftOtypeEnv _leftOtypecounter _leftOvarEnv) ( _rightIerrors,_rightItp,_rightItypecounter) = (right_ _rightOerrors _rightOexpect _rightOtypeEnv _rightOtypecounter _rightOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_Skip :: T_Expr sem_Expr_Skip = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _tp = VOID _lhsOerrors = _lhsIerrors <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOtp = _tp _lhsOtypecounter = _lhsItypecounter in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_StringLit :: String -> Pos -> T_Expr sem_Expr_StringLit value_ pos_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _tp = STRING _lhsOerrors = _lhsIerrors <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOtp = _tp _lhsOtypecounter = _lhsItypecounter in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_UnOp :: Pos -> String -> T_Expr -> T_Expr sem_Expr_UnOp pos_ op_ expr_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _exprOerrors :: Errors _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _exprOexpect :: TYPE _exprOtypeEnv :: TypeEnv _exprOtypecounter :: Int _exprOvarEnv :: VarEnv _exprIerrors :: Errors _exprItp :: TYPE _exprItypecounter :: Int __tup12 = case op_ of "-" -> (INT,INT) _ -> compilerError ("unknown unary operator: " ++ op_) (_tp,_) = __tup12 (_,_expect) = __tup12 _exprOerrors = _lhsIerrors <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOerrors = _exprIerrors _lhsOtp = _tp _lhsOtypecounter = _exprItypecounter _exprOexpect = _expect _exprOtypeEnv = _lhsItypeEnv _exprOtypecounter = _lhsItypecounter _exprOvarEnv = _lhsIvarEnv ( _exprIerrors,_exprItp,_exprItypecounter) = (expr_ _exprOerrors _exprOexpect _exprOtypeEnv _exprOtypecounter _exprOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_Expr_While :: Pos -> T_Expr -> T_Expr -> T_Expr sem_Expr_While pos_ cond_ body_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _condOexpect :: TYPE _bodyOexpect :: TYPE _condOerrors :: Errors _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _condOtypeEnv :: TypeEnv _condOtypecounter :: Int _condOvarEnv :: VarEnv _bodyOerrors :: Errors _bodyOtypeEnv :: TypeEnv _bodyOtypecounter :: Int _bodyOvarEnv :: VarEnv _condIerrors :: Errors _condItp :: TYPE _condItypecounter :: Int _bodyIerrors :: Errors _bodyItp :: TYPE _bodyItypecounter :: Int _tp = VOID _condOexpect = INT _bodyOexpect = VOID _condOerrors = _lhsIerrors <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOerrors = _bodyIerrors _lhsOtp = _tp _lhsOtypecounter = _bodyItypecounter _condOtypeEnv = _lhsItypeEnv _condOtypecounter = _lhsItypecounter _condOvarEnv = _lhsIvarEnv _bodyOerrors = _condIerrors _bodyOtypeEnv = _lhsItypeEnv _bodyOtypecounter = _condItypecounter _bodyOvarEnv = _lhsIvarEnv ( _condIerrors,_condItp,_condItypecounter) = (cond_ _condOerrors _condOexpect _condOtypeEnv _condOtypecounter _condOvarEnv) ( _bodyIerrors,_bodyItp,_bodyItypecounter) = (body_ _bodyOerrors _bodyOexpect _bodyOtypeEnv _bodyOtypecounter _bodyOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) -- FunDec ------------------------------------------------------ -- cata sem_FunDec :: FunDec -> T_FunDec sem_FunDec (FunDec _pos _ident _argTps _retTp _body) = (sem_FunDec_FunDec _pos _ident _argTps _retTp (sem_Expr _body)) -- semantic domain type T_FunDec = Errors -> VarEnv -> TypeEnv -> Int -> VarEnv -> ( Errors,VarEnv,Int) sem_FunDec_FunDec :: Pos -> VarIdent -> ([TypedVar]) -> (Maybe TypeIdent) -> T_Expr -> T_FunDec sem_FunDec_FunDec pos_ ident_ argTps_ retTp_ body_ = (\ _lhsIerrors _lhsIfundecs _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _bodyOvarEnv :: VarEnv _bodyOerrors :: Errors _bodyOexpect :: TYPE _lhsOerrors :: Errors _lhsOfundecs :: VarEnv _lhsOtypecounter :: Int _bodyOtypeEnv :: TypeEnv _bodyOtypecounter :: Int _bodyIerrors :: Errors _bodyItp :: TYPE _bodyItypecounter :: Int __tup13 = case lookupPos ident_ _lhsIfundecs of Just pos -> (single (DuplicateFun ident_ pos ), _lhsIfundecs) Nothing -> (empty, insertIdent ident_ (FunType _atps _ret) _lhsIfundecs) (_err1,_) = __tup13 (_,_fundecs) = __tup13 __tup14 = let f (TypedVar n t) ~(errs,env,tps) = let (e1,tp) = findType _lhsItypeEnv t (e2,en) = case lookupPos n env of Just p -> (single (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_ (_err2,_,_) = __tup14 (_,_argEnv,_) = __tup14 (_,_,_atps) = __tup14 __tup15 = case retTp_ of Just tp -> findType _lhsItypeEnv tp Nothing -> (empty,VOID) (_err3,_) = __tup15 (_,_ret) = __tup15 _bodyOvarEnv = _argEnv `union` _lhsIvarEnv _bodyOerrors = _lhsIerrors <> _err1 <> _err2 <> _err3 _bodyOexpect = _ret _lhsOerrors = _bodyIerrors _lhsOfundecs = _fundecs _lhsOtypecounter = _bodyItypecounter _bodyOtypeEnv = _lhsItypeEnv _bodyOtypecounter = _lhsItypecounter ( _bodyIerrors,_bodyItp,_bodyItypecounter) = (body_ _bodyOerrors _bodyOexpect _bodyOtypeEnv _bodyOtypecounter _bodyOvarEnv) in ( _lhsOerrors,_lhsOfundecs,_lhsOtypecounter))) -- FunDecs ----------------------------------------------------- -- cata sem_FunDecs :: FunDecs -> T_FunDecs sem_FunDecs list = (Prelude.foldr sem_FunDecs_Cons sem_FunDecs_Nil (Prelude.map sem_FunDec list)) -- semantic domain type T_FunDecs = Errors -> TypeEnv -> Int -> VarEnv -> ( Errors,VarEnv,Int) sem_FunDecs_Cons :: T_FunDec -> T_FunDecs -> T_FunDecs sem_FunDecs_Cons hd_ tl_ = (\ _lhsIerrors _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOfundecs :: VarEnv _hdOfundecs :: VarEnv _lhsOerrors :: Errors _lhsOtypecounter :: Int _hdOerrors :: Errors _hdOtypeEnv :: TypeEnv _hdOtypecounter :: Int _hdOvarEnv :: VarEnv _tlOerrors :: Errors _tlOtypeEnv :: TypeEnv _tlOtypecounter :: Int _tlOvarEnv :: VarEnv _hdIerrors :: Errors _hdIfundecs :: VarEnv _hdItypecounter :: Int _tlIerrors :: Errors _tlIfundecs :: VarEnv _tlItypecounter :: Int _lhsOfundecs = _hdIfundecs _hdOfundecs = _tlIfundecs _lhsOerrors = _tlIerrors _lhsOtypecounter = _tlItypecounter _hdOerrors = _lhsIerrors _hdOtypeEnv = _lhsItypeEnv _hdOtypecounter = _lhsItypecounter _hdOvarEnv = _lhsIvarEnv _tlOerrors = _hdIerrors _tlOtypeEnv = _lhsItypeEnv _tlOtypecounter = _hdItypecounter _tlOvarEnv = _lhsIvarEnv ( _hdIerrors,_hdIfundecs,_hdItypecounter) = (hd_ _hdOerrors _hdOfundecs _hdOtypeEnv _hdOtypecounter _hdOvarEnv) ( _tlIerrors,_tlIfundecs,_tlItypecounter) = (tl_ _tlOerrors _tlOtypeEnv _tlOtypecounter _tlOvarEnv) in ( _lhsOerrors,_lhsOfundecs,_lhsOtypecounter))) sem_FunDecs_Nil :: T_FunDecs sem_FunDecs_Nil = (\ _lhsIerrors _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOfundecs :: VarEnv _lhsOerrors :: Errors _lhsOtypecounter :: Int _lhsOfundecs = Map.empty _lhsOerrors = _lhsIerrors _lhsOtypecounter = _lhsItypecounter in ( _lhsOerrors,_lhsOfundecs,_lhsOtypecounter))) -- LValue ------------------------------------------------------ -- cata sem_LValue :: LValue -> T_LValue sem_LValue (Dot _pos _expr _ident) = (sem_LValue_Dot _pos (sem_LValue _expr) _ident) sem_LValue (Ident _ident) = (sem_LValue_Ident _ident) sem_LValue (Sub _pos _expr _index) = (sem_LValue_Sub _pos (sem_LValue _expr) (sem_Expr _index)) -- semantic domain type T_LValue = Errors -> TYPE -> TypeEnv -> Int -> VarEnv -> ( Errors,TYPE,Int) sem_LValue_Dot :: Pos -> T_LValue -> VarIdent -> T_LValue sem_LValue_Dot pos_ expr_ ident_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _exprOexpect :: TYPE _exprOerrors :: Errors _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _exprOtypeEnv :: TypeEnv _exprOtypecounter :: Int _exprOvarEnv :: VarEnv _exprIerrors :: Errors _exprItp :: TYPE _exprItypecounter :: Int __tup16 = recordType pos_ _exprItp (_err1,_) = __tup16 (_,_fieldEnv) = __tup16 __tup17 = recordFieldType pos_ _fieldEnv ident_ (_err2,_) = __tup17 (_,_tp) = __tup17 _exprOexpect = case _tp of ERROR -> ERROR ; _ -> _exprItp _exprOerrors = _lhsIerrors <> _err1 <> _err2 <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOerrors = _exprIerrors _lhsOtp = _tp _lhsOtypecounter = _exprItypecounter _exprOtypeEnv = _lhsItypeEnv _exprOtypecounter = _lhsItypecounter _exprOvarEnv = _lhsIvarEnv ( _exprIerrors,_exprItp,_exprItypecounter) = (expr_ _exprOerrors _exprOexpect _exprOtypeEnv _exprOtypecounter _exprOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_LValue_Ident :: VarIdent -> T_LValue sem_LValue_Ident ident_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int __tup18 = findVar _lhsIvarEnv ident_ (_errs,_) = __tup18 (_,_tp) = __tup18 _lhsOerrors = _lhsIerrors <> _errs <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOtp = _tp _lhsOtypecounter = _lhsItypecounter in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) sem_LValue_Sub :: Pos -> T_LValue -> T_Expr -> T_LValue sem_LValue_Sub pos_ expr_ index_ = (\ _lhsIerrors _lhsIexpect _lhsItypeEnv _lhsItypecounter _lhsIvarEnv -> (let _indexOexpect :: TYPE _exprOexpect :: TYPE _exprOerrors :: Errors _lhsOerrors :: Errors _lhsOtp :: TYPE _lhsOtypecounter :: Int _exprOtypeEnv :: TypeEnv _exprOtypecounter :: Int _exprOvarEnv :: VarEnv _indexOerrors :: Errors _indexOtypeEnv :: TypeEnv _indexOtypecounter :: Int _indexOvarEnv :: VarEnv _exprIerrors :: Errors _exprItp :: TYPE _exprItypecounter :: Int _indexIerrors :: Errors _indexItp :: TYPE _indexItypecounter :: Int __tup19 = arrayComponentType pos_ _exprItp (_err,_) = __tup19 (_,_tp) = __tup19 _indexOexpect = INT _exprOexpect = case _tp of ERROR -> ERROR ; _ -> _exprItp _exprOerrors = _lhsIerrors <> _err <> if match _lhsIexpect _tp then empty else single (TypeMisMatch _lhsIexpect _tp) _lhsOerrors = _indexIerrors _lhsOtp = _tp _lhsOtypecounter = _indexItypecounter _exprOtypeEnv = _lhsItypeEnv _exprOtypecounter = _lhsItypecounter _exprOvarEnv = _lhsIvarEnv _indexOerrors = _exprIerrors _indexOtypeEnv = _lhsItypeEnv _indexOtypecounter = _exprItypecounter _indexOvarEnv = _lhsIvarEnv ( _exprIerrors,_exprItp,_exprItypecounter) = (expr_ _exprOerrors _exprOexpect _exprOtypeEnv _exprOtypecounter _exprOvarEnv) ( _indexIerrors,_indexItp,_indexItypecounter) = (index_ _indexOerrors _indexOexpect _indexOtypeEnv _indexOtypecounter _indexOvarEnv) in ( _lhsOerrors,_lhsOtp,_lhsOtypecounter))) -- Program ----------------------------------------------------- -- cata sem_Program :: Program -> T_Program sem_Program (Program _expr) = (sem_Program_Program (sem_Expr _expr)) -- semantic domain type T_Program = ( ([Error])) sem_Program_Program :: T_Expr -> T_Program sem_Program_Program expr_ = (let _lhsOerrors :: ([Error]) _exprOerrors :: Errors _exprOvarEnv :: VarEnv _exprOtypeEnv :: TypeEnv _exprOtypecounter :: Int _exprOexpect :: TYPE _exprIerrors :: Errors _exprItp :: TYPE _exprItypecounter :: Int _lhsOerrors = toList _exprIerrors _exprOerrors = empty _exprOvarEnv = initVarEnv _exprOtypeEnv = initTypeEnv _exprOtypecounter = 10 _exprOexpect = _exprItp ( _exprIerrors,_exprItp,_exprItypecounter) = (expr_ _exprOerrors _exprOexpect _exprOtypeEnv _exprOtypecounter _exprOvarEnv) in ( _lhsOerrors)) -- TypeDec ----------------------------------------------------- -- cata sem_TypeDec :: TypeDec -> T_TypeDec sem_TypeDec (TypeDec _pos _ident _tp) = (sem_TypeDec_TypeDec _pos _ident _tp) -- semantic domain type T_TypeDec = Errors -> TypeEnv -> Int -> ((TypeEnv, TypeSyns)) -> ( Errors,Int,((TypeEnv, TypeSyns))) sem_TypeDec_TypeDec :: Pos -> TypeIdent -> Type -> T_TypeDec sem_TypeDec_TypeDec pos_ ident_ tp_ = (\ _lhsIerrors _lhsItypeEnv _lhsItypecounter _lhsItypedecs -> (let _lhsOtypecounter :: Int _lhsOerrors :: Errors _lhsOtypedecs :: ((TypeEnv, TypeSyns)) __tup20 = let (env,syns) = _lhsItypedecs in case lookupPos ident_ env `mplus` lookupPos ident_ syns of Just pos -> (single (DuplicateType ident_ pos ), _lhsItypedecs) Nothing -> case tp_ of Var nm -> (empty, (env, insertIdent ident_ nm syns) ) Array t -> let (err,t') = findType _lhsItypeEnv t tp = ARRAY ident_ _lhsItypecounter t' in (err, (insertIdent ident_ tp env, syns)) Record fs -> let (err,fs') = recordFields _lhsItypeEnv fs tp = RECORD ident_ _lhsItypecounter fs' in (err, (insertIdent ident_ tp env, syns)) (_errs,_) = __tup20 (_,_typedecs) = __tup20 _lhsOtypecounter = _lhsItypecounter + 1 _lhsOerrors = _lhsIerrors <> _errs _lhsOtypedecs = _typedecs in ( _lhsOerrors,_lhsOtypecounter,_lhsOtypedecs))) -- TypeDecs ---------------------------------------------------- -- cata sem_TypeDecs :: TypeDecs -> T_TypeDecs sem_TypeDecs list = (Prelude.foldr sem_TypeDecs_Cons sem_TypeDecs_Nil (Prelude.map sem_TypeDec list)) -- semantic domain type T_TypeDecs = Errors -> TypeEnv -> Int -> ( Errors,Int,((TypeEnv, TypeSyns))) sem_TypeDecs_Cons :: T_TypeDec -> T_TypeDecs -> T_TypeDecs sem_TypeDecs_Cons hd_ tl_ = (\ _lhsIerrors _lhsItypeEnv _lhsItypecounter -> (let _lhsOtypedecs :: ((TypeEnv, TypeSyns)) _hdOtypedecs :: ((TypeEnv, TypeSyns)) _lhsOerrors :: Errors _lhsOtypecounter :: Int _hdOerrors :: Errors _hdOtypeEnv :: TypeEnv _hdOtypecounter :: Int _tlOerrors :: Errors _tlOtypeEnv :: TypeEnv _tlOtypecounter :: Int _hdIerrors :: Errors _hdItypecounter :: Int _hdItypedecs :: ((TypeEnv, TypeSyns)) _tlIerrors :: Errors _tlItypecounter :: Int _tlItypedecs :: ((TypeEnv, TypeSyns)) _lhsOtypedecs = _hdItypedecs _hdOtypedecs = _tlItypedecs _lhsOerrors = _tlIerrors _lhsOtypecounter = _tlItypecounter _hdOerrors = _lhsIerrors _hdOtypeEnv = _lhsItypeEnv _hdOtypecounter = _lhsItypecounter _tlOerrors = _hdIerrors _tlOtypeEnv = _lhsItypeEnv _tlOtypecounter = _hdItypecounter ( _hdIerrors,_hdItypecounter,_hdItypedecs) = (hd_ _hdOerrors _hdOtypeEnv _hdOtypecounter _hdOtypedecs) ( _tlIerrors,_tlItypecounter,_tlItypedecs) = (tl_ _tlOerrors _tlOtypeEnv _tlOtypecounter) in ( _lhsOerrors,_lhsOtypecounter,_lhsOtypedecs))) sem_TypeDecs_Nil :: T_TypeDecs sem_TypeDecs_Nil = (\ _lhsIerrors _lhsItypeEnv _lhsItypecounter -> (let _lhsOtypedecs :: ((TypeEnv, TypeSyns)) _lhsOerrors :: Errors _lhsOtypecounter :: Int _lhsOtypedecs = (Map.empty,Map.empty) _lhsOerrors = _lhsIerrors _lhsOtypecounter = _lhsItypecounter in ( _lhsOerrors,_lhsOtypecounter,_lhsOtypedecs)))