diff --git a/INSTALL b/INSTALL --- a/INSTALL +++ b/INSTALL @@ -1,5 +1,11 @@ -run: +to conveniently install prerequisites, run: +cabal build +in the directory with the tiger.cabal file. -autoconf -./configure -make +The above process fails when building "tiger" itself. Instead, run: +ghc --make Setup.hs -o setup +./setup configure --user +./setup build + +then to install tiger: +./setup install diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,6 @@ module Main where import Distribution.Simple +import Distribution.Simple.UUAGC -main :: IO () -main = defaultMain +main = defaultMainWithHooks uuagcUserHook diff --git a/derived/TigerAS.hs b/derived/TigerAS.hs deleted file mode 100644 --- a/derived/TigerAS.hs +++ /dev/null @@ -1,50 +0,0 @@ --- UUAGC 0.9.5 (src/TigerAS.ag) -module TigerAS where - - -import TigerTypes -import UU.Scanner.Position --- Args -------------------------------------------------------- -type Args = [Expr] --- AssignField ------------------------------------------------- -data AssignField = AssignField (VarIdent) (Expr) --- AssignFields ------------------------------------------------ -type AssignFields = [AssignField] --- DeclGroup --------------------------------------------------- -data DeclGroup = FunDecs (FunDecs) - | TypeDecs (TypeDecs) - | VarDec (Pos) (VarIdent) (Maybe TypeIdent) (Expr) --- Declarations ------------------------------------------------ -type Declarations = [DeclGroup] --- Expr -------------------------------------------------------- -data Expr = Apply (VarIdent) (Args) - | ArrayVal (TypeIdent) (Expr) (Expr) - | Assign (LValue) (Pos) (Expr) - | Break (Pos) - | For (Pos) (VarIdent) (Expr) (Expr) (Expr) - | If (Pos) (Expr) (Expr) (Expr) - | IntLit (Integer) (Pos) - | LValue (LValue) - | Let (Pos) (Declarations) (Expr) - | Nil (Pos) - | Op (String) (Pos) (Expr) (Expr) - | RecordVal (TypeIdent) (AssignFields) - | Sequence (Expr) (Expr) - | Skip - | StringLit (String) (Pos) - | UnOp (Pos) (String) (Expr) - | While (Pos) (Expr) (Expr) --- FunDec ------------------------------------------------------ -data FunDec = FunDec (Pos) (VarIdent) ([TypedVar]) (Maybe TypeIdent) (Expr) --- FunDecs ----------------------------------------------------- -type FunDecs = [FunDec] --- LValue ------------------------------------------------------ -data LValue = Dot (Pos) (LValue) (VarIdent) - | Ident (VarIdent) - | Sub (Pos) (LValue) (Expr) --- Program ----------------------------------------------------- -data Program = Program (Expr) --- TypeDec ----------------------------------------------------- -data TypeDec = TypeDec (Pos) (TypeIdent) (Type) --- TypeDecs ---------------------------------------------------- -type TypeDecs = [TypeDec] diff --git a/derived/TigerError.hs b/derived/TigerError.hs deleted file mode 100644 --- a/derived/TigerError.hs +++ /dev/null @@ -1,232 +0,0 @@ --- UUAGC 0.9.5 (src/TigerError.ag) -module TigerError where - - -import TigerTypes -import UU.Scanner.Position - -showField ident = show (getName ident) --- Error ------------------------------------------------------- -data Error = AssignLoopcounter (Pos) - | CompareOp (Pos) (String) - | CyclicType (Ident) - | DupRecordFieldDecl (Ident) (Pos) - | DuplicateArg (Ident) (Ident) (Pos) - | DuplicateFun (Ident) (Pos) - | DuplicateType (Ident) (Pos) - | FieldNotInit (Ident) - | InitWithVoid (Pos) - | NoSuchField (Pos) (Ident) - | NotArrayType (Pos) - | NotFunType (Ident) - | NotRecordType (Pos) - | NotVarType (Ident) - | TooFewArguments (Ident) - | TooManyArguments (Ident) - | TypeMisMatch (TYPE) (TYPE) - | UndeclaredFun (Ident) - | UndeclaredType (Ident) - | UndeclaredVar (Ident) - | UnknownType (Pos) --- cata -sem_Error :: Error -> - T_Error -sem_Error (AssignLoopcounter _pos) = - (sem_Error_AssignLoopcounter _pos) -sem_Error (CompareOp _pos _op) = - (sem_Error_CompareOp _pos _op) -sem_Error (CyclicType _ident) = - (sem_Error_CyclicType _ident) -sem_Error (DupRecordFieldDecl _ident _pos2) = - (sem_Error_DupRecordFieldDecl _ident _pos2) -sem_Error (DuplicateArg _fun _ident _pos2) = - (sem_Error_DuplicateArg _fun _ident _pos2) -sem_Error (DuplicateFun _ident _pos2) = - (sem_Error_DuplicateFun _ident _pos2) -sem_Error (DuplicateType _ident _pos2) = - (sem_Error_DuplicateType _ident _pos2) -sem_Error (FieldNotInit _field) = - (sem_Error_FieldNotInit _field) -sem_Error (InitWithVoid _pos) = - (sem_Error_InitWithVoid _pos) -sem_Error (NoSuchField _pos _field) = - (sem_Error_NoSuchField _pos _field) -sem_Error (NotArrayType _pos) = - (sem_Error_NotArrayType _pos) -sem_Error (NotFunType _ident) = - (sem_Error_NotFunType _ident) -sem_Error (NotRecordType _pos) = - (sem_Error_NotRecordType _pos) -sem_Error (NotVarType _ident) = - (sem_Error_NotVarType _ident) -sem_Error (TooFewArguments _fun) = - (sem_Error_TooFewArguments _fun) -sem_Error (TooManyArguments _fun) = - (sem_Error_TooManyArguments _fun) -sem_Error (TypeMisMatch _expect _tp) = - (sem_Error_TypeMisMatch _expect _tp) -sem_Error (UndeclaredFun _ident) = - (sem_Error_UndeclaredFun _ident) -sem_Error (UndeclaredType _ident) = - (sem_Error_UndeclaredType _ident) -sem_Error (UndeclaredVar _ident) = - (sem_Error_UndeclaredVar _ident) -sem_Error (UnknownType _pos) = - (sem_Error_UnknownType _pos) --- semantic domain -type T_Error = ( String) -sem_Error_AssignLoopcounter :: Pos -> - T_Error -sem_Error_AssignLoopcounter pos_ = - (let _lhsOmsg :: String - _lhsOmsg = - "at: " ++ show pos_ ++ ":" ++ "cannot assign to loop variable" - in ( _lhsOmsg)) -sem_Error_CompareOp :: Pos -> - String -> - T_Error -sem_Error_CompareOp pos_ op_ = - (let _lhsOmsg :: String - _lhsOmsg = - "at: " ++ show pos_ ++ ":" ++ " operator " ++ show op_ ++ " only defined for int and string" - in ( _lhsOmsg)) -sem_Error_CyclicType :: Ident -> - T_Error -sem_Error_CyclicType ident_ = - (let _lhsOmsg :: String - _lhsOmsg = - "cyclic type synonym: " ++ show ident_ - in ( _lhsOmsg)) -sem_Error_DupRecordFieldDecl :: Ident -> - Pos -> - T_Error -sem_Error_DupRecordFieldDecl ident_ pos2_ = - (let _lhsOmsg :: String - _lhsOmsg = - "duplicate record field declaration: " ++ show ident_ ++ " other occurrence at: " ++ show pos2_ - in ( _lhsOmsg)) -sem_Error_DuplicateArg :: Ident -> - Ident -> - Pos -> - T_Error -sem_Error_DuplicateArg fun_ ident_ pos2_ = - (let _lhsOmsg :: String - _lhsOmsg = - "duplicate formal argument declaration: " ++ show ident_ ++ " other occurrence at: " ++ show pos2_ - in ( _lhsOmsg)) -sem_Error_DuplicateFun :: Ident -> - Pos -> - T_Error -sem_Error_DuplicateFun ident_ pos2_ = - (let _lhsOmsg :: String - _lhsOmsg = - "duplicate function declaration: " ++ show ident_ ++ " other occurrence at: " ++ show pos2_ - in ( _lhsOmsg)) -sem_Error_DuplicateType :: Ident -> - Pos -> - T_Error -sem_Error_DuplicateType ident_ pos2_ = - (let _lhsOmsg :: String - _lhsOmsg = - "duplicate type declaration: " ++ show ident_ ++ " other occurrence at: " ++ show pos2_ - in ( _lhsOmsg)) -sem_Error_FieldNotInit :: Ident -> - T_Error -sem_Error_FieldNotInit field_ = - (let _lhsOmsg :: String - _lhsOmsg = - "field not initialized: " ++ showField field_ - in ( _lhsOmsg)) -sem_Error_InitWithVoid :: Pos -> - T_Error -sem_Error_InitWithVoid pos_ = - (let _lhsOmsg :: String - _lhsOmsg = - "at: " ++ show pos_ ++ ":" ++ "cannot initialize with no value" - in ( _lhsOmsg)) -sem_Error_NoSuchField :: Pos -> - Ident -> - T_Error -sem_Error_NoSuchField pos_ field_ = - (let _lhsOmsg :: String - _lhsOmsg = - "at: " ++ show pos_ ++ " record type does not have a field named: " ++ showField field_ - in ( _lhsOmsg)) -sem_Error_NotArrayType :: Pos -> - T_Error -sem_Error_NotArrayType pos_ = - (let _lhsOmsg :: String - _lhsOmsg = - "at: " ++ show pos_ ++ " subscript of non-array type" - in ( _lhsOmsg)) -sem_Error_NotFunType :: Ident -> - T_Error -sem_Error_NotFunType ident_ = - (let _lhsOmsg :: String - _lhsOmsg = - "identifier: " ++ show ident_ ++ " is not a function" - in ( _lhsOmsg)) -sem_Error_NotRecordType :: Pos -> - T_Error -sem_Error_NotRecordType pos_ = - (let _lhsOmsg :: String - _lhsOmsg = - "at: " ++ show pos_ ++ " field selection of non-record type" - in ( _lhsOmsg)) -sem_Error_NotVarType :: Ident -> - T_Error -sem_Error_NotVarType ident_ = - (let _lhsOmsg :: String - _lhsOmsg = - "identifier: " ++ show ident_ ++ " is not a variable" - in ( _lhsOmsg)) -sem_Error_TooFewArguments :: Ident -> - T_Error -sem_Error_TooFewArguments fun_ = - (let _lhsOmsg :: String - _lhsOmsg = - "not enough arguments for: " ++ show fun_ - in ( _lhsOmsg)) -sem_Error_TooManyArguments :: Ident -> - T_Error -sem_Error_TooManyArguments fun_ = - (let _lhsOmsg :: String - _lhsOmsg = - "too many arguments for: " ++ show fun_ - in ( _lhsOmsg)) -sem_Error_TypeMisMatch :: TYPE -> - TYPE -> - T_Error -sem_Error_TypeMisMatch expect_ tp_ = - (let _lhsOmsg :: String - _lhsOmsg = - "type: " ++ show tp_ ++ " does not match: " ++ show expect_ - in ( _lhsOmsg)) -sem_Error_UndeclaredFun :: Ident -> - T_Error -sem_Error_UndeclaredFun ident_ = - (let _lhsOmsg :: String - _lhsOmsg = - "undeclared function: " ++ show ident_ - in ( _lhsOmsg)) -sem_Error_UndeclaredType :: Ident -> - T_Error -sem_Error_UndeclaredType ident_ = - (let _lhsOmsg :: String - _lhsOmsg = - "undeclared type: " ++ show ident_ - in ( _lhsOmsg)) -sem_Error_UndeclaredVar :: Ident -> - T_Error -sem_Error_UndeclaredVar ident_ = - (let _lhsOmsg :: String - _lhsOmsg = - "undeclared variable: " ++ show ident_ - in ( _lhsOmsg)) -sem_Error_UnknownType :: Pos -> - T_Error -sem_Error_UnknownType pos_ = - (let _lhsOmsg :: String - _lhsOmsg = - "unable to determine type for expression at: " ++ show pos_ - in ( _lhsOmsg)) diff --git a/derived/TigerSem.hs b/derived/TigerSem.hs deleted file mode 100644 --- a/derived/TigerSem.hs +++ /dev/null @@ -1,2100 +0,0 @@ --- 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))) diff --git a/dist/build/tiger/tiger-tmp/TigerScanner.hs b/dist/build/tiger/tiger-tmp/TigerScanner.hs deleted file mode 100644 --- a/dist/build/tiger/tiger-tmp/TigerScanner.hs +++ /dev/null @@ -1,411 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 1 "src/TigerScanner.x" #-} - -module TigerScanner(scanFile) where - -import UU.Scanner.Token -import UU.Scanner.TokenShow -import UU.Scanner.Position -import qualified UU.DData.Set as Set - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#elif defined(__GLASGOW_HASKELL__) -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -import Data.Char (ord) -import Data.Array.Base (unsafeAt) -#else -import Array -import Char (ord) -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif -{-# LINE 1 "templates/wrappers.hs" #-} -{-# LINE 1 "templates/wrappers.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "templates/wrappers.hs" #-} --- ----------------------------------------------------------------------------- --- Alex wrapper code. --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - - - - - - - --- ----------------------------------------------------------------------------- --- The input type - - -type AlexInput = (AlexPosn, -- current position, - Char, -- previous char - String) -- current input string - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p,c,s) = c - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (p,c,[]) = Nothing -alexGetChar (p,_,(c:s)) = let p' = alexMove p c in p' `seq` - Just (c, (p', c, s)) - - -{-# LINE 45 "templates/wrappers.hs" #-} - --- ----------------------------------------------------------------------------- --- Token positions - --- `Posn' records the location of a token in the input text. It has three --- fields: the address (number of chacaters preceding the token), line number --- and column of a token within the file. `start_pos' gives the position of the --- start of the file and `eof_pos' a standard encoding for the end of file. --- `move_pos' calculates the new position after traversing a given character, --- assuming the usual eight character tab stops. - - -data AlexPosn = AlexPn !Int !Int !Int - deriving (Eq,Show) - -alexStartPos :: AlexPosn -alexStartPos = AlexPn 0 1 1 - -alexMove :: AlexPosn -> Char -> AlexPosn -alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1) -alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1 -alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) - - --- ----------------------------------------------------------------------------- --- Default monad - -{-# LINE 150 "templates/wrappers.hs" #-} - - --- ----------------------------------------------------------------------------- --- Monad (with ByteString input) - -{-# LINE 233 "templates/wrappers.hs" #-} - - --- ----------------------------------------------------------------------------- --- Basic wrapper - -{-# LINE 255 "templates/wrappers.hs" #-} - - --- ----------------------------------------------------------------------------- --- Basic wrapper, ByteString version - -{-# LINE 277 "templates/wrappers.hs" #-} - - --- ----------------------------------------------------------------------------- --- Posn wrapper - --- Adds text positions to the basic model. - -{-# LINE 294 "templates/wrappers.hs" #-} - - --- ----------------------------------------------------------------------------- --- Posn wrapper, ByteString version - -{-# LINE 309 "templates/wrappers.hs" #-} - - --- ----------------------------------------------------------------------------- --- GScan wrapper - --- For compatibility with previous versions of Alex, and because we can. - - -alexGScan stop state inp = alex_gscan stop alexStartPos '\n' inp (0,state) - -alex_gscan stop p c inp (sc,state) = - case alexScan (p,c,inp) sc of - AlexEOF -> stop p c inp (sc,state) - AlexError _ -> stop p c inp (sc,state) - AlexSkip (p',c',inp') len -> alex_gscan stop p' c' inp' (sc,state) - AlexToken (p',c',inp') len k -> - k p c inp len (\scs -> alex_gscan stop p' c' inp' scs) - (sc,state) -alex_base :: AlexAddr -alex_base = AlexA# "\xf8\xff\xff\xff\xfd\xff\xff\xff\x6d\x00\x00\x00\x00\x00\x00\x00\xe1\xff\xff\xff\x00\x00\x00\x00\xcf\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xd2\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\xcd\x00\x00\x00\x2c\x01\x00\x00\x8b\x01\x00\x00\xea\x01\x00\x00\x49\x02\x00\x00\xa8\x02\x00\x00\x05\x03\x00\x00\x4e\x03\x00\x00\x74\x03\x00\x00\xbf\x03\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x03\x00\x1a\x00\x15\x00\x14\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x02\x00\x18\x00\x00\x00\x08\x00\x09\x00\x11\x00\x0f\x00\x05\x00\x10\x00\x0e\x00\x04\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x06\x00\x07\x00\x13\x00\x12\x00\x16\x00\x00\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x0a\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x0c\x00\x19\x00\x0d\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x1e\x00\x1e\x00\x1c\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x24\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1c\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x24\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1c\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x24\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1c\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x24\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1c\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x24\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1c\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x24\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1c\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x24\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1e\x00\x00\x00\x1e\x00\x00\x00\x25\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2a\x00\x3d\x00\x3d\x00\x3e\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\x20\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\x76\x00\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0::Int,39) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[],[],[],[],[],[],[],[],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))]] -{-# LINE 42 "src/TigerScanner.x" #-} - --- semantic actions --- if a sequence of letters is an identifier, except when it is member of the set of reserved words. -identifier = makeToken keywordOrIdentifier - where keywordOrIdentifier str | Set.member str reservedwords = reserved str - | otherwise = valueToken TkVarid str - - -reservedwords = Set.fromList [ "array", "if", "then", "else", "while", "for", "to", "do", "let", "in", "end", "of", "break", "nil", "function", "var", "type" ] - --- special symbols and operators -symbol = makeToken reserved - --- decimal integers -integer = makeToken (valueToken TkInteger10) - --- string literals -string = makeToken (valueToken TkString) - --- comment-lexer: drops a comment-block enclosed by /* and */ from the input, and resumes lexing. --- block comments can be nested, hence: /* this /* is some */ text */ --- is a single comment-block - -comment pos _ inp _ _ st@(_,file) = dropcomments (move_pos2 pos) 1 (drop 2 inp) - where move_pos2 (AlexPn a l c) = AlexPn (a+2) l (c+2) - dropcomments p 0 ss = continue p ss - dropcomments p n inp = case inp of - ('*':'/':ss) -> dropcomments (move_pos2 p ) (n-1) ss - ('/':'*':ss) -> dropcomments (move_pos2 p ) (n+1) ss - (s :ss) -> dropcomments (alexMove p s) n ss - [] -> errToken ("unterminated comment") (makePos file pos) - : continue p [] - continue = tiger_scan file - -makeToken :: (String -> Pos -> Token) - -> AlexPosn - -> a - -> String - -> Int - -> ((Int,FilePath) -> [Token]) - -> (Int,FilePath) -> [Token] -makeToken f p _ inp len cont state@(_,file) = f (take len inp) (makePos file p) : cont state - -makePos :: FilePath -> AlexPosn -> Pos -makePos f (AlexPn _ l c) = Pos l c f - -scanFile :: FilePath -> IO [Token] -scanFile file = do txt <- readFile file - return (tiger_scan file alexStartPos txt) - -tiger_scan :: FilePath -> AlexPosn -> String -> [Token] -tiger_scan file pos input = alex_gscan stop_act pos '\n' input (0,file) - -stop_act pos char "" state = [] -stop_act pos char (s:ss) state = errToken ("unexpected character: " ++ show s) (makePos (snd state) pos) - : tiger_scan (snd state) (alexMove pos s) ss - -alex_action_1 = comment -alex_action_2 = symbol -alex_action_3 = integer -alex_action_4 = string -alex_action_5 = identifier -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - -{-# LINE 35 "templates/GenericTemplate.hs" #-} - -{-# LINE 45 "templates/GenericTemplate.hs" #-} - - -data AlexAddr = AlexA# Addr# - -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else - indexInt16OffAddr# arr off -#endif - - - - - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else - indexInt32OffAddr# arr off -#endif - - - - - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - - - - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input (I# (sc)) - = alexScanUser undefined input (I# (sc)) - -alexScanUser user input (I# (sc)) - = case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, input') -> - case alexGetChar input of - Nothing -> - - - - AlexEOF - Just _ -> - - - - AlexError input' - - (AlexLastSkip input len, _) -> - - - - AlexSkip input len - - (AlexLastAcc k input len, _) -> - - - - AlexToken input len k - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user orig_input len input s last_acc = - input `seq` -- strict in the input - let - new_acc = check_accs (alex_accept `quickIndex` (I# (s))) - in - new_acc `seq` - case alexGetChar input of - Nothing -> (new_acc, input) - Just (c, new_input) -> - - - - let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if (offset >=# 0#) && (check ==# ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - -1# -> (new_acc, input) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user orig_input (len +# 1#) - new_input new_s new_acc - - where - check_accs [] = last_acc - check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) - check_accs (AlexAccPred a pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkipPred pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastSkip input (I# (len)) - check_accs (_ : rest) = check_accs rest - -data AlexLastAcc a - = AlexNone - | AlexLastAcc a !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc a user - = AlexAcc a - | AlexAccSkip - | AlexAccPred a (AlexAccPred user) - | AlexAccSkipPred (AlexAccPred user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user in1 len in2 - = p1 user in1 len in2 && p2 user in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext (I# (sc)) user _ _ input = - case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. - --- used by wrappers -iUnbox (I# (i)) = i diff --git a/src/Tiger.hs b/src/Tiger.hs --- a/src/Tiger.hs +++ b/src/Tiger.hs @@ -1,7 +1,7 @@ module Main where import Prelude hiding (exp) -import UU.Parsing +import UU.Parsing import TigerScanner (scanFile) import UU.Scanner.Token import UU.Scanner.Position @@ -10,13 +10,13 @@ import TigerError(sem_Error) import TigerAS import TigerTypes -import System(getArgs) +import System.Environment(getArgs) import UU.Scanner.GenTokenSymbol import UU.Scanner.GenTokenOrd -pBracksPos p = (,) <$> pOBrackPos <*> p <* pCBrack +pBracksPos p = (,) <$> pOBrackPos <*> p <* pCBrack -ident :: Parser Token Ident +ident :: Parser Token Ident ident = uncurry Id <$> (pVaridPos <|> pConidPos) integer :: Parser Token (Integer,Pos) @@ -25,7 +25,7 @@ string :: Parser Token (String,Pos) string = pStringPos {- -Precedence of the operators (high to low): +Precedence of the operators (high to low): * / -- left + - -- left @@ -47,64 +47,64 @@ tokens <- scanFile f ast <- parseIO program tokens --print ast - mapM (putStrLn.sem_Error) + mapM (putStrLn.sem_Error) (sem_Program ast) - return () + return () {- where keywords = ["array", "if", "then", "else", "while", "for", "to", "do", "let", "in", "end", "of", "break", "nil", "function", "var", "type" ] keyops = [".",":", "+", "-", "*", "/", "=", "<>", "<", "<=", ">", ">=", "&", "|", ":=" ] symbols = ",;()[]{}" opchars = ":+-*/=<>&.|" --} +-} program = Program <$> exp -oper ops = case ops of +oper ops = case ops of [] -> error "empty operator list" [x] -> mkOp x - _ -> foldr1 (<|>) (map mkOp ops) + _ -> foldr1 (<|>) (map mkOp ops) where mkOp x = Op x <$> pKeyPos x - + operators = [ (["*", "/" ], LeftAssoc) - , (["+", "-" ], LeftAssoc) + , (["+", "-" ], LeftAssoc) , ([">=", "<=", "=", "<>", "<", ">"], NonAssoc ) , (["&" ], LeftAssoc) , (["|" ], LeftAssoc) ] - + expression = foldl f atom operators - where f p (ops,assoc) = case assoc of + where f p (ops,assoc) = case assoc of LeftAssoc -> pChainl (oper ops) p RightAssoc -> pChainr (oper ops) p - NonAssoc -> p (oper ops <*> p) - + NonAssoc -> p (oper ops <*> p) + data Assoc = LeftAssoc | RightAssoc | NonAssoc deriving Show assignField = AssignField <$> ident <* pKey "=" <*> exp exp = Assign <$> lvalue <*> pKeyPos ":=" <*> exp <|> expression - + atom = Nil <$> pKeyPos "nil" <|> uncurry IntLit <$> integer <|> uncurry StringLit <$> string <|> RecordVal <$> type_ident <*> pCurly (pListSep (pKey ",") assignField) <|> LValue <$> lvalue <|> Apply <$>ident <*> pParens (pListSep (pKey ",") exp) - <|> pParens exps - <|> Let <$> pKeyPos "let" <*> decs - <* pKey "in" <*> exps + <|> pParens exps + <|> Let <$> pKeyPos "let" <*> decs + <* pKey "in" <*> exps <* pKey "end" <|> ArrayVal <$> type_ident <*> pBracks exp <* pKey "of" <*> exp <|> (\p e -> UnOp p "-" e) <$> pKeyPos "-" <*> exp <|> Break <$> pKeyPos "break" -- Control structures - <|> If <$> pKeyPos "if" <*> exp - <* pKey "then" <*> exp + <|> If <$> pKeyPos "if" <*> exp + <* pKey "then" <*> exp <*> ((pKey "else" *> exp) `opt` Skip) - <|> While <$> pKeyPos "while" <*> exp + <|> While <$> pKeyPos "while" <*> exp <* pKey "do" <*> exp - <|> For <$> pKeyPos "for" <*> ident <* pKey ":=" <*> exp <* pKey "to" <*> exp + <|> For <$> pKeyPos "for" <*> ident <* pKey ":=" <*> exp <* pKey "to" <*> exp <* pKey "do" <*> exp lvalue = (\i f -> f (Ident i)) <$> ident <*> subOrFields @@ -116,9 +116,9 @@ where f xs = case xs of [] -> Skip [x] -> x - _ -> foldr1 Sequence xs + _ -> foldr1 Sequence xs -decs = pList declGroup +decs = pList declGroup declGroup = FunDecs <$> pList1 funDec <|> TypeDecs <$> pList1 typeDec @@ -133,8 +133,8 @@ ty = Var <$> type_ident <|> Record <$> pCurly tyfields <|> Array <$ pKey "array" <* pKey "of" <*> type_ident - + tyfields = pListSep (pKey ",") tyfield - where tyfield = TypedVar <$> ident <* pKey ":" <*> type_ident + where tyfield = TypedVar <$> ident <* pKey ":" <*> type_ident type_ident = ident diff --git a/src/TigerAS.ag b/src/TigerAS.ag new file mode 100644 --- /dev/null +++ b/src/TigerAS.ag @@ -0,0 +1,114 @@ +MODULE {TigerAS} {} {} + +imports +{ +import TigerTypes +import UU.Scanner.Position +} + +DATA Program | Program expr:Expr + +DATA DeclGroup + | VarDec pos:Pos + ident:VarIdent + tp:{Maybe TypeIdent} + expr:Expr + + | TypeDecs decs:TypeDecs + + | FunDecs decs:FunDecs + +DATA TypeDec + | TypeDec pos:Pos + ident:TypeIdent + tp:Type + +DATA FunDec + | FunDec pos:Pos + ident:VarIdent + argTps:{[TypedVar]} + retTp:{Maybe TypeIdent} + body:Expr + +TYPE TypeDecs = [TypeDec] +TYPE FunDecs = [FunDec ] + +TYPE AssignFields = [AssignField] +TYPE Declarations = [DeclGroup] + +TYPE Args = [Expr] + +DATA LValue + | Sub pos:Pos + expr:LValue + index:Expr + + + | Dot pos:Pos + expr:LValue + ident:VarIdent + + | Ident ident:VarIdent + +DATA Expr + | LValue lvalue:LValue + + | Apply ident:VarIdent + args:Args + + | RecordVal ident:TypeIdent + fields:AssignFields + + | ArrayVal ident:TypeIdent + size:Expr + init:Expr + + | IntLit value:Integer + pos:Pos + + | StringLit value:String + pos:Pos + + | While pos:Pos + cond:Expr + body:Expr + + | For pos:Pos + ident:VarIdent + low:Expr + hi:Expr + body:Expr + + | If pos:Pos + cond:Expr + thenPart:Expr + elsePart:Expr + + | Let pos:Pos + decls:Declarations + body:Expr + + | Assign lvalue:LValue + pos:Pos + expr:Expr + + | Op op:String + pos:Pos + left:Expr + right:Expr + + | UnOp pos:Pos + op:String + expr:Expr + + | Skip + + | Nil pos:Pos + + | Break pos:Pos + + | Sequence left:Expr + right:Expr + +DATA AssignField + | AssignField ident:VarIdent expr:Expr diff --git a/src/TigerError.ag b/src/TigerError.ag new file mode 100644 --- /dev/null +++ b/src/TigerError.ag @@ -0,0 +1,56 @@ +MODULE {TigerError} {} {} + +{ +import TigerTypes +import UU.Scanner.Position +} + +DATA Error + | UndeclaredVar Ident + | UndeclaredType Ident + | DuplicateType Ident pos2:Pos + | DuplicateFun Ident pos2:Pos + | DuplicateArg fun:Ident Ident pos2:Pos + | DupRecordFieldDecl Ident pos2:Pos + | CyclicType Ident + | UnknownType pos:Pos + | NotVarType Ident + | UndeclaredFun Ident + | NotFunType Ident + | NotArrayType pos:Pos + | NotRecordType pos:Pos + | NoSuchField pos:Pos field:Ident + | TypeMisMatch expect:{TYPE} tp:{TYPE} + | TooManyArguments fun:Ident + | TooFewArguments fun:Ident + | FieldNotInit field:Ident + | CompareOp pos:Pos op:String + | AssignLoopcounter pos:Pos + | InitWithVoid pos:Pos +ATTR Error [ || msg:String ] + +SEM Error + | UndeclaredVar lhs.msg = "undeclared variable: " ++ show @ident + | UndeclaredType lhs.msg = "undeclared type: " ++ show @ident + | DuplicateType lhs.msg = "duplicate type declaration: " ++ show @ident ++ " other occurrence at: " ++ show @pos2 + | DuplicateFun lhs.msg = "duplicate function declaration: " ++ show @ident ++ " other occurrence at: " ++ show @pos2 + | DuplicateArg lhs.msg = "duplicate formal argument declaration: " ++ show @ident ++ " other occurrence at: " ++ show @pos2 + | DupRecordFieldDecl lhs.msg = "duplicate record field declaration: " ++ show @ident ++ " other occurrence at: " ++ show @pos2 + | CyclicType lhs.msg = "cyclic type synonym: " ++ show @ident + | UnknownType lhs.msg = "unable to determine type for expression at: " ++ show @pos + | NotVarType lhs.msg = "identifier: " ++ show @ident ++ " is not a variable" + | UndeclaredFun lhs.msg = "undeclared function: " ++ show @ident + | NotFunType lhs.msg = "identifier: " ++ show @ident ++ " is not a function" + | NotArrayType lhs.msg = "at: " ++ show @pos ++ " subscript of non-array type" + | NotRecordType lhs.msg = "at: " ++ show @pos ++ " field selection of non-record type" + | NoSuchField lhs.msg = "at: " ++ show @pos ++ " record type does not have a field named: " ++ showField @field + | TypeMisMatch lhs.msg = "type: " ++ show @tp ++ " does not match: " ++ show @expect + | TooManyArguments lhs.msg = "too many arguments for: " ++ show @fun + | TooFewArguments lhs.msg = "not enough arguments for: " ++ show @fun + | FieldNotInit lhs.msg = "field not initialized: " ++ showField @field + | CompareOp lhs.msg = "at: " ++ show @pos ++ ":" ++ " operator " ++ show @op ++ " only defined for int and string" + | AssignLoopcounter lhs.msg = "at: " ++ show @pos ++ ":" ++ "cannot assign to loop variable" + | InitWithVoid lhs.msg = "at: " ++ show @pos ++ ":" ++ "cannot initialize with no value" +{ +showField ident = show (getName ident) +} diff --git a/src/TigerScanner.x b/src/TigerScanner.x --- a/src/TigerScanner.x +++ b/src/TigerScanner.x @@ -1,10 +1,11 @@ { +{-# LANGUAGE BangPatterns #-} module TigerScanner(scanFile) where import UU.Scanner.Token import UU.Scanner.TokenShow import UU.Scanner.Position -import qualified UU.DData.Set as Set +import qualified Data.Set as Set } %wrapper "gscan" @@ -24,9 +25,9 @@ "," | ":" | ";" | "(" | ")" | - "[" | "]" | "{" | "}" | "." | - "+" | "-" | "*" | "/" | "=" | - "<>" | "<" | "<=" | ">" | + "[" | "]" | "{" | "}" | "." | + "+" | "-" | "*" | "/" | "=" | + "<>" | "<" | "<=" | ">" | ">=" | "&" | "|" | ":=" { symbol } $digit+ { integer } @@ -34,19 +35,19 @@ \" @content* \" { string } $letter $ident* { identifier } - - -{ + + +{ -- semantic actions -- if a sequence of letters is an identifier, except when it is member of the set of reserved words. -identifier = makeToken keywordOrIdentifier - where keywordOrIdentifier str | Set.member str reservedwords = reserved str - | otherwise = valueToken TkVarid str - +identifier = makeToken keywordOrIdentifier + where keywordOrIdentifier str | Set.member str reservedwords = reserved str + | otherwise = valueToken TkVarid str + reservedwords = Set.fromList [ "array", "if", "then", "else", "while", "for", "to", "do", "let", "in", "end", "of", "break", "nil", "function", "var", "type" ] -- special symbols and operators @@ -58,32 +59,32 @@ -- string literals string = makeToken (valueToken TkString) --- comment-lexer: drops a comment-block enclosed by /* and */ from the input, and resumes lexing. --- block comments can be nested, hence: /* this /* is some */ text */ +-- comment-lexer: drops a comment-block enclosed by /* and */ from the input, and resumes lexing. +-- block comments can be nested, hence: /* this /* is some */ text */ -- is a single comment-block comment pos _ inp _ _ st@(_,file) = dropcomments (move_pos2 pos) 1 (drop 2 inp) where move_pos2 (AlexPn a l c) = AlexPn (a+2) l (c+2) - dropcomments p 0 ss = continue p ss + dropcomments p 0 ss = continue p ss dropcomments p n inp = case inp of ('*':'/':ss) -> dropcomments (move_pos2 p ) (n-1) ss ('/':'*':ss) -> dropcomments (move_pos2 p ) (n+1) ss (s :ss) -> dropcomments (alexMove p s) n ss [] -> errToken ("unterminated comment") (makePos file pos) - : continue p [] - continue = tiger_scan file - -makeToken :: (String -> Pos -> Token) - -> AlexPosn - -> a - -> String - -> Int - -> ((Int,FilePath) -> [Token]) + : continue p [] + continue = tiger_scan file + +makeToken :: (String -> Pos -> Token) + -> AlexPosn + -> a + -> String + -> Int + -> ((Int,FilePath) -> [Token]) -> (Int,FilePath) -> [Token] -makeToken f p _ inp len cont state@(_,file) = f (take len inp) (makePos file p) : cont state +makeToken f p _ inp len cont state@(_,file) = f (take len inp) (makePos file p) : cont state makePos :: FilePath -> AlexPosn -> Pos -makePos f (AlexPn _ l c) = Pos l c f +makePos f (AlexPn _ l c) = Pos l c f scanFile :: FilePath -> IO [Token] scanFile file = do txt <- readFile file diff --git a/src/TigerSem.ag b/src/TigerSem.ag new file mode 100644 --- /dev/null +++ b/src/TigerSem.ag @@ -0,0 +1,499 @@ +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 diff --git a/src/TigerTypes.hs b/src/TigerTypes.hs --- a/src/TigerTypes.hs +++ b/src/TigerTypes.hs @@ -1,6 +1,6 @@ module TigerTypes where -import UU.DData.Map(Map) +import Data.Map(Map) import UU.Scanner.Position data Ident = Id {getName :: String, getPos :: Pos} diff --git a/tiger.cabal b/tiger.cabal --- a/tiger.cabal +++ b/tiger.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.2 -build-type: Simple +build-type: Custom name: tiger -version: 1.0 +version: 1.1 license: GPL license-file: LICENSE maintainer: Doaitse Swierstra @@ -11,12 +11,13 @@ category: Compiler stability: Experimental copyright: Universiteit Utrecht -extra-source-files: INSTALL, LICENSE +extra-source-files: INSTALL, LICENSE, uuagc_options, src/TigerAS.ag, src/TigerError.ag, src/TigerSem.ag executable tiger - build-depends: base >= 3 - build-depends: haskell98, array - build-depends: uulib + build-depends: base >= 4, base < 5 + build-depends: array >= 0.3.0.3 + build-depends: uulib >= 0.9.14, containers >= 0.4.1.0 + build-depends: uuagc >= 0.9.39.1, uuagc-cabal >= 1.0.0.4 main-is: Tiger.hs - hs-source-dirs: src, derived + hs-source-dirs: src other-modules: TigerAS, TigerSem, TigerError, TigerScanner, TigerTypes diff --git a/uuagc_options b/uuagc_options new file mode 100644 --- /dev/null +++ b/uuagc_options @@ -0,0 +1,8 @@ +file: "src/TigerAS.ag" +options: data, module + +file: "src/TigerSem.ag" +options: module, catas, semfuns, signatures + +file: "src/TigerError.ag" +options: module, data, catas, semfuns, signatures