module CAttrs (
AttrC, attrC, getCHeader, enterNewRangeC, enterNewObjRangeC,
leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC,
lookupDefObjCShadow, addDefTagC, lookupDefTagC,
lookupDefTagCShadow, applyPrefix, getDefOfIdentC,
setDefOfIdentC, updDefOfIdentC, freezeDefOfIdentsAttrC,
softenDefOfIdentsAttrC,
CObj(..), CTag(..), CDef(..))
where
import Data.Char (toUpper)
import Data.List (isPrefixOf)
import Data.Maybe (mapMaybe)
import Position (Position, Pos(posOf), nopos, dontCarePos, builtinPos)
import Errors (interr)
import Idents (Ident, getIdentAttrs, identToLexeme, onlyPosIdent)
import Attributes (Attr(..), AttrTable, getAttr, setAttr, updAttr,
newAttrTable, freezeAttrTable, softenAttrTable)
import NameSpaces (NameSpace, nameSpace, enterNewRange, leaveRange, defLocal,
defGlobal, find, nameSpaceToList)
import Binary (Binary(..), putByte, getByte)
import CAST
data AttrC = AttrC {
headerAC :: CHeader,
defObjsAC :: CObjNS,
defTagsAC :: CTagNS,
shadowsAC :: CShadowNS,
defsAC :: CDefTable
}
attrC :: CHeader -> AttrC
attrC header = AttrC {
headerAC = header,
defObjsAC = cObjNS,
defTagsAC = cTagNS,
shadowsAC = cShadowNS,
defsAC = cDefTable
}
getCHeader :: AttrC -> CHeader
getCHeader = headerAC
enterNewRangeC :: AttrC -> AttrC
enterNewRangeC ac = ac {
defObjsAC = enterNewRange . defObjsAC $ ac,
defTagsAC = enterNewRange . defTagsAC $ ac
}
enterNewObjRangeC :: AttrC -> AttrC
enterNewObjRangeC ac = ac {
defObjsAC = enterNewRange . defObjsAC $ ac
}
leaveRangeC :: AttrC -> AttrC
leaveRangeC ac = ac {
defObjsAC = fst . leaveRange . defObjsAC $ ac,
defTagsAC = fst . leaveRange . defTagsAC $ ac
}
leaveObjRangeC :: AttrC -> AttrC
leaveObjRangeC ac = ac {
defObjsAC = fst . leaveRange . defObjsAC $ ac
}
addDefObjC :: AttrC -> Ident -> CObj -> (AttrC, Maybe CObj)
addDefObjC ac ide obj = let om = defObjsAC ac
(ac', obj') = defLocal om ide obj
in
(ac {defObjsAC = ac'}, obj')
lookupDefObjC :: AttrC -> Ident -> Maybe CObj
lookupDefObjC ac ide = find (defObjsAC ac) ide
lookupDefObjCShadow :: AttrC -> Ident -> Maybe (CObj, Ident)
lookupDefObjCShadow ac ide =
case lookupDefObjC ac ide of
Just obj -> Just (obj, ide)
Nothing -> case find (shadowsAC ac) ide of
Nothing -> Nothing
Just ide' -> case lookupDefObjC ac ide' of
Just obj -> Just (obj, ide')
Nothing -> Nothing
addDefTagC :: AttrC -> Ident -> CTag -> (AttrC, Maybe CTag)
addDefTagC ac ide obj = let tm = defTagsAC ac
(ac', obj') = defLocal tm ide obj
in
(ac {defTagsAC = ac'}, obj')
lookupDefTagC :: AttrC -> Ident -> Maybe CTag
lookupDefTagC ac ide = find (defTagsAC ac) ide
lookupDefTagCShadow :: AttrC -> Ident -> Maybe (CTag, Ident)
lookupDefTagCShadow ac ide =
case lookupDefTagC ac ide of
Just tag -> Just (tag, ide)
Nothing -> case find (shadowsAC ac) ide of
Nothing -> Nothing
Just ide' -> case lookupDefTagC ac ide' of
Just tag -> Just (tag, ide')
Nothing -> Nothing
applyPrefix :: AttrC -> String -> AttrC
applyPrefix ac prefix =
let
shadows = shadowsAC ac
names = map fst (nameSpaceToList (defObjsAC ac))
++ map fst (nameSpaceToList (defTagsAC ac))
newShadows = mapMaybe (strip prefix) names
in
ac {shadowsAC = foldl define shadows newShadows}
where
strip prefix ide = case eat prefix (identToLexeme ide) of
Nothing -> Nothing
Just "" -> Nothing
Just newName -> Just
(onlyPosIdent (posOf ide) newName,
ide)
eat [] ('_':cs) = eat [] cs
eat [] cs = Just cs
eat (p:prefix) (c:cs) | toUpper p == toUpper c = eat prefix cs
| otherwise = Nothing
eat _ _ = Nothing
define ns (ide, def) = fst (defGlobal ns ide def)
getDefOfIdentC :: AttrC -> Ident -> CDef
getDefOfIdentC ac = getAttr (defsAC ac) . getIdentAttrs
setDefOfIdentC :: AttrC -> Ident -> CDef -> AttrC
setDefOfIdentC ac id def =
let tot' = setAttr (defsAC ac) (getIdentAttrs id) def
in
ac {defsAC = tot'}
updDefOfIdentC :: AttrC -> Ident -> CDef -> AttrC
updDefOfIdentC ac id def =
let tot' = updAttr (defsAC ac) (getIdentAttrs id) def
in
ac {defsAC = tot'}
freezeDefOfIdentsAttrC :: AttrC -> AttrC
freezeDefOfIdentsAttrC ac = ac {defsAC = freezeAttrTable (defsAC ac)}
softenDefOfIdentsAttrC :: AttrC -> AttrC
softenDefOfIdentsAttrC ac = ac {defsAC = softenAttrTable (defsAC ac)}
data CObj = TypeCO CDecl
| ObjCO CDecl
| EnumCO Ident CEnum
| BuiltinCO
instance Eq CObj where
(TypeCO decl1 ) == (TypeCO decl2 ) = decl1 == decl2
(ObjCO decl1 ) == (ObjCO decl2 ) = decl1 == decl2
(EnumCO ide1 enum1) == (EnumCO ide2 enum2) = ide1 == ide2 && enum1 == enum2
_ == _ = False
instance Pos CObj where
posOf (TypeCO def ) = posOf def
posOf (ObjCO def ) = posOf def
posOf (EnumCO ide _) = posOf ide
posOf (BuiltinCO ) = builtinPos
data CTag = StructUnionCT CStructUnion
| EnumCT CEnum
instance Eq CTag where
(StructUnionCT struct1) == (StructUnionCT struct2) = struct1 == struct2
(EnumCT enum1 ) == (EnumCT enum2 ) = enum1 == enum2
_ == _ = False
instance Pos CTag where
posOf (StructUnionCT def) = posOf def
posOf (EnumCT def) = posOf def
data CDef = UndefCD
| DontCareCD
| ObjCD CObj
| TagCD CTag
instance Eq CDef where
(ObjCD obj1) == (ObjCD obj2) = obj1 == obj2
(TagCD tag1) == (TagCD tag2) = tag1 == tag2
DontCareCD == _ = True
_ == DontCareCD = True
UndefCD == _ =
interr "CAttrs: Attempt to compare an undefined C definition!"
_ == UndefCD =
interr "CAttrs: Attempt to compare an undefined C definition!"
_ == _ = False
instance Attr CDef where
undef = UndefCD
dontCare = DontCareCD
isUndef UndefCD = True
isUndef _ = False
isDontCare DontCareCD = True
isDontCare _ = False
instance Pos CDef where
posOf UndefCD = nopos
posOf DontCareCD = dontCarePos
posOf (ObjCD obj) = posOf obj
posOf (TagCD tag) = posOf tag
type CObjNS = NameSpace CObj
cObjNS :: CObjNS
cObjNS = nameSpace
type CTagNS = NameSpace CTag
cTagNS :: CTagNS
cTagNS = nameSpace
type CShadowNS = NameSpace Ident
cShadowNS :: CShadowNS
cShadowNS = nameSpace
type CDefTable = AttrTable CDef
cDefTable :: CDefTable
cDefTable = newAttrTable "C General Definition Table for Idents"
instance Binary AttrC where
put_ bh (AttrC aa ab ac ad ae) = do
put_ bh ab
put_ bh ac
put_ bh ad
put_ bh ae
get bh = do
ab <- get bh
ac <- get bh
ad <- get bh
ae <- get bh
return (AttrC (error "AttrC.headerAC should not be needed") ab ac ad ae)
instance Binary CObj where
put_ bh (TypeCO aa) = do
putByte bh 0
put_ bh aa
put_ bh (ObjCO ab) = do
putByte bh 1
put_ bh ab
put_ bh (EnumCO ac ad) = do
putByte bh 2
put_ bh ac
put_ bh ad
put_ bh BuiltinCO = do
putByte bh 3
get bh = do
h <- getByte bh
case h of
0 -> do
aa <- get bh
return (TypeCO aa)
1 -> do
ab <- get bh
return (ObjCO ab)
2 -> do
ac <- get bh
ad <- get bh
return (EnumCO ac ad)
3 -> do
return BuiltinCO
instance Binary CTag where
put_ bh (StructUnionCT aa) = do
putByte bh 0
put_ bh aa
put_ bh (EnumCT ab) = do
putByte bh 1
put_ bh ab
get bh = do
h <- getByte bh
case h of
0 -> do
aa <- get bh
return (StructUnionCT aa)
1 -> do
ab <- get bh
return (EnumCT ab)
instance Binary CDef where
put_ bh UndefCD = do
putByte bh 0
put_ bh DontCareCD = do
putByte bh 1
put_ bh (ObjCD aa) = do
putByte bh 2
put_ bh aa
put_ bh (TagCD ab) = do
putByte bh 3
put_ bh ab
get bh = do
h <- getByte bh
case h of
0 -> do
return UndefCD
1 -> do
return DontCareCD
2 -> do
aa <- get bh
return (ObjCD aa)
3 -> do
ab <- get bh
return (TagCD ab)