language-c99-simple-0.3.0/0000755000000000000000000000000007346545000013357 5ustar0000000000000000language-c99-simple-0.3.0/ChangeLog.md0000644000000000000000000000164507346545000015536 0ustar0000000000000000# Revision history for language-c99-simple ## 0.3.0 -- 2024-01-03 * Use https instead of git:// for source url (thanks felixonmars) (#24). * Extend FunDef with an optional StorageSpec. (thanks ivanperez-keera) (#23). ## 0.2.3 -- 2023-08-30 * Allow building with mtl-2.3.1 (thanks RyanGlScott) (#15). ## 0.2.2 -- 2022-08-28 * Added support for `sizeof` (#12). ## 0.2.1 -- 2022-08-15 * Bump version number for release (#10). * Fixed a bug where the order of init list was reversed (thanks RyanGlScott!). (#9) ## 0.2.0 -- 2022-05-21 * Added support for initializers with designators. * Added support for enum and union. ## 0.1.2 -- 2019-05-12 * Added support for storagespec. ## 0.1.1 -- 2019-04-01 * Implemented `transtypename`, used in typecasts. * Fixed version bounds on dependencies. ## 0.1.0.0 -- 2019-03-30 * First version. Initial version supporting features needed for copilot. Contains no comments yet. language-c99-simple-0.3.0/LICENSE0000644000000000000000000000204507346545000014365 0ustar0000000000000000Copyright (c) 2018-2019 Frank Dedden Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. language-c99-simple-0.3.0/Setup.hs0000644000000000000000000000005607346545000015014 0ustar0000000000000000import Distribution.Simple main = defaultMain language-c99-simple-0.3.0/language-c99-simple.cabal0000644000000000000000000000300607346545000020016 0ustar0000000000000000-- Initial language-c99-simple.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: language-c99-simple version: 0.3.0 synopsis: C-like AST to simplify writing C99 programs. description: This package is a wrapper on top of 'language-c99'. It provides a simpler interface more suited for writing C99 programs. It achieves this by implementing its own C-like AST, supporting the most used C features. In turn, this AST is translated into actual C99 one, showing that it is an actual subset. license: MIT license-file: LICENSE author: Frank Dedden maintainer: Frank Dedden -- copyright: category: Language build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.10 source-repository head type: git location: https://github.com/fdedden/language-c99-simple.git library exposed-modules: Language.C99.Simple, Language.C99.Simple.AST Language.C99.Simple.Translate, Language.C99.Simple.Util, Language.C99.Simple.Expr -- other-modules: -- other-extensions: build-depends: base >=4.9 && <5, language-c99 >= 0.2 && < 0.3, language-c99-util >= 0.2 && < 0.3, mtl >= 2.2.0 && < 2.4 hs-source-dirs: src default-language: Haskell2010 language-c99-simple-0.3.0/src/Language/C99/0000755000000000000000000000000007346545000016235 5ustar0000000000000000language-c99-simple-0.3.0/src/Language/C99/Simple.hs0000644000000000000000000000047607346545000020031 0ustar0000000000000000module Language.C99.Simple ( module Language.C99.Simple.AST , module Language.C99.Simple.Translate , module Language.C99.Simple.Util , module Language.C99.Simple.Expr ) where import Language.C99.Simple.AST import Language.C99.Simple.Translate import Language.C99.Simple.Util import Language.C99.Simple.Expr language-c99-simple-0.3.0/src/Language/C99/Simple/0000755000000000000000000000000007346545000017466 5ustar0000000000000000language-c99-simple-0.3.0/src/Language/C99/Simple/AST.hs0000644000000000000000000001067007346545000020455 0ustar0000000000000000{- This module implements a simplified version of a C99 AST. It omits a lot of - specific and rarely used language constructs and features, which typically - are not used by code generators anyway. Some parts of the AST differ quite a - lot from the C99 one, and do not necessarily mimic their counterparts, even - if the names are similar. - - A total translation function proves that the simplified AST can be rewritten - in terms of the full AST, and thus is a subset. -} module Language.C99.Simple.AST where import Prelude hiding (LT, GT) import Data.List.NonEmpty (NonEmpty) type Ident = String data TransUnit = TransUnit [Decln] [FunDef] data FunDef = FunDef (Maybe StorageSpec) Type Ident [Param] [Decln] [Stmt] data Param = Param Type Ident data Decln = VarDecln (Maybe StorageSpec) Type Ident (Maybe Init) | FunDecln (Maybe StorageSpec) Type Ident [Param] | TypeDecln Type data StorageSpec = Typedef | Extern | Static | Auto | Register data Type = Type Type | TypeSpec TypeSpec | Ptr Type | Array Type (Maybe Expr) | Const Type | Restrict Type | Volatile Type data TypeSpec = Void | Char | Signed_Char | Unsigned_Char | Short | Signed_Short | Short_Int | Signed_Short_Int | Unsigned_Short | Unsigned_Short_Int | Int | Signed | Signed_Int | Unsigned | Unsigned_Int | Long | Signed_Long | Long_Int | Signed_Long_Int | Unsigned_Long | Unsgined_Long_Int | Long_Long | Signed_Long_Long | Long_Long_Int | Signed_Long_Long_Int | Unsigned_Long_Long | Unsigned_Long_Long_Int | Float | Double | Long_Double | Bool | Float_Complex | Double_Complex | Long_Double_Complex | TypedefName Ident | Struct Ident | StructDecln (Maybe Ident) (NonEmpty FieldDecln) | Union Ident | UnionDecln (Maybe Ident) (NonEmpty FieldDecln) | Enum Ident | EnumDecln (Maybe Ident) (NonEmpty Ident) data FieldDecln = FieldDecln Type Ident data Init = InitExpr Expr | InitList (NonEmpty InitItem) data InitItem = InitItem (Maybe Ident) Init data Expr = Ident Ident | LitBool Bool | LitInt Integer | LitFloat Float | LitDouble Double | LitString String | Index Expr Expr | Funcall Expr [Expr] | Dot Expr Ident | Arrow Expr Ident | InitVal TypeName (NonEmpty InitItem) | UnaryOp UnaryOp Expr | Cast TypeName Expr | BinaryOp BinaryOp Expr Expr | Cond Expr Expr Expr | AssignOp AssignOp Expr Expr | SizeOf Expr | SizeOfType TypeName data UnaryOp = Inc | Dec | Ref | DeRef | Plus | Min | BoolNot | Not data BinaryOp = Mult | Div | Mod | Add | Sub | ShiftL | ShiftR | LT | GT | LE | GE | Eq | NEq | And | XOr | Or | LAnd | LOr data AssignOp = Assign | AssignMult | AssignDiv | AssignMod | AssignAdd | AssignSub | AssignShiftL | AssignShiftR | AssignAnd | AssignXOr | AssignOr data TypeName = TypeName Type data Case = Case Expr Stmt | Default Stmt data Stmt = Expr Expr | If Expr [Stmt] | IfElse Expr [Stmt] [Stmt] | Switch Expr [Case] | While Expr [Stmt] | For Expr Expr Expr [Stmt] | ForInf [Stmt] | Continue | Break | Label String Stmt | Return (Maybe Expr) language-c99-simple-0.3.0/src/Language/C99/Simple/Expr.hs0000644000000000000000000000401707346545000020742 0ustar0000000000000000module Language.C99.Simple.Expr where import Prelude hiding (LT, GT) import Language.C99.Simple.AST -- Unary Operators (.++) :: Expr -> Expr (.++) = UnaryOp Inc (.--) :: Expr -> Expr (.--) = UnaryOp Dec ref :: Expr -> Expr ref = UnaryOp Ref deref :: Expr -> Expr deref = UnaryOp DeRef pos :: Expr -> Expr pos = UnaryOp Plus neg :: Expr -> Expr neg = UnaryOp Min (.~) :: Expr -> Expr (.~) = UnaryOp BoolNot (.!) :: Expr -> Expr (.!) = UnaryOp Not -- Binary Operators (.*) :: Expr -> Expr -> Expr (.*) = BinaryOp Mult (./) :: Expr -> Expr -> Expr (./) = BinaryOp Div (.%) :: Expr -> Expr -> Expr (.%) = BinaryOp Mod (.+) :: Expr -> Expr -> Expr (.+) = BinaryOp Add (.-) :: Expr -> Expr -> Expr (.-) = BinaryOp Sub (.<<) :: Expr -> Expr -> Expr (.<<) = BinaryOp ShiftL (.>>) :: Expr -> Expr -> Expr (.>>) = BinaryOp ShiftR (.<) :: Expr -> Expr -> Expr (.<) = BinaryOp LT (.>) :: Expr -> Expr -> Expr (.>) = BinaryOp GT (.<=) :: Expr -> Expr -> Expr (.<=) = BinaryOp LE (.>=) :: Expr -> Expr -> Expr (.>=) = BinaryOp GE (.==) :: Expr -> Expr -> Expr (.==) = BinaryOp Eq (.!=) :: Expr -> Expr -> Expr (.!=) = BinaryOp NEq (.&) :: Expr -> Expr -> Expr (.&) = BinaryOp And (.^) :: Expr -> Expr -> Expr (.^) = BinaryOp XOr (.|) :: Expr -> Expr -> Expr (.|) = BinaryOp Or (.&&) :: Expr -> Expr -> Expr (.&&) = BinaryOp LAnd (.||) :: Expr -> Expr -> Expr (.||) = BinaryOp LOr -- Assignment operators (.=) :: Expr -> Expr -> Expr (.=) = AssignOp Assign (.*=) :: Expr -> Expr -> Expr (.*=) = AssignOp AssignMult (./=) :: Expr -> Expr -> Expr (./=) = AssignOp AssignDiv (.%=) :: Expr -> Expr -> Expr (.%=) = AssignOp AssignMod (.+=) :: Expr -> Expr -> Expr (.+=) = AssignOp AssignAdd (.-=) :: Expr -> Expr -> Expr (.-=) = AssignOp AssignSub (.<<=) :: Expr -> Expr -> Expr (.<<=) = AssignOp AssignShiftL (.>>=) :: Expr -> Expr -> Expr (.>>=) = AssignOp AssignShiftR (.&=) :: Expr -> Expr -> Expr (.&=) = AssignOp AssignAnd (.^=) :: Expr -> Expr -> Expr (.^=) = AssignOp AssignXOr (.|=) :: Expr -> Expr -> Expr (.|=) = AssignOp AssignOr language-c99-simple-0.3.0/src/Language/C99/Simple/Translate.hs0000644000000000000000000004031707346545000021764 0ustar0000000000000000module Language.C99.Simple.Translate where import Prelude hiding (LT, GT) import GHC.Exts (fromList) import Control.Monad.State (State, execState, get, put) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Language.C99.Simple.AST import qualified Language.C99.AST as C import Language.C99.Util import Language.C99.Simple.Util translate = transtransunit transtransunit :: TransUnit -> C.TransUnit transtransunit (TransUnit declns fundefs) = fromList (declns' ++ fundefs') where declns' = map (C.ExtDecln . transdecln) declns fundefs' = map (C.ExtFun . transfundef) fundefs transfundef :: FunDef -> C.FunDef transfundef (FunDef storespec ty name params decln ss) = C.FunDef dspecs declr Nothing body where dspecs = getdeclnspecs storespec ty body = compound decln ss declr = execState (getdeclr ty) fundeclr fundeclr = C.Declr Nothing (fundirectdeclr name params) transdecln :: Decln -> C.Decln transdecln decln = case decln of FunDecln storespec ty name params -> C.Decln dspecs dlist where dspecs = getdeclnspecs storespec ty dlist = Just $ C.InitDeclrBase $ C.InitDeclr declr declr = execState (getdeclr ty) fundeclr fundeclr = C.Declr Nothing (fundirectdeclr name params) VarDecln storespec ty name init -> C.Decln dspecs dlist where dspecs = getdeclnspecs storespec ty dlist = Just $ case init of Nothing -> C.InitDeclrBase $ C.InitDeclr declr Just val -> C.InitDeclrBase $ C.InitDeclrInitr declr (transinit val) declr = execState (getdeclr ty) (identdeclr name) TypeDecln ty -> C.Decln dspecs Nothing where dspecs = getdeclnspecs Nothing ty transparamdecln :: Param -> C.ParamDecln transparamdecln (Param ty name) = C.ParamDecln dspecs declr where dspecs = getdeclnspecs Nothing ty declr = execState (getdeclr ty) (identdeclr name) transparam :: Param -> C.Decln transparam (Param ty name) = C.Decln dspecs dlist where dspecs = getdeclnspecs Nothing ty dlist = Just $ C.InitDeclrBase $ C.InitDeclr declr declr = execState (getdeclr ty) (identdeclr name) getdeclr :: Type -> State C.Declr () getdeclr ty = case ty of Type ty' -> do getdeclr ty' declr <- get put $ C.Declr Nothing (C.DirectDeclrDeclr declr) TypeSpec ty' -> return () Ptr ty' -> do let (quals, ty'') = gettypequals ty' declr <- get put $ insertptr (C.PtrBase quals) declr getdeclr ty'' Array ty' len -> do let lenexpr = (wrap.transexpr) <$> len C.Declr ptr declr <- get let ddeclr = case ptr of Nothing -> declr Just _ -> C.DirectDeclrDeclr $ C.Declr ptr declr put $ C.Declr Nothing (C.DirectDeclrArray1 ddeclr Nothing lenexpr) getdeclr ty' Const ty' -> getdeclr ty' Restrict ty' -> getdeclr ty' Volatile ty' -> getdeclr ty' getdeclnspecs :: Maybe StorageSpec -> Type -> C.DeclnSpecs getdeclnspecs storespec ty = dspecs where dspecs = case storespec of Nothing -> tyspec Just spec -> C.DeclnSpecsStorage (transstorespec spec) (Just tyspec) tyspec = case ty of Type ty' -> rec ty' TypeSpec ty' -> foldtypespecs $ spec2spec ty' Ptr ty' -> rec (snd $ gettypequals ty') Array ty' _ -> rec ty' Const ty' -> C.DeclnSpecsQual C.QConst (Just $ rec ty') Restrict ty' -> C.DeclnSpecsQual C.QRestrict (Just $ rec ty') Volatile ty' -> C.DeclnSpecsQual C.QVolatile (Just $ rec ty') rec = getdeclnspecs Nothing transstorespec :: StorageSpec -> C.StorageClassSpec transstorespec spec = case spec of Typedef -> C.STypedef Extern -> C.SExtern Static -> C.SStatic Auto -> C.SAuto Register -> C.SRegister spec2spec :: TypeSpec -> [C.TypeSpec] spec2spec ts = case ts of Void -> [C.TVoid] Char -> [C.TChar] Signed_Char -> [C.TSigned, C.TChar] Unsigned_Char -> [C.TUnsigned, C.TChar] Short -> [C.TShort] Signed_Short -> [C.TSigned, C.TShort] Short_Int -> [C.TShort, C.TInt] Signed_Short_Int -> [C.TSigned, C.TShort, C.TInt] Unsigned_Short -> [C.TUnsigned, C.TShort] Unsigned_Short_Int -> [C.TUnsigned, C.TShort, C.TInt] Int -> [C.TInt] Signed -> [C.TSigned] Signed_Int -> [C.TSigned, C.TInt] Unsigned -> [C.TUnsigned] Unsigned_Int -> [C.TUnsigned, C.TInt] Long -> [C.TLong] Signed_Long -> [C.TSigned, C.TLong] Long_Int -> [C.TLong, C.TInt] Signed_Long_Int -> [C.TSigned, C.TLong, C.TInt] Unsigned_Long -> [C.TUnsigned, C.TLong] Unsgined_Long_Int -> [C.TUnsigned, C.TLong, C.TInt] Long_Long -> [C.TLong, C.TLong] Signed_Long_Long -> [C.TSigned, C.TLong, C.TLong] Long_Long_Int -> [C.TLong, C.TLong, C.TInt] Signed_Long_Long_Int-> [C.TSigned, C.TLong, C.TLong, C.TInt] Unsigned_Long_Long -> [C.TUnsigned, C.TLong, C.TLong] Unsigned_Long_Long_Int -> [C.TUnsigned, C.TLong, C.TLong, C.TInt] Float -> [C.TFloat] Double -> [C.TDouble] Long_Double -> [C.TLong, C.TDouble] Bool -> [C.TBool] Float_Complex -> [C.TComplex, C.TFloat] Double_Complex -> [C.TComplex, C.TDouble] Long_Double_Complex -> [C.TLong, C.TDouble, C.TComplex] TypedefName name -> [C.TTypedef $ C.TypedefName $ ident name] Struct name -> [C.TStructOrUnion $ C.StructOrUnionForwDecln C.Struct (ident name)] StructDecln name declns -> [C.TStructOrUnion $ C.StructOrUnionDecln C.Struct (ident <$> name) declns'] where declns' = transfielddeclns declns Union name -> [C.TStructOrUnion $ C.StructOrUnionForwDecln C.Union (ident name)] UnionDecln name declns -> [C.TStructOrUnion $ C.StructOrUnionDecln C.Union (ident <$> name) declns'] where declns' = transfielddeclns declns Enum name -> [C.TEnum $ C.EnumSpecForw (ident name)] EnumDecln name declns -> [C.TEnum $ C.EnumSpec (ident <$> name) declns'] where declns' = transvariantdeclns declns transfielddeclns :: NonEmpty FieldDecln -> C.StructDeclnList transfielddeclns (decln NE.:| declns) = foldl step (base decln) declns where base d = C.StructDeclnBase (transfielddecln d) step ds d = C.StructDeclnCons ds (transfielddecln d) transfielddecln :: FieldDecln -> C.StructDecln transfielddecln (FieldDecln ty name) = C.StructDecln quals declrlist where declrlist = C.StructDeclrBase $ C.StructDeclr declr declr = execState (getdeclr ty) (identdeclr name) quals = getspecquals ty transvariantdeclns :: NonEmpty Ident -> C.EnumrList transvariantdeclns (decln NE.:| declns) = foldl step (base decln) declns where base d = C.EnumrBase (transvariantdecln d) step ds d = C.EnumrCons ds (transvariantdecln d) transvariantdecln :: Ident -> C.Enumr transvariantdecln name = C.Enumr (C.Enum (ident name)) getspecquals :: Type -> C.SpecQualList getspecquals ty = case ty of Type ty' -> getspecquals ty' TypeSpec ts -> foldtypequals $ spec2spec ts Ptr ty' -> getspecquals ty' Array ty' len -> getspecquals ty' Const ty' -> C.SpecQualQual C.QConst (Just $ getspecquals ty') Restrict ty' -> C.SpecQualQual C.QRestrict (Just $ getspecquals ty') Volatile ty' -> C.SpecQualQual C.QVolatile (Just $ getspecquals ty') transexpr :: Expr -> C.Expr transexpr e = case e of Ident i -> wrap $ C.PrimIdent $ ident i LitBool b -> wrap $ litbool b LitInt i -> wrap $ litint i LitFloat f -> wrap $ litfloat f LitDouble d -> wrap $ litdouble d LitString s -> wrap $ litstring s Index arr idx -> wrap $ indexexpr arr idx Funcall fun args -> wrap $ funcall fun args Dot e field -> wrap $ dotexpr e field Arrow e field -> wrap $ arrowexpr e field InitVal ty init -> wrap $ initexpr ty init UnaryOp op e -> wrap $ unaryop op e Cast ty e -> wrap $ castexpr ty e BinaryOp op e1 e2 -> binaryop op e1 e2 AssignOp op e1 e2 -> wrap $ assignop op e1 e2 Cond c e1 e2 -> wrap $ condexpr c e1 e2 SizeOf e -> wrap $ C.UnarySizeExpr (wrap $ transexpr e) SizeOfType ty -> wrap $ C.UnarySizeType (transtypename ty) unaryop :: UnaryOp -> Expr -> C.UnaryExpr unaryop op e = case op of Inc -> C.UnaryInc (wrap e') Dec -> C.UnaryDec (wrap e') Ref -> C.UnaryOp C.UORef (wrap e') DeRef -> C.UnaryOp C.UODeref (wrap e') Plus -> C.UnaryOp C.UOPlus (wrap e') Min -> C.UnaryOp C.UOMin (wrap e') BoolNot -> C.UnaryOp C.UOBNot (wrap e') Not -> C.UnaryOp C.UONot (wrap e') where e' = transexpr e binaryop :: BinaryOp -> Expr -> Expr -> C.Expr binaryop op e1 e2 = case op of Mult -> wrap $ C.MultMult (wrap e1') (wrap e2') Div -> wrap $ C.MultDiv (wrap e1') (wrap e2') Mod -> wrap $ C.MultMod (wrap e1') (wrap e2') Add -> wrap $ C.AddPlus (wrap e1') (wrap e2') Sub -> wrap $ C.AddMin (wrap e1') (wrap e2') ShiftL -> wrap $ C.ShiftLeft (wrap e1') (wrap e2') ShiftR -> wrap $ C.ShiftRight (wrap e1') (wrap e2') LT -> wrap $ C.RelLT (wrap e1') (wrap e2') GT -> wrap $ C.RelGT (wrap e1') (wrap e2') LE -> wrap $ C.RelLE (wrap e1') (wrap e2') GE -> wrap $ C.RelGE (wrap e1') (wrap e2') Eq -> wrap $ C.EqEq (wrap e1') (wrap e2') NEq -> wrap $ C.EqNEq (wrap e1') (wrap e2') And -> wrap $ C.And (wrap e1') (wrap e2') XOr -> wrap $ C.XOr (wrap e1') (wrap e2') Or -> wrap $ C.Or (wrap e1') (wrap e2') LAnd -> wrap $ C.LAnd (wrap e1') (wrap e2') LOr -> wrap $ C.LOr (wrap e1') (wrap e2') where e1' = transexpr e1 e2' = transexpr e2 assignop :: AssignOp -> Expr -> Expr -> C.AssignExpr assignop op e1 e2 = C.Assign e1' op' e2' where e1' = wrap $ transexpr e1 e2' = wrap $ transexpr e2 op' = case op of Assign -> C.AEq AssignMult -> C.ATimes AssignDiv -> C.ADiv AssignMod -> C.AMod AssignAdd -> C.AAdd AssignSub -> C.ASub AssignShiftL -> C.AShiftL AssignShiftR -> C.AShiftR AssignAnd -> C.AAnd AssignXOr -> C.AXOr AssignOr -> C.AOr transinit :: Init -> C.Init transinit (InitExpr e) = C.InitExpr (wrap $ transexpr e) transinit (InitList es) = C.InitList (transinitlist es) transinitlist :: NonEmpty InitItem -> C.InitList transinitlist (x NE.:| xs) = foldl step (base x) xs where base (InitItem mident y) = C.InitBase (transdesigr <$> mident) (transinit y) step ys (InitItem mident y) = C.InitCons ys (transdesigr <$> mident) (transinit y) transdesigr :: Ident -> C.Design transdesigr = C.Design . C.DesigrBase . C.DesigrIdent . ident initexpr :: TypeName -> NonEmpty InitItem -> C.PostfixExpr initexpr ty inits = C.PostfixInits ty' inits' where ty' = transtypename ty inits' = transinititems inits transinititems :: NonEmpty InitItem -> C.InitList transinititems = transinitlist indexexpr arr idx = C.PostfixIndex arr' idx' where arr' = wrap $ transexpr arr idx' = wrap $ transexpr idx dotexpr e field = C.PostfixDot e' field' where e' = wrap $ transexpr e field' = ident field arrowexpr e field = C.PostfixArrow e' field' where e' = wrap $ transexpr e field' = ident field castexpr ty e = C.Cast ty' e' where ty' = transtypename ty e' = wrap $ transexpr e funcall fun args = C.PostfixFunction fun' args' where fun' = wrap $ transexpr fun args' = case argses of [] -> Nothing _ -> Just $ fromList argses argses :: [C.AssignExpr] argses = map wrap exprs exprs :: [C.Expr] exprs = map transexpr args condexpr c e1 e2 = C.Cond c' e1' e2' where c' = wrap $ transexpr c e1' = wrap $ transexpr e1 e2' = wrap $ transexpr e2 transtypename :: TypeName -> C.TypeName transtypename (TypeName ty) = C.TypeName specquals adeclr where specquals = getspecquals ty adeclr = execState (getabstractdeclr ty) Nothing getabstractdeclr :: Type -> State (Maybe C.AbstractDeclr) () getabstractdeclr ty = case ty of Type ty' -> do getabstractdeclr ty' adeclr <- get case adeclr of Nothing -> return () Just adeclr' -> put $ Just $ C.AbstractDeclrDirect Nothing dadeclr where dadeclr = C.DirectAbstractDeclr adeclr' TypeSpec ts -> return () Ptr ty' -> do let (quals, ty'') = gettypequals ty' ptr = C.PtrBase quals adeclr <- get case adeclr of Nothing -> put $ Just $ C.AbstractDeclr ptr Just adeclr' -> put $ Just $ C.AbstractDeclrDirect (Just ptr) dadeclr where dadeclr = C.DirectAbstractDeclr adeclr' getabstractdeclr ty'' Array ty' len -> do let lenexpr = (wrap.transexpr) <$> len emptyarrdeclr = C.DirectAbstractDeclrArray1 Nothing Nothing lenexpr adeclr <- get let declr = case adeclr of Nothing -> C.AbstractDeclrDirect Nothing emptyarrdeclr Just adeclr -> case adeclr of C.AbstractDeclrDirect mptr adeclr' -> C.AbstractDeclrDirect mptr arrdeclr where arrdeclr = C.DirectAbstractDeclrArray1 (Just adeclr') Nothing lenexpr C.AbstractDeclr ptr -> C.AbstractDeclrDirect (Just ptr) emptyarrdeclr put $ Just declr getabstractdeclr ty' Const ty' -> getabstractdeclr ty' Restrict ty' -> getabstractdeclr ty' Volatile ty' -> getabstractdeclr ty' transstmt :: Stmt -> C.Stmt transstmt stmt = case stmt of Expr e -> exprstmt e If cond ss -> ifstmt cond ss IfElse cond ssthen sselse -> ifelsestmt cond ssthen sselse Switch cond cases -> switchstmt cond cases While cond ss -> whilestmt cond ss For start end step ss -> forstmt (Just start) (Just end) (Just step) ss ForInf ss -> forstmt Nothing Nothing Nothing ss Continue -> C.StmtJump $ C.JumpContinue Break -> C.StmtJump $ C.JumpBreak Label name s -> labelstmt name s Return e -> returnstmt e exprstmt :: Expr -> C.Stmt exprstmt e = C.StmtExpr $ C.ExprStmt (Just $ wrap $ transexpr e) ifstmt :: Expr -> [Stmt] -> C.Stmt ifstmt cond ss = C.StmtSelect $ C.SelectIf cond' body where cond' = wrap $ transexpr cond body = compoundstmt [] ss ifelsestmt :: Expr -> [Stmt] -> [Stmt] -> C.Stmt ifelsestmt cond ssthen sselse = C.StmtSelect $ C.SelectIfElse cond' ssthen' sselse' where cond' = wrap $ transexpr cond ssthen' = compoundstmt [] ssthen sselse' = compoundstmt [] sselse switchstmt :: Expr -> [Case] -> C.Stmt switchstmt cond cs = C.StmtSelect $ C.SelectSwitch cond' cs' where cond' = wrap $ transexpr cond cs' = casestmt cs whilestmt :: Expr -> [Stmt] -> C.Stmt whilestmt cond ss = C.StmtIter $ C.IterWhile cond' ss' where cond' = wrap $ transexpr cond ss' = compoundstmt [] ss forstmt :: Maybe Expr -> Maybe Expr -> Maybe Expr -> [Stmt] -> C.Stmt forstmt start end step ss = C.StmtIter $ C.IterForUpdate start' end' step' ss' where start' = (wrap.transexpr) <$> start end' = (wrap.transexpr) <$> end step' = (wrap.transexpr) <$> step ss' = compoundstmt [] ss labelstmt :: String -> Stmt -> C.Stmt labelstmt name s = C.StmtLabeled $ C.LabeledIdent (ident name) (transstmt s) returnstmt :: Maybe Expr -> C.Stmt returnstmt e = C.StmtJump $ C.JumpReturn ((wrap.transexpr) <$> e) casestmt :: [Case] -> C.Stmt casestmt cs = C.StmtCompound $ C.Compound (Just $ fromList $ map casestmt' cs) where casestmt' cs = C.BlockItemStmt $ C.StmtLabeled $ case cs of Case e s -> C.LabeledCase (C.Const $ wrap $ transexpr e) (transstmt s) Default s -> C.LabeledDefault (transstmt s) compound :: [Decln] -> [Stmt] -> C.CompoundStmt compound ds ss = C.Compound (Just $ fromList items) where items = ds' ++ ss' ss' = map (C.BlockItemStmt . transstmt) ss ds' = map (C.BlockItemDecln . transdecln) ds compoundstmt :: [Decln] -> [Stmt] -> C.Stmt compoundstmt ds ss = C.StmtCompound $ compound ds ss fundirectdeclr :: Ident -> [Param] -> C.DirectDeclr fundirectdeclr name params = C.DirectDeclrFun1 namedeclr params' where namedeclr = C.DirectDeclrIdent $ ident name params' = C.ParamTypeList $ voidparamlist $ map transparamdecln params language-c99-simple-0.3.0/src/Language/C99/Simple/Util.hs0000644000000000000000000000515707346545000020747 0ustar0000000000000000module Language.C99.Simple.Util where import GHC.Exts (fromList) import Language.C99.Simple.AST import qualified Language.C99.AST as C import Language.C99.Util -- Append two declaration specs appendspecs :: C.DeclnSpecs -> C.DeclnSpecs -> C.DeclnSpecs appendspecs x y = let rec x' = Just $ appendspecs x' y in case x of C.DeclnSpecsType ts Nothing -> C.DeclnSpecsType ts (Just y) C.DeclnSpecsQual qs Nothing -> C.DeclnSpecsQual qs (Just y) C.DeclnSpecsType ts (Just x) -> C.DeclnSpecsType ts (rec x) C.DeclnSpecsQual qs (Just x) -> C.DeclnSpecsQual qs (rec x) -- Insert a pointer into a declaration insertptr :: C.Ptr -> C.Declr -> C.Declr insertptr ptr (C.Declr Nothing declr) = C.Declr (Just ptr) declr insertptr ptr (C.Declr (Just ptr') declr) = C.Declr (Just $ appendptr ptr ptr') declr -- Append pointers, giving a pointer level of the sum of both appendptr :: C.Ptr -> C.Ptr -> C.Ptr appendptr (C.PtrBase quals) ptr = C.PtrCons quals ptr appendptr (C.PtrCons quals ptr') ptr = C.PtrCons quals (appendptr ptr ptr') -- Keep taking qualifiers as long as possible and return the remainder gettypequals :: Type -> (Maybe C.TypeQualList, Type) gettypequals ty = (f quals, ty') where f [] = Nothing f xs = Just $ fromList xs (quals, ty') = gettypequals' ty gettypequals' ty = case ty of Const ty' -> rec C.QConst ty' Restrict ty' -> rec C.QRestrict ty' Volatile ty' -> rec C.QVolatile ty' _ -> ([], ty) rec qual ty = let (quals, ty') = gettypequals' ty in (qual:quals, ty') -- Turn a declr in an array by appending an ArrayDeclr declrarray :: C.Declr -> Maybe C.AssignExpr -> C.Declr declrarray (C.Declr ptr ddeclr) mexpr = C.Declr ptr (C.DirectDeclrArray1 ddeclr Nothing mexpr) -- Takes a list of C.TypeSpec and turns it into a C.DeclnSpecs foldtypespecs :: [C.TypeSpec] -> C.DeclnSpecs foldtypespecs ts = foldtypespecs' (reverse ts) where foldtypespecs' [] = error "DeclnSpecs can't be empty" foldtypespecs' (t:ts) = foldl step base ts where base = C.DeclnSpecsType t Nothing step x y = C.DeclnSpecsType y (Just x) -- Takes a list of C.TypeSpec and turns it into a C.SpecQualsList foldtypequals :: [C.TypeSpec] -> C.SpecQualList foldtypequals ts = foldtypequals' (reverse ts) where foldtypequals' [] = error "SpecQualList can't be empty" foldtypequals' (t:ts) = foldl step base ts where base = C.SpecQualType t Nothing step x y = C.SpecQualType y (Just x) -- Decay a type: turn an toplevel array into a pointer, usefull for functions -- returning an array. decay :: Type -> Type decay (Array ty len) = Ptr ty decay ty = ty