oberon0-0.0.1: src/Language/Oberon0/L4/SemT3.hs
{-# OPTIONS -fcontext-stack=100 #-}
{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction, TemplateHaskell, DeriveDataTypeable #-}
module Language.Oberon0.L4.SemT3 (module Language.Oberon0.L4.SemT3, module Language.Oberon0.L3.SemT3) where
import Language.Grammars.AspectAG
import Language.Grammars.AspectAG.Derive
import Language.Grammars.Grammar (DTerm(..),Pos(..))
import Data.HList.Label4
import Data.HList.TypeEqGeneric1
import Data.HList.TypeCastGeneric1
import qualified Data.Map as Map
import Data.List (intercalate)
import Data.Dynamic
import Language.Oberon0.L4.Decl
import qualified Language.Oberon0.L4.SemT2 as T2
import qualified Language.Oberon0.L1.SemT3 as L1
import qualified Language.Oberon0.L3.SemT3 as L3
import Language.Oberon0.L3.SemT3 (mkL1'',l2t3,spp,sidl,sval,senv,ienv,serr,spos,sty,sterr,sknd,spl,ParamInfo(..),check,SymbolInfo(..),NameDef(..),TInfo(..)
,baseType,intType,boolType,unkType,findType)
---- T3 (L4) Type-checking
data ArrType = ArrType (Maybe Int) TInfo
deriving Typeable
instance Show ArrType where
show (ArrType _ ty) = "ARRAY OF " ++ show ty
data RecType = RecType [ FInfo ]
deriving Typeable
data FInfo = FInfo String TInfo
deriving Typeable
instance Show FInfo where
show (FInfo f t) = f ++ ": " ++ show t
instance Show RecType where
show (RecType fs) = "RECORD " ++ intercalate "; " (map show fs) ++ " END"
arrayType l ty = let t = (ArrType l ty)
in TInfo (toDyn t) (show t) (const False)
recordType fts = let t = (RecType fts)
in TInfo (toDyn t) (show t) (const False)
-- sknd
skndSelExp = syn sknd $ do return $ VarP
-- spos
sposSelExp = syn spos $ do i <- at ch_id_SelExp
return $ pos i
-- ity
$(attLabels ["ity"])
ityNT = nt_Select .*. nt_SelectL .*. hNil
ityRule = copy ity ityNT
ityAssigSelStmt = inh ity ityNT $
do lhs <- at lhs
id <- at ch_id_AssigSelStmt
return $ ch_sel_AssigSelStmt .=. findType (value id) (lhs # ienv) .*.
emptyRecord
itySelExp = inh ity ityNT $ do lhs <- at lhs
id <- at ch_id_SelExp
return $ ch_sel_SelExp .=. findType (value id) (lhs # ienv) .*.
emptyRecord
itySelectL_Cons = inh ity ityNT $ do lhs <- at lhs
h <- at ch_hd_SelectL_Cons
return $ ch_hd_SelectL_Cons .=. lhs # ity .*.
ch_tl_SelectL_Cons .=. h # sty .*.
emptyRecord
-- sty
styNT = nt_Select .*. nt_SelectL .*. L3.styNT
styArrayType = syn sty $ do exp <- at ch_exp_ArrayType
typ <- at ch_typ_ArrayType
return $ arrayType (exp # sval) (typ # sty)
styRecordType = syn sty $ do fields <- at ch_fields_RecordType
let fs = Map.toList (fields # senv)
return $ recordType (map (\(f, SI _ (SI t _)) -> FInfo f t) fs)
stySelExp = syn sty $ do sel <- at ch_sel_SelExp
return $ sel # sty
fieldType _ [] = Nothing
fieldType n ((FInfo f ft):fs) | n == f = Just ft
| otherwise = fieldType n fs
stySelField = syn sty $ do lhs <- at lhs
ids <- at ch_id_SelField
return $ case (fromDynamic . trep . baseType) (lhs # ity) of
Just (RecType fs) -> maybe unkType id (fieldType (value ids) fs)
_ -> unkType
stySelArray = syn sty $ do lhs <- at lhs
return $ case (fromDynamic . trep . baseType) (lhs # ity) of
Just (ArrType _ t) -> t
_ -> unkType
stySelectL_Cons = syn sty $ do t <- at ch_tl_SelectL_Cons
return $ t # sty
stySelectL_Nil = syn sty $ do lhs <- at lhs
return $ lhs # ity
-- sval
svalNT = L3.svalNT
svalSelExp = syn sval $ do return $ Nothing
-- senv
senvNT = T2.senvNT
senvField' r = synupdM senv $ do typ <- at ch_typ_Field
return $ Map.map (\(SI nd _) -> (SI nd (SI (typ # sty) r)))
-- ienv
ienvNT = T2.ienvNT
ienvIni = L3.ienvIni
-- serr
sterrNT = nt_Select .*. nt_SelectL .*. nt_Field .*. nt_FieldL .*. L3.sterrNT
sterrRule = use sterr sterrNT (++) ([] :: [String])
checkSize pos (Just s) | s < 0 = [ show pos ++ ": Array size is negative" ]
| otherwise = []
checkSize _ _ = []
sterrArrayType = syn sterr $ do exp <- at ch_exp_ArrayType
typ <- at ch_typ_ArrayType
return $ check (exp # spos) intType (exp # sty) ++ checkSize (exp # spos) (exp # sval) ++ exp # sterr ++ typ # sterr
sterrSelField = syn sterr $ do lhs <- at lhs
id <- at ch_id_SelField
return $ if teq (lhs # ity) unkType
then []
else case (fromDynamic . trep . baseType) (lhs # ity) of
Just (RecType fs) -> maybe [ show (pos id) ++ ": The record does not contain a field with name " ++ value id ]
(const []) (fieldType (value id) fs)
_ -> [ (show . L1.moveLeft) (pos id) ++ ": The accessed variable is not a record." ]
checkIndex pos (Just i) (Just l) | i < 0 || i >= l = [ show pos ++ ": Index out of range" ]
| otherwise = [ ]
checkIndex _ _ _ = []
sterrSelArray = syn sterr $ do lhs <- at lhs
exp <- at ch_exp_SelArray
let err = if teq (lhs # ity) unkType
then []
else case (fromDynamic . trep . baseType) (lhs # ity) of
Just (ArrType l t) -> checkIndex (exp # spos) (exp # sval) l
_ -> [ (show . L1.moveLeft) (exp # spos) ++ ": The accessed variable is not an array." ]
return $ err ++ check (exp # spos) intType (exp # sty)
checkAssig pos ty = let errR = case (fromDynamic . trep . baseType) ty of
Just (RecType _) -> [ show pos ++ ": Can not assign to a record." ]
_ -> [ ]
errA = case (fromDynamic . trep . baseType) ty of
Just (ArrType _ _) -> [ show pos ++ ": Can not assign to an array." ]
_ -> [ ]
in errR ++ errA
sterrAssigSelStmt = syn sterr $ do id <- at ch_id_AssigSelStmt
sel <- at ch_sel_AssigSelStmt
exp <- at ch_exp_AssigSelStmt
let lerr = checkAssig (pos id) (sel # sty) ++ (sel # sterr)
return $ if lerr == []
then check (exp # spos) (sel # sty) (exp # sty) ++ exp # sterr
else lerr
sterrAssigStmt' = synupdM sterr $ do lhs <- at lhs
id <- at ch_id_AssigStmt
let lerr = checkAssig (pos id) (findType (value id) (lhs # ienv))
return $ \err -> if lerr == [] then err else lerr
checkSt _ ty VarP = []
checkSt pos ty _ = let errR = case (fromDynamic . trep . baseType) ty of
Just (RecType _) -> [ show pos ++ ": Ilegal parameter, a record parameter has to be a variable." ]
_ -> [ ]
errA = case (fromDynamic . trep . baseType) ty of
Just (ArrType _ _) -> [ show pos ++ ": Ilegal parameter, an array parameter has to be a variable." ]
_ -> [ ]
in errR ++ errA
sterrParam' = synupdM sterr $ do knd <- at ch_kind_Param
idl <- at ch_idl_Param
typ <- at ch_typ_Param
return $ \err -> err ++ checkSt (idl # spos) (typ # sty) knd
---- Aspects
pTInfo :: a -> SymbolInfo TInfo a
pTInfo _ = undefined
aspArrayType r = styArrayType `ext` sterrArrayType `ext` (T2.aspArrayType (pTInfo r))
aspRecordType r = styRecordType `ext` sterrRule `ext` (T2.aspRecordType (pTInfo r))
aspFieldL_Cons r = sterrRule `ext` (T2.aspFieldL_Cons (pTInfo r))
aspFieldL_Nil r = sterrRule `ext` (T2.aspFieldL_Nil (pTInfo r))
aspField r = (senvField' r) `ext` sterrRule `ext` (T2.aspField (pTInfo r))
aspEmptyField r = sterrRule `ext` (T2.aspEmptyField (pTInfo r))
aspSelExp r = itySelExp `ext` sposSelExp `ext` stySelExp `ext`svalSelExp `ext` sterrRule `ext` (T2.aspSelExp (pTInfo r))
aspSelectL_Cons r = itySelectL_Cons `ext` stySelectL_Cons `ext` sterrRule `ext` (T2.aspSelectL_Cons (pTInfo r))
aspSelectL_Nil r = ityRule `ext` stySelectL_Nil `ext` sterrRule `ext` (T2.aspSelectL_Nil (pTInfo r))
aspSelField r = ityRule `ext` stySelField `ext` sterrSelField `ext` (T2.aspSelField (pTInfo r))
aspSelArray r = ityRule `ext` stySelArray `ext` sterrSelArray `ext` (T2.aspSelArray (pTInfo r))
aspAssigSelStmt r = ityAssigSelStmt `ext` sterrAssigSelStmt `ext` (T2.aspAssigSelStmt (pTInfo r))
---- Semantic Functions
mkL1''' aspAssigStmt aspBoolBOpExp aspBoolExp aspBoolUOpExp aspCondStmt aspCondStmtL_Cons
aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil aspDecls aspEmptyStmt
aspIdExp aspIdentL_Cons aspIdentL_Nil aspIfStmt aspIntBOpExp aspIntCmpExp aspIntExp
aspIntUOpExp aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule aspParExp
aspSeqStmt aspTypDecl aspType aspVarDecl aspWhileStmt
= mkL1'' (sterrAssigStmt' `ext` aspAssigStmt) aspBoolBOpExp aspBoolExp
aspBoolUOpExp aspCondStmt aspCondStmtL_Cons
aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil aspDecls aspEmptyStmt
aspIdExp aspIdentL_Cons aspIdentL_Nil aspIfStmt aspIntBOpExp
aspIntCmpExp aspIntExp
aspIntUOpExp aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule
aspParExp aspSeqStmt aspTypDecl aspType aspVarDecl aspWhileStmt
l1t3 = mkL1''' (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspBoolUOpExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ())
(L1.aspCondStmtL_Nil ()) (L1.aspCstDecl ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) (L1.aspDecls ()) (L1.aspEmptyStmt ())
(L1.aspIdExp ()) (L1.aspIdentL_Cons ()) (L1.aspIdentL_Nil ()) (L1.aspIfStmt ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ())
(L1.aspIntUOpExp ()) (L1.aspMaybeElseStmt_Just ()) (L1.aspMaybeElseStmt_Nothing ()) (L1.aspModule ()) (L1.aspParExp ())
(L1.aspSeqStmt ()) (L1.aspTypDecl ()) (L1.aspType ()) (L1.aspVarDecl ()) (L1.aspWhileStmt ())
mkL3' _aspExtDeclarations _aspProcDecl _aspParamL_Cons _aspParamL_Nil _aspParam
_aspProcCStmt _aspExpressionL_Cons _aspExpressionL_Nil
_aspEmptyStmt _aspDeclL_Cons _aspDeclL_Nil
= mkL3 _aspExtDeclarations _aspProcDecl _aspParamL_Cons _aspParamL_Nil (sterrParam' `ext` _aspParam)
_aspProcCStmt _aspExpressionL_Cons _aspExpressionL_Nil
_aspEmptyStmt _aspDeclL_Cons _aspDeclL_Nil
l3t3 = mkL3' (L3.aspExtDeclarations ()) (L3.aspProcDecl ()) (L3.aspParamL_Cons ()) (L3.aspParamL_Nil ()) (L3.aspParam ())
(L3.aspProcCStmt ()) (L3.aspExpressionL_Cons ()) (L3.aspExpressionL_Nil ())
(L1.aspEmptyStmt ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ())
mkL4' _aspArrayType _aspAssigSelStmt _aspEmptyField _aspField _aspFieldL_Cons _aspFieldL_Nil
_aspRecordType _aspSelArray _aspSelExp _aspSelField _aspSelectL_Cons _aspSelectL_Nil
= mkL4 _aspArrayType _aspAssigSelStmt _aspEmptyField _aspField _aspFieldL_Cons _aspFieldL_Nil
_aspRecordType _aspSelArray (skndSelExp `ext` _aspSelExp) _aspSelField _aspSelectL_Cons _aspSelectL_Nil
l4t3 = mkL4' (aspArrayType ()) (aspAssigSelStmt ()) (aspEmptyField ()) (aspField ()) (aspFieldL_Cons ()) (aspFieldL_Nil ())
(aspRecordType ()) (aspSelArray ()) (aspSelExp ()) (aspSelField ()) (aspSelectL_Cons ()) (aspSelectL_Nil ())