language-c99-simple (empty) → 0.1.0.0
raw patch · 9 files changed
+829/−0 lines, 9 filesdep +basedep +language-c99dep +language-c99-utilsetup-changed
Dependencies added: base, language-c99, language-c99-util, mtl
Files
- ChangeLog.md +6/−0
- LICENSE +20/−0
- Setup.hs +2/−0
- language-c99-simple.cabal +40/−0
- src/Language/C99/Simple.hs +11/−0
- src/Language/C99/Simple/AST.hs +173/−0
- src/Language/C99/Simple/Expr.hs +121/−0
- src/Language/C99/Simple/Translate.hs +388/−0
- src/Language/C99/Simple/Util.hs +68/−0
+ ChangeLog.md view
@@ -0,0 +1,6 @@+# Revision history for language-c99-simple++## 0.1.0.0 -- 2019-03-30++* First version. Initial version supporting features needed for copilot.+ Contains no comments yet.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ language-c99-simple.cabal view
@@ -0,0 +1,40 @@+-- 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.1.0.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 <dev@dedden.net>+-- copyright: +category: Language+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++source-repository head+ type: git+ location: git://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.1.*,+ language-c99-util == 0.1.*,+ mtl >= 2.2.0 && < 2.3+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Language/C99/Simple.hs view
@@ -0,0 +1,11 @@+module 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
+ src/Language/C99/Simple/AST.hs view
@@ -0,0 +1,173 @@+{- 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)++type Ident = String++data TransUnit = TransUnit [Decln] [FunDef]++data FunDef = FunDef 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) [FieldDecln]++data FieldDecln = FieldDecln Type Ident++data Init = InitExpr Expr+ | InitArray [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 [Init]++ | UnaryOp UnaryOp Expr++ | Cast TypeName Expr++ | BinaryOp BinaryOp Expr Expr++ | Cond Expr Expr Expr++ | AssignOp AssignOp Expr Expr++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)
+ src/Language/C99/Simple/Expr.hs view
@@ -0,0 +1,121 @@+module 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
+ src/Language/C99/Simple/Translate.hs view
@@ -0,0 +1,388 @@+module Language.C99.Simple.Translate where++import Prelude hiding (LT, GT)++import GHC.Exts (fromList)+import Control.Monad.State (State, execState, get, put)++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 ty name params decln ss) =+ C.FunDef dspecs declr Nothing body where+ dspecs = getdeclnspecs 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 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 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 ty++transparamdecln :: Param -> C.ParamDecln+transparamdecln (Param ty name) = C.ParamDecln dspecs declr where+ dspecs = getdeclnspecs ty+ declr = execState (getdeclr ty) (identdeclr name)++transparam :: Param -> C.Decln+transparam (Param ty name) = C.Decln dspecs dlist where+ dspecs = getdeclnspecs 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 :: Type -> C.DeclnSpecs+getdeclnspecs ty = case ty of+ Type ty' -> getdeclnspecs ty'+ TypeSpec ty' -> foldtypespecs $ spec2spec ty'+ Ptr ty' -> getdeclnspecs (snd $ gettypequals ty')+ Array ty' _ -> getdeclnspecs ty'+ Const ty' -> C.DeclnSpecsQual C.QConst (Just $ getdeclnspecs ty')+ Restrict ty' -> C.DeclnSpecsQual C.QRestrict (Just $ getdeclnspecs ty')+ Volatile ty' -> C.DeclnSpecsQual C.QVolatile (Just $ getdeclnspecs ty')+++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' = fromList $ map transfielddecln declns++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+++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+++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 (InitArray es) = C.InitArray (fromList $ map transinit es)++initexpr ty init = C.PostfixInits ty' init' where+ ty' = transtypename ty+ init' = fromList $ map transinit init++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 = undefined -- TODO+++getabstractdeclr :: Type -> State C.AbstractDeclr ()+getabstractdeclr ty = case ty of+ Type ty' -> do+ getabstractdeclr ty'+ adeclr <- get+ put $ C.AbstractDeclrDirect Nothing (C.DirectAbstractDeclr adeclr)++ TypeSpec ts -> return ()++ Ptr ty' -> do+ let (quals, ty'') = gettypequals ty'+ getabstractdeclr ty''+ adeclr <- get+ let ptr = C.PtrBase quals+ put $ C.AbstractDeclrDirect (Just ptr) (C.DirectAbstractDeclr adeclr)++ Array ty' len -> do+ getabstractdeclr ty'+ declr <- get+ case declr of+ C.AbstractDeclrDirect ptr adeclr -> do+ let len' = (wrap.transexpr) <$> len+ arrdeclr = C.DirectAbstractDeclrArray1 (Just adeclr) Nothing len'+ put $ C.AbstractDeclrDirect ptr arrdeclr+ _ -> error "This should never happen, contact maintainer if it does."++ 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+
+ src/Language/C99/Simple/Util.hs view
@@ -0,0 +1,68 @@+module 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