diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/language-c99-simple.cabal b/language-c99-simple.cabal new file mode 100644 --- /dev/null +++ b/language-c99-simple.cabal @@ -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 +-- 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 diff --git a/src/Language/C99/Simple.hs b/src/Language/C99/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Language/C99/Simple.hs @@ -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 diff --git a/src/Language/C99/Simple/AST.hs b/src/Language/C99/Simple/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/C99/Simple/AST.hs @@ -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) diff --git a/src/Language/C99/Simple/Expr.hs b/src/Language/C99/Simple/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Language/C99/Simple/Expr.hs @@ -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 diff --git a/src/Language/C99/Simple/Translate.hs b/src/Language/C99/Simple/Translate.hs new file mode 100644 --- /dev/null +++ b/src/Language/C99/Simple/Translate.hs @@ -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 + diff --git a/src/Language/C99/Simple/Util.hs b/src/Language/C99/Simple/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/C99/Simple/Util.hs @@ -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