tiger-1.1: src/TigerSem.ag
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