tiger 1.0 → 1.1
raw patch · 14 files changed
+752/−2860 lines, 14 filesdep +containersdep +uuagcdep +uuagc-cabaldep −haskell98dep ~arraydep ~basedep ~uulibbuild-type:Customsetup-changed
Dependencies added: containers, uuagc, uuagc-cabal
Dependencies removed: haskell98
Dependency ranges changed: array, base, uulib
Files
- INSTALL +10/−4
- Setup.hs +2/−2
- derived/TigerAS.hs +0/−50
- derived/TigerError.hs +0/−232
- derived/TigerSem.hs +0/−2100
- dist/build/tiger/tiger-tmp/TigerScanner.hs +0/−411
- src/Tiger.hs +28/−28
- src/TigerAS.ag +114/−0
- src/TigerError.ag +56/−0
- src/TigerScanner.x +26/−25
- src/TigerSem.ag +499/−0
- src/TigerTypes.hs +1/−1
- tiger.cabal +8/−7
- uuagc_options +8/−0
INSTALL view
@@ -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
Setup.hs view
@@ -1,6 +1,6 @@ module Main where import Distribution.Simple+import Distribution.Simple.UUAGC -main :: IO ()-main = defaultMain+main = defaultMainWithHooks uuagcUserHook
− derived/TigerAS.hs
@@ -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]
− derived/TigerError.hs
@@ -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))
− derived/TigerSem.hs
@@ -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)))
− dist/build/tiger/tiger-tmp/TigerScanner.hs
@@ -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 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# 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 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# 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
src/Tiger.hs view
@@ -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
+ src/TigerAS.ag view
@@ -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
+ src/TigerError.ag view
@@ -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) +}
src/TigerScanner.x view
@@ -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
+ src/TigerSem.ag view
@@ -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><singleton(CompareOp @pos @op),tp)+ | @op `elem` [ "=", "<>"] = let (e,tp) = meetErr @left.tp @right.tp+ in if tp == NIL+ then (e><singleton(UnknownType @pos) ,ERROR)+ else (e,tp)+ | otherwise = compilerError ("unknown binary operator: " ++ @op)+ in check+ left.errors = @lhs.errors ><+ @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><e,t:ts)+ in foldr f (empty,[]) @fields.names+ -- check lhs.expect = tp+ -- check all fields defined+ loc.notInit = foldr (Seq.<|) empty [ FieldNotInit f | f <- keys @fieldEnv, not (f `elem` @fields.names)]+ fields.expects = @expFields+ fields.errors = @lhs.errors ><+ @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
src/TigerTypes.hs view
@@ -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}
tiger.cabal view
@@ -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
+ uuagc_options view
@@ -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