language-c-0.4.7/0000755000000000000000000000000012425376061011721 5ustar0000000000000000language-c-0.4.7/AUTHORS0000644000000000000000000000120312425376061012765 0ustar0000000000000000Benedikt Huber Manuel M T Chakravarty Duncan Coutts Bertram Felgenhauer with code contributions and patches from Iavor Diatchki Kevin Charter This project originated from the C parser component of c2hs, for many additional contributors see AUTHORS.c2hs. Special thanks for their great support, comments and suggestions to: Duncan Coutts Iavor Diatchki Don Steward language-c-0.4.7/AUTHORS.c2hs0000644000000000000000000000146712425376061013637 0ustar0000000000000000Manuel M T Chakravarty Duncan Coutts with contributions from (alphabetical order) Bertram Felgenhauer Ian Lynagh André Pang Jens-Ulrik Petersen Armin Sander Sean Seefried Udo Stenzel Axel Simon Michael Weber Thanks for comments and suggestions to Roman Leshchinskiy Jan Kort Seth Kurtzberg Simon Marlow Matthias Neubauer Sven Panne Simon L. Peyton Jones Volker Wysk language-c-0.4.7/ChangeLog0000644000000000000000000000351412425376061013476 0ustar0000000000000000Changes since 0.4.1 ========================================================================== Thu Feb 28 2013 * Fix parsing and printing of octal character escapes. Tue Jun 12 2012 * Export Annotated type class from AST module Wed Aug 24 2012 * Patch for alex-3.0 Changes 0.3.1 - 0.4.1 ========================================================================== Tue Aug 16 2011: * Port to ghc-7.2 Fr April 15 2011: Alexander Bernauer * Show instances (popular request) for AST types, DumpAst demo Changes 0.3 - 0.3.1 ========================================================================== Thu Aug 21 benedikt.huber@gmail.com * add aliases for exposed parsers, in order to document them Fri Aug 15 benedikt.huber@gmail.com * Remove NameMap from Data.Name. We will do this right when neccessary. * Parser public API: expose parsers and the Parser Monad * ParserMonad: Return updated name supply when executing parser * Parser: Expose expression, statement, declaration and file parsers * Data: Add newNameSupply ~ (namesStartingFrom 0) Thu Aug 14 17:13:29 CEST 2008 iavor.diatchki@gmail.com * Add a utility function to create a "blank" set of cpp arguments. * Make that analysis traversal monad abstract. * Export the type synonym "Register" (and bump version) Wed Aug 13 12:00:57 CEST 2008 benedikt.huber@gmail.com * add Data.Position: internalIdentAt Old Changes ========================================================================== Mon Jun 9 23:12:46 CEST 2008 benedikt.huber@gmail.com * License switched to 3-clause BSD $ - In accordance with the original authors, Language.C is now licensed as BSD-3. See: http://haskell.org/pipermail/c2hs/2008-June/000833.html http://haskell.org/pipermail/c2hs/2008-June/000834.html http://haskell.org/pipermail/c2hs/2008-June/000835.html language-c-0.4.7/language-c.cabal0000644000000000000000000000770412425376061014720 0ustar0000000000000000Name: language-c Version: 0.4.7 Cabal-Version: >= 1.6 Build-Type: Simple License: BSD3 License-File: LICENSE Copyright: LICENSE Author: AUTHORS Maintainer: benedikt.huber@gmail.com Stability: experimental Homepage: http://www.sivity.net/projects/language.c/ Bug-reports: http://www.sivity.net/projects/language.c/ Synopsis: Analysis and generation of C code Description: Language C is a haskell library for the analysis and generation of C code. It features a complete, well tested parser and pretty printer for all of C99 and a large set of GNU extensions. Category: Language Extra-Source-Files: AUTHORS AUTHORS.c2hs ChangeLog README src/Language/C/Parser/Lexer.x src/Language/C/Parser/Parser.y Source-Repository head type: darcs location: http://code.haskell.org/language-c Flag splitBase Description: Choose the new smaller, split-up base package. Flag useByteStrings Description: Use ByteString as InputStream datatype Default: True Flag separateSYB description: Data.Generics available in separate package. Library Extensions: CPP, DeriveDataTypeable, PatternGuards, BangPatterns, ExistentialQuantification, GeneralizedNewtypeDeriving, ScopedTypeVariables Build-Depends: filepath if flag(splitBase) Build-Depends: base >= 3 && < 5, process, directory, array, containers, pretty If flag(separateSYB) Build-Depends: base >=4 && <5, syb Else Build-Depends: base <4 else Build-Depends: base < 3 if flag(useByteStrings) Build-Depends: bytestring >= 0.9.0 else cpp-options: -DNO_BYTESTRING Build-Tools: happy, alex Hs-Source-Dirs: src Exposed-Modules: -- top-level Language.C -- data Language.C.Data Language.C.Data.Position Language.C.Data.Ident Language.C.Data.Error Language.C.Data.Name Language.C.Data.Node Language.C.Data.InputStream -- syntax Language.C.Syntax Language.C.Syntax.AST Language.C.Syntax.Constants Language.C.Syntax.Ops Language.C.Syntax.Utils -- parser Language.C.Parser -- pretty printer Language.C.Pretty -- system Language.C.System.Preprocess Language.C.System.GCC -- analysis [experimental] Language.C.Analysis Language.C.Analysis.ConstEval Language.C.Analysis.Builtins Language.C.Analysis.SemError Language.C.Analysis.SemRep Language.C.Analysis.DefTable Language.C.Analysis.TravMonad Language.C.Analysis.AstAnalysis Language.C.Analysis.DeclAnalysis Language.C.Analysis.Debug Language.C.Analysis.TypeCheck Language.C.Analysis.TypeConversions Language.C.Analysis.TypeUtils Language.C.Analysis.NameSpaceMap -- semrep -> code [alpha] Language.C.Analysis.Export Other-Modules: Language.C.Data.RList -- parser implementation Language.C.Parser.Builtin Language.C.Parser.Lexer Language.C.Parser.ParserMonad Language.C.Parser.Tokens Language.C.Parser.Parser language-c-0.4.7/LICENSE0000644000000000000000000000310012425376061012720 0ustar0000000000000000Copyright (c) 1999-2008 Manuel M T Chakravarty Duncan Coutts Benedikt Huber Portions Copyright (c) 1989, 1990 James A. Roskind All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. language-c-0.4.7/README0000644000000000000000000000137712425376061012611 0ustar0000000000000000= Language.C = Language.C is a parser and pretty-printer framework for C99 and the extensions of gcc. See http://www.sivity.net/projects/language.c/ == Build and Install == cabal install -- or -- runhaskell Setup.hs configure FLAGS runhaskell Setup.hs build runhaskell Setup.hs install Provide the set of flags passing --flags="" to configure. == Compatibility == Tested with ghc-7.2 (Ubuntu) and ghc-7.4 (Ubuntu). It is recommended to use the most recent platform release: http://hackage.haskell.org/platform/. == Sources == see src/README == Examples == A couple of small examples are available in /examples == Testing == A couple of regression tests can be run via > cd test/harness; make For more tests, see test/README.language-c-0.4.7/Setup.hs0000644000000000000000000000011212425376061013347 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain language-c-0.4.7/src/0000755000000000000000000000000012425376061012510 5ustar0000000000000000language-c-0.4.7/src/Language/0000755000000000000000000000000012425376061014233 5ustar0000000000000000language-c-0.4.7/src/Language/C.hs0000644000000000000000000000404212425376061014751 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.C -- Copyright : (c) 2008 Benedikt Huber -- [1995..2007] -- Manuel M. T. Chakravarty -- Duncan Coutts -- Betram Felgenhauer -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- Library for analysing and generating C code. -- -- See ----------------------------------------------------------------------------- module Language.C ( parseCFile, parseCFilePre, -- maybe change ? module Language.C.Data, module Language.C.Syntax, module Language.C.Pretty, module Language.C.Parser, ) where import Language.C.Data import Language.C.Syntax import Language.C.Pretty import Language.C.Parser import Language.C.System.Preprocess -- | preprocess (if necessary) and parse a C source file -- -- > Synopsis: parseCFile preprocesssor tmp-dir? cpp-opts file -- > Example: parseCFile (newGCC "gcc") Nothing ["-I/usr/include/gtk-2.0"] my-gtk-exts.c parseCFile :: (Preprocessor cpp) => cpp -> (Maybe FilePath) -> [String] -> FilePath -> IO (Either ParseError CTranslUnit) parseCFile cpp tmp_dir_opt args input_file = do input_stream <- if not (isPreprocessed input_file) then let cpp_args = (rawCppArgs args input_file) { cppTmpDir = tmp_dir_opt } in runPreprocessor cpp cpp_args >>= handleCppError else readInputStream input_file return$ parseC input_stream (initPos input_file) where handleCppError (Left exitCode) = fail $ "Preprocessor failed with " ++ show exitCode handleCppError (Right ok) = return ok -- | parse an already preprocessed C file -- -- > Synopsis: parseCFilePre file.i parseCFilePre :: FilePath -> IO (Either ParseError CTranslUnit) parseCFilePre file = do input_stream <- readInputStream file return $ parseC input_stream (initPos file)language-c-0.4.7/src/Language/C/0000755000000000000000000000000012425376061014415 5ustar0000000000000000language-c-0.4.7/src/Language/C/Analysis.hs0000644000000000000000000000362312425376061016540 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : alpha -- Portability : ghc -- -- Analysis of the AST. -- -- Currently, we provide a monad for analysis and analyze declarations and types. -- Especially note that there is no direct support for analyzing function bodies and -- constant expressions. -- -- /NOTE/ This is an experimental interface, and therefore the API will change in the -- future. -- -- DONE: -- -- * Name analysis framework -- -- * File-scope analysis -- -- * Declaration analysis -- -- TODO: -- -- * Type checking expressions -- -- * Constant expression evaluation (CEE) -- -- * Typed representation of attributes (depends on CEE) -- -- * Normalized representation of initializers -- -- * Support for analyzing function bodies (depends on CEE) -- -- * Normalizing expressions and statements -- -- * Formal rules how to link back to the AST using NodeInfo fields -- -- * Typed assembler representation ----------------------------------------------------------------------------- module Language.C.Analysis ( -- * Semantic representation module Language.C.Analysis.SemRep, -- * Error datatypes for the analysis module Language.C.Analysis.SemError, -- * Traversal monad module Language.C.Analysis.TravMonad, -- * Top level analysis module Language.C.Analysis.AstAnalysis, -- * Analyzing declarations module Language.C.Analysis.DeclAnalysis, -- * Debug print module Language.C.Analysis.Debug, ) where import Language.C.Analysis.SemError import Language.C.Analysis.SemRep import Language.C.Analysis.DefTable import Language.C.Analysis.TravMonad import Language.C.Analysis.AstAnalysis import Language.C.Analysis.DeclAnalysis import Language.C.Analysis.Debug language-c-0.4.7/src/Language/C/Data.hs0000644000000000000000000000247712425376061015634 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.C.Data -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- Common data types for Language.C: Identifiers, unique names, source code locations, -- ast node attributes and extensible errors. ----------------------------------------------------------------------------- module Language.C.Data ( -- * Input stream module Language.C.Data.InputStream, -- * Identifiers SUERef(..), isAnonymousRef, Ident,mkIdent, identToString, internalIdent, isInternalIdent, builtinIdent, -- * Unqiue names Name(..),newNameSupply, -- * Source code positions Position(..),Pos(..), initPos, nopos,builtinPos,internalPos, isSourcePos,isBuiltinPos,isInternalPos, -- * Syntax tree nodes NodeInfo(..),CNode(..), fileOfNode,posOfNode,nameOfNode, undefNode,mkNodeInfoOnlyPos,mkNodeInfo, internalNode, -- DEPRECATED -- * Extensible errors module Language.C.Data.Error ) where import Language.C.Data.InputStream import Language.C.Data.Ident import Language.C.Data.Name import Language.C.Data.Position import Language.C.Data.Error import Language.C.Data.Node language-c-0.4.7/src/Language/C/Parser.hs0000644000000000000000000000227312425376061016211 0ustar0000000000000000{-# OPTIONS #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Parser -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- Language.C parser ----------------------------------------------------------------------------- module Language.C.Parser ( -- * Simple API parseC, -- * Parser Monad P,execParser,execParser_,builtinTypeNames, -- * Exposed Parsers translUnitP, extDeclP, statementP, expressionP, -- * Parser Monad ParseError(..) ) where import Language.C.Parser.Parser (parseC,translUnitP, extDeclP, statementP, expressionP) import Language.C.Parser.ParserMonad (execParser, ParseError(..),P) import Language.C.Parser.Builtin (builtinTypeNames) import Language.C.Data -- | run the given parser using a new name supply and builtin typedefs -- see 'execParser' -- -- Synopsis: @runParser parser inputStream initialPos@ execParser_ :: P a -> InputStream -> Position -> Either ParseError a execParser_ parser input pos = fmap fst $ execParser parser input pos builtinTypeNames newNameSupply language-c-0.4.7/src/Language/C/Pretty.hs0000644000000000000000000005423112425376061016245 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Pretty -- Copyright : Copyright (c) 2007 Bertram Felgenhauer -- (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : portable -- -- This module provides a pretty printer for the parse tree -- ('Language.C.Syntax.AST'). ----------------------------------------------------------------------------- module Language.C.Pretty ( -- * Pretty Printing Pretty (..), -- * Testing prettyUsingInclude ) where import Data.List (partition,nub,isSuffixOf) import qualified Data.Set as Set import Text.PrettyPrint.HughesPJ import Debug.Trace {- for warnings -} import Language.C.Data import Language.C.Syntax -- | A class of types which can be pretty printed class Pretty p where -- | pretty print the given value pretty :: p -> Doc -- | @prettyPrec prec p@ pretty prints p assuming -- that the surrounding context has a precedence of -- @prec@ prettyPrec :: Int -> p -> Doc pretty = prettyPrec 0 prettyPrec _ = pretty -- pretty print optional chunk maybeP :: (p -> Doc) -> Maybe p -> Doc maybeP = maybe empty -- pretty print when flag is true ifP :: Bool -> Doc -> Doc ifP flag doc = if flag then doc else empty -- pretty print _optional_ list, i.e. [] ~ Nothing and (x:xs) ~ Just (x:xs) mlistP :: ([p] -> Doc) -> [p] -> Doc mlistP pp xs = maybeP pp (if null xs then Nothing else Just xs) -- pretty print identifier identP :: Ident -> Doc identP = text . identToString -- pretty print attribute annotations attrlistP :: [CAttr] -> Doc attrlistP [] = empty attrlistP attrs = text "__attribute__" <> parens (parens (hcat . punctuate comma . map pretty $ attrs)) -- analogous to showParen parenPrec :: Int -> Int -> Doc -> Doc parenPrec prec prec2 t = if prec <= prec2 then t else parens t -- indent a chunk of code ii :: Doc -> Doc ii = nest 4 -- Pretty instances instance Pretty CTranslUnit where pretty (CTranslUnit edecls _) = vcat (map pretty edecls) -- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives. -- -- The resulting file may not compile (because of missing @#define@ directives and similar things), but is very useful -- for testing, as otherwise the pretty printed file will be cluttered with declarations from system headers. prettyUsingInclude :: CTranslUnit -> Doc prettyUsingInclude (CTranslUnit edecls _) = includeWarning headerFiles $$ (vcat $ map (either includeHeader pretty) mappedDecls) where (headerFiles,mappedDecls) = foldr addDecl (Set.empty,[]) $ map tagIncludedDecls edecls tagIncludedDecls edecl | maybe False isHeaderFile (fileOfNode edecl) = Left ((posFile . posOf) edecl) | otherwise = Right edecl addDecl decl@(Left headerRef) (headerSet, ds) | Set.member headerRef headerSet = (headerSet, ds) | otherwise = (Set.insert headerRef headerSet, decl : ds) addDecl decl (headerSet,ds) = (headerSet, decl : ds) includeHeader hFile = text "#include" <+> doubleQuotes (text hFile) isHeaderFile = (".h" `isSuffixOf`) includeWarning hs | Set.null hs = empty | otherwise = text "/* Warning: The #include directives in this file aren't necessarily correct. */" -- TODO: Check need of __extension__ instance Pretty CExtDecl where pretty (CDeclExt decl) = pretty decl <> semi pretty (CFDefExt fund) = pretty fund pretty (CAsmExt asmStmt _) = text "asm" <> parens (pretty asmStmt) <> semi -- TODO: Check that old-style and new-style aren't mixed instance Pretty CFunDef where pretty (CFunDef declspecs declr decls stat _) = -- Example: hsep (map pretty declspecs) -- __attribute__((noreturn)) static long <+> pretty declr -- foo(b) $+$ (ii . vcat . map (<> semi) . map pretty) decls -- register long b; $$ prettyPrec (-1) stat -- { ... -- } instance Pretty CStat where pretty (CLabel ident stat cattrs _) = identP ident <> text ":" <+> attrlistP cattrs $$ pretty stat pretty (CCase expr stat _) = text "case" <+> pretty expr <> text ":" $$ pretty stat pretty (CCases expr1 expr2 stat _) = text "case" <+> pretty expr1 <+> text "..." <+> pretty expr2 <> text ":" $$ pretty stat pretty (CDefault stat _) = text "default:" $$ pretty stat pretty (CExpr expr _) = ii $ maybeP pretty expr <> semi pretty c@(CCompound _ _ _) = prettyPrec 0 c pretty (CIf expr stat estat _) = ii $ text "if" <+> parens (pretty expr) $+$ prettyBody stat $$ maybeP prettyElse estat where prettyBody c@(CCompound _ _ _) = prettyPrec (-1) c prettyBody nonCompound = prettyPrec (-1) (CCompound [] [CBlockStmt nonCompound] undefined) prettyElse (CIf else_if_expr else_if_stat else_stat _) = text "else if" <+> parens (pretty else_if_expr) $+$ prettyBody else_if_stat $$ maybeP prettyElse else_stat prettyElse else_stmt = text "else" $+$ prettyBody else_stmt pretty (CSwitch expr stat _) = ii $ text "switch" <+> text "(" <> pretty expr <> text ")" $+$ prettyPrec (-1) stat pretty (CWhile expr stat False _) = ii $ text "while" <+> text "(" <> pretty expr <> text ")" $+$ prettyPrec (-1) stat pretty (CWhile expr stat True _) = ii $ text "do" $+$ prettyPrec (-1) stat $$ text "while" <+> text "(" <> pretty expr <> text ");" pretty (CFor for_init cond step stat _) = ii $ text "for" <+> text "(" <> either (maybeP pretty) pretty for_init <> semi <+> maybeP pretty cond <> semi <+> maybeP pretty step <> text ")" $+$ prettyPrec (-1) stat pretty (CGoto ident _) = ii $ text "goto" <+> identP ident <> semi pretty (CGotoPtr expr _) = ii $ text "goto" <+> text "*" <+> prettyPrec 30 expr <> semi pretty (CCont _) = ii $ text "continue" <> semi pretty (CBreak _) = ii $ text "break" <> semi pretty (CReturn Nothing _) = ii $ text "return" <> semi pretty (CReturn (Just e) _) = ii $ text "return" <+> pretty e <> semi pretty (CAsm asmStmt _) = pretty asmStmt prettyPrec p (CCompound localLabels bis _) = let inner = text "{" $+$ mlistP ppLblDecls localLabels $+$ vcat (map pretty bis) $$ text "}" in if p == -1 then inner else ii inner where ppLblDecls = vcat . map (\l -> text "__label__" <+> identP l <+> semi) prettyPrec _ p = pretty p instance Pretty CAsmStmt where pretty (CAsmStmt tyQual expr outOps inOps clobbers _) = ii $ text "__asm__" <+> maybeP pretty tyQual <> parens asmStmt <> semi where asmStmt = pretty expr <+> (if all null [inOps,outOps] && null clobbers then empty else ops) ops = text ":" <+> hcat (punctuate comma (map pretty outOps)) <+> text ":" <+> hcat (punctuate comma (map pretty inOps)) <+> (if null clobbers then empty else clobs) clobs = text ":" <+> hcat (punctuate comma (map pretty clobbers)) instance Pretty CAsmOperand where -- asm_operand :~ [operand-name] "constraint" ( expr ) pretty (CAsmOperand mArgName cnstr expr _) = maybeP (\argName -> text "[" <> identP argName <> text "]") mArgName <+> pretty cnstr <+> parens (pretty expr) -- TODO: Check need of __extension__ instance Pretty CBlockItem where pretty (CBlockStmt stat) = pretty stat pretty (CBlockDecl decl) = ii $ pretty decl <> semi pretty (CNestedFunDef fundef) = ii $ pretty fundef instance Pretty CDecl where -- CAVEAT: -- we may not print __attribute__s directly after typespecs, -- as this may change the semantics of the declaration. -- The parser fixes this, but to avoid hard-to-track code generator -- errors, we enforce this invariant on the AST level. pretty (CDecl specs divs _) = hsep (map pretty checked_specs) <+> hsep (punctuate comma (map p divs)) where -- possible hint for AST improvement - (declr, initializer, expr, attrs) -- currently there are no sensible attributes for unnamed bitfields though p (declr, initializer, expr) = maybeP (prettyDeclr False 0) declr <+> maybeP ((text ":" <+>) . pretty) expr <+> attrlistP (getAttrs declr) <+> maybeP ((text "=" <+>) . pretty) initializer checked_specs = case any isAttrAfterSUE (zip specs (tail specs)) of True -> trace ("Warning: AST Invariant violated: __attribute__ specifier following struct/union/enum:"++ (show $ map pretty specs)) specs False -> specs isAttrAfterSUE (CTypeSpec ty,CTypeQual (CAttrQual _)) = isSUEDef ty isAttrAfterSUE _ = False getAttrs Nothing = [] getAttrs (Just (CDeclr _ _ _ cattrs _)) = cattrs instance Pretty CDeclSpec where pretty (CStorageSpec sp) = pretty sp pretty (CTypeSpec sp) = pretty sp pretty (CTypeQual qu) = pretty qu instance Pretty CStorageSpec where pretty (CAuto _) = text "auto" pretty (CRegister _) = text "register" pretty (CStatic _) = text "static" pretty (CExtern _) = text "extern" pretty (CTypedef _) = text "typedef" pretty (CThread _) = text "__thread" instance Pretty CTypeSpec where pretty (CVoidType _) = text "void" pretty (CCharType _) = text "char" pretty (CShortType _) = text "short" pretty (CIntType _) = text "int" pretty (CLongType _) = text "long" pretty (CFloatType _) = text "float" pretty (CDoubleType _) = text "double" pretty (CSignedType _) = text "signed" pretty (CUnsigType _) = text "unsigned" pretty (CBoolType _) = text "_Bool" pretty (CComplexType _) = text "_Complex" pretty (CSUType union _) = pretty union pretty (CEnumType enum _) = pretty enum pretty (CTypeDef ident _) = identP ident pretty (CTypeOfExpr expr _) = text "typeof" <> text "(" <> pretty expr <> text ")" pretty (CTypeOfType decl _) = text "typeof" <> text "(" <> pretty decl <> text ")" instance Pretty CTypeQual where pretty (CConstQual _) = text "const" pretty (CVolatQual _) = text "volatile" pretty (CRestrQual _) = text "__restrict" pretty (CInlineQual _) = text "inline" pretty (CAttrQual a) = attrlistP [a] instance Pretty CStructUnion where pretty (CStruct tag ident Nothing cattrs _) = pretty tag <+> attrlistP cattrs <+> maybeP identP ident pretty (CStruct tag ident (Just []) cattrs _) = pretty tag <+> attrlistP cattrs <+> maybeP identP ident <+> text "{ }" pretty (CStruct tag ident (Just decls) cattrs _) = vcat [ pretty tag <+> attrlistP cattrs <+> maybeP identP ident <+> text "{", ii $ sep (map (<> semi) (map pretty decls)), text "}"] instance Pretty CStructTag where pretty CStructTag = text "struct" pretty CUnionTag = text "union" instance Pretty CEnum where pretty (CEnum enum_ident Nothing cattrs _) = text "enum" <+> attrlistP cattrs <+> maybeP identP enum_ident pretty (CEnum enum_ident (Just vals) cattrs _) = vcat [ text "enum" <+> attrlistP cattrs <+> maybeP identP enum_ident <+> text "{", ii $ sep (punctuate comma (map p vals)), text "}"] where p (ident, expr) = identP ident <+> maybeP ((text "=" <+>) . pretty) expr -- Analyze a declarator and return a human-readable description -- See C99 Spec p 115ff. -- describeDeclr :: CDeclr -> Doc -- describeDeclr declr = -- let declrs = reverse (declrChain declr) in -- endDescr (foldl descrDeclr undefined declrs) -- -- where -- declrChain declr@(CVarDeclr _ _ _ _) = [declr] -- declrChain declr@(CPtrDeclr _ ideclr _) = declr : declrChain ideclr -- declrChain declr@(CArrDeclr ideclr _ _ _) = declr : declrChain ideclr -- declrChain declr@(CFunDeclr ideclr _ _ _) = declr : declrChain ideclr -- -- descrDeclr _ (CVarDeclr ident asm cattrs _) = single False $ \_ -> -- maybe (text "") identP ident <+> -- maybeP (\asmname -> parens (text "asm:" <+> pretty asmname)) asm <+> -- text "is" <+> (if null cattrs then empty else prettyList (map CAttrQual cattrs) <> comma) -- descrDeclr (pre,isPlural) (CPtrDeclr quals declr _) = single isPlural $ \pluralize -> -- pre <+> indefArticle isPlural <> prettyList quals <+> pluralize "pointer to" "pointers to" -- descrDeclr (pre,isPlural) (CArrDeclr declr quals expr _) = plural isPlural $ \pluralize -> -- pre <+> indefArticle' isPlural <> prettyList quals <+> pluralize "array of" "arrays of" -- descrDeclr (pre,isPlural) (CFunDeclr declr params cattrs _) = single isPlural $ \pluralize -> -- pre <+> indefArticle isPlural <> prettyList (map CAttrQual cattrs) <+> pluralize "function returning" "functions returning" -- endDescr (pre, isPlural) = pre <+> text (if isPlural then "" else "a ") -- single :: Bool -> ( (String -> String -> Doc) -> a ) -> (a, Bool) -- single isPlural mkDescr = (mkDescr (pluralize isPlural), isPlural) -- plural :: Bool -> ( (String -> String -> Doc) -> a ) -> (a, Bool) -- plural isPlural mkDescr = (mkDescr (pluralize isPlural), True) -- indefArticle isPlural = text$ if isPlural then "" else "a " -- indefArticle' isPlural = text$ if isPlural then "" else "an " -- pluralize isPlural s p = text (if isPlural then p else s) -- prettyList :: (Pretty a) => [a] -> Doc -- prettyList = hsep . punctuate comma . map pretty instance Pretty CDeclr where prettyPrec prec declr = prettyDeclr True prec declr prettyDeclr :: Bool -> Int -> CDeclr -> Doc prettyDeclr show_attrs prec (CDeclr name derived_declrs asmname cattrs _) = ppDeclr prec (reverse derived_declrs) <+> prettyAsmName asmname <+> ifP show_attrs (attrlistP cattrs) where ppDeclr _ [] = maybeP identP name --'*' __attribute__? qualifiers declarator ppDeclr p (CPtrDeclr quals _ : declrs) = parenPrec p 5 $ text "*" <+> hsep (map pretty quals) <+> ppDeclr 5 declrs -- declarator[ __attribute__? qualifiers expr ] ppDeclr p (CArrDeclr quals size _ : declrs) = parenPrec p 6 $ ppDeclr 6 declrs <> brackets (hsep (map pretty quals) <+> pretty size) -- declarator ( arguments ) -- or (__attribute__ declarator) (arguments) ppDeclr _ (CFunDeclr params fun_attrs _ : declrs) = (if not (null fun_attrs) then parens (attrlistP fun_attrs <+> ppDeclr 5 declrs) else ppDeclr 6 declrs) <> parens (prettyParams params) prettyParams (Right (decls, isVariadic)) = sep (punctuate comma (map pretty decls)) <> (if isVariadic then text "," <+> text "..." else empty) prettyParams (Left oldStyleIds) = hsep (punctuate comma (map identP oldStyleIds)) prettyAsmName asm_name_opt = maybe empty (\asm_name -> text "__asm__" <> parens (pretty asm_name)) asm_name_opt instance Pretty CArrSize where pretty (CNoArrSize completeType) = ifP completeType (text "*") pretty (CArrSize staticMod expr) = ifP staticMod (text "static") <+> pretty expr -- initializer :: { CInit } -- initializer :- assignment_expression -- | '{' (designation? initializer)_cs_list '}' instance Pretty CInit where pretty (CInitExpr expr _) = pretty expr pretty (CInitList initl _) = text "{" <+> hsep (punctuate comma (map p initl)) <+> text "}" where p ([], initializer) = pretty initializer p (desigs, initializer) = hsep (map pretty desigs) <+> text "=" <+> pretty initializer -- designation :- designator_list '=' -- | array_range_designator -- arr_designator :- '[' constant_expression ']' -- member_designator :- '.' identifier -- arr_range _designator :- '[' constant_expression "..." constant_expression ']' instance Pretty CDesignator where pretty (CArrDesig expr _) = text "[" <> pretty expr <> text "]" pretty (CMemberDesig ident _) = text "." <> identP ident pretty (CRangeDesig expr1 expr2 _) = text "[" <> pretty expr1 <+> text "..." <+> pretty expr2 <> text "]" instance Pretty CAttr where pretty (CAttr attrName [] _) = identP attrName pretty (CAttr attrName attrParams _) = identP attrName <> parens (hsep . punctuate comma . map pretty $ attrParams) instance Pretty CExpr where prettyPrec p (CComma exprs _) = parenPrec p (-1) $ hsep (punctuate comma (map (prettyPrec 2) exprs)) prettyPrec p (CAssign op expr1 expr2 _) = parenPrec p 2 $ prettyPrec 3 expr1 <+> pretty op <+> prettyPrec 2 expr2 prettyPrec p (CCond expr1 expr2 expr3 _) = parenPrec p 2 $ prettyPrec 4 expr1 <+> text "?" -- NB: assignment only has a higher precedence if cond is on the rhs <+> maybeP pretty expr2 <+> text ":" <+> prettyPrec 4 expr3 prettyPrec p (CBinary op expr1 expr2 _) = let prec = binPrec op in parenPrec p prec $ prettyPrec prec expr1 <+> pretty op <+> prettyPrec (prec + 1) expr2 prettyPrec p (CCast decl expr _) = parenPrec p 25 $ text "(" <> pretty decl <> text ")" <+> prettyPrec 25 expr prettyPrec p (CUnary CPostIncOp expr _) = parenPrec p 26 $ prettyPrec 26 expr <> text "++" prettyPrec p (CUnary CPostDecOp expr _) = parenPrec p 26 $ prettyPrec 26 expr <> text "--" prettyPrec p (CUnary op expr@(CUnary _ _ _) _) = -- parens aren't necessary, but look nicer imho parenPrec p 25 $ pretty op <+> parens (prettyPrec 25 expr) prettyPrec p (CUnary op expr _) = parenPrec p 25 $ pretty op <> prettyPrec 25 expr prettyPrec p (CSizeofExpr expr _) = parenPrec p 25 $ text "sizeof" <> parens (pretty expr) prettyPrec p (CSizeofType decl _) = parenPrec p 25 $ text "sizeof" <> parens (pretty decl) prettyPrec p (CAlignofExpr expr _) = parenPrec p 25 $ text "__alignof" <> parens (pretty expr) prettyPrec p (CAlignofType decl _) = parenPrec p 25 $ text "__alignof" <> parens (pretty decl) prettyPrec p (CComplexReal expr _) = parenPrec p 25 $ text "__real" <+> prettyPrec 25 expr prettyPrec p (CComplexImag expr _) = parenPrec p 25 $ text "__imag" <+> prettyPrec 25 expr prettyPrec p (CIndex expr1 expr2 _) = parenPrec p 26 $ prettyPrec 26 expr1 <> text "[" <> pretty expr2 <> text "]" prettyPrec p (CCall expr args _) = parenPrec p 30 $ prettyPrec 30 expr <> text "(" <> (sep . punctuate comma . map pretty) args <> text ")" prettyPrec p (CMember expr ident deref _) = parenPrec p 26 $ prettyPrec 26 expr <> text (if deref then "->" else ".") <> identP ident prettyPrec _p (CVar ident _) = identP ident prettyPrec _p (CConst constant) = pretty constant prettyPrec _p (CCompoundLit decl initl _) = parens (pretty decl) <+> (braces . hsep . punctuate comma) (map p initl) where p ([], initializer) = pretty initializer p (mems, initializer) = hcat (punctuate (text ".") (map pretty mems)) <+> text "=" <+> pretty initializer prettyPrec _p (CStatExpr stat _) = text "(" <> pretty stat <> text ")" -- unary_expr :- && ident {- address of label -} prettyPrec _p (CLabAddrExpr ident _) = text "&&" <> identP ident prettyPrec _p (CBuiltinExpr builtin) = pretty builtin instance Pretty CBuiltin where pretty (CBuiltinVaArg expr ty_name _) = text "__builtin_va_arg" <+> (parens $ pretty expr <> comma <+> pretty ty_name) -- The first desig has to be a member field. pretty (CBuiltinOffsetOf ty_name (CMemberDesig field1 _ : desigs) _) = text "__builtin_offsetof" <+> (parens $ pretty ty_name <> comma <+> identP field1 <> hcat (map pretty desigs) ) pretty (CBuiltinOffsetOf _ty_name otherDesigs _) = error $ "Inconsistent AST: Cannot interpret designators in offsetOf: "++ show (hcat$ map pretty otherDesigs) pretty (CBuiltinTypesCompatible ty1 ty2 _) = text "__builtin_types_compatible_p" <+> (parens $ pretty ty1 <> comma <+> pretty ty2) instance Pretty CAssignOp where pretty op = text $ case op of CAssignOp -> "=" CMulAssOp -> "*=" CDivAssOp -> "/=" CRmdAssOp -> "%=" CAddAssOp -> "+=" CSubAssOp -> "-=" CShlAssOp -> "<<=" CShrAssOp -> ">>=" CAndAssOp -> "&=" CXorAssOp -> "^=" COrAssOp -> "|=" instance Pretty CBinaryOp where pretty op = text $ case op of CMulOp -> "*" CDivOp -> "/" CRmdOp -> "%" CAddOp -> "+" CSubOp -> "-" CShlOp -> "<<" CShrOp -> ">>" CLeOp -> "<" CGrOp -> ">" CLeqOp -> "<=" CGeqOp -> ">=" CEqOp -> "==" CNeqOp -> "!=" CAndOp -> "&" CXorOp -> "^" COrOp -> "|" CLndOp -> "&&" CLorOp -> "||" instance Pretty CUnaryOp where pretty op = text $ case op of CPreIncOp -> "++" CPreDecOp -> "--" CPostIncOp -> "++" CPostDecOp -> "--" CAdrOp -> "&" CIndOp -> "*" CPlusOp -> "+" CMinOp -> "-" CCompOp -> "~" CNegOp -> "!" instance Pretty CConst where pretty (CIntConst int_const _) = text (show int_const) pretty (CCharConst chr _) = text (show chr) pretty (CFloatConst flt _) = text (show flt) pretty (CStrConst str _) = text (show str) instance Pretty CStrLit where pretty (CStrLit str _) = text (show str) -- precedence of C operators binPrec :: CBinaryOp -> Int binPrec CMulOp = 20 binPrec CDivOp = 20 binPrec CRmdOp = 20 binPrec CAddOp = 19 binPrec CSubOp = 19 binPrec CShlOp = 18 binPrec CShrOp = 18 binPrec CLeOp = 17 binPrec CGrOp = 17 binPrec CLeqOp = 17 binPrec CGeqOp = 17 binPrec CEqOp = 16 binPrec CNeqOp = 16 binPrec CAndOp = 15 binPrec CXorOp = 14 binPrec COrOp = 13 binPrec CLndOp = 12 binPrec CLorOp = 11 language-c-0.4.7/src/Language/C/Syntax.hs0000644000000000000000000000120212425376061016232 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.C.Syntax -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- Syntax of C files: The abstract syntax tree and constants. ----------------------------------------------------------------------------- module Language.C.Syntax ( -- * Constants module Language.C.Syntax.Constants, -- * Syntax tree module Language.C.Syntax.AST, ) where import Language.C.Syntax.AST import Language.C.Syntax.Constants language-c-0.4.7/src/Language/C/Analysis/0000755000000000000000000000000012425376061016200 5ustar0000000000000000language-c-0.4.7/src/Language/C/Analysis/AstAnalysis.hs0000644000000000000000000007625512425376061021006 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Parser.Translation -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : alpha -- Portability : ghc -- -- Analyse the parse tree -- -- Traverses the AST, analyses declarations and invokes handlers. ----------------------------------------------------------------------------- module Language.C.Analysis.AstAnalysis ( -- * Top-level analysis analyseAST, analyseExt,analyseFunDef,analyseDecl, -- * Building blocks for additional analyses analyseFunctionBody, defineParams, -- * Type checking tExpr, ExprSide(..), tStmt, StmtCtx(..), tDesignator, defaultMD ) where import Language.C.Analysis.SemError import Language.C.Analysis.SemRep import Language.C.Analysis.TravMonad import Language.C.Analysis.ConstEval import Language.C.Analysis.Debug import Language.C.Analysis.DefTable (DefTable, globalDefs, defineScopedIdent, defineLabel, inFileScope, lookupTag, lookupLabel, insertType, lookupType) import Language.C.Analysis.DeclAnalysis import Language.C.Analysis.TypeUtils import Language.C.Analysis.TypeCheck import Language.C.Analysis.TypeConversions import Language.C.Data import Language.C.Pretty import Language.C.Syntax.AST import Language.C.Syntax.Constants import Language.C.Syntax.Ops import Language.C.Syntax.Utils import Text.PrettyPrint.HughesPJ import Control.Monad import Prelude hiding (reverse) import Data.Either (rights) import Data.Foldable (foldrM) import Data.List hiding (reverse) import qualified Data.Map as Map import Data.Maybe -- * analysis -- | Analyse the given AST -- -- @analyseAST ast@ results in global declaration dictionaries. -- If you want to perform specific actions on declarations or definitions, you may provide -- callbacks in the @MonadTrav@ @m@. -- -- Returns the set of global declarations and definitions which where successfully translated. -- It is the users responsibility to check whether any hard errors occurred (@runTrav@ does this for you). analyseAST :: (MonadTrav m) => CTranslUnit -> m GlobalDecls analyseAST (CTranslUnit decls _file_node) = do -- analyse all declarations, but recover from errors mapRecoverM_ analyseExt decls -- check we are in global scope afterwards getDefTable >>= \dt -> when (not (inFileScope dt)) $ error "Internal Error: Not in filescope after analysis" -- get the global definition table (XXX: remove ?) liftM globalDefs getDefTable where mapRecoverM_ f = mapM_ (handleTravError . f) -- | Analyse an top-level declaration analyseExt :: (MonadTrav m) => CExtDecl -> m () analyseExt (CAsmExt asm _) = handleAsmBlock asm analyseExt (CFDefExt fundef) = analyseFunDef fundef analyseExt (CDeclExt decl) = analyseDecl False decl -- | Analyse a function definition analyseFunDef :: (MonadTrav m) => CFunDef -> m () analyseFunDef (CFunDef declspecs declr oldstyle_decls stmt node_info) = do -- analyse the declarator var_decl_info <- analyseVarDecl' True declspecs declr oldstyle_decls Nothing let (VarDeclInfo name is_inline storage_spec attrs ty declr_node) = var_decl_info when (isNoName name) $ astError node_info "NoName in analyseFunDef" let ident = identOfVarName name -- improve incomplete type ty' <- improveFunDefType ty -- compute storage fun_storage <- computeFunDefStorage ident storage_spec let var_decl = VarDecl name (DeclAttrs is_inline fun_storage attrs) ty' -- callback for declaration handleVarDecl False (Decl var_decl node_info) -- process body stmt' <- analyseFunctionBody node_info var_decl stmt -- callback for definition handleFunDef ident (FunDef var_decl stmt' node_info) where improveFunDefType (FunctionType (FunTypeIncomplete return_ty) attrs) = return $ FunctionType (FunType return_ty [] False) attrs improveFunDefType ty = return $ ty -- | Analyse a declaration other than a function definition analyseDecl :: (MonadTrav m) => Bool -> CDecl -> m () analyseDecl is_local decl@(CDecl declspecs declrs node) | null declrs = case typedef_spec of Just _ -> astError node "bad typedef declaration: missing declarator" Nothing -> analyseTypeDecl decl >> return () | (Just declspecs') <- typedef_spec = mapM_ (uncurry (analyseTyDef declspecs')) declr_list | otherwise = do let (storage_specs, attrs, typequals, typespecs, inline) = partitionDeclSpecs declspecs canonTySpecs <- canonicalTypeSpec typespecs let specs = (storage_specs, attrs, typequals, canonTySpecs, inline) mapM_ (uncurry (analyseVarDeclr specs)) declr_list where declr_list = zip (True : repeat False) declrs typedef_spec = hasTypeDef declspecs analyseTyDef declspecs' handle_sue_def declr = case declr of (Just tydeclr, Nothing , Nothing) -> analyseTypeDef handle_sue_def declspecs' tydeclr node _ -> astError node "bad typdef declaration: bitfieldsize or initializer present" analyseVarDeclr specs handle_sue_def (Just declr, init_opt, Nothing) = do -- analyse the declarator let (storage_specs, attrs, typequals, canonTySpecs, inline) = specs vardeclInfo@(VarDeclInfo _ _ _ _ typ _) <- analyseVarDecl handle_sue_def storage_specs attrs typequals canonTySpecs inline declr [] Nothing -- declare / define the object if (isFunctionType typ) then extFunProto vardeclInfo else (if is_local then localVarDecl else extVarDecl) -- XXX: if Initializer becomes different from CInit, this -- will have to change. vardeclInfo init_opt init_opt' <- mapMaybeM init_opt (tInit typ) return () analyseVarDeclr _ _ (Nothing,_,_) = astError node "abstract declarator in object declaration" analyseVarDeclr _ _ (_,_,Just bitfieldSz) = astError node "bitfield size in object declaration" -- | Analyse a typedef analyseTypeDef :: (MonadTrav m) => Bool -> [CDeclSpec] -> CDeclr -> NodeInfo -> m () analyseTypeDef handle_sue_def declspecs declr node_info = do -- analyse the declarator (VarDeclInfo name is_inline storage_spec attrs ty declr_node) <- analyseVarDecl' handle_sue_def declspecs declr [] Nothing checkValidTypeDef is_inline storage_spec attrs when (isNoName name) $ astError node_info "NoName in analyseTypeDef" let ident = identOfVarName name handleTypeDef (TypeDef ident ty attrs node_info) where checkValidTypeDef True _ _ = astError node_info "inline specifier for typeDef" checkValidTypeDef _ NoStorageSpec _ = return () checkValidTypeDef _ bad_storage _ = astError node_info $ "storage specified for typeDef: " ++ show bad_storage -- | compute storage of a function definition -- -- a function definition has static storage with internal linkage if specified `static`, -- the previously declared linkage if any if 'extern' or no specifier are present. (See C99 6.2.2, clause 5) -- -- This function won't raise an Trav error if the declaration is incompatible with the existing one, -- this case is handled in 'handleFunDef'. computeFunDefStorage :: (MonadTrav m) => Ident -> StorageSpec -> m Storage computeFunDefStorage _ (StaticSpec b) = return$ FunLinkage InternalLinkage computeFunDefStorage ident other_spec = do obj_opt <- lookupObject ident let defaultSpec = FunLinkage ExternalLinkage case other_spec of NoStorageSpec -> return$ maybe defaultSpec declStorage obj_opt (ExternSpec False) -> return$ maybe defaultSpec declStorage obj_opt bad_spec -> throwTravError $ badSpecifierError (nodeInfo ident) $ "unexpected function storage specifier (only static or extern is allowed)" ++ show bad_spec -- (private) Get parameters of a function type getParams :: Type -> Maybe [ParamDecl] getParams (FunctionType (FunType _ params _) _) = Just params getParams _ = Nothing -- | handle a function prototype extFunProto :: (MonadTrav m) => VarDeclInfo -> m () extFunProto (VarDeclInfo var_name is_inline storage_spec attrs ty node_info) = do when (isNoName var_name) $ astError node_info "NoName in extFunProto" old_fun <- lookupObject (identOfVarName var_name) checkValidSpecs let decl = VarDecl var_name (DeclAttrs is_inline (funDeclLinkage old_fun) attrs) ty handleVarDecl False (Decl decl node_info) -- XXX: structs should be handled in 'function prototype scope' too enterPrototypeScope maybe (return ()) (mapM_ handleParamDecl) (getParams ty) leavePrototypeScope where funDeclLinkage old_fun = case storage_spec of NoStorageSpec -> FunLinkage ExternalLinkage -- prototype declaration / external linkage StaticSpec False -> FunLinkage InternalLinkage -- prototype declaration / internal linkage ExternSpec False -> case old_fun of Nothing -> FunLinkage ExternalLinkage Just f -> declStorage f _ -> error $ "funDeclLinkage: " ++ show storage_spec checkValidSpecs | hasThreadLocalSpec storage_spec = astError node_info "thread local storage specified for function" | RegSpec <- storage_spec = astError node_info "invalid `register' storage specified for function" | otherwise = return () -- | handle a object declaration \/ definition -- -- We have to check the storage specifiers here, as they determine wheter we're dealing with decalartions -- or definitions -- see [http://www.sivity.net/projects/language.c/wiki/ExternalDefinitions] extVarDecl :: (MonadTrav m) => VarDeclInfo -> (Maybe Initializer) -> m () extVarDecl (VarDeclInfo var_name is_inline storage_spec attrs typ node_info) init_opt = do when (isNoName var_name) $ astError node_info "NoName in extVarDecl" (storage,is_def) <- globalStorage storage_spec let vardecl = VarDecl var_name (DeclAttrs is_inline storage attrs) typ if is_def then handleObjectDef False ident $ ObjDef vardecl init_opt node_info else handleVarDecl False $ Decl vardecl node_info where ident = identOfVarName var_name globalStorage _ | is_inline = astError node_info "invalid `inline' specifier external variable" globalStorage RegSpec = do when (isJust init_opt) $ astError node_info "initializer given for global register variable" case var_name of NoName -> astError node_info "global register variable has no name" VarName _ Nothing -> astError node_info "no register specified for global register variable" _ -> return () dt <- getDefTable when (hasFunDef dt) $ astError node_info "global register variable appears after a function definition" return (Static InternalLinkage False, False) -- tentative if there is no initializer, external globalStorage NoStorageSpec = return $ (Static ExternalLinkage False, True) -- tentative if there is no initializer, internal globalStorage (StaticSpec thread_local) = return $ (Static InternalLinkage thread_local, True) globalStorage (ExternSpec thread_local) = case init_opt of -- declaration with either external or old storage Nothing -> do old_decl <- lookupObject ident return $ (maybe (Static ExternalLinkage thread_local) declStorage old_decl,False) -- warning, external definition Just _ -> do warn $ badSpecifierError node_info "Both initializer and `extern` specifier given - treating as definition" return $ (Static ExternalLinkage thread_local, True) hasFunDef dt = any (isFuncDef . snd) (Map.toList $ gObjs $ globalDefs dt) isFuncDef (FunctionDef fd) = not $ isInline $ declAttrs fd isFuncDef _ = False isInline (DeclAttrs inl _ _) = inl -- | handle a function-scope object declaration \/ definition -- see [http://www.sivity.net/projects/language.c/wiki/LocalDefinitions] localVarDecl :: (MonadTrav m) => VarDeclInfo -> (Maybe Initializer) -> m () localVarDecl (VarDeclInfo var_name is_inline storage_spec attrs typ node_info) init_opt = do when (isNoName var_name) $ astError node_info "NoName in localVarDecl" (storage,is_def) <- localStorage storage_spec let vardecl = VarDecl var_name (DeclAttrs is_inline storage attrs) typ if is_def then handleObjectDef True ident (ObjDef vardecl init_opt node_info) else handleVarDecl True (Decl vardecl node_info) where ident = identOfVarName var_name localStorage _ | is_inline = astError node_info "invalid `inline' specifier for local variable" localStorage NoStorageSpec = return $ (Auto False,True) localStorage RegSpec = return $ (Auto True,True) -- static no linkage localStorage (StaticSpec thread_local) = return $ (Static NoLinkage thread_local,True) localStorage (ExternSpec thread_local) | isJust init_opt = astError node_info "extern keyword and initializer for local" | otherwise = do old_decl <- lookupObject ident return (maybe (Static ExternalLinkage thread_local) declStorage old_decl,False) localStorage s = astError node_info "bad storage specifier for local" defineParams :: MonadTrav m => NodeInfo -> VarDecl -> m () defineParams ni decl = case (getParams $ declType decl) of Nothing -> astError ni "expecting complete function type in function definition" Just params -> mapM_ handleParamDecl params analyseFunctionBody :: (MonadTrav m) => NodeInfo -> VarDecl -> CStat -> m Stmt analyseFunctionBody node_info decl s@(CCompound localLabels items _) = do enterFunctionScope mapM_ (withDefTable . defineLabel) (localLabels ++ getLabels s) defineParams node_info decl -- record parameters mapM_ (tBlockItem [FunCtx decl]) items leaveFunctionScope return s -- XXX: bogus analyseFunctionBody _ _ s = astError (nodeInfo s) "Function body is no compound statement" data StmtCtx = FunCtx VarDecl | LoopCtx | SwitchCtx -- | Given a context, determine the type declaration for the enclosing -- function, if possible, given a context. enclosingFunctionType :: [StmtCtx] -> Maybe Type enclosingFunctionType [] = Nothing enclosingFunctionType (FunCtx vd : _) = Just $ declType vd enclosingFunctionType (_ : cs) = enclosingFunctionType cs inLoop :: [StmtCtx] -> Bool inLoop c = any isLoop c where isLoop LoopCtx = True isLoop _ = False inSwitch :: [StmtCtx] -> Bool inSwitch c = any isSwitch c where isSwitch SwitchCtx = True isSwitch _ = False data ExprSide = LValue | RValue deriving (Eq, Show) -- | Typecheck a statement, given a statement context. The type of a -- statement is usually @void@, but expression statements and blocks -- can sometimes have other types. tStmt :: MonadTrav m => [StmtCtx] -> CStat -> m Type tStmt c (CLabel _ s _ _) = tStmt c s tStmt c (CExpr e _) = maybe (return voidType) (tExpr c RValue) e tStmt c (CCompound ls body _) = do enterBlockScope mapM_ (withDefTable . defineLabel) ls t <- foldM (const $ tBlockItem c) voidType body leaveBlockScope return t tStmt c (CIf e sthen selse _) = checkGuard c e >> tStmt c sthen >> maybe (return ()) (\s -> tStmt c s >> return ()) selse >> return voidType tStmt c (CSwitch e s ni) = tExpr c RValue e >>= checkIntegral' ni >> tStmt (SwitchCtx : c) s tStmt c (CWhile e s _ _) = checkGuard c e >> tStmt (LoopCtx : c) s tStmt _ (CGoto l ni) = do dt <- getDefTable case lookupLabel l dt of Just _ -> return voidType Nothing -> typeError ni $ "undefined label in goto: " ++ identToString l tStmt c (CCont ni) = do unless (inLoop c) $ astError ni "continue statement outside of loop" return voidType tStmt c (CBreak ni) = do unless (inLoop c || inSwitch c) $ astError ni "break statement outside of loop or switch statement" return voidType tStmt c (CReturn (Just e) ni) = do t <- tExpr c RValue e rt <- case enclosingFunctionType c of Just (FunctionType (FunType rt _ _) _) -> return rt Just (FunctionType (FunTypeIncomplete rt) _) -> return rt Just ft -> astError ni $ "bad function type: " ++ pType ft Nothing -> astError ni "return statement outside function" case (rt, t) of -- apparently it's ok to return void from a void function? (DirectType TyVoid _ _, DirectType TyVoid _ _) -> return () _ -> assignCompatible' ni CAssignOp rt t return voidType tStmt _ (CReturn Nothing _) = return voidType -- XXX: anything to do for assembly? tStmt _ (CAsm _ _) = return voidType tStmt c (CCase e s ni) = do unless (inSwitch c) $ astError ni "case statement outside of switch statement" tExpr c RValue e >>= checkIntegral' ni tStmt c s tStmt c (CCases e1 e2 s ni) = do unless (inSwitch c) $ astError ni "case statement outside of switch statement" tExpr c RValue e1 >>= checkIntegral' ni tExpr c RValue e2 >>= checkIntegral' ni tStmt c s tStmt c (CDefault s ni) = do unless (inSwitch c) $ astError ni "default statement outside of switch statement" tStmt c s tStmt c (CFor i g inc s _) = do enterBlockScope either (maybe (return ()) checkExpr) (analyseDecl True) i maybe (return ()) (checkGuard c) g maybe (return ()) checkExpr inc tStmt (LoopCtx : c) s leaveBlockScope return voidType where checkExpr e = tExpr c RValue e >> return () tStmt c (CGotoPtr e ni) = do t <- tExpr c RValue e case t of (PtrType _ _ _) -> return voidType _ -> typeError ni "can't goto non-pointer" -- | Typecheck a block item. When statement expressions are blocks, -- they have the type of their last expression statement, so this -- needs to return a type. tBlockItem :: MonadTrav m => [StmtCtx] -> CBlockItem -> m Type tBlockItem c (CBlockStmt s) = tStmt c s tBlockItem _ (CBlockDecl d) = analyseDecl True d >> return voidType -- TODO: fixup analyseFunDef to handle nested functions tBlockItem _ (CNestedFunDef fd) = analyseFunDef fd >> return voidType checkGuard :: MonadTrav m => [StmtCtx] -> CExpr -> m () checkGuard c e = tExpr c RValue e >>= checkScalar' (nodeInfo e) -- XXX: this is bogus, correct only for IA32. We should eventually -- have a collection of these and allow people to choose one. defaultMD :: MachineDesc defaultMD = MachineDesc { iSize = \it -> case it of TyBool -> 1 TyChar -> 1 TySChar -> 1 TyUChar -> 1 TyShort -> 2 TyUShort -> 2 TyInt -> 4 TyUInt -> 4 TyLong -> 4 TyULong -> 4 TyLLong -> 8 TyULLong -> 8 , fSize = \ft -> case ft of TyFloat -> 4 TyDouble -> 8 TyLDouble -> 16 , builtinSize = \bt -> case bt of TyVaList -> 4 TyAny -> 4 , ptrSize = 4 , voidSize = 1 , iAlign = \it -> case it of TyBool -> 1 TyChar -> 1 TySChar -> 1 TyUChar -> 1 TyShort -> 2 TyUShort -> 2 TyInt -> 4 TyUInt -> 4 TyLong -> 4 TyULong -> 4 TyLLong -> 8 TyULLong -> 8 , fAlign = \ft -> case ft of TyFloat -> 4 TyDouble -> 8 TyLDouble -> 16 , builtinAlign = \bt -> case bt of TyVaList -> 4 TyAny -> 4 , ptrAlign = 4 , voidAlign = 1 } tExpr :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type tExpr c side e = case nameOfNode (nodeInfo e) of Just n -> do dt <- getDefTable case lookupType dt n of Just t -> return t Nothing -> do t <- tExpr' c side e withDefTable (\dt -> (t, insertType dt n t)) Nothing -> tExpr' c side e -- | Typecheck an expression, with information about whether it -- appears as an lvalue or an rvalue. tExpr' :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type tExpr' c side (CBinary op le re ni) = do when (side == LValue) $ typeError ni "binary operator as lvalue" lt <- tExpr c RValue le rt <- tExpr c RValue re binopType' ni op lt rt tExpr' c side (CUnary CAdrOp e ni) = do when (side == LValue) $ typeError ni "address-of operator as lvalue" case e of CCompoundLit _ _ _ -> simplePtr `liftM` tExpr c RValue e CVar i _ -> lookupObject i >>= typeErrorOnLeft ni . maybe (notFound i) varAddrType _ -> simplePtr `liftM` tExpr c LValue e tExpr' c _ (CUnary CIndOp e ni) = tExpr c RValue e >>= (typeErrorOnLeft ni . derefType) tExpr' c _ (CUnary CCompOp e ni) = do t <- tExpr c RValue e checkIntegral' ni t return t tExpr' c side (CUnary CNegOp e ni) = do when (side == LValue) $ typeError ni "logical negation used as lvalue" tExpr c RValue e >>= checkScalar' ni return boolType tExpr' c side (CUnary op e _) = tExpr c (if isEffectfulOp op then LValue else side) e tExpr' c _ (CIndex b i ni) = do bt <- tExpr c RValue b it <- tExpr c RValue i addrTy <- binopType' ni CAddOp bt it typeErrorOnLeft ni $ derefType addrTy tExpr' c side (CCond e1 me2 e3 ni) = do t1 <- tExpr c RValue e1 checkScalar' (nodeInfo e1) t1 t3 <- tExpr c side e3 case me2 of Just e2 -> do t2 <- tExpr c side e2 conditionalType' ni t2 t3 Nothing -> conditionalType' ni t1 t3 tExpr' c side (CMember e m deref ni) = do t <- tExpr c RValue e bt <- if deref then typeErrorOnLeft ni (derefType t) else return t fieldType ni m bt tExpr' c side (CComma es _) = mapM (tExpr c side) es >>= return . last tExpr' c side (CCast d e ni) = do dt <- analyseTypeDecl d et <- tExpr c side e typeErrorOnLeft ni $ castCompatible dt et return dt tExpr' c side (CSizeofExpr e ni) = do when (side == LValue) $ typeError ni "sizeof as lvalue" tExpr c RValue e return size_tType tExpr' c side (CAlignofExpr e ni) = do when (side == LValue) $ typeError ni "alignof as lvalue" tExpr c RValue e return size_tType tExpr' c side (CComplexReal e ni) = complexBaseType ni c side e tExpr' c side (CComplexImag e ni) = complexBaseType ni c side e tExpr' _ side (CLabAddrExpr _ ni) = do when (side == LValue) $ typeError ni "label address as lvalue" return $ PtrType voidType noTypeQuals [] tExpr' _ side (CCompoundLit d initList ni) = do when (side == LValue) $ typeError ni "compound literal as lvalue" lt <- analyseTypeDecl d tInitList ni (canonicalType lt) initList return lt tExpr' _ RValue (CAlignofType _ _) = return size_tType tExpr' _ RValue (CSizeofType _ _) = return size_tType tExpr' _ LValue (CAlignofType _ ni) = typeError ni "alignoftype as lvalue" tExpr' _ LValue (CSizeofType _ ni) = typeError ni "sizeoftype as lvalue" tExpr' _ side (CVar i ni) = lookupObject i >>= maybe (typeErrorOnLeft ni $ notFound i) (return . declType) tExpr' _ _ (CConst c) = constType c tExpr' _ _ (CBuiltinExpr b) = builtinType b tExpr' c side (CCall (CVar i _) args ni) | identToString i == "__builtin_choose_expr" = case args of [g, e1, e2] -> -- XXX: the MachineDesc parameter below should be configurable do b <- constEval defaultMD Map.empty g case boolValue b of Just True -> tExpr c side e1 Just False -> tExpr c side e2 Nothing -> astError ni "non-constant argument to __builtin_choose_expr" _ -> astError ni "wrong number of arguments to __builtin_choose_expr" tExpr' c _ (CCall fe args ni) = do let defType = FunctionType (FunTypeIncomplete (DirectType (TyIntegral TyInt) noTypeQuals noAttributes)) noAttributes fallback i = do warn $ invalidAST ni $ "unknown function: " ++ identToString i return defType t <- case fe of CVar i _ -> lookupObject i >>= maybe (fallback i) (const $ tExpr c RValue fe) _ -> tExpr c RValue fe atys <- mapM (tExpr c RValue) args -- XXX: we don't actually want to return the canonical return type here case canonicalType t of PtrType (FunctionType (FunType rt pdecls varargs) _) _ _ -> do let ptys = map declType pdecls mapM_ checkArg $ zip3 ptys atys args unless varargs $ when (length atys /= length ptys) $ typeError ni "incorrect number of arguments" return $ canonicalType rt PtrType (FunctionType (FunTypeIncomplete rt) _) _ _ -> do -- warn $ invalidAST ni "incomplete function type" return $ canonicalType rt _ -> typeError ni $ "attempt to call non-function of type " ++ pType t where checkArg (pty, aty, arg) = do attrs <- deepTypeAttrs pty case isTransparentUnion attrs of True -> case canonicalType pty of DirectType (TyComp ctr) _ _ -> do td <- lookupSUE (nodeInfo arg) (sueRef ctr) ms <- tagMembers (nodeInfo arg) td {- when (null $ rights $ matches ms) $ astError (nodeInfo arg) $ "argument matches none of the elements " ++ "of transparent union" -} return () where matches = map (\d -> assignCompatible CAssignOp (snd d) aty ) _ -> astError (nodeInfo arg) "non-composite has __transparent_union__ attribute" False -> assignCompatible' (nodeInfo arg) CAssignOp pty aty isTransparentUnion = any (\(Attr n _ _) -> identToString n == "__transparent_union__") tExpr' c _ (CAssign op le re ni) = do lt <- tExpr c LValue le rt <- tExpr c RValue re when (constant $ typeQuals lt) $ typeError ni $ "assignment to lvalue with `constant' qualifier: " ++ (render . pretty) le case (canonicalType lt, re) of (lt', CConst (CIntConst i _)) | isPointerType lt' && getCInteger i == 0 -> return () (_, _) -> assignCompatible' ni op lt rt return lt tExpr' c _ (CStatExpr s _) = do enterBlockScope mapM_ (withDefTable . defineLabel) (getLabels s) t <- tStmt c s leaveBlockScope return t tInitList :: MonadTrav m => NodeInfo -> Type -> CInitList -> m () tInitList ni t@(ArrayType (DirectType (TyIntegral TyChar) _ _) _ _ _) [([], CInitExpr e@(CConst (CStrConst _ _)) _)] = tExpr [] RValue e >> return () tInitList ni t@(ArrayType _ _ _ _) initList = do let default_ds = repeat (CArrDesig (CConst (CIntConst (cInteger 0) ni)) ni) checkInits t default_ds initList tInitList ni t@(DirectType (TyComp ctr) _ _) initList = do td <- lookupSUE ni (sueRef ctr) ms <- tagMembers ni td let default_ds = map (\m -> CMemberDesig (fst m) ni) ms checkInits t default_ds initList tInitList ni (PtrType (DirectType TyVoid _ _) _ _ ) _ = return () -- XXX: more checking tInitList _ t [([], i)] = tInit t i >> return () tInitList ni t _ = typeError ni $ "initializer list for type: " ++ pType t checkInits :: MonadTrav m => Type -> [CDesignator] -> CInitList -> m () checkInits _ _ [] = return () checkInits t dds ((ds, i) : is) = do (dds', ds') <- case (dds, ds) of ([], []) -> typeError (nodeInfo i) "excess elements in initializer" (dd' : rest, []) -> return (rest, [dd']) (_, d : _) -> return (advanceDesigList dds d, ds) t' <- tDesignator t ds' tInit t' i checkInits t dds' is advanceDesigList :: [CDesignator] -> CDesignator -> [CDesignator] advanceDesigList ds d = drop 1 $ dropWhile (not . matchDesignator d) ds matchDesignator :: CDesignator -> CDesignator -> Bool matchDesignator (CMemberDesig m1 _) (CMemberDesig m2 _) = m1 == m2 matchDesignator _ _ = True -- XXX: for now, array ranges aren't checked tDesignator :: MonadTrav m => Type -> [CDesignator] -> m Type -- XXX: check that initializers are within array size tDesignator (ArrayType bt _ _ _) (CArrDesig e ni : ds) = do tExpr [] RValue e >>= checkIntegral' ni tDesignator bt ds tDesignator (ArrayType bt _ _ _) (CRangeDesig e1 e2 ni : ds) = do tExpr [] RValue e1 >>= checkIntegral' ni tExpr [] RValue e2 >>= checkIntegral' ni tDesignator bt ds tDesignator (ArrayType _ _ _ _) (d : ds) = typeError (nodeInfo d) "member designator in array initializer" tDesignator t@(DirectType (TyComp _) _ _) (CMemberDesig m ni : ds) = do mt <- fieldType ni m t tDesignator (canonicalType mt) ds tDesignator t@(DirectType (TyComp _) _ _) (d : _) = typeError (nodeInfo d) "array designator in compound initializer" tDesignator t [] = return t tInit :: MonadTrav m => Type -> CInit -> m Initializer tInit t i@(CInitExpr e ni) = do it <- tExpr [] RValue e assignCompatible' ni CAssignOp t it return i tInit t i@(CInitList initList ni) = tInitList ni (canonicalType t) initList >> return i complexBaseType :: MonadTrav m => NodeInfo -> [StmtCtx] -> ExprSide -> CExpr -> m Type complexBaseType ni c side e = do t <- tExpr c side e case canonicalType t of DirectType (TyComplex ft) quals attrs -> return $ DirectType (TyFloating ft) quals attrs _ -> typeError ni $ "expected complex type, got: " ++ pType t -- | Return the type of a builtin. builtinType :: MonadTrav m => CBuiltin -> m Type builtinType (CBuiltinVaArg _ d _) = analyseTypeDecl d builtinType (CBuiltinOffsetOf _ _ _) = return size_tType builtinType (CBuiltinTypesCompatible _ _ _) = return boolType -- return @Just declspecs@ without @CTypedef@ if the declaration specifier contain @typedef@ hasTypeDef :: [CDeclSpec] -> Maybe [CDeclSpec] hasTypeDef declspecs = case foldr hasTypeDefSpec (False,[]) declspecs of (True,specs') -> Just specs' (False,_) -> Nothing where hasTypeDefSpec (CStorageSpec (CTypedef n)) (_,specs) = (True, specs) hasTypeDefSpec spec (b,specs) = (b,spec:specs) language-c-0.4.7/src/Language/C/Analysis/AstAnalysis.hs-boot0000644000000000000000000000050412425376061021727 0ustar0000000000000000module Language.C.Analysis.AstAnalysis where import Language.C.Analysis.SemRep import Language.C.Analysis.TravMonad import Language.C.Syntax.AST data StmtCtx = FunCtx VarDecl | LoopCtx | SwitchCtx data ExprSide = LValue | RValue tExpr :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type language-c-0.4.7/src/Language/C/Analysis/Builtins.hs0000644000000000000000000002431612425376061020333 0ustar0000000000000000module Language.C.Analysis.Builtins (builtins) where import Language.C.Data.Ident import Language.C.Data.Node import Language.C.Analysis.DefTable import Language.C.Analysis.SemRep import Language.C.Analysis.TypeUtils builtins :: DefTable builtins = foldr doIdent (foldr doTypeDef emptyDefTable typedefs) idents where doTypeDef d = snd . defineTypeDef (identOfTypeDef d) d doIdent d = snd . defineGlobalIdent (declIdent d) d dName s = VarName (builtinIdent s) Nothing param ty = ParamDecl (VarDecl NoName (DeclAttrs False (Auto False) []) ty) undefNode fnAttrs = DeclAttrs False (FunLinkage ExternalLinkage) [] varAttrs = DeclAttrs False (Static InternalLinkage False) [] fnType r as = FunctionType (FunType r (map param as) False) noAttributes fnType' r as = FunctionType (FunType r (map param as) True) noAttributes func n r as = Declaration (Decl (VarDecl (dName n) fnAttrs (fnType r as)) undefNode) func' n r as = Declaration (Decl (VarDecl (dName n) fnAttrs (fnType' r as)) undefNode) var n t = Declaration (Decl (VarDecl (dName n) varAttrs t) undefNode) typedef n t = TypeDef (builtinIdent n) t [] undefNode typedefs = [ typedef "__builtin_va_list" valistType ] idents = [ func "__builtin_expect" (integral TyLong) [integral TyLong, integral TyLong] , func "__builtin_fabs" (floating TyDouble) [floating TyDouble] , func "__builtin_fabsf" (floating TyFloat) [floating TyFloat] , func "__builtin_fabsl" (floating TyLDouble) [floating TyLDouble] , func "__builtin_inf" (floating TyDouble) [] , func "__builtin_inff" (floating TyFloat) [] , func "__builtin_infl" (floating TyLDouble) [] , func "__builtin_huge_val" (floating TyDouble) [] , func "__builtin_huge_valf" (floating TyFloat) [] , func "__builtin_huge_vall" (floating TyLDouble) [] , func "__builtin_copysign" (floating TyDouble) [ floating TyDouble, floating TyDouble ] , func "__builtin_va_start" voidType [ valistType , voidPtr ] , func "__builtin_va_end" voidType [valistType] , func "__builtin_va_copy" voidType [ valistType, valistType ] , func "__builtin_va_arg_pack" (integral TyInt) [] , func "__builtin_va_arg_pack_len" (integral TyInt) [] , func "__builtin_alloca" voidPtr [ size_tType ] , func "__builtin_memcpy" voidPtr [ voidPtr , constVoidPtr , size_tType ] , func "__builtin_strspn" size_tType [ constCharPtr, constCharPtr ] , func "__builtin_strcspn" size_tType [ constCharPtr, constCharPtr ] , func "__builtin_strchr" charPtr [ constCharPtr, integral TyInt] , func "__builtin_strncpy" charPtr [ constCharPtr -- XXX: restrict , constCharPtr -- XXX: restrict , size_tType ] , func "__builtin_strncat" charPtr [ constCharPtr -- XXX: restrict , constCharPtr -- XXX: restrict , size_tType ] , func "__builtin_strcmp" (integral TyInt) [ constCharPtr, constCharPtr ] , func "__builtin_strpbrk" charPtr [ constCharPtr, constCharPtr ] , func "__builtin_bzero" voidType [ voidPtr, size_tType ] , func "__builtin_clz" (integral TyInt) [ integral TyUInt ] , func "__builtin_constant_p" (integral TyInt) [DirectType (TyBuiltin TyAny) noTypeQuals noAttributes] -- XXX: I don't know if the following has the -- correct type. It doesn't seem to be -- documented. , func "__builtin_extract_return_addr" voidPtr [ voidPtr ] , func "__builtin_return_address" voidPtr [ integral TyUInt ] , func "__builtin_frame_address" voidPtr [ integral TyUInt ] , func "__builtin_expect" (integral TyLong) [ integral TyLong, integral TyLong ] , func "__builtin_prefetch" voidType [ constVoidPtr ] , var "__func__" stringType , var "__PRETTY_FUNCTION__" stringType , var "__FUNCTION__" stringType -- Builtin GCC error checking functions , func "__builtin_object_size" size_tType [ voidPtr, integral TyInt ] , func "__builtin___memcpy_chk" voidPtr [ voidPtr, constVoidPtr, size_tType, size_tType ] , func "__builtin___mempcpy_chk" voidPtr [ voidPtr, constVoidPtr, size_tType, size_tType ] , func "__builtin___memmove_chk" voidPtr [ voidPtr, constVoidPtr, size_tType, size_tType ] , func "__builtin___memset_chk" voidPtr [ voidPtr, integral TyInt, size_tType, size_tType ] , func "__builtin___strcpy_chk" charPtr [ constCharPtr -- XXX: restrict , constCharPtr -- XXX: restrict , size_tType ] , func "__builtin___stpcpy_chk" charPtr [ constCharPtr -- XXX: restrict , constCharPtr -- XXX: restrict , size_tType ] , func "__builtin___strncpy_chk" charPtr [ constCharPtr -- XXX: restrict , constCharPtr -- XXX: restrict , size_tType , size_tType ] , func "__builtin___strcat_chk" charPtr [ constCharPtr -- XXX: restrict , constCharPtr -- XXX: restrict , size_tType ] , func "__builtin___strncat_chk" charPtr [ constCharPtr -- XXX: restrict , constCharPtr -- XXX: restrict , size_tType , size_tType ] , func' "__builtin___sprintf_chk" (integral TyInt) [ charPtr , integral TyInt , size_tType , constCharPtr ] , func' "__builtin___snprintf_chk" (integral TyInt) [ charPtr , size_tType , integral TyInt , size_tType , constCharPtr ] , func "__builtin___vsprintf_chk" (integral TyInt) [ charPtr , integral TyInt , size_tType , constCharPtr , valistType ] , func "__builtin___vsnprintf_chk" (integral TyInt) [ charPtr , size_tType , integral TyInt , size_tType , constCharPtr , valistType ] ] language-c-0.4.7/src/Language/C/Analysis/ConstEval.hs0000644000000000000000000002064012425376061020434 0ustar0000000000000000{-# LANGUAGE RelaxedPolyRec #-} module Language.C.Analysis.ConstEval where import Control.Monad import Data.Bits import Data.Maybe import qualified Data.Map as Map import Language.C.Syntax.AST import Language.C.Syntax.Constants import {-# SOURCE #-} Language.C.Analysis.AstAnalysis (tExpr, ExprSide(..)) import Language.C.Analysis.Debug import Language.C.Analysis.DeclAnalysis import Language.C.Analysis.DefTable import Language.C.Data import Language.C.Pretty import Language.C.Analysis.SemRep import Language.C.Analysis.TravMonad import Language.C.Analysis.TypeUtils import Text.PrettyPrint.HughesPJ data MachineDesc = MachineDesc { iSize :: IntType -> Integer , fSize :: FloatType -> Integer , builtinSize :: BuiltinType -> Integer , ptrSize :: Integer , voidSize :: Integer , iAlign :: IntType -> Integer , fAlign :: FloatType -> Integer , builtinAlign :: BuiltinType -> Integer , ptrAlign :: Integer , voidAlign :: Integer } intExpr :: (Pos n, MonadName m) => n -> Integer -> m CExpr intExpr n i = genName >>= \name -> return $ CConst $ CIntConst (cInteger i) (mkNodeInfo (posOf n) name) sizeofType :: (MonadTrav m, CNode n) => MachineDesc -> n -> Type -> m Integer sizeofType md _ (DirectType TyVoid _ _) = return $ voidSize md sizeofType md _ (DirectType (TyIntegral it) _ _) = return $ iSize md it sizeofType md _ (DirectType (TyFloating ft) _ _) = return $ fSize md ft sizeofType md _ (DirectType (TyComplex ft) _ _) = return $ 2 * fSize md ft sizeofType md _ (DirectType (TyComp ctr) _ _) = compSize md ctr sizeofType md _ (DirectType (TyEnum _) _ _) = return $ iSize md TyInt sizeofType md _ (DirectType (TyBuiltin b) _ _) = return $ builtinSize md b sizeofType md _ (PtrType _ _ _) = return $ ptrSize md sizeofType md n (ArrayType bt (UnknownArraySize _) _ _) = return $ ptrSize md sizeofType md n (ArrayType bt (ArraySize _ sz) _ _) = do sz' <- constEval md Map.empty sz case sz' of CConst (CIntConst i _) -> do s <- sizeofType md n bt return $ getCInteger i * s _ -> return $ ptrSize md {- astError (nodeInfo sz) $ "array size is not a constant: " ++ (render . pretty) sz -} sizeofType md n (TypeDefType (TypeDefRef _ (Just t) _) _ _) = sizeofType md n t sizeofType md _ (FunctionType _ _) = return $ ptrSize md sizeofType _ n t = astError (nodeInfo n) $ "can't find size of type: " ++ (render . pretty) t alignofType :: (MonadTrav m, CNode n) => MachineDesc -> n -> Type -> m Integer alignofType md _ (DirectType TyVoid _ _) = return $ voidAlign md alignofType md _ (DirectType (TyIntegral it) _ _) = return $ iAlign md it alignofType md _ (DirectType (TyFloating ft) _ _) = return $ fAlign md ft alignofType md _ (DirectType (TyComplex ft) _ _) = return $ fAlign md ft alignofType md _ (DirectType (TyEnum _) _ _) = return $ iAlign md TyInt alignofType md _ (DirectType (TyBuiltin b) _ _) = return $ builtinAlign md b alignofType md _ (PtrType _ _ _) = return $ ptrAlign md alignofType md n (ArrayType bt (UnknownArraySize _) _ _) = return $ ptrAlign md alignofType md n (ArrayType bt (ArraySize _ sz) _ _) = alignofType md n bt alignofType md n (TypeDefType (TypeDefRef _ (Just t) _) _ _) = alignofType md n t alignofType _ n t = astError (nodeInfo n) $ "can't find alignment of type: " ++ (render . pretty) t compSize :: MonadTrav m => MachineDesc -> CompTypeRef -> m Integer compSize md ctr = do dt <- getDefTable case lookupTag (sueRef ctr) dt of Just (Left _) -> astError (nodeInfo ctr) "composite declared but not defined" Just (Right (CompDef (CompType _ tag ms _ ni))) -> do let ts = map declType ms sizes <- mapM (sizeofType md ni) ts -- XXX: handle padding case tag of StructTag -> return $ sum sizes UnionTag -> return $ maximum sizes Just (Right (EnumDef _)) -> return $ iSize md TyInt Nothing -> astError (nodeInfo ctr) "unknown composite" {- Expression evaluation -} -- Use the withWordBytes function to wrap the results around to the -- correct word size intOp :: CBinaryOp -> Integer -> Integer -> Integer intOp CAddOp i1 i2 = i1 + i2 intOp CSubOp i1 i2 = i1 - i2 intOp CMulOp i1 i2 = i1 * i2 intOp CDivOp i1 i2 = i1 `div` i2 intOp CRmdOp i1 i2 = i1 `mod` i2 intOp CShlOp i1 i2 = i1 `shiftL` fromInteger i2 intOp CShrOp i1 i2 = i1 `shiftR` fromInteger i2 intOp CLeOp i1 i2 = toInteger $ fromEnum $ i1 < i2 intOp CGrOp i1 i2 = toInteger $ fromEnum $ i1 > i2 intOp CLeqOp i1 i2 = toInteger $ fromEnum $ i1 <= i2 intOp CGeqOp i1 i2 = toInteger $ fromEnum $ i1 >= i2 intOp CEqOp i1 i2 = toInteger $ fromEnum $ i1 == i2 intOp CNeqOp i1 i2 = toInteger $ fromEnum $ i1 /= i2 intOp CAndOp i1 i2 = i1 .&. i2 intOp CXorOp i1 i2 = i1 `xor` i2 intOp COrOp i1 i2 = i1 .|. i2 intOp CLndOp i1 i2 = toInteger $ fromEnum $ (i1 /= 0) && (i2 /= 0) intOp CLorOp i1 i2 = toInteger $ fromEnum $ (i1 /= 0) || (i2 /= 0) -- Use the withWordBytes function to wrap the results around to the -- correct word size intUnOp :: CUnaryOp -> Integer -> Maybe Integer intUnOp CPlusOp i = Just i intUnOp CMinOp i = Just $ -i intUnOp CCompOp i = Just $ complement i intUnOp CNegOp i = Just $ toInteger $ fromEnum $ i == 0 intUnOp _ _ = Nothing withWordBytes :: Int -> Integer -> Integer withWordBytes bytes n = n `rem` (1 `shiftL` (bytes `shiftL` 3)) boolValue :: CExpr -> Maybe Bool boolValue (CConst (CIntConst i _)) = Just $ getCInteger i /= 0 boolValue (CConst (CCharConst c _)) = Just $ getCCharAsInt c /= 0 boolValue (CConst (CStrConst _ _)) = Just True boolValue _ = Nothing intValue :: CExpr -> Maybe Integer intValue (CConst (CIntConst i _)) = Just $ getCInteger i intValue (CConst (CCharConst c _)) = Just $ getCCharAsInt c intValue _ = Nothing constEval :: (MonadTrav m) => MachineDesc -> Map.Map Ident CExpr -> CExpr -> m CExpr constEval md env (CCond e1 me2 e3 ni) = do e1' <- constEval md env e1 me2' <- maybe (return Nothing) (\e -> Just `liftM` constEval md env e) me2 e3' <- constEval md env e3 case boolValue e1' of Just True -> return $ fromMaybe e1' me2' Just False -> return e3' Nothing -> return $ CCond e1' me2' e3' ni constEval md env e@(CBinary op e1 e2 ni) = do e1' <- constEval md env e1 e2' <- constEval md env e2 t <- tExpr [] RValue e bytes <- fromIntegral `liftM` sizeofType md e t case (intValue e1', intValue e2') of (Just i1, Just i2) -> intExpr ni (withWordBytes bytes (intOp op i1 i2)) (_, _) -> return $ CBinary op e1' e2' ni constEval md env (CUnary op e ni) = do e' <- constEval md env e t <- tExpr [] RValue e bytes <- fromIntegral `liftM` sizeofType md e t case intValue e' of Just i -> case intUnOp op i of Just i' -> intExpr ni (withWordBytes bytes i') Nothing -> astError ni "invalid unary operator applied to constant" Nothing -> return $ CUnary op e' ni constEval md env (CCast d e ni) = do e' <- constEval md env e t <- analyseTypeDecl d bytes <- fromIntegral `liftM` sizeofType md d t case intValue e' of Just i -> intExpr ni (withWordBytes bytes i) Nothing -> return $ CCast d e' ni constEval md _ (CSizeofExpr e ni) = do t <- tExpr [] RValue e sz <- sizeofType md e t intExpr ni sz constEval md _ (CSizeofType d ni) = do t <- analyseTypeDecl d sz <- sizeofType md d t intExpr ni sz constEval md _ (CAlignofExpr e ni) = do t <- tExpr [] RValue e sz <- alignofType md e t intExpr ni sz constEval md _ (CAlignofType d ni) = do t <- analyseTypeDecl d sz <- alignofType md d t intExpr ni sz constEval md env e@(CVar i _) | Map.member i env = return $ fromMaybe e $ Map.lookup i env constEval md env e@(CVar i _) = do t <- tExpr [] RValue e case derefTypeDef t of DirectType (TyEnum etr) _ _ -> do dt <- getDefTable case lookupTag (sueRef etr) dt of Just (Right (EnumDef (EnumType _ es _ _))) -> do env' <- foldM enumConst env es return $ fromMaybe e $ Map.lookup i env' _ -> return e _ -> return e where enumConst env' (Enumerator n e' _ _) = do c <- constEval md env' e' return $ Map.insert n c env' constEval _ _ e = return e language-c-0.4.7/src/Language/C/Analysis/Debug.hs0000644000000000000000000001744012425376061017570 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# OPTIONS -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis.Debug -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : prototype -- Portability : ghc -- -- Pretty printing the semantic analysis representation. -- This is currently only intended for debugging purposes. ----------------------------------------------------------------------------- module Language.C.Analysis.Debug ( globalDeclStats, prettyAssocs, prettyAssocsWith, -- and many pretty instances ) where import Language.C.Analysis.SemRep import Language.C.Analysis.Export import Language.C.Analysis.DefTable import Language.C.Analysis.NameSpaceMap import Language.C.Data import Language.C.Pretty import Language.C.Syntax import Text.PrettyPrint.HughesPJ import Data.Map (Map) ; import qualified Data.Map as Map prettyAssocs :: (Pretty k, Pretty v) => String -> [(k,v)] -> Doc prettyAssocs label = prettyAssocsWith label pretty pretty prettyAssocsWith :: String -> (k -> Doc) -> (v -> Doc) -> [(k,v)] -> Doc prettyAssocsWith label prettyKey prettyVal theMap = text label $$ (nest 8) (vcat $ map prettyEntry theMap) where prettyEntry (k,v) = prettyKey k <+> text " ~> " <+> prettyVal v instance Pretty DefTable where pretty dt = text "DefTable" $$ (nest 4 $ vcat defMaps) where defMaps = [ prettyNSMap "idents" identDecls , prettyNSMap "tags" tagDecls , prettyNSMap "labels" labelDefs , prettyNSMap "members" memberDecls ] prettyNSMap label f = prettyAssocs label . nsMapToList $ f dt instance Pretty GlobalDecls where pretty gd = text "Global Declarations" $$ (nest 4 $ vcat declMaps) where declMaps = [ prettyMap "enumerators" theEnums, prettyMap "declarations" theDecls, prettyMap "objects" theObjs, prettyMap "functions" theFuns, prettyMap "tags" $ gTags gd, prettyMap "typeDefs" $ gTypeDefs gd ] prettyMap :: (Pretty t, Pretty k) => String -> Map k t -> Doc prettyMap label = prettyAssocs label . Map.assocs (theDecls, (theEnums, theObjs, theFuns)) = splitIdentDecls False (gObjs gd) globalDeclStats :: (FilePath -> Bool) -> GlobalDecls -> [(String,Int)] globalDeclStats file_filter gmap = [ ("Enumeration Constants",Map.size enumerators), ("Total Object/Function Declarations",Map.size all_decls), ("Object definitions", Map.size objDefs), ("Function Definitions", Map.size funDefs), ("Tag definitions", Map.size tagDefs), ("TypeDefs", Map.size typeDefs) ] where gmap' = filterGlobalDecls filterFile gmap (all_decls,(enumerators,objDefs,funDefs)) = splitIdentDecls True (gObjs gmap') (tagDefs,typeDefs) = (gTags gmap', gTypeDefs gmap') filterFile :: (CNode n) => n -> Bool filterFile = maybe True file_filter . fileOfNode . nodeInfo instance (Pretty a, Pretty b) => Pretty (Either a b) where pretty = either pretty pretty instance Pretty TagFwdDecl where pretty (CompDecl ct) = pretty ct pretty (EnumDecl et) = pretty et instance Pretty CompTyKind where pretty StructTag = text "struct" pretty UnionTag = text "union" instance Pretty CompTypeRef where pretty (CompTypeRef sue kind _) = pretty kind <+> pretty sue instance Pretty EnumTypeRef where pretty (EnumTypeRef sue _ ) = text "enum" <+> pretty sue instance Pretty Ident where pretty = text . identToString instance Pretty SUERef where pretty (AnonymousRef name) = text $ "$" ++ show (nameId name) pretty (NamedRef ident) = pretty ident instance Pretty TagDef where pretty (CompDef compty) = pretty compty pretty (EnumDef enumty) = pretty enumty instance Pretty IdentDecl where pretty (Declaration decl) = pretty decl pretty (ObjectDef odef) = pretty odef pretty (FunctionDef fdef) = pretty fdef pretty (EnumeratorDef enumerator) = pretty enumerator instance Pretty Decl where pretty (Decl vardecl _) = text "declaration" <+> pretty vardecl instance Pretty TypeDef where pretty (TypeDef ident ty attrs _) = text "typedef" <+> pretty ident <+> text "as" <+> pretty attrs <+> pretty ty instance Pretty ObjDef where pretty (ObjDef vardecl init_opt _) = text "object" <+> pretty vardecl <+> maybe empty (((text "=") <+>) . pretty) init_opt instance Pretty FunDef where pretty (FunDef vardecl _stmt _) = text "function" <+> pretty vardecl instance Pretty VarDecl where pretty (VarDecl name attrs ty) = ((hsep . punctuate (text " |")) [pretty name, pretty attrs, pretty ty]) instance Pretty ParamDecl where pretty (ParamDecl (VarDecl name declattrs ty) _) = pretty declattrs <+> pretty name <+> text "::" <+> pretty ty pretty (AbstractParamDecl (VarDecl name declattrs ty) _) = text "abstract" <+> pretty declattrs <+> pretty name <+> text "::" <+> pretty ty instance Pretty DeclAttrs where pretty (DeclAttrs inline storage attrs) = (if inline then (text "inline") else empty) <+> (hsep $ [ pretty storage, pretty attrs]) instance Pretty Type where pretty ty = pretty (exportTypeDecl ty) instance Pretty TypeQuals where pretty tyQuals = hsep $ map showAttr [ ("const",constant),("volatile",volatile),("restrict",restrict) ] where showAttr (str,select) | select tyQuals = text str | otherwise = empty instance Pretty CompType where pretty (CompType sue_ref tag members attrs node) = (text.show) tag <+> pretty sue_ref <+> braces (terminateSemi members) <+> pretty attrs instance Pretty MemberDecl where pretty (MemberDecl (VarDecl name declattrs ty) bitfield _) = pretty declattrs <+> pretty name <+> text "::" <+> pretty ty <+> (maybe empty (\bf -> text ":" <+> pretty bf) bitfield) pretty (AnonBitField ty bitfield_sz _) = pretty ty <+> text ":" <+> pretty bitfield_sz instance Pretty EnumType where pretty (EnumType sue_ref enumerators attrs _) = text "enum" <+> pretty sue_ref <+> braces (terminateSemi_ $ map prettyEnr enumerators) <+> pretty attrs where prettyEnr (Enumerator ident expr enumty _) = pretty ident <+> text " = " <+> pretty expr instance Pretty Enumerator where pretty (Enumerator ident expr enumty _) = text "<" <> text "econst" <+> pretty (sueRef enumty) <> text ">" <+> pretty ident <+> text " = " <+> pretty expr instance Pretty Storage where pretty NoStorage = empty pretty (Auto reg) = text$ if reg then "auto/register" else "auto" pretty (Static linkage thread_local) = (hcat . punctuate (text "/") $ [ text "static",pretty linkage ]) <+> (if thread_local then text ", __thread" else empty) pretty (FunLinkage linkage) = text "function/" <> pretty linkage instance Pretty Linkage where pretty InternalLinkage = text "internal" pretty ExternalLinkage = text "external" pretty NoLinkage = text "local" instance Pretty VarName where pretty NoName = text "" pretty (VarName ident asmname_opt) = pretty ident <+> (maybe empty pAsmName asmname_opt) where pAsmName asmname = text "" <+> parens (text "asmname" <+> pretty asmname) instance Pretty Attributes where pretty = joinComma instance Pretty Attr where pretty (Attr ident es _) = pretty ident <+> (if null es then empty else text "(...)") joinComma :: (Pretty a) => [a] -> Doc joinComma = hsep . punctuate comma . map pretty terminateSemi :: (Pretty a) => [a] -> Doc terminateSemi = terminateSemi_ . map pretty terminateSemi_ :: [Doc] -> Doc terminateSemi_ = hsep . map (<> semi) language-c-0.4.7/src/Language/C/Analysis/DeclAnalysis.hs0000644000000000000000000006770512425376061021126 0ustar0000000000000000{-# LANGUAGE PatternGuards, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis.DeclAnalysis -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : alpha -- Portability : ghc -- -- This module performs the analysis of declarations and the translation of -- type specifications in the AST. ----------------------------------------------------------------------------- module Language.C.Analysis.DeclAnalysis ( -- * Translating types analyseTypeDecl, tType,tDirectType,tNumType,tArraySize,tTypeQuals, mergeOldStyle, -- * Dissecting type specs canonicalTypeSpec, NumBaseType(..),SignSpec(..),SizeMod(..),NumTypeSpec(..),TypeSpecAnalysis(..), canonicalStorageSpec, StorageSpec(..),hasThreadLocalSpec, isTypeDef, -- * Helpers VarDeclInfo(..), tAttr,mkVarName,getOnlyDeclr,nameOfDecl,analyseVarDecl,analyseVarDecl' ) where import Language.C.Data.Error import Language.C.Data.Node import Language.C.Data.Ident import Language.C.Pretty import Language.C.Syntax import {-# SOURCE #-} Language.C.Analysis.AstAnalysis (tExpr, ExprSide(..)) import Language.C.Analysis.DefTable (TagFwdDecl(..), insertType, lookupType) import Language.C.Analysis.Export import Language.C.Analysis.SemError import Language.C.Analysis.SemRep import Language.C.Analysis.TravMonad import Data.Foldable as F (foldrM) import qualified Data.Traversable as T import Control.Monad (liftM,when,ap) import Data.List (intersperse, mapAccumL) import Data.Map (Map) import qualified Data.Map as Map import Text.PrettyPrint.HughesPJ -- * handling declarations -- | analyse and translate a parameter declaration -- Should be called in either prototype or block scope tParamDecl :: (MonadTrav m) => CDecl -> m ParamDecl tParamDecl (CDecl declspecs declrs node) = do declr <- getParamDeclr -- analyse the variable declaration (VarDeclInfo name is_inline storage_spec attrs ty declr_node) <- analyseVarDecl' True declspecs declr [] Nothing when (is_inline) $ throwTravError (badSpecifierError node "parameter declaration with inline specifier") -- compute storage of parameter (NoStorage, but might have a register specifier) storage <- throwOnLeft $ computeParamStorage node storage_spec let paramDecl = mkParamDecl name storage attrs ty declr_node -- XXX: we shouldn't modify the deftable here, just analyse and build representation return $ paramDecl where getParamDeclr = case declrs of [] -> return (emptyDeclr node) [(Just declr,Nothing,Nothing)] -> return declr _ -> astError node "bad parameter declaration: multiple decls / bitfield or initializer present" mkParamDecl name storage attrs ty declr_node = let vd = VarDecl name (DeclAttrs False storage attrs) ty in case name of NoName -> AbstractParamDecl vd declr_node _ -> ParamDecl vd declr_node -- | a parameter declaration has no linkage and either auto or register storage computeParamStorage :: NodeInfo -> StorageSpec -> Either BadSpecifierError Storage computeParamStorage _ NoStorageSpec = Right (Auto False) computeParamStorage _ RegSpec = Right (Auto True) computeParamStorage node spec = Left . badSpecifierError node $ "Bad storage specified for parameter: " ++ show spec -- | analyse and translate a member declaration tMemberDecls :: (MonadTrav m) => CDecl -> m [MemberDecl] -- Anonymous struct or union members tMemberDecls (CDecl declspecs [] node) = do let (storage_specs, _attrs, typequals, typespecs, is_inline) = partitionDeclSpecs declspecs when is_inline $ astError node "member declaration with inline specifier" canonTySpecs <- canonicalTypeSpec typespecs ty <- tType True node typequals canonTySpecs [] [] case ty of DirectType (TyComp _) _ _ -> return $ [MemberDecl -- XXX: are these DeclAttrs correct? (VarDecl NoName (DeclAttrs False NoStorage []) ty) Nothing node] _ -> astError node "anonymous member has a non-composite type" -- Named members tMemberDecls (CDecl declspecs declrs node) = mapM (uncurry tMemberDecl) (zip (True:repeat False) declrs) where tMemberDecl handle_sue_def (Just member_declr,Nothing,bit_field_size_opt) = -- TODO: use analyseVarDecl here, not analyseVarDecl' do var_decl <- analyseVarDecl' handle_sue_def declspecs member_declr [] Nothing let (VarDeclInfo name is_inline storage_spec attrs ty declr_node) = var_decl -- checkValidMemberSpec is_inline storage_spec return $ MemberDecl (VarDecl name (DeclAttrs False NoStorage attrs) ty) bit_field_size_opt node tMemberDecl handle_sue_def (Nothing,Nothing,Just bit_field_size) = do let (storage_specs, _attrs, typequals, typespecs, is_inline) = partitionDeclSpecs declspecs storage_spec <- canonicalStorageSpec storage_specs canonTySpecs <- canonicalTypeSpec typespecs typ <- tType handle_sue_def node typequals canonTySpecs [] [] -- return $ AnonBitField typ bit_field_size node tMemberDecl _ _ = astError node "Bad member declaration" checkValidMemberSpec is_inline storage_spec = do when (is_inline) $ astError node "member declaration with inline specifier" when (storage_spec /= NoStorageSpec) $ astError node "storage specifier for member" return () data StorageSpec = NoStorageSpec | AutoSpec | RegSpec | ThreadSpec | StaticSpec Bool | ExternSpec Bool deriving (Eq,Ord,Show,Read) hasThreadLocalSpec :: StorageSpec -> Bool hasThreadLocalSpec ThreadSpec = True hasThreadLocalSpec (StaticSpec b) = b hasThreadLocalSpec (ExternSpec b) = b hasThreadLocalSpec _ = False data VarDeclInfo = VarDeclInfo VarName Bool {- is-inline? -} StorageSpec Attributes Type NodeInfo analyseVarDecl' :: (MonadTrav m) => Bool -> [CDeclSpec] -> CDeclr -> [CDecl] -> (Maybe CInit) -> m VarDeclInfo analyseVarDecl' handle_sue_def declspecs declr oldstyle init_opt = do let (storage_specs, attrs, type_quals, type_specs, inline) = partitionDeclSpecs declspecs canonTySpecs <- canonicalTypeSpec type_specs analyseVarDecl handle_sue_def storage_specs attrs type_quals canonTySpecs inline declr oldstyle init_opt -- | analyse declarators analyseVarDecl :: (MonadTrav m) => Bool -> [CStorageSpec] -> [CAttr] -> [CTypeQual] -> TypeSpecAnalysis -> Bool -> CDeclr -> [CDecl] -> (Maybe CInit) -> m VarDeclInfo analyseVarDecl handle_sue_def storage_specs decl_attrs typequals canonTySpecs inline (CDeclr name_opt derived_declrs asmname_opt declr_attrs node) oldstyle_params init_opt = do -- analyse the storage specifiers storage_spec <- canonicalStorageSpec storage_specs -- translate the type into semantic representation typ <- tType handle_sue_def node typequals canonTySpecs derived_declrs oldstyle_params -- translate attributes attrs' <- mapM tAttr (decl_attrs ++ declr_attrs) -- make name name <- mkVarName node name_opt asmname_opt return $ VarDeclInfo name inline storage_spec attrs' typ node where isInlineSpec (CInlineQual _) = True isInlineSpec _ = False -- return @True@ if the declarations is a type def isTypeDef :: [CDeclSpec] -> Bool isTypeDef declspecs = not $ null [ n | (CStorageSpec (CTypedef n)) <- declspecs ] -- * translation -- | get the type of a /type declaration/ -- -- A type declaration @T@ may appear in thre forms: -- -- * @typeof(T)@ -- -- * as abstract declarator in a function prototype, as in @f(int)@ -- -- * in a declaration without declarators, as in @struct x { int a } ;@ -- -- Currently, @analyseTypeDecl@ is exlusively used for analysing types for GNU's @typeof(T)@. -- -- We move attributes to the type, as they have no meaning for the abstract declarator analyseTypeDecl :: (MonadTrav m) => CDecl -> m Type analyseTypeDecl (CDecl declspecs declrs node) | [] <- declrs = analyseTyDeclr (emptyDeclr node) | [(Just declr,Nothing,Nothing)] <- declrs = analyseTyDeclr declr | otherwise = astError node "Bad declarator for type declaration" where analyseTyDeclr (CDeclr Nothing derived_declrs Nothing attrs _declrnode) | (not (null storagespec) || inline) = astError node "storage specifier for type declaration" | otherwise = do canonTySpecs <- canonicalTypeSpec typespecs t <- tType True node (map CAttrQual (attrs++attrs_decl) ++ typequals) canonTySpecs derived_declrs [] case nameOfNode node of Just n -> withDefTable (\dt -> (t, insertType dt n t)) Nothing -> return t where (storagespec, attrs_decl, typequals, typespecs, inline) = partitionDeclSpecs declspecs analyseTyDeclr _ = astError node "Non-abstract declarator in type declaration" -- | translate a type tType :: (MonadTrav m) => Bool -> NodeInfo -> [CTypeQual] -> TypeSpecAnalysis -> [CDerivedDeclr] -> [CDecl] -> m Type tType handle_sue_def top_node typequals canonTySpecs derived_declrs oldstyle_params = mergeOldStyle top_node oldstyle_params derived_declrs >>= buildType where buildType [] = tDirectType handle_sue_def top_node typequals canonTySpecs buildType (CPtrDeclr ptrquals node : dds) = buildType dds >>= buildPointerType ptrquals node buildType (CArrDeclr arrquals size node : dds) = buildType dds >>= buildArrayType arrquals size node buildType (CFunDeclr (Right (params, isVariadic)) attrs node : dds) = buildType dds >>= (liftM (uncurry FunctionType) . buildFunctionType params isVariadic attrs node) buildType (CFunDeclr (Left _) _ _ : _) -- /FIXME/: this is really an internal error, not an AST error. = astError top_node "old-style parameters remaining after mergeOldStyle" buildPointerType ptrquals _node inner_ty = liftM (\(quals,attrs) -> PtrType inner_ty quals attrs) (tTypeQuals ptrquals) buildArrayType arr_quals size _node inner_ty = do (quals,attrs) <- tTypeQuals arr_quals arr_sz <- tArraySize size return$ ArrayType inner_ty arr_sz quals attrs -- We build functions in function prototype scope. -- When analyzing the the function body, we push parameters in function body scope. buildFunctionType params is_variadic attrs _node return_ty = do enterPrototypeScope params' <- mapM tParamDecl params leavePrototypeScope attrs' <- mapM tAttr attrs return $ (\t -> (t,attrs')) $ case (map declType params',is_variadic) of ([],False) -> FunTypeIncomplete return_ty -- may be improved later on ([DirectType TyVoid _ _],False) -> FunType return_ty [] False _ -> FunType return_ty params' is_variadic -- | translate a type without (syntactic) indirections -- Due to the GNU @typeof@ extension and typeDefs, this can be an arbitrary type tDirectType :: (MonadTrav m) => Bool -> NodeInfo -> [CTypeQual] -> TypeSpecAnalysis -> m Type tDirectType handle_sue_def node ty_quals canonTySpec = do (quals,attrs) <- tTypeQuals ty_quals let baseType ty_name = DirectType ty_name quals attrs case canonTySpec of TSNone -> return$ baseType (TyIntegral TyInt) TSVoid -> return$ baseType TyVoid TSBool -> return$ baseType (TyIntegral TyBool) TSNum tsnum -> do numType <- tNumType tsnum return . baseType $ case numType of Left (floatType,iscomplex) | iscomplex -> TyComplex floatType | otherwise -> TyFloating floatType Right intType -> TyIntegral intType TSTypeDef tdr -> return$ TypeDefType tdr quals attrs TSNonBasic (CSUType su _tnode) -> liftM (baseType . TyComp) $ tCompTypeDecl handle_sue_def su TSNonBasic (CEnumType enum _tnode) -> liftM (baseType . TyEnum) $ tEnumTypeDecl handle_sue_def enum TSType t -> mergeTypeAttributes node quals attrs t TSNonBasic _ -> astError node "Unexpected typespec" -- | Merge type attributes -- -- This handles for example the form -- -- > /* tyqual attr typeof(type) */ -- > const typeof(char volatile) x; mergeTypeAttributes :: (MonadCError m) => NodeInfo -> TypeQuals -> [Attr] -> Type -> m Type mergeTypeAttributes node_info quals attrs typ = case typ of DirectType ty_name quals' attrs' -> merge quals' attrs' $ mkDirect ty_name PtrType ty quals' attrs' -> merge quals' attrs' $ PtrType ty ArrayType ty array_sz quals' attrs' -> merge quals' attrs' $ ArrayType ty array_sz FunctionType (FunType return_ty params inline) attrs' -- /FIXME/: This needs review, but checking (null attrs) seems strange here -- | not (null attrs) -> astError node_info "type qualifiers for function type" -- | otherwise -> return$ FunctionType (FunType return_ty params inline (attrs' ++ attrs)) -> return$ FunctionType (FunType return_ty params inline) (attrs' ++ attrs) TypeDefType tdr quals' attrs' -> merge quals' attrs' $ TypeDefType tdr where mkDirect ty_name quals' attrs' = DirectType ty_name quals' attrs' merge quals' attrs' tyf = return $ tyf (mergeTypeQuals quals quals') (attrs' ++ attrs) typeDefRef :: (MonadCError m, MonadSymtab m) => NodeInfo -> Ident -> m TypeDefRef typeDefRef t_node name = lookupTypeDef name >>= \ty -> return (TypeDefRef name (Just ty) t_node) -- extract a struct\/union -- we emit @declStructUnion@ and @defStructUnion@ actions -- -- TODO: should attributes be part of declarartions too ? tCompTypeDecl :: (MonadTrav m) => Bool -> CStructUnion -> m CompTypeRef tCompTypeDecl handle_def (CStruct tag ident_opt member_decls_opt attrs node_info) = do -- create reference sue_ref <- createSUERef node_info ident_opt let tag' = tTag tag attrs' <- mapM tAttr attrs -- record tag name let decl = CompTypeRef sue_ref tag' node_info handleTagDecl (CompDecl decl) -- when handle_def is true, enter the definition when (handle_def) $ do maybeM member_decls_opt $ \decls -> tCompType sue_ref tag' decls (attrs') node_info >>= (handleTagDef.CompDef) return decl tTag :: CStructTag -> CompTyKind tTag CStructTag = StructTag tTag CUnionTag = UnionTag tCompType :: (MonadTrav m) => SUERef -> CompTyKind -> [CDecl] -> Attributes -> NodeInfo -> m CompType tCompType tag sue_ref member_decls attrs node = return (CompType tag sue_ref) `ap` (concatMapM tMemberDecls member_decls) `ap` (return attrs) `ap` (return node) -- | translate a enum type decl -- -- > enum my_enum -- > enum your_enum { x, y=3 } -- tEnumTypeDecl :: (MonadTrav m) => Bool -> CEnum -> m EnumTypeRef tEnumTypeDecl handle_def (CEnum ident_opt enumerators_opt attrs node_info) | (Nothing, Nothing) <- (ident_opt, enumerators_opt) = astError node_info "both definition and name of enum missing" | Just [] <- enumerators_opt = astError node_info "empty enumerator list" | otherwise = do sue_ref <- createSUERef node_info ident_opt attrs' <- mapM tAttr attrs let decl = EnumTypeRef sue_ref node_info when handle_def $ do maybeM enumerators_opt $ \enumerators -> tEnumType sue_ref enumerators attrs' node_info >>= (handleTagDef . EnumDef) return decl -- | translate and analyse an enumeration type tEnumType :: (MonadCError m, MonadSymtab m) => SUERef -> [(Ident, Maybe CExpr)] -> Attributes -> NodeInfo -> m EnumType tEnumType sue_ref enumerators attrs node = do mapM_ handleEnumeratorDef enumerators' return ty where ty = EnumType sue_ref enumerators' attrs node (_,enumerators') = mapAccumL nextEnumerator (Left 0) enumerators nextEnumerator memo (ident,e) = let (memo',expr) = nextEnrExpr memo e in (memo', Enumerator ident expr ty (nodeInfo ident)) nextEnrExpr :: (Either Integer (Expr,Integer)) -> Maybe CExpr -> (Either Integer (Expr,Integer), CExpr) nextEnrExpr (Left i) Nothing = (Left (succ i), intExpr i) nextEnrExpr (Right (e,offs)) Nothing = (Right (e, succ offs), offsExpr e offs) nextEnrExpr _ (Just e) = (Right (e,1), e) intExpr i = CConst (CIntConst (cInteger i) undefNode) offsExpr e offs = CBinary CAddOp e (intExpr offs) undefNode -- | Mapping from num type specs to C types (C99 6.7.2-2), ignoring the complex qualifier. tNumType :: (MonadCError m) => NumTypeSpec -> m (Either (FloatType,Bool) IntType) tNumType (NumTypeSpec basetype sgn sz iscomplex) = case (basetype,sgn,sz) of (BaseChar,_,NoSizeMod) | Signed <- sgn -> intType TySChar | Unsigned <- sgn -> intType TyUChar | otherwise -> intType TyChar (intbase, _, NoSizeMod) | optBase BaseInt intbase -> intType$ case sgn of Unsigned -> TyUInt _ -> TyInt (intbase, signed, sizemod) | optBase BaseInt intbase, optSign Signed signed -> intType$ case sizemod of ShortMod -> TyShort LongMod -> TyLong LongLongMod -> TyLLong _ -> internalErr "numTypeMapping: unexpected pattern matching error" (intbase, Unsigned, sizemod) | optBase BaseInt intbase -> intType$ case sizemod of ShortMod -> TyUShort LongMod -> TyULong LongLongMod -> TyULLong _ -> internalErr "numTypeMapping: unexpected pattern matching error" (BaseFloat, NoSignSpec, NoSizeMod) -> floatType TyFloat (BaseDouble, NoSignSpec, NoSizeMod) -> floatType TyDouble (BaseDouble, NoSignSpec, LongMod) -> floatType TyLDouble -- TODO: error analysis (_,_,_) -> error "Bad AST analysis" where optBase _ NoBaseType = True optBase expect baseTy = expect == baseTy optSign _ NoSignSpec = True optSign expect sign = expect == sign intType = return . Right floatType ft = return (Left (ft,iscomplex)) -- TODO: currently bogus tArraySize :: (MonadTrav m) => CArrSize -> m ArraySize tArraySize (CNoArrSize False) = return (UnknownArraySize False) tArraySize (CNoArrSize True) = return (UnknownArraySize True) tArraySize (CArrSize static szexpr) = liftM (ArraySize static) (return szexpr) tTypeQuals :: (MonadTrav m) => [CTypeQual] -> m (TypeQuals,Attributes) tTypeQuals = foldrM go (noTypeQuals,[]) where go (CConstQual _) (tq,attrs) = return$ (tq { constant = True },attrs) go (CVolatQual _) (tq,attrs) = return$ (tq { volatile = True },attrs) go (CRestrQual _) (tq,attrs) = return$ (tq { restrict = True },attrs) go (CAttrQual attr) (tq,attrs) = liftM (\attr' -> (tq,attr':attrs)) (tAttr attr) go (CInlineQual node) (_tq,_attrs) = astError node "unexpected inline qualifier" -- * analysis {- To canoicalize type specifiers, we define a canonical form: void | bool | (char|int|float|double) (signed|unsigned)? (long long?)? complex? | othertype -} data NumBaseType = NoBaseType | BaseChar | BaseInt | BaseFloat | BaseDouble deriving (Eq,Ord) data SignSpec = NoSignSpec | Signed | Unsigned deriving (Eq,Ord) data SizeMod = NoSizeMod | ShortMod | LongMod | LongLongMod deriving (Eq,Ord) data NumTypeSpec = NumTypeSpec { base :: NumBaseType, signSpec :: SignSpec, sizeMod :: SizeMod, isComplex :: Bool } emptyNumTypeSpec :: NumTypeSpec emptyNumTypeSpec = NumTypeSpec { base = NoBaseType, signSpec = NoSignSpec, sizeMod = NoSizeMod, isComplex = False } data TypeSpecAnalysis = TSNone | TSVoid | TSBool | TSNum NumTypeSpec | TSTypeDef TypeDefRef | TSType Type | TSNonBasic CTypeSpec canonicalTypeSpec :: (MonadTrav m) => [CTypeSpec] -> m TypeSpecAnalysis canonicalTypeSpec = foldrM go TSNone where getNTS TSNone = Just emptyNumTypeSpec getNTS (TSNum nts) = Just nts getNTS _ = Nothing updLongMod NoSizeMod = Just LongMod updLongMod LongMod = Just LongLongMod updLongMod _ = Nothing getTypeSpecs :: MonadTrav m => Type -> m [CTypeSpec] getTypeSpecs = return . getTS . partitionDeclSpecs . fst . exportType getTS (_, _, _, ts, _) = ts go :: (MonadTrav m) => CTypeSpec -> TypeSpecAnalysis -> m TypeSpecAnalysis go (CVoidType _) TSNone = return$ TSVoid go (CBoolType _) TSNone = return$ TSBool go (CCharType _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa = return$ TSNum$ nts { base = BaseChar } go (CIntType _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa = return$ TSNum$ nts { base = BaseInt } go (CFloatType _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa = return$ TSNum$ nts { base = BaseFloat } go (CDoubleType _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa = return$ TSNum$ nts { base = BaseDouble } go (CShortType _) tsa | (Just nts@(NumTypeSpec { sizeMod = NoSizeMod })) <- getNTS tsa = return$ TSNum$nts { sizeMod = ShortMod } go (CLongType _) tsa | (Just nts@(NumTypeSpec { sizeMod = szMod })) <- getNTS tsa, (Just szMod') <- updLongMod szMod = return$ TSNum$ nts { sizeMod = szMod' } go (CSignedType _) tsa | (Just nts@(NumTypeSpec { signSpec = NoSignSpec })) <- getNTS tsa = return$ TSNum$ nts { signSpec = Signed } go (CUnsigType _) tsa | (Just nts@(NumTypeSpec { signSpec = NoSignSpec })) <- getNTS tsa = return$ TSNum$ nts { signSpec = Unsigned } go (CComplexType _) tsa | (Just nts@(NumTypeSpec { isComplex = False })) <- getNTS tsa = return$ TSNum$ nts { isComplex = True } go (CTypeDef i ni) TSNone = liftM TSTypeDef $ typeDefRef ni i go (CTypeOfType d ni) TSNone = liftM TSType $ analyseTypeDecl d go (CTypeOfExpr e _) TSNone = liftM TSType $ tExpr [] RValue e go otherType TSNone = return$ TSNonBasic otherType go ty _ts = astError (nodeInfo ty) "Invalid type specifier" -- compute storage given storage specifiers canonicalStorageSpec :: (MonadCError m) =>[CStorageSpec] -> m StorageSpec canonicalStorageSpec storagespecs = liftM elideAuto $ foldrM updStorage NoStorageSpec storagespecs where updStorage (CAuto _) NoStorageSpec = return$ AutoSpec updStorage (CRegister _) NoStorageSpec = return$ RegSpec updStorage (CThread _) NoStorageSpec = return$ ThreadSpec updStorage (CThread _) (StaticSpec _) = return$ StaticSpec True updStorage (CThread _) (ExternSpec _) = return$ ExternSpec True updStorage (CStatic _) NoStorageSpec = return$ StaticSpec False updStorage (CExtern _) NoStorageSpec = return$ ExternSpec False updStorage (CStatic _) ThreadSpec = return$ StaticSpec True updStorage (CExtern _) ThreadSpec = return$ ExternSpec True updStorage badSpec old = astError (nodeInfo badSpec) $ "Invalid storage specifier "++render (pretty badSpec)++" in combination with "++show old elideAuto AutoSpec = NoStorageSpec elideAuto spec = spec -- | convert old style parameters -- -- This requires matching parameter names and declarations, as in the following example: -- -- > int f(d,c,a,b) -- > char a,*b; -- > int c; -- > { } -- -- is converted to -- -- > int f(int d, int c, char a, char* b) -- -- TODO: This could be moved to syntax, as it operates on the AST only mergeOldStyle :: (MonadCError m) => NodeInfo -> [CDecl] -> [CDerivedDeclr] -> m [CDerivedDeclr] mergeOldStyle _node [] declrs = return declrs mergeOldStyle node oldstyle_params (CFunDeclr params attrs fdnode : dds) = case params of Left list -> do -- FIXME: This translation doesn't work in the following example -- [| int f(b,a) struct x { }; int b,a; { struct x local; return local.x } |] oldstyle_params' <- liftM concat $ mapM splitCDecl oldstyle_params param_map <- liftM Map.fromList $ mapM attachNameOfDecl oldstyle_params' (newstyle_params,param_map') <- foldrM insertParamDecl ([],param_map) list when (not $ Map.null param_map') $ astError node $ "declarations for parameter(s) "++ showParamMap param_map' ++" but no such parameter" return $ (CFunDeclr (Right (newstyle_params, False)) attrs fdnode : dds) Right _newstyle -> astError node "oldstyle parameter list, but newstyle function declaration" where attachNameOfDecl decl = nameOfDecl decl >>= \n -> return (n,decl) insertParamDecl param_name (ps, param_map) = case Map.lookup param_name param_map of Just p -> return (p:ps, Map.delete param_name param_map) Nothing -> return (implicitIntParam param_name : ps, param_map) implicitIntParam param_name = let node = (nodeInfo param_name) in CDecl [CTypeSpec (CIntType node)] [(Just (CDeclr (Just param_name) [] Nothing [] node),Nothing,Nothing)] node showParamMap = concat . intersperse ", " . map identToString . Map.keys mergeOldStyle node _ _ = astError node "oldstyle parameter list, but not function type" -- | split a CDecl into declarators, hereby eliding SUE defs from the second declarator on. -- -- There are several reasons why this isn;t the preferred way for handling multiple-declarator declarations, -- but it can be convinient some times. -- -- > splitCDecl [d| struct x { int z; } a,*b; |] -- > [ [d| struct x { int z; } a, struct x *b |] ] -- -- /TODO/: This could be moved to syntax, as it operates on the AST only splitCDecl :: (MonadCError m) => CDecl -> m [CDecl] splitCDecl decl@(CDecl declspecs declrs node) = case declrs of [] -> internalErr "splitCDecl applied to empty declaration" [declr] -> return [decl] (d1:ds) -> let declspecs' = map elideSUEDef declspecs in return$ (CDecl declspecs [d1] node) : [ CDecl declspecs' [declr] node | declr <- ds ] where elideSUEDef declspec@(CTypeSpec tyspec) = case tyspec of (CEnumType (CEnum name def attrs enum_node) node) -> CTypeSpec (CEnumType (CEnum name Nothing [] enum_node) node) (CSUType (CStruct tag name def attrs su_node) node) -> CTypeSpec (CSUType (CStruct tag name Nothing [] su_node) node) _ -> declspec elideSUEDef declspec = declspec -- | translate @__attribute__@ annotations -- TODO: This is a unwrap and wrap stub tAttr :: (MonadCError m, MonadSymtab m) => CAttr -> m Attr tAttr (CAttr name cexpr node) = return$ Attr name cexpr node -- | construct a name for a variable -- TODO: more or less bogus mkVarName :: (MonadCError m, MonadSymtab m) => NodeInfo -> Maybe Ident -> Maybe AsmName -> m VarName mkVarName node Nothing _ = return NoName mkVarName node (Just n) asm = return $ VarName n asm -- helpers nameOfDecl :: (MonadCError m) => CDecl -> m Ident nameOfDecl d = getOnlyDeclr d >>= \declr -> case declr of (CDeclr (Just name) _ _ _ _) -> return name (CDeclr Nothing _ _ _ node) -> internalErr "nameOfDecl: abstract declarator" emptyDeclr :: NodeInfo -> CDeclr emptyDeclr node = CDeclr Nothing [] Nothing [] node getOnlyDeclr :: (MonadCError m) => CDecl -> m CDeclr getOnlyDeclr (CDecl _ [(Just declr,_,_)] _) = return declr getOnlyDeclr (CDecl _ _ node) = internalErr "getOnlyDeclr: declaration doesn't have a unique declarator" language-c-0.4.7/src/Language/C/Analysis/DefTable.hs0000644000000000000000000003360212425376061020206 0ustar0000000000000000{-# LANGUAGE PatternGuards, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis.DefTable -- Copyright : (c) 2008 Benedikt Huber -- based on code from c2hs -- (c) [1999..2001] Manuel M. T. Chakravarty -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : alpha -- Portability : ghc -- -- This module manages symbols in local and global scopes. -- -- There are four different kind of identifiers: ordinary identifiers (henceforth -- simply called `identifier'), tag names (names of struct\/union\/enum types), -- labels and structure members. ----------------------------------------------------------------------------- module Language.C.Analysis.DefTable ( IdentEntry, identOfTyDecl, TagEntry, TagFwdDecl(..), DefTable(..), emptyDefTable, globalDefs, inFileScope, enterFunctionScope,leaveFunctionScope,enterBlockScope,leaveBlockScope, enterMemberDecl,leaveMemberDecl, DeclarationStatus(..),declStatusDescr, defineTypeDef, defineGlobalIdent, defineScopedIdent, defineScopedIdentWhen, declareTag,defineTag,defineLabel,lookupIdent, lookupTag,lookupLabel,lookupIdentInner,lookupTagInner, insertType, lookupType, mergeDefTable ) where import Language.C.Data import Language.C.Analysis.NameSpaceMap import Language.C.Analysis.SemRep import Control.Applicative ((<|>)) import Data.Map (Map) import qualified Data.Map as Map import Data.IntMap (IntMap, union) import qualified Data.IntMap as IntMap import Data.Generics {- Name spaces, scopes and contexts [Scopes] In C, there are 4 categories of identifiers: * labels * tag names (@(struct|union|enum) tag-name@), where /all/ tag names live in one namespace * members of structures and unions * ordinary identifiers, denoting objects, functions, typeDefs and enumeration constants There are 4 kind of scopes: * file scope: outside of parameter lists and blocks * function prototype scope * function scope: labels are visible within the entire function, and declared implicitely * block scope While function scope is irrelevant for variable declarations, they might also appear in member declarations. Therefore, there are also 4 kinds of contexts where a variable might be declared: * File Scope Context: external declaration \/ definition * Block Scope Context: either external or local definition * Function prototype scope context * Member Declaration context See C99 6 -} -- | All ordinary identifiers map to 'IdenTyDecl': either a typedef or a object\/function\/enumerator type IdentEntry = Either TypeDef IdentDecl identOfTyDecl :: IdentEntry -> Ident identOfTyDecl = either identOfTypeDef declIdent data TagFwdDecl = CompDecl CompTypeRef | EnumDecl EnumTypeRef instance HasSUERef TagFwdDecl where sueRef (CompDecl ctr) = sueRef ctr sueRef (EnumDecl etr) = sueRef etr instance CNode TagFwdDecl where nodeInfo (CompDecl ctr) = nodeInfo ctr nodeInfo (EnumDecl etr) = nodeInfo etr -- | Tag names map to forward declarations or definitions of struct\/union\/enum types type TagEntry = Either TagFwdDecl TagDef -- | Table holding current definitions data DefTable = DefTable { identDecls :: NameSpaceMap Ident IdentEntry, -- ^ declared `ordinary identifiers' tagDecls :: NameSpaceMap SUERef TagEntry, -- ^ declared struct/union/enum tags labelDefs :: NameSpaceMap Ident Ident, -- ^ defined labels memberDecls :: NameSpaceMap Ident MemberDecl, -- ^ member declarations (only local) refTable :: IntMap Name, -- ^ link names with definitions typeTable :: IntMap Type } -- | empty definition table, with all name space maps in global scope emptyDefTable :: DefTable emptyDefTable = DefTable nameSpaceMap nameSpaceMap nameSpaceMap nameSpaceMap IntMap.empty IntMap.empty -- | get the globally defined entries of a definition table globalDefs :: DefTable -> GlobalDecls globalDefs deftbl = Map.foldWithKey insertDecl (GlobalDecls e gtags e) (globalNames $ identDecls deftbl) where e = Map.empty (_fwd_decls,gtags) = Map.mapEither id $ globalNames (tagDecls deftbl) insertDecl ident (Left tydef) ds = ds { gTypeDefs = Map.insert ident tydef (gTypeDefs ds)} insertDecl ident (Right obj) ds = ds { gObjs = Map.insert ident obj (gObjs ds) } inFileScope :: DefTable -> Bool inFileScope dt = not (hasLocalNames (identDecls dt) || hasLocalNames (labelDefs dt)) leaveScope_ :: (Ord k) => NameSpaceMap k a -> NameSpaceMap k a leaveScope_ = fst . leaveScope enterLocalScope :: DefTable -> DefTable enterLocalScope deftbl = deftbl { identDecls = enterNewScope (identDecls deftbl), tagDecls = enterNewScope (tagDecls deftbl) } leaveLocalScope :: DefTable -> DefTable leaveLocalScope deftbl = deftbl { identDecls = leaveScope_ (identDecls deftbl), tagDecls = leaveScope_ (tagDecls deftbl) } -- | Enter function scope (AND the corresponding block scope) enterFunctionScope :: DefTable -> DefTable enterFunctionScope deftbl = enterLocalScope $ deftbl { labelDefs = enterNewScope (labelDefs deftbl) } -- | Leave function scope, and return the associated DefTable. -- Error if not in function scope. leaveFunctionScope :: DefTable -> DefTable leaveFunctionScope deftbl = leaveLocalScope $ deftbl { labelDefs = leaveScope_ (labelDefs deftbl) } -- | Enter new block scope enterBlockScope :: DefTable -> DefTable enterBlockScope deftbl = enterLocalScope $ deftbl { labelDefs = enterNewScope (labelDefs deftbl) } -- | Leave innermost block scope leaveBlockScope :: DefTable -> DefTable leaveBlockScope deftbl = leaveLocalScope $ deftbl { labelDefs = leaveScope_ (labelDefs deftbl) } -- | Enter new member declaration scope enterMemberDecl :: DefTable -> DefTable enterMemberDecl deftbl = deftbl { memberDecls = enterNewScope (memberDecls deftbl) } -- | Leave innermost member declaration scope leaveMemberDecl :: DefTable -> ([MemberDecl], DefTable) leaveMemberDecl deftbl = let (decls',members) = leaveScope (memberDecls deftbl) in (,) (map snd members) (deftbl { memberDecls = decls' }) -- * declarations -- | Status of a declaration data DeclarationStatus t = NewDecl -- ^ new entry | Redeclared t -- ^ old def was overwritten | KeepDef t -- ^ new def was discarded | Shadowed t -- ^ new def shadows one in outer scope | KindMismatch t -- ^ kind mismatch deriving (Data,Typeable) declStatusDescr :: DeclarationStatus t -> String declStatusDescr NewDecl = "new" declStatusDescr (Redeclared _) = "redeclared" declStatusDescr (KeepDef _) = "keep old" declStatusDescr (Shadowed _) = "shadowed" declStatusDescr (KindMismatch _) = "kind mismatch" compatIdentEntry :: IdentEntry -> IdentEntry -> Bool compatIdentEntry (Left _tydef) = either (const True) (const False) compatIdentEntry (Right def) = either (const False) $ \other_def -> case (def,other_def) of (EnumeratorDef _, EnumeratorDef _) -> True (EnumeratorDef _, _) -> True (_, EnumeratorDef _) -> True (_,_) -> True data TagEntryKind = CompKind CompTyKind | EnumKind deriving (Eq,Ord) instance Show TagEntryKind where show (CompKind ctk) = show ctk show EnumKind = "enum" -- | @sameTagKind ty1 ty2@ returns @True@ if @ty1,ty2@ are the same kind of tag (struct,union or enum) tagKind :: TagEntry -> TagEntryKind tagKind (Left (CompDecl cd)) = CompKind (compTag cd) tagKind (Left (EnumDecl _)) = EnumKind tagKind (Right (CompDef cd)) = CompKind (compTag cd) tagKind (Right (EnumDef _)) = EnumKind compatTagEntry :: TagEntry -> TagEntry -> Bool compatTagEntry te1 te2 = tagKind te1 == tagKind te2 defRedeclStatus :: (t -> t -> Bool) -> t -> Maybe t -> DeclarationStatus t defRedeclStatus sameKind def oldDecl = case oldDecl of Just def' | def `sameKind` def' -> Redeclared def' | otherwise -> KindMismatch def' Nothing -> NewDecl defRedeclStatusLocal :: (Ord k) => (t -> t -> Bool) -> k -> t -> Maybe t -> NameSpaceMap k t -> DeclarationStatus t defRedeclStatusLocal sameKind ident def oldDecl nsm = case defRedeclStatus sameKind def oldDecl of NewDecl -> case lookupName nsm ident of Just shadowed -> Shadowed shadowed Nothing -> NewDecl redecl -> redecl defineTypeDef :: Ident -> TypeDef -> DefTable -> (DeclarationStatus IdentEntry, DefTable) defineTypeDef ident tydef deftbl = (defRedeclStatus compatIdentEntry (Left tydef) oldDecl, deftbl { identDecls = decls' }) where (decls', oldDecl) = defLocal (identDecls deftbl) ident (Left tydef) -- | declare\/define a global object\/function\/typeDef -- -- returns @Redeclared def@ if there is already an object\/function\/typeDef -- in global scope, or @DifferentKindRedec def@ if the old declaration is of a different kind. defineGlobalIdent :: Ident -> IdentDecl -> DefTable -> (DeclarationStatus IdentEntry, DefTable) defineGlobalIdent ident def deftbl = (defRedeclStatus compatIdentEntry (Right def) oldDecl, deftbl { identDecls = decls' }) where (decls',oldDecl) = defGlobal (identDecls deftbl) ident (Right def) -- | declare\/define a object\/function\/typeDef with lexical scope -- -- returns @Redeclared def@ or @DifferentKindRedec def@ if there is already an object\/function\/typeDef -- in the same scope. defineScopedIdent :: Ident -> IdentDecl -> DefTable -> (DeclarationStatus IdentEntry, DefTable) defineScopedIdent = defineScopedIdentWhen (const True) -- | declare\/define a object\/function\/typeDef with lexical scope, if the given predicate holds on the old -- entry. -- -- returns @Keep old_def@ if the old definition shouldn't be overwritten, and otherwise @Redeclared def@ or -- @DifferentKindRedecl def@ if there is already an object\/function\/typeDef in the same scope. defineScopedIdentWhen :: (IdentDecl -> Bool) -> Ident -> IdentDecl -> DefTable -> (DeclarationStatus IdentEntry, DefTable) defineScopedIdentWhen override_def ident def deftbl = (redecl_status, deftbl { identDecls = decls' }) where new_def = Right def old_decls = identDecls deftbl old_decl_opt = lookupInnermostScope old_decls ident (decls',redecl_status) | (Just old_decl) <- old_decl_opt, not (old_decl `compatIdentEntry` new_def) = (new_decls, KindMismatch old_decl) | maybe True doOverride old_decl_opt = (new_decls, redeclStatus' old_decl_opt) | otherwise = (old_decls, maybe NewDecl KeepDef old_decl_opt) new_decls = fst (defLocal old_decls ident new_def) doOverride (Left _) = False doOverride (Right old_def) = (override_def old_def) redeclStatus' overriden_decl = defRedeclStatusLocal compatIdentEntry ident new_def overriden_decl old_decls -- | declare a tag (fwd decl in case the struct name isn't defined yet) declareTag :: SUERef -> TagFwdDecl -> DefTable -> (DeclarationStatus TagEntry, DefTable) declareTag sueref decl deftbl = case lookupTag sueref deftbl of Nothing -> (NewDecl, deftbl { tagDecls = fst $ defLocal (tagDecls deftbl) sueref (Left decl) }) Just old_def | tagKind old_def == tagKind (Left decl) -> (KeepDef old_def, deftbl) | otherwise -> (KindMismatch old_def, deftbl) -- | define a tag defineTag :: SUERef -> TagDef -> DefTable -> (DeclarationStatus TagEntry, DefTable) defineTag sueref def deftbl = (redeclStatus, deftbl { tagDecls = decls'}) where (decls',olddecl) = defLocal (tagDecls deftbl) sueref (Right def) redeclStatus = case olddecl of Just fwd_decl@(Left decl) | tagKind fwd_decl == tagKind (Right def) -> NewDecl -- should be NewDef | otherwise -> KindMismatch fwd_decl _ -> defRedeclStatusLocal compatTagEntry sueref (Right def) olddecl (tagDecls deftbl) -- | define a label -- Return the old label if it is already defined in this function's scope defineLabel :: Ident -> DefTable -> (DeclarationStatus Ident, DefTable) defineLabel ident deftbl = let (labels',old_label) = defLocal (labelDefs deftbl) ident ident in (maybe NewDecl Redeclared old_label, deftbl { labelDefs = labels' }) -- | lookup identifier (object, function, typeDef, enumerator) lookupIdent :: Ident -> DefTable -> Maybe IdentEntry lookupIdent ident deftbl = lookupName (identDecls deftbl) ident -- | lookup tag lookupTag :: SUERef -> DefTable -> Maybe TagEntry lookupTag sue_ref deftbl = lookupName (tagDecls deftbl) sue_ref -- | lookup label lookupLabel :: Ident -> DefTable -> Maybe Ident lookupLabel ident deftbl = lookupName (labelDefs deftbl) ident -- | lookup an object in the innermost scope lookupIdentInner :: Ident -> DefTable -> Maybe IdentEntry lookupIdentInner ident deftbl = lookupInnermostScope (identDecls deftbl) ident -- | lookup an identifier in the innermost scope lookupTagInner :: SUERef -> DefTable -> Maybe TagEntry lookupTagInner sue_ref deftbl = lookupInnermostScope (tagDecls deftbl) sue_ref -- | Record the type of a node. insertType :: DefTable -> Name -> Type -> DefTable insertType dt n t = dt { typeTable = IntMap.insert (nameId n) t (typeTable dt) } -- | Lookup the type of a node. lookupType :: DefTable -> Name -> Maybe Type lookupType dt n = IntMap.lookup (nameId n) (typeTable dt) -- | Merge two DefTables. If both tables contain an entry for a given -- key, they must agree on its value. mergeDefTable :: DefTable -> DefTable -> DefTable mergeDefTable (DefTable i1 t1 l1 m1 r1 tt1) (DefTable i2 t2 l2 m2 r2 tt2) = DefTable (mergeNameSpace i1 i2) (mergeNameSpace t1 t2) (mergeNameSpace l1 l2) (mergeNameSpace m1 m2) (union r1 r2) (union tt1 tt2) language-c-0.4.7/src/Language/C/Analysis/Export.hs0000644000000000000000000002263212425376061020022 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis.Export -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : prototype -- Portability : ghc -- -- /WARNING/ : This is just an implementation sketch and not very well tested. -- -- Export 'SemRep' entities to 'AST' nodes. ----------------------------------------------------------------------------- module Language.C.Analysis.Export ( exportDeclr, exportType, exportTypeDecl, exportTypeSpec, exportTypeDef, exportCompType, exportCompTypeDecl, exportCompTypeRef, exportEnumType, exportEnumTypeDecl, exportEnumTypeRef, ) where import Language.C.Data.Ident import Language.C.Data.Name (nameId) import Language.C.Data.Node import Language.C.Syntax.AST import Language.C.Analysis.SemRep import Data.Maybe -- |Export Declarator -- -- Synopsis: @exportDeclr other_specs type attributes variable-name@ exportDeclr :: [CDeclSpec] -> Type -> Attributes -> VarName -> ([CDeclSpec],CDeclr) exportDeclr other_specs ty attrs name = (other_specs ++ specs, CDeclr ident derived asmname (exportAttrs attrs) ni) where (specs,derived) = exportType ty (ident,asmname) = case name of (VarName vident asmname_opt) -> (Just vident, asmname_opt) _ -> (Nothing,Nothing) exportTypeDecl :: Type -> CDecl exportTypeDecl ty = CDecl declspecs declrs ni where (declspecs,derived) = exportType ty declrs | null derived = [] | otherwise = [(Just $ CDeclr Nothing derived Nothing [] ni,Nothing,Nothing)] exportTypeDef :: TypeDef -> CDecl exportTypeDef (TypeDef ident ty attrs node_info) = CDecl (CStorageSpec (CTypedef ni) : declspecs) [declr] node_info where (declspecs,derived) = exportType ty declr = (Just $ CDeclr (Just ident) derived Nothing (exportAttrs attrs) ni, Nothing, Nothing) -- |Export a type to syntax exportType :: Type -> ([CDeclSpec],[CDerivedDeclr]) exportType ty = exportTy [] ty where exportTy dd (PtrType ity tyquals attrs) = let ptr_declr = CPtrDeclr (exportTypeQualsAttrs tyquals attrs) ni in exportTy (ptr_declr : dd) ity exportTy dd (ArrayType ity array_sz tyquals attrs) = let arr_declr = CArrDeclr (exportTypeQualsAttrs tyquals attrs) (exportArraySize array_sz) ni in exportTy (arr_declr : dd) ity exportTy dd (FunctionType (FunType ity params variadic) attrs) = let fun_declr = CFunDeclr (Right (map exportParamDecl params,variadic)) (exportAttrs attrs) ni in exportTy (fun_declr : dd) ity exportTy dd (FunctionType (FunTypeIncomplete ity) attrs) = let fun_declr = CFunDeclr (Right ([],False)) (exportAttrs attrs) ni in exportTy (fun_declr : dd) ity exportTy dd (TypeDefType (TypeDefRef ty_ident _ node) quals attrs) = let declspecs = [CTypeSpec (CTypeDef ty_ident node)] ++ map CTypeQual (exportTypeQualsAttrs quals attrs) in (declspecs, reverse dd) exportTy dd (DirectType ity quals attrs) = let declspecs = map CTypeQual (exportTypeQualsAttrs quals attrs) ++ map CTypeSpec (exportTypeSpec ity) in (declspecs, reverse dd) exportTypeQuals :: TypeQuals -> [CTypeQual] exportTypeQuals quals = mapMaybe select [(constant,CConstQual ni),(volatile,CVolatQual ni),(restrict,CRestrQual ni)] where select (predicate,tyqual) | predicate quals = Just tyqual | otherwise = Nothing exportTypeQualsAttrs :: TypeQuals -> Attributes -> [CTypeQual] exportTypeQualsAttrs tyqs attrs = (exportTypeQuals tyqs ++ map CAttrQual (exportAttrs attrs)) exportArraySize :: ArraySize -> CArrSize exportArraySize (ArraySize static e) = CArrSize static e exportArraySize (UnknownArraySize complete) = CNoArrSize complete exportTypeSpec :: TypeName -> [CTypeSpec] exportTypeSpec tyname = case tyname of TyVoid -> [CVoidType ni] TyIntegral ity -> exportIntType ity TyFloating fty -> exportFloatType fty TyComplex fty -> exportComplexType fty TyComp comp -> exportCompTypeDecl comp TyEnum enum -> exportEnumTypeDecl enum TyBuiltin TyVaList -> [CTypeDef (internalIdent "va_list") ni] TyBuiltin TyAny -> [CTypeDef (internalIdent "__ty_any") ni] exportIntType :: IntType -> [CTypeSpec] exportIntType ty = case ty of TyBool -> [CBoolType ni] TyChar -> [CCharType ni] TySChar -> [CSignedType ni,CCharType ni] TyUChar -> [CUnsigType ni,CCharType ni] TyShort -> [CShortType ni] TyUShort -> [CUnsigType ni, CShortType ni] TyInt -> [CIntType ni] TyUInt -> [CUnsigType ni, CIntType ni] TyLong -> [CLongType ni] TyULong -> [CUnsigType ni,CLongType ni] TyLLong -> [CLongType ni, CLongType ni] TyULLong -> [CUnsigType ni, CLongType ni, CLongType ni] exportFloatType :: FloatType -> [CTypeSpec] exportFloatType ty = case ty of TyFloat -> [CFloatType ni] TyDouble -> [CDoubleType ni] TyLDouble -> [CLongType ni, CDoubleType ni] exportComplexType :: FloatType -> [CTypeSpec] exportComplexType ty = (CComplexType ni) : exportFloatType ty exportCompTypeDecl :: CompTypeRef -> [CTypeSpec] exportCompTypeDecl ty = [CSUType (exportComp ty) ni] where exportComp (CompTypeRef sue_ref comp_tag _n) = CStruct (if comp_tag == StructTag then CStructTag else CUnionTag) (exportSUERef sue_ref) Nothing [] ni exportEnumTypeDecl :: EnumTypeRef -> [CTypeSpec] exportEnumTypeDecl ty = [CEnumType (exportEnum ty) ni] where exportEnum (EnumTypeRef sue_ref _n) = CEnum (exportSUERef sue_ref) Nothing [] ni exportCompType :: CompType -> [CTypeSpec] exportCompType (CompType sue_ref comp_tag members attrs node_info) = [CSUType comp ni] where comp = CStruct (if comp_tag == StructTag then CStructTag else CUnionTag) (exportSUERef sue_ref) (Just (map exportMemberDecl members)) (exportAttrs attrs) node_info exportCompTypeRef :: CompType -> [CTypeSpec] exportCompTypeRef (CompType sue_ref com_tag _ _ node_info) = exportCompTypeDecl (CompTypeRef sue_ref com_tag node_info) exportEnumType :: EnumType -> [CTypeSpec] exportEnumType (EnumType sue_ref enumerators attrs node_info) = [CEnumType enum ni] where enum = CEnum (exportSUERef sue_ref) (Just (map exportEnumerator enumerators)) (exportAttrs attrs) node_info exportEnumerator (Enumerator ident val _ty _) = (ident,Just val) exportEnumTypeRef :: EnumType -> [CTypeSpec] exportEnumTypeRef (EnumType sue_ref _ _ node_info) = exportEnumTypeDecl (EnumTypeRef sue_ref node_info) -- XXX: relies on a the source program not having any $'s in it exportSUERef :: SUERef -> Maybe Ident exportSUERef (AnonymousRef name) = Just (internalIdent $ "$" ++ show (nameId name)) exportSUERef (NamedRef ident) = Just ident exportMemberDecl :: MemberDecl -> CDecl exportMemberDecl (AnonBitField ty expr node_info) = CDecl (map CTypeSpec $ exportTypeSpec $ fromDirectType ty) [(Nothing,Nothing,Just expr)] node_info exportMemberDecl (MemberDecl vardecl bitfieldsz node_info) = let (specs,declarator) = exportVarDecl vardecl in CDecl specs [(Just declarator, Nothing, bitfieldsz)] node_info exportVarDecl :: VarDecl -> ([CDeclSpec],CDeclr) -- NOTE: that there is an ambiguity between two possible places for __attributes__ s here exportVarDecl (VarDecl name attrs ty) = exportDeclr (exportDeclAttrs attrs) ty [] name exportParamDecl :: ParamDecl -> CDecl exportParamDecl paramdecl = let (specs,declr) = exportVarDecl (getVarDecl paramdecl) in CDecl specs [(Just declr, Nothing , Nothing) ] (nodeInfo paramdecl) exportDeclAttrs :: DeclAttrs -> [CDeclSpec] exportDeclAttrs (DeclAttrs inline storage attrs) = (if inline then [CTypeQual (CInlineQual ni)] else []) ++ map (CStorageSpec) (exportStorage storage) ++ map (CTypeQual . CAttrQual) (exportAttrs attrs) -- | express storage in terms of storage specifiers. -- -- This isn't always possible and depends on the context the identifier is declared. -- Most importantly, if there is a /conflicting/ declaration in scope, export is impossible. -- Furthermore, automatic storage is impossible in file scope. -- If the storage can actually be specified, the export is correct. exportStorage :: Storage -> [CStorageSpec] exportStorage NoStorage = [] exportStorage (Auto reg) = if reg then [CRegister ni] else [] exportStorage (Static InternalLinkage thread_local) = threadLocal thread_local [CStatic ni] exportStorage (Static ExternalLinkage thread_local) = threadLocal thread_local [CExtern ni] exportStorage (Static NoLinkage _) = error "impossible storage: static without linkage" exportStorage (FunLinkage InternalLinkage) = [CStatic ni] exportStorage (FunLinkage ExternalLinkage) = [] exportStorage (FunLinkage NoLinkage) = error "impossible storage: function without linkage" threadLocal :: Bool -> [CStorageSpec] -> [CStorageSpec] threadLocal False = id threadLocal True = ((CThread ni) :) exportAttrs :: [Attr] -> [CAttr] exportAttrs = map exportAttr where exportAttr (Attr ident es n) = CAttr ident es n fromDirectType :: Type -> TypeName fromDirectType (DirectType ty _ _) = ty fromDirectType (TypeDefType (TypeDefRef _ ref _) _ _) = maybe (error "undefined typeDef") fromDirectType ref fromDirectType _ = error "fromDirectType" ni :: NodeInfo ni = undefNode language-c-0.4.7/src/Language/C/Analysis/NameSpaceMap.hs0000644000000000000000000001412712425376061021033 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis.NameSpaceMap -- Copyright : (c) [1995..1999] Manuel M. T. Chakravarty -- (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : alpha -- Portability : portable -- -- This module manages name spaces. -- -- * A name space map associates identifiers with their definition. -- -- * Each name space map is organized in a hierarchical way using the notion of -- scopes. A name space map, at any moment, always has a global scope and may -- have several local scopes. Definitions in inner scopes hide definitions -- of the same identifier in outer scopes. -- module Language.C.Analysis.NameSpaceMap ( -- * name space maps NameSpaceMap, nameSpaceMap, nsMapToList, globalNames,localNames,hasLocalNames, -- * scope modification defGlobal, enterNewScope, leaveScope, defLocal, lookupName,lookupGlobal,lookupInnermostScope, mergeNameSpace ) where import Prelude hiding (lookup) import qualified Prelude import qualified Data.Map as Map (empty, insert, lookup, toList, union) import qualified Data.List as List (unionBy) import Data.Map (Map) import Language.C.Data.Ident (Ident) {- C Namespaces and scopes: -} -- DevDocs: -- -- * the definitions in the global scope are stored in a finite map, because -- they tend to be a lot. -- -- * the definitions of the local scopes are stored in a single list, usually -- they are not very many and the definitions entered last are the most -- frequently accessed ones; the list structure naturally hides older -- definitions, i.e., definitions from outer scopes; adding new definitions -- is done in time proportinal to the current size of the scope; removing a -- scope is done in constant time (and the definitions of a scope can be -- returned as a result of leaving the scope); lookup is proportional to the -- number of definitions in the local scopes and the logarithm of the number -- of definitions in the global scope -- i.e., efficiency relies on a -- relatively low number of local definitions together with frequent lookup -- of the most recently defined local identifiers -- -- | @NameSpaceMap a@ is a Map from identifiers to @a@, which manages -- global and local name spaces. data NameSpaceMap k v = NsMap (Map k v) -- defs in global scope [[(k, v)]] -- stack of local scopes globalNames :: (Ord k) => NameSpaceMap k v -> Map k v globalNames (NsMap g _) = g hasLocalNames :: NameSpaceMap k v -> Bool hasLocalNames (NsMap _ l) = not (null l) localNames :: (Ord k) => NameSpaceMap k v -> [[(k,v)]] localNames (NsMap _ l) = l -- | create a name space nameSpaceMap :: (Ord k) => NameSpaceMap k v nameSpaceMap = NsMap Map.empty [] -- | Add global definition -- -- @(ns',oldDef) = defGlobal ns ident def@ -- adds a global definition @ident := def@ to the namespace. -- It returns the modified namespace @ns'@. If the identifier is -- already declared in the global namespace, the definition is overwritten -- and the old definition @oldDef@ is returned. defGlobal :: (Ord k) => NameSpaceMap k a -> k -> a -> (NameSpaceMap k a, Maybe a) defGlobal (NsMap gs lss) ident def = (NsMap (Map.insert ident def gs) lss, Map.lookup ident gs) -- | Enter new local scope -- -- @ns' = enterNewScope ns@ creates and enters a new local scope. enterNewScope :: (Ord k) => NameSpaceMap k a -> NameSpaceMap k a enterNewScope (NsMap gs lss) = NsMap gs ([]:lss) -- | Leave innermost local scope -- -- @(ns',defs) = leaveScope ns@ pops leaves the innermost local scope. -- and returns its definitions leaveScope :: (Ord k) => NameSpaceMap k a -> (NameSpaceMap k a, [(k, a)]) leaveScope (NsMap _ []) = error "NsMaps.leaveScope: No local scope!" leaveScope (NsMap gs (ls:lss)) = (NsMap gs lss, ls) -- | Add local definition -- -- @(ns',oldDef) = defLocal ns ident def@ adds the local definition -- @ident := def@ to the innermost local scope, if there is a local scope, -- and to the global scope otherwise. -- It returns the modified name space @ns'@ and the old binding of -- the identifier @oldDef@, which is overwritten. defLocal :: (Ord k) => NameSpaceMap k a -> k -> a -> (NameSpaceMap k a, Maybe a) defLocal ns@(NsMap _ []) ident def = defGlobal ns ident def defLocal (NsMap gs (ls:lss)) ident def = (NsMap gs (((ident, def):ls):lss), Prelude.lookup ident ls) -- | Search for a definition -- -- @def = find ns ident@ returns the definition in some scope (inner to outer), -- if there is one. lookupName :: (Ord k) => NameSpaceMap k a -> k -> Maybe a lookupName ns@(NsMap _ localDefs) ident = case (lookupLocal localDefs) of Nothing -> lookupGlobal ns ident Just def -> Just def where lookupLocal [] = Nothing lookupLocal (ls:lss) = case (Prelude.lookup ident ls) of Nothing -> lookupLocal lss Just def -> Just def lookupGlobal :: (Ord k) => NameSpaceMap k a -> k -> Maybe a lookupGlobal (NsMap gs _) ident = Map.lookup ident gs lookupInnermostScope :: (Ord k) => NameSpaceMap k a -> k -> Maybe a lookupInnermostScope nsm@(NsMap _gs localDefs) ident = case localDefs of (ls : _lss) -> Prelude.lookup ident ls [] -> lookupGlobal nsm ident -- | flatten a namespace into a assoc list -- -- @nameSpaceToList ns = (localDefInnermost ns ++ .. ++ localDefsOutermost ns) ++ globalDefs ns@ nsMapToList :: (Ord k) => NameSpaceMap k a -> [(k, a)] nsMapToList (NsMap gs lss) = concat lss ++ Map.toList gs -- | Merge two namespaces. If they disagree on the types of any -- variables, all bets are off. mergeNameSpace :: (Ord k) => NameSpaceMap k a -> NameSpaceMap k a -> NameSpaceMap k a mergeNameSpace (NsMap global1 local1) (NsMap global2 local2) = NsMap (Map.union global1 global2) (localUnion local1 local2) where localUnion (l1:ls1) (l2:ls2) = List.unionBy (\p1 p2 -> fst p1 == fst p2) l1 l2 : localUnion ls1 ls2 localUnion [] ls2 = ls2 localUnion ls1 [] = ls1 language-c-0.4.7/src/Language/C/Analysis/SemError.hs0000644000000000000000000001067312425376061020301 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis.SemError -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : alpha -- Portability : ghc -- -- Errors in the semantic analysis ----------------------------------------------------------------------------- module Language.C.Analysis.SemError ( InvalidASTError(..), invalidAST, BadSpecifierError(..), badSpecifierError, TypeMismatch(..), typeMismatch, RedefError(..), RedefInfo(..), RedefKind(..), redefinition, ) where import Data.Typeable -- this means we cannot use SemError in SemRep, but use rich types here import Language.C.Analysis.SemRep import Language.C.Data.Error import Language.C.Data.Node -- here are the errors available -- | InvalidASTError is caused by the violation of an invariant in the AST newtype InvalidASTError = InvalidAST ErrorInfo deriving (Typeable) instance Error InvalidASTError where errorInfo (InvalidAST ei) = ei changeErrorLevel (InvalidAST ei) lvl' = InvalidAST (changeErrorLevel ei lvl') -- | BadSpecifierError is caused by an invalid combination of specifiers newtype BadSpecifierError = BadSpecifierError ErrorInfo deriving (Typeable) instance Error BadSpecifierError where errorInfo (BadSpecifierError ei) = ei changeErrorLevel (BadSpecifierError ei) lvl' = BadSpecifierError (changeErrorLevel ei lvl') -- | RedefError is caused by an invalid redefinition of the same identifier or type data RedefError = RedefError ErrorLevel RedefInfo deriving Typeable data RedefInfo = RedefInfo String RedefKind NodeInfo NodeInfo data RedefKind = DuplicateDef | DiffKindRedecl | ShadowedDef | DisagreeLinkage | NoLinkageOld data TypeMismatch = TypeMismatch String (NodeInfo,Type) (NodeInfo,Type) deriving Typeable -- Invalid AST -- ~~~~~~~~~~~ instance Show InvalidASTError where show = showError "AST invariant violated" invalidAST :: NodeInfo -> String -> InvalidASTError invalidAST node_info msg = InvalidAST (mkErrorInfo LevelError msg node_info) -- Bad specifier (e.g. static for a parameter, or extern when there is an initializer) -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ instance Show BadSpecifierError where show = showError "Bad specifier" badSpecifierError :: NodeInfo -> String -> BadSpecifierError badSpecifierError node_info msg = BadSpecifierError (mkErrorInfo LevelError msg node_info) -- Type mismatch -- ~~~~~~~~~~~~~ typeMismatch :: String -> (NodeInfo, Type) -> (NodeInfo,Type) -> TypeMismatch typeMismatch = TypeMismatch instance Show TypeMismatch where show tm = showError "Type mismatch" (typeMismatchInfo tm) instance Error TypeMismatch where errorInfo = typeMismatchInfo typeMismatchInfo :: TypeMismatch -> ErrorInfo typeMismatchInfo (TypeMismatch reason (node1,_ty2) _t2) = ErrorInfo LevelError (posOfNode node1) [reason] -- Redefinitions -- ~~~~~~~~~~~~~ instance Show RedefError where show (RedefError lvl info) = showErrorInfo (redefErrLabel info) (redefErrorInfo lvl info) instance Error RedefError where errorInfo (RedefError lvl info) = redefErrorInfo lvl info changeErrorLevel (RedefError _lvl info) lvl' = RedefError lvl' info redefErrLabel :: RedefInfo -> String redefErrLabel (RedefInfo ident _ _ _) = ident ++ " redefined" redefErrorInfo :: ErrorLevel -> RedefInfo -> ErrorInfo redefErrorInfo lvl info@(RedefInfo _ _ node old_node) = ErrorInfo lvl (posOfNode node) ([redefErrReason info] ++ prevDeclMsg old_node) redefErrReason :: RedefInfo -> String redefErrReason (RedefInfo ident DuplicateDef _ _) = "duplicate definition of " ++ ident redefErrReason (RedefInfo ident ShadowedDef _ _) = "this declaration of " ++ ident ++ " shadows a previous one" redefErrReason (RedefInfo ident DiffKindRedecl _ _) = ident ++ " previously declared as a different kind of symbol" redefErrReason (RedefInfo ident DisagreeLinkage _ _) = ident ++ " previously declared with different linkage" redefErrReason (RedefInfo ident NoLinkageOld _ _) = ident ++ " previously declared without linkage" prevDeclMsg :: NodeInfo -> [String] prevDeclMsg old_node = ["The previous declaration was here: ", show (posOfNode old_node)] redefinition :: ErrorLevel -> String -> RedefKind -> NodeInfo -> NodeInfo -> RedefError redefinition lvl ctx kind new old = RedefError lvl (RedefInfo ctx kind new old) language-c-0.4.7/src/Language/C/Analysis/SemRep.hs0000644000000000000000000005510612425376061017736 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis.Syntax -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : alpha -- Portability : ghc -- -- This module contains definitions for representing C translation units. -- In contrast to 'Language.C.Syntax.AST', the representation tries to express the semantics of -- of a translation unit. --------------------------------------------------------------------------------------------------- module Language.C.Analysis.SemRep( -- * Sums of tags and identifiers TagDef(..),typeOfTagDef, Declaration(..),declIdent,declName,declType,declAttrs, IdentDecl(..),objKindDescr, splitIdentDecls, -- * Global definitions GlobalDecls(..),emptyGlobalDecls,filterGlobalDecls,mergeGlobalDecls, -- * Events for visitors DeclEvent(..), -- * Declarations and definitions Decl(..), ObjDef(..),isTentative, FunDef(..), ParamDecl(..),MemberDecl(..), TypeDef(..),identOfTypeDef, VarDecl(..), -- * Declaration attributes DeclAttrs(..),isExtDecl, Storage(..),declStorage,ThreadLocal,Register, Linkage(..),hasLinkage,declLinkage, -- * Types Type(..), FunType(..), ArraySize(..), TypeDefRef(..), TypeName(..),BuiltinType(..), IntType(..),FloatType(..), HasSUERef(..),HasCompTyKind(..), CompTypeRef(..),CompType(..),typeOfCompDef,CompTyKind(..), EnumTypeRef(..),EnumType(..),typeOfEnumDef, Enumerator(..), TypeQuals(..),noTypeQuals,mergeTypeQuals, -- * Variable names VarName(..),identOfVarName,isNoName,AsmName, -- * Attributes (STUB, not yet analyzed) Attr(..),Attributes,noAttributes,mergeAttributes, -- * Statements and Expressions (STUB, aliases to Syntax) Stmt,Expr,Initializer,AsmBlock, ) where import Language.C.Data import Language.C.Syntax import Language.C.Syntax.Constants import Data.Map (Map) import qualified Data.Map as Map import Data.Generics import Text.PrettyPrint.HughesPJ -- | accessor class : struct\/union\/enum names class HasSUERef a where sueRef :: a -> SUERef -- | accessor class : composite type tags (struct or union) class HasCompTyKind a where compTag :: a -> CompTyKind -- | Composite type definitions (tags) data TagDef = CompDef CompType --definition | EnumDef EnumType -- enum definition deriving (Typeable, Data {-! ,CNode !-}) instance HasSUERef TagDef where sueRef (CompDef ct) = sueRef ct sueRef (EnumDef et) = sueRef et -- | return the type corresponding to a tag definition typeOfTagDef :: TagDef -> TypeName typeOfTagDef (CompDef comptype) = typeOfCompDef comptype typeOfTagDef (EnumDef enumtype) = typeOfEnumDef enumtype -- | All datatypes aggregating a declaration are instances of @Declaration@ class Declaration n where -- | get the name, type and declaration attributes of a declaration or definition getVarDecl :: n -> VarDecl -- | get the declaration corresponding to a definition declOfDef :: (Declaration n, CNode n) => n -> Decl declOfDef def = let vd = getVarDecl def in Decl vd (nodeInfo def) -- | get the variable identifier of a declaration (only safe if the -- the declaration is known to have a name) declIdent :: (Declaration n) => n -> Ident declIdent = identOfVarName . declName -- | get the variable name of a @Declaration@ declName :: (Declaration n) => n -> VarName declName = (\(VarDecl n _ _) -> n) . getVarDecl -- | get the type of a @Declaration@ declType :: (Declaration n) => n -> Type declType = (\(VarDecl _ _ ty) -> ty) . getVarDecl -- | get the declaration attributes of a @Declaration@ declAttrs :: (Declaration n) => n -> DeclAttrs declAttrs = (\(VarDecl _ specs _) -> specs) . getVarDecl instance (Declaration a, Declaration b) => Declaration (Either a b) where getVarDecl = either getVarDecl getVarDecl -- | identifiers, typedefs and enumeration constants (namespace sum) data IdentDecl = Declaration Decl -- ^ object or function declaration | ObjectDef ObjDef -- ^ object definition | FunctionDef FunDef -- ^ function definition | EnumeratorDef Enumerator -- ^ definition of an enumerator deriving (Typeable, Data {-! ,CNode !-}) instance Declaration IdentDecl where getVarDecl (Declaration decl) = getVarDecl decl getVarDecl (ObjectDef def) = getVarDecl def getVarDecl (FunctionDef def) = getVarDecl def getVarDecl (EnumeratorDef def) = getVarDecl def -- | textual description of the kind of an object objKindDescr :: IdentDecl -> String objKindDescr (Declaration _ ) = "declaration" objKindDescr (ObjectDef _) = "object definition" objKindDescr (FunctionDef _) = "function definition" objKindDescr (EnumeratorDef _) = "enumerator definition" -- | @splitIdentDecls includeAllDecls@ splits a map of object, function and enumerator declarations and definitions into one map -- holding declarations, and three maps for object definitions, enumerator definitions and function definitions. -- If @includeAllDecls@ is @True@ all declarations are present in the first map, otherwise only those where no corresponding definition -- is available. splitIdentDecls :: Bool -> Map Ident IdentDecl -> (Map Ident Decl, ( Map Ident Enumerator, Map Ident ObjDef, Map Ident FunDef ) ) splitIdentDecls include_all = Map.foldWithKey (if include_all then deal else deal') (Map.empty,(Map.empty,Map.empty,Map.empty)) where deal ident entry (decls,defs) = (Map.insert ident (declOfDef entry) decls, addDef ident entry defs) deal' ident (Declaration d) (decls,defs) = (Map.insert ident d decls,defs) deal' ident def (decls,defs) = (decls, addDef ident def defs) addDef ident entry (es,os,fs) = case entry of Declaration _ -> (es,os,fs) EnumeratorDef e -> (Map.insert ident e es,os,fs) ObjectDef o -> (es,Map.insert ident o os,fs) FunctionDef f -> (es, os,Map.insert ident f fs) -- | global declaration\/definition table returned by the analysis data GlobalDecls = GlobalDecls { gObjs :: Map Ident IdentDecl, gTags :: Map SUERef TagDef, gTypeDefs :: Map Ident TypeDef } -- | empty global declaration table emptyGlobalDecls :: GlobalDecls emptyGlobalDecls = GlobalDecls Map.empty Map.empty Map.empty -- | filter global declarations filterGlobalDecls :: (DeclEvent -> Bool) -> GlobalDecls -> GlobalDecls filterGlobalDecls decl_filter gmap = GlobalDecls { gObjs = Map.filter (decl_filter . DeclEvent) (gObjs gmap), gTags = Map.filter (decl_filter . TagEvent) (gTags gmap), gTypeDefs = Map.filter (decl_filter . TypeDefEvent) (gTypeDefs gmap) } -- | merge global declarations mergeGlobalDecls :: GlobalDecls -> GlobalDecls -> GlobalDecls mergeGlobalDecls gmap1 gmap2 = GlobalDecls { gObjs = Map.union (gObjs gmap1) (gObjs gmap2), gTags = Map.union (gTags gmap1) (gTags gmap2), gTypeDefs = Map.union (gTypeDefs gmap1) (gTypeDefs gmap2) } -- * Events -- | Declaration events -- -- Those events are reported to callbacks, which are executed during the traversal. data DeclEvent = TagEvent TagDef -- ^ file-scope struct\/union\/enum event | DeclEvent IdentDecl -- ^ file-scope declaration or definition | ParamEvent ParamDecl -- ^ parameter declaration | LocalEvent IdentDecl -- ^ local variable declaration or definition | TypeDefEvent TypeDef -- ^ a type definition | AsmEvent AsmBlock -- ^ assembler block deriving ({-! CNode !-}) -- * Declarations and definitions -- | Declarations, which aren't definitions data Decl = Decl VarDecl NodeInfo deriving (Typeable, Data {-! ,CNode !-}) instance Declaration Decl where getVarDecl (Decl vd _) = vd -- | Object Definitions -- -- An object definition is a declaration together with an initializer. -- -- If the initializer is missing, it is a tentative definition, i.e. a -- definition which might be overriden later on. data ObjDef = ObjDef VarDecl (Maybe Initializer) NodeInfo deriving (Typeable, Data {-! ,CNode !-}) instance Declaration ObjDef where getVarDecl (ObjDef vd _ _) = vd -- | Returns @True@ if the given object definition is tentative. isTentative :: ObjDef -> Bool isTentative (ObjDef decl init_opt _) | isExtDecl decl = maybe True (const False) init_opt | otherwise = False -- | Function definitions -- -- A function definition is a declaration together with a statement (the function body). data FunDef = FunDef VarDecl Stmt NodeInfo deriving (Typeable, Data {-! ,CNode !-}) instance Declaration FunDef where getVarDecl (FunDef vd _ _) = vd -- | Parameter declaration data ParamDecl = ParamDecl VarDecl NodeInfo | AbstractParamDecl VarDecl NodeInfo deriving (Typeable, Data {-! ,CNode !-} ) instance Declaration ParamDecl where getVarDecl (ParamDecl vd _) = vd getVarDecl (AbstractParamDecl vd _) = vd -- | Struct\/Union member declaration data MemberDecl = MemberDecl VarDecl (Maybe Expr) NodeInfo -- ^ @MemberDecl vardecl bitfieldsize node@ | AnonBitField Type Expr NodeInfo -- ^ @AnonBitField typ size@ deriving (Typeable, Data {-! ,CNode !-} ) instance Declaration MemberDecl where getVarDecl (MemberDecl vd _ _) = vd getVarDecl (AnonBitField ty _ _) = VarDecl NoName (DeclAttrs False NoStorage []) ty -- | @typedef@ definitions. -- -- The identifier is a new name for the given type. data TypeDef = TypeDef Ident Type Attributes NodeInfo deriving (Typeable, Data {-! ,CNode !-} ) -- | return the idenitifier of a @typedef@ identOfTypeDef :: TypeDef -> Ident identOfTypeDef (TypeDef ide _ _ _) = ide -- | Generic variable declarations data VarDecl = VarDecl VarName DeclAttrs Type deriving (Typeable, Data) instance Declaration VarDecl where getVarDecl = id -- @isExtDecl d@ returns true if the declaration has /linkage/ isExtDecl :: (Declaration n) => n -> Bool isExtDecl = hasLinkage . declStorage -- | Declaration attributes of the form @DeclAttrs isInlineFunction storage linkage attrs@ -- -- They specify the storage and linkage of a declared object. data DeclAttrs = DeclAttrs Bool Storage Attributes -- ^ @DeclAttrs inline storage attrs@ deriving (Typeable, Data) -- | get the 'Storage' of a declaration declStorage :: (Declaration d) => d -> Storage declStorage d = case declAttrs d of (DeclAttrs _ st _) -> st -- In C we have -- Identifiers can either have internal, external or no linkage -- (same object everywhere, same object within the translation unit, unique). -- * top-level identifiers -- static : internal linkage (objects and function defs) -- extern : linkage of prior declaration (if specified), external linkage otherwise -- no-spec: external linkage -- * storage duration -- * static storage duration: objects with external or internal linkage, or local ones with the static keyword -- * automatic storage duration: otherwise (register) -- See http://publications.gbdirect.co.uk/c_book/chapter8/declarations_and_definitions.html, Table 8.1, 8.2 -- | Storage duration and linkage of a variable data Storage = NoStorage -- ^ no storage | Auto Register -- ^ automatic storage (optional: register) | Static Linkage ThreadLocal -- ^ static storage, linkage spec and thread local specifier (gnu c) | FunLinkage Linkage -- ^ function, either internal or external linkage deriving (Typeable, Data, Show, Eq, Ord) type ThreadLocal = Bool type Register = Bool -- | Linkage: Either no linkage, internal to the translation unit or external data Linkage = NoLinkage | InternalLinkage | ExternalLinkage deriving (Typeable, Data, Show, Eq, Ord) -- | return @True@ if the object has linkage hasLinkage :: Storage -> Bool hasLinkage (Auto _) = False hasLinkage (Static NoLinkage _) = False hasLinkage _ = True -- | Get the linkage of a definition declLinkage :: (Declaration d) => d -> Linkage declLinkage decl = case declStorage decl of NoStorage -> undefined Auto _ -> NoLinkage Static linkage _ -> linkage FunLinkage linkage -> linkage -- * types -- | types of C objects data Type = DirectType TypeName TypeQuals Attributes -- ^ a non-derived type | PtrType Type TypeQuals Attributes -- ^ pointer type | ArrayType Type ArraySize TypeQuals Attributes -- ^ array type | FunctionType FunType Attributes -- ^ function type | TypeDefType TypeDefRef TypeQuals Attributes -- ^ a defined type deriving (Typeable, Data) -- | Function types are of the form @FunType return-type params isVariadic@. -- -- If the parameter types aren't yet known, the function has type @FunTypeIncomplete type attrs@. data FunType = FunType Type [ParamDecl] Bool | FunTypeIncomplete Type deriving (Typeable, Data) -- | An array type may either have unknown size or a specified array size, the latter either variable or constant. -- Furthermore, when used as a function parameters, the size may be qualified as /static/. -- In a function prototype, the size may be `Unspecified variable size' (@[*]@). data ArraySize = UnknownArraySize Bool -- ^ @UnknownArraySize is-starred@ | ArraySize Bool Expr -- ^ @FixedSizeArray is-static size-expr@ deriving (Typeable, Data) -- | normalized type representation data TypeName = TyVoid | TyIntegral IntType | TyFloating FloatType | TyComplex FloatType | TyComp CompTypeRef | TyEnum EnumTypeRef | TyBuiltin BuiltinType deriving (Typeable, Data) -- | Builtin type (va_list, anything) data BuiltinType = TyVaList | TyAny deriving (Typeable, Data) -- | typdef references -- If the actual type is known, it is attached for convenience data TypeDefRef = TypeDefRef Ident (Maybe Type) NodeInfo deriving (Typeable, Data {-! ,CNode !-}) -- | integral types (C99 6.7.2.2) data IntType = TyBool | TyChar | TySChar | TyUChar | TyShort | TyUShort | TyInt | TyUInt | TyLong | TyULong | TyLLong | TyULLong deriving (Typeable, Data, Eq, Ord) instance Show IntType where show TyBool = "_Bool" show TyChar = "char" show TySChar = "signed char" show TyUChar = "unsigned char" show TyShort = "short" show TyUShort = "unsigned short" show TyInt = "int" show TyUInt = "unsigned int" show TyLong = "long" show TyULong = "unsigned long" show TyLLong = "long long" show TyULLong = "unsigned long long" -- | floating point type (C99 6.7.2.2) data FloatType = TyFloat | TyDouble | TyLDouble deriving (Typeable, Data, Eq, Ord) instance Show FloatType where show TyFloat = "float" show TyDouble = "double" show TyLDouble = "long double" -- | composite type declarations data CompTypeRef = CompTypeRef SUERef CompTyKind NodeInfo deriving (Typeable, Data {-! ,CNode !-}) instance HasSUERef CompTypeRef where sueRef (CompTypeRef ref _ _) = ref instance HasCompTyKind CompTypeRef where compTag (CompTypeRef _ tag _) = tag data EnumTypeRef = EnumTypeRef SUERef NodeInfo deriving (Typeable, Data {-! ,CNode !-}) instance HasSUERef EnumTypeRef where sueRef (EnumTypeRef ref _) = ref -- | Composite type (struct or union). data CompType = CompType SUERef CompTyKind [MemberDecl] Attributes NodeInfo deriving (Typeable, Data {-! ,CNode !-} ) instance HasSUERef CompType where sueRef (CompType ref _ _ _ _) = ref instance HasCompTyKind CompType where compTag (CompType _ tag _ _ _) = tag -- | return the type of a composite type definition typeOfCompDef :: CompType -> TypeName typeOfCompDef (CompType ref tag _ _ _) = TyComp (CompTypeRef ref tag undefNode) -- | a tag to determine wheter we refer to a @struct@ or @union@, see 'CompType'. data CompTyKind = StructTag | UnionTag deriving (Eq,Ord,Typeable,Data) instance Show CompTyKind where show StructTag = "struct" show UnionTag = "union" -- | Representation of C enumeration types data EnumType = EnumType SUERef [Enumerator] Attributes NodeInfo -- ^ @EnumType name enumeration-constants attrs node@ deriving (Typeable, Data {-! ,CNode !-} ) instance HasSUERef EnumType where sueRef (EnumType ref _ _ _) = ref -- | return the type of an enum definition typeOfEnumDef :: EnumType -> TypeName typeOfEnumDef (EnumType ref _ _ _) = TyEnum (EnumTypeRef ref undefNode) -- | An Enumerator consists of an identifier, a constant expressions and the link to its type data Enumerator = Enumerator Ident Expr EnumType NodeInfo deriving (Typeable, Data {-! ,CNode !-}) instance Declaration Enumerator where getVarDecl (Enumerator ide _ enumty _) = VarDecl (VarName ide Nothing) (DeclAttrs False NoStorage []) (DirectType (typeOfEnumDef enumty) noTypeQuals noAttributes) -- | Type qualifiers: constant, volatile and restrict data TypeQuals = TypeQuals { constant :: Bool, volatile :: Bool, restrict :: Bool } deriving (Typeable, Data) -- | no type qualifiers noTypeQuals :: TypeQuals noTypeQuals = TypeQuals False False False -- | merge (/&&/) two type qualifier sets mergeTypeQuals :: TypeQuals -> TypeQuals -> TypeQuals mergeTypeQuals (TypeQuals c1 v1 r1) (TypeQuals c2 v2 r2) = TypeQuals (c1 && c2) (v1 && v2) (r1 && r2) -- * initializers -- | 'Initializer' is currently an alias for 'CInit'. -- -- We're planning a normalized representation, but this depends on the implementation of -- constant expression evaluation type Initializer = CInit -- | Normalized C Initializers -- * If the expression has scalar type, the initializer is an expression -- * If the expression has struct type, the initializer is a map from designators to initializers -- * If the expression has array type, the initializer is a list of values -- Not implemented yet, as it depends on constant expression evaluation -- * names and attributes -- | @VarName name assembler-name@ is a name of an declared object data VarName = VarName Ident (Maybe AsmName) | NoName deriving (Typeable, Data) identOfVarName :: VarName -> Ident identOfVarName NoName = error "identOfVarName: NoName" identOfVarName (VarName ident _) = ident isNoName :: VarName -> Bool isNoName NoName = True isNoName _ = False -- | Top level assembler block (alias for @CStrLit@) type AsmBlock = CStrLit -- | Assembler name (alias for @CStrLit@) type AsmName = CStrLit -- | @__attribute__@ annotations -- -- Those are of the form @Attr attribute-name attribute-parameters@, -- and serve as generic properties of some syntax tree elements. -- -- Some examples: -- -- * labels can be attributed with /unused/ to indicate that their not used -- -- * struct definitions can be attributed with /packed/ to tell the compiler to use the most compact representation -- -- * declarations can be attributed with /deprecated/ -- -- * function declarations can be attributes with /noreturn/ to tell the compiler that the function will never return, -- -- * or with /const/ to indicate that it is a pure function -- -- /TODO/: ultimatively, we want to parse attributes and represent them in a typed way data Attr = Attr Ident [Expr] NodeInfo deriving (Typeable, Data {-! ,CNode !-}) type Attributes = [Attr] -- |Empty attribute list noAttributes :: Attributes noAttributes = [] -- |Merge attribute lists -- /TODO/: currently does not remove duplicates mergeAttributes :: Attributes -> Attributes -> Attributes mergeAttributes = (++) -- * statements and expressions (Type aliases) -- | 'Stmt' is an alias for 'CStat' (Syntax) type Stmt = CStat -- | 'Expr' is currently an alias for 'CExpr' (Syntax) type Expr = CExpr -- GENERATED START instance CNode TagDef where nodeInfo (CompDef d) = nodeInfo d nodeInfo (EnumDef d) = nodeInfo d instance Pos TagDef where posOf x = posOf (nodeInfo x) instance CNode IdentDecl where nodeInfo (Declaration d) = nodeInfo d nodeInfo (ObjectDef d) = nodeInfo d nodeInfo (FunctionDef d) = nodeInfo d nodeInfo (EnumeratorDef d) = nodeInfo d instance Pos IdentDecl where posOf x = posOf (nodeInfo x) instance CNode DeclEvent where nodeInfo (TagEvent d) = nodeInfo d nodeInfo (DeclEvent d) = nodeInfo d nodeInfo (ParamEvent d) = nodeInfo d nodeInfo (LocalEvent d) = nodeInfo d nodeInfo (TypeDefEvent d) = nodeInfo d nodeInfo (AsmEvent d) = nodeInfo d instance Pos DeclEvent where posOf x = posOf (nodeInfo x) instance CNode Decl where nodeInfo (Decl _ n) = n instance Pos Decl where posOf x = posOf (nodeInfo x) instance CNode ObjDef where nodeInfo (ObjDef _ _ n) = n instance Pos ObjDef where posOf x = posOf (nodeInfo x) instance CNode FunDef where nodeInfo (FunDef _ _ n) = n instance Pos FunDef where posOf x = posOf (nodeInfo x) instance CNode ParamDecl where nodeInfo (ParamDecl _ n) = n nodeInfo (AbstractParamDecl _ n) = n instance Pos ParamDecl where posOf x = posOf (nodeInfo x) instance CNode MemberDecl where nodeInfo (MemberDecl _ _ n) = n nodeInfo (AnonBitField _ _ n) = n instance Pos MemberDecl where posOf x = posOf (nodeInfo x) instance CNode TypeDef where nodeInfo (TypeDef _ _ _ n) = n instance Pos TypeDef where posOf x = posOf (nodeInfo x) instance CNode TypeDefRef where nodeInfo (TypeDefRef _ _ n) = n instance Pos TypeDefRef where posOf x = posOf (nodeInfo x) instance CNode CompTypeRef where nodeInfo (CompTypeRef _ _ n) = n instance Pos CompTypeRef where posOf x = posOf (nodeInfo x) instance CNode EnumTypeRef where nodeInfo (EnumTypeRef _ n) = n instance Pos EnumTypeRef where posOf x = posOf (nodeInfo x) instance CNode CompType where nodeInfo (CompType _ _ _ _ n) = n instance Pos CompType where posOf x = posOf (nodeInfo x) instance CNode EnumType where nodeInfo (EnumType _ _ _ n) = n instance Pos EnumType where posOf x = posOf (nodeInfo x) instance CNode Enumerator where nodeInfo (Enumerator _ _ _ n) = n instance Pos Enumerator where posOf x = posOf (nodeInfo x) instance CNode Attr where nodeInfo (Attr _ _ n) = n instance Pos Attr where posOf x = posOf (nodeInfo x) -- GENERATED STOP language-c-0.4.7/src/Language/C/Analysis/TravMonad.hs0000644000000000000000000004646512425376061020446 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts,FlexibleInstances, PatternGuards, RankNTypes, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis.TravMonad -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : alpha -- Portability : ghc -- -- Monad for Traversals of the C AST. -- -- For the traversal, we maintain a symboltable and need MonadError and unique -- name generation facilities. -- Furthermore, the user may provide callbacks to handle declarations and definitions. ----------------------------------------------------------------------------- module Language.C.Analysis.TravMonad ( -- * Name generation monad MonadName(..), -- * Symbol table monad MonadSymtab(..), -- * Specialized C error-handling monad MonadCError(..), -- * AST traversal monad MonadTrav(..), -- * Handling declarations handleTagDecl, handleTagDef, handleEnumeratorDef, handleTypeDef, handleObjectDef,handleFunDef,handleVarDecl,handleParamDecl, handleAsmBlock, -- * Symbol table scope modification enterPrototypeScope,leavePrototypeScope, enterFunctionScope,leaveFunctionScope, enterBlockScope,leaveBlockScope, -- * Symbol table lookup (delegate) lookupTypeDef, lookupObject, -- * Symbol table modification createSUERef, -- * Additional error handling facilities hadHardErrors,handleTravError,throwOnLeft, astError, warn, -- * Trav - default MonadTrav implementation Trav, runTrav,runTrav_, TravState,initTravState,withExtDeclHandler,modifyUserState,userState, getUserState, TravOptions(..),modifyOptions, travErrors, -- * Language options CLanguage(..), -- * Helpers mapMaybeM,maybeM,mapSndM,concatMapM, ) where import Language.C.Data import Language.C.Data.Ident import Language.C.Data.RList as RList import Language.C.Syntax import Language.C.Analysis.Builtins import Language.C.Analysis.SemError import Language.C.Analysis.SemRep import Language.C.Analysis.DefTable hiding (enterBlockScope,leaveBlockScope, enterFunctionScope,leaveFunctionScope) import qualified Language.C.Analysis.DefTable as ST import Data.IntMap (insert, lookup) import Data.Maybe import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap) import Prelude hiding (lookup) class (Monad m) => MonadName m where -- | unique name generation genName :: m Name class (Monad m) => MonadSymtab m where -- symbol table handling -- | return the definition table getDefTable :: m DefTable -- | perform an action modifying the definition table withDefTable :: (DefTable -> (a, DefTable)) -> m a class (Monad m) => MonadCError m where -- error handling facilities -- | throw an 'Error' throwTravError :: Error e => e -> m a -- | catch an 'Error' (we could implement dynamically-typed catch here) catchTravError :: m a -> (CError -> m a) -> m a -- | remember that an 'Error' occurred (without throwing it) recordError :: Error e => e -> m () -- | return the list of recorded errors getErrors :: m [CError] -- | Traversal monad class (MonadName m, MonadSymtab m, MonadCError m) => MonadTrav m where -- | handling declarations and definitions handleDecl :: DeclEvent -> m () -- * handling declarations -- check wheter a redefinition is ok checkRedef :: (MonadCError m, CNode t, CNode t1) => String -> t -> (DeclarationStatus t1) -> m () checkRedef subject new_decl redecl_status = case redecl_status of NewDecl -> return () Redeclared old_def -> throwTravError $ redefinition LevelError subject DuplicateDef (nodeInfo new_decl) (nodeInfo old_def) KindMismatch old_def -> throwTravError $ redefinition LevelError subject DiffKindRedecl (nodeInfo new_decl) (nodeInfo old_def) Shadowed _old_def -> return () -- warn $ -- redefinition LevelWarn subject ShadowedDef (nodeInfo new_decl) (nodeInfo old_def) KeepDef _old_def -> return () -- | forward declaration of a tag. Only necessary for name analysis, but otherwise no semantic -- consequences. handleTagDecl :: (MonadCError m, MonadSymtab m) => TagFwdDecl -> m () handleTagDecl decl = do redecl <- withDefTable $ declareTag (sueRef decl) decl checkRedef (show $ sueRef decl) decl redecl -- | define the given composite type or enumeration -- If there is a declaration visible, overwrite it with the definition. -- Otherwise, enter a new definition in the current namespace. -- If there is already a definition present, yield an error (redeclaration). handleTagDef :: (MonadTrav m) => TagDef -> m () handleTagDef def = do redecl <- withDefTable $ defineTag (sueRef def) def checkRedef (show $ sueRef def) def redecl handleDecl (TagEvent def) handleEnumeratorDef :: (MonadCError m, MonadSymtab m) => Enumerator -> m () handleEnumeratorDef enumerator = do let ident = declIdent enumerator redecl <- withDefTable $ defineScopedIdent ident (EnumeratorDef enumerator) checkRedef (show ident) ident redecl return () handleTypeDef :: (MonadTrav m) => TypeDef -> m () handleTypeDef typeDef@(TypeDef ident _ _ _) = do redecl <- withDefTable $ defineTypeDef ident typeDef checkRedef (show ident) typeDef redecl handleDecl (TypeDefEvent typeDef) return () handleAsmBlock :: (MonadTrav m) => AsmBlock -> m () handleAsmBlock asm = handleDecl (AsmEvent asm) redefErr :: (MonadCError m, CNode old, CNode new) => Ident -> ErrorLevel -> new -> old -> RedefKind -> m () redefErr name lvl new old kind = throwTravError $ redefinition lvl (show name) kind (nodeInfo new) (nodeInfo old) -- TODO: unused checkIdentTyRedef :: (MonadCError m) => IdentEntry -> (DeclarationStatus IdentEntry) -> m () checkIdentTyRedef (Right decl) status = checkVarRedef decl status checkIdentTyRedef (Left tydef) (KindMismatch old_def) = redefErr (identOfTypeDef tydef) LevelError tydef old_def DiffKindRedecl checkIdentTyRedef (Left tydef) (Redeclared old_def) = redefErr (identOfTypeDef tydef) LevelError tydef old_def DuplicateDef checkIdentTyRedef (Left _tydef) _ = return () -- Check whether it is ok to declare a variable already in scope checkVarRedef :: (MonadCError m) => IdentDecl -> (DeclarationStatus IdentEntry) -> m () checkVarRedef def redecl = case redecl of -- always an error KindMismatch old_def -> redefVarErr old_def DiffKindRedecl -- Declaration referencing definition: -- * new entry has to be a declaration -- * old entry and new entry have to have linkage and agree on linkage -- * types have to match KeepDef (Right old_def) | not (agreeOnLinkage def old_def) -> linkageErr def old_def | otherwise -> throwOnLeft $ checkCompatibleTypes new_ty (declType old_def) -- redefinition: -- * old entry has to be a declaration or tentative definition -- * old entry and new entry have to have linkage and agree on linkage -- * types have to match Redeclared (Right old_def) | not (agreeOnLinkage def old_def) -> linkageErr def old_def | not(canBeOverwritten old_def) -> redefVarErr old_def DuplicateDef | otherwise -> throwOnLeft $ checkCompatibleTypes new_ty (declType old_def) -- NewDecl/Shadowed is ok _ -> return () where redefVarErr old_def kind = redefErr (declIdent def) LevelError def old_def kind linkageErr def old_def = case (declLinkage def, declLinkage old_def) of (NoLinkage, _) -> redefErr (declIdent def) LevelError def old_def NoLinkageOld otherwise -> redefErr (declIdent def) LevelError def old_def DisagreeLinkage new_ty = declType def canBeOverwritten (Declaration _) = True canBeOverwritten (ObjectDef od) = isTentative od canBeOverwritten _ = False agreeOnLinkage def old_def | declStorage old_def == FunLinkage InternalLinkage = True | not (hasLinkage $ declStorage def) || not (hasLinkage $ declStorage old_def) = False | (declLinkage def) /= (declLinkage old_def) = False | otherwise = True -- | handle variable declarations (external object declarations and function prototypes) -- variable declarations are either function prototypes, or external declarations, and not very -- interesting on their own. we only put them in the symbol table and call the handle. -- declarations never override definitions handleVarDecl :: (MonadTrav m) => Bool -> Decl -> m () handleVarDecl is_local decl = do def <- enterDecl decl (const False) handleDecl ((if is_local then LocalEvent else DeclEvent) def) -- | handle parameter declaration. The interesting part is that parameters can be abstract -- (if they are part of a type). If they have a name, we enter the name (usually in function prototype or function scope), -- checking if there are duplicate definitions. -- FIXME: I think it would be more transparent to handle parameter declarations in a special way handleParamDecl :: (MonadTrav m) => ParamDecl -> m () handleParamDecl pd@(AbstractParamDecl _ _) = handleDecl (ParamEvent pd) handleParamDecl pd@(ParamDecl vardecl node) = do let def = ObjectDef (ObjDef vardecl Nothing node) redecl <- withDefTable $ defineScopedIdent (declIdent def) def checkVarRedef def redecl handleDecl (ParamEvent pd) -- shared impl enterDecl :: (MonadCError m, MonadSymtab m) => Decl -> (IdentDecl -> Bool) -> m IdentDecl enterDecl decl cond = do let def = Declaration decl redecl <- withDefTable $ defineScopedIdentWhen cond (declIdent def) def checkVarRedef def redecl return def -- | handle function definitions handleFunDef :: (MonadTrav m) => Ident -> FunDef -> m () handleFunDef ident fun_def = do let def = FunctionDef fun_def redecl <- withDefTable $ defineScopedIdentWhen isDeclaration ident def checkVarRedef def redecl handleDecl (DeclEvent def) isDeclaration :: IdentDecl -> Bool isDeclaration (Declaration _) = True isDeclaration _ = False checkCompatibleTypes :: Type -> Type -> Either TypeMismatch () checkCompatibleTypes _ _ = Right () -- | handle object defintions (maybe tentative) handleObjectDef :: (MonadTrav m) => Bool -> Ident -> ObjDef -> m () handleObjectDef local ident obj_def = do let def = ObjectDef obj_def redecl <- withDefTable $ defineScopedIdentWhen (\old -> shouldOverride def old) ident def checkVarRedef def redecl handleDecl ((if local then LocalEvent else DeclEvent) def) where isTentativeDef (ObjectDef object_def) = isTentative object_def isTentativeDef _ = False shouldOverride def old | isDeclaration old = True | not (isTentativeDef def) = True | isTentativeDef old = True | otherwise = False -- * scope manipulation -- -- * file scope: outside of parameter lists and blocks (outermost) -- -- * function prototype scope -- -- * function scope: labels are visible within the entire function, and declared implicitely -- -- * block scope updDefTable :: (MonadSymtab m) => (DefTable -> DefTable) -> m () updDefTable f = withDefTable (\st -> ((),f st)) enterPrototypeScope :: (MonadSymtab m) => m () enterPrototypeScope = updDefTable (ST.enterBlockScope) leavePrototypeScope :: (MonadSymtab m) => m () leavePrototypeScope = updDefTable (ST.leaveBlockScope) enterFunctionScope :: (MonadSymtab m) => m () enterFunctionScope = updDefTable (ST.enterFunctionScope) leaveFunctionScope :: (MonadSymtab m) => m () leaveFunctionScope = updDefTable (ST.leaveFunctionScope) enterBlockScope :: (MonadSymtab m) => m () enterBlockScope = updDefTable (ST.enterBlockScope) leaveBlockScope :: (MonadSymtab m) => m () leaveBlockScope = updDefTable (ST.leaveBlockScope) -- * Lookup -- | lookup a type definition -- the 'wrong kind of object' is an internal error here, -- because the parser should distinguish typeDefs and other -- objects lookupTypeDef :: (MonadCError m, MonadSymtab m) => Ident -> m Type lookupTypeDef ident = getDefTable >>= \symt -> case lookupIdent ident symt of Nothing -> astError (nodeInfo ident) $ "unbound typeDef: " ++ identToString ident Just (Left (TypeDef def_ident ty _ _)) -> addRef ident def_ident >> return ty Just (Right d) -> astError (nodeInfo ident) (wrongKindErrMsg d) where wrongKindErrMsg d = "wrong kind of object: expected typedef but found "++ (objKindDescr d) ++ " (for identifier `" ++ identToString ident ++ "')" -- | lookup an object, function or enumerator lookupObject :: (MonadCError m, MonadSymtab m) => Ident -> m (Maybe IdentDecl) lookupObject ident = do old_decl <- liftM (lookupIdent ident) getDefTable mapMaybeM old_decl $ \obj -> case obj of Right objdef -> addRef ident objdef >> return objdef Left _tydef -> astError (nodeInfo ident) (mismatchErr "lookupObject" "an object" "a typeDef") -- | add link between use and definition (private) addRef :: (MonadCError m, MonadSymtab m, CNode u, CNode d) => u -> d -> m () addRef use def = case (nodeInfo use, nodeInfo def) of (NodeInfo _ _ useName, NodeInfo _ _ defName) -> withDefTable (\dt -> ((), dt { refTable = insert (nameId useName) defName (refTable dt) } ) ) (_, _) -> return () -- Don't have Names for both, so can't record. mismatchErr :: String -> String -> String -> String mismatchErr ctx expect found = ctx ++ ": Expected " ++ expect ++ ", but found: " ++ found -- * inserting declarations -- | create a reference to a struct\/union\/enum -- -- This currently depends on the fact the structs are tagged with unique names. -- We could use the name generation of TravMonad as well, which might be the better -- choice when dealing with autogenerated code. createSUERef :: (MonadCError m, MonadSymtab m) => NodeInfo -> Maybe Ident -> m SUERef createSUERef _node_info (Just ident) = return$ NamedRef ident createSUERef node_info Nothing | (Just name) <- nameOfNode node_info = return $ AnonymousRef name | otherwise = astError node_info "struct/union/enum definition without unique name" -- * error handling facilities handleTravError :: (MonadCError m) => m a -> m (Maybe a) handleTravError a = liftM Just a `catchTravError` (\e -> recordError e >> return Nothing) -- | check wheter non-recoverable errors occurred hadHardErrors :: [CError] -> Bool hadHardErrors = (not . null . filter isHardError) -- | raise an error caused by a malformed AST astError :: (MonadCError m) => NodeInfo -> String -> m a astError node msg = throwTravError $ invalidAST node msg -- | raise an error based on an Either argument throwOnLeft :: (MonadCError m, Error e) => Either e a -> m a throwOnLeft (Left err) = throwTravError err throwOnLeft (Right v) = return v warn :: (Error e, MonadCError m) => e -> m () warn err = recordError (changeErrorLevel err LevelWarn) -- * The Trav datatype -- | simple traversal monad, providing user state and callbacks newtype Trav s a = Trav { unTrav :: TravState s -> Either CError (a, TravState s) } modify :: (TravState s -> TravState s) -> Trav s () modify f = Trav (\s -> Right ((),f s)) gets :: (TravState s -> a) -> Trav s a gets f = Trav (\s -> Right (f s, s)) get :: Trav s (TravState s) get = Trav (\s -> Right (s,s)) put :: TravState s -> Trav s () put s = Trav (\_ -> Right ((),s)) runTrav :: forall s a. s -> Trav s a -> Either [CError] (a, TravState s) runTrav state traversal = case unTrav action (initTravState state) of Left trav_err -> Left [trav_err] Right (v, ts) | hadHardErrors (travErrors ts) -> Left (travErrors ts) | otherwise -> Right (v,ts) where action = do withDefTable (const ((), builtins)) traversal runTrav_ :: Trav () a -> Either [CError] (a,[CError]) runTrav_ t = fmap fst . runTrav () $ do r <- t es <- getErrors return (r,es) withExtDeclHandler :: Trav s a -> (DeclEvent -> Trav s ()) -> Trav s a withExtDeclHandler action handler = do modify $ \st -> st { doHandleExtDecl = handler } action instance Functor (Trav s) where fmap = liftM instance Applicative (Trav s) where pure = return (<*>) = ap instance Monad (Trav s) where return x = Trav (\s -> Right (x,s)) m >>= k = Trav (\s -> case unTrav m s of Right (x,s1) -> unTrav (k x) s1 Left e -> Left e) instance MonadName (Trav s) where -- unique name generation genName = generateName instance MonadSymtab (Trav s) where -- symbol table handling getDefTable = gets symbolTable withDefTable f = do ts <- get let (r,symt') = f (symbolTable ts) put $ ts { symbolTable = symt' } return r instance MonadCError (Trav s) where -- error handling facilities throwTravError e = Trav (\_ -> Left (toError e)) catchTravError a handler = Trav (\s -> case unTrav a s of Left e -> unTrav (handler e) s Right r -> Right r) recordError e = modify $ \st -> st { rerrors = (rerrors st) `snoc` toError e } getErrors = gets (RList.reverse . rerrors) instance MonadTrav (Trav s) where -- handling declarations and definitions handleDecl d = ($ d) =<< gets doHandleExtDecl -- | The variety of the C language to accept. Note: this is not yet enforced. data CLanguage = C89 | C99 | GNU89 | GNU99 data TravOptions = TravOptions { language :: CLanguage } data TravState s = TravState { symbolTable :: DefTable, rerrors :: RList CError, nameGenerator :: [Name], doHandleExtDecl :: (DeclEvent -> Trav s ()), userState :: s, options :: TravOptions } travErrors :: TravState s -> [CError] travErrors = RList.reverse . rerrors initTravState :: s -> TravState s initTravState userst = TravState { symbolTable = emptyDefTable, rerrors = RList.empty, nameGenerator = newNameSupply, doHandleExtDecl = const (return ()), userState = userst, options = TravOptions { language = C99 } } -- * Trav specific operations modifyUserState :: (s -> s) -> Trav s () modifyUserState f = modify $ \ts -> ts { userState = f (userState ts) } getUserState :: Trav s s getUserState = userState `liftM` get modifyOptions :: (TravOptions -> TravOptions) -> Trav s () modifyOptions f = modify $ \ts -> ts { options = f (options ts) } generateName :: Trav s Name generateName = get >>= \ts -> do let (new_name : gen') = nameGenerator ts put $ ts { nameGenerator = gen'} return new_name -- * helpers mapMaybeM :: (Monad m) => (Maybe a) -> (a -> m b) -> m (Maybe b) mapMaybeM m f = maybe (return Nothing) (liftM Just . f) m maybeM :: (Monad m) => (Maybe a) -> (a -> m ()) -> m () maybeM m f = maybe (return ()) f m mapSndM :: (Monad m) => (b -> m c) -> (a,b) -> m (a,c) mapSndM f (a,b) = liftM ((,) a) (f b) concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] concatMapM f = liftM concat . mapM f language-c-0.4.7/src/Language/C/Analysis/TypeCheck.hs0000644000000000000000000004753212425376061020426 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, CPP #-} module Language.C.Analysis.TypeCheck where import Control.Monad import Data.Either import Data.Maybe import Language.C.Data.Ident import Language.C.Data.Node import Language.C.Data.Position import Language.C.Pretty import Language.C.Syntax.AST import Language.C.Syntax.Constants import Language.C.Syntax.Ops import Language.C.Analysis.Debug import Language.C.Analysis.DefTable import Language.C.Analysis.SemRep import Language.C.Analysis.TravMonad import Language.C.Analysis.TypeConversions import Language.C.Analysis.TypeUtils import Text.PrettyPrint.HughesPJ -- We used to re-implement and export the standard Either instance for -- Monad, which is bad, because as of GHC 7 it is in Control.Monad.Instances -- in base >4.2. For backwards compatibility with ghc-6.X, we use CPP here. #if __GLASGOW_HASKELL__ < 700 instance Monad (Either String) where return = Right Left l >>= _ = Left l Right r >>= k = k r fail msg = Left msg #endif pType :: Type -> String pType = render . pretty typeErrorOnLeft :: (MonadCError m) => NodeInfo -> Either String a -> m a typeErrorOnLeft ni (Left err) = typeError ni err typeErrorOnLeft _ (Right v) = return v -- XXX: this should use a custom error type, but typeMismatch isn't always right typeError :: MonadCError m => NodeInfo -> String -> m a typeError = astError notFound :: Ident -> Either String a notFound i = Left $ "not found: " ++ identToString i checkScalar' :: MonadCError m => NodeInfo -> Type -> m () checkScalar' ni = typeErrorOnLeft ni . checkScalar checkIntegral' :: MonadCError m => NodeInfo -> Type -> m () checkIntegral' ni = typeErrorOnLeft ni . checkIntegral assignCompatible' :: MonadCError m => NodeInfo -> CAssignOp -> Type -> Type -> m () assignCompatible' ni op t1 t2 = typeErrorOnLeft ni (assignCompatible op t1 t2) binopType' :: MonadCError m => NodeInfo -> CBinaryOp -> Type -> Type -> m Type binopType' ni op t1 t2 = typeErrorOnLeft ni (binopType op t1 t2) conditionalType' :: MonadCError m => NodeInfo -> Type -> Type -> m Type conditionalType' ni t1 t2 = typeErrorOnLeft ni $ conditionalType t1 t2 checkScalar :: Type -> Either String () checkScalar t = case canonicalType t of DirectType _ _ _ -> return () PtrType _ _ _ -> return () ArrayType _ _ _ _ -> return () -- because it's just a pointer t' -> fail $ "expected scalar type, got: " ++ pType t ++ " (" ++ pType t' ++ ")" checkIntegral :: Type -> Either String () checkIntegral t | isIntegralType (canonicalType t) = return () | otherwise = fail $ "expected integral type, got: " ++ pType t ++ " (" ++ pType (canonicalType t) ++ ")" -- | Determine the type of a constant. constType :: (MonadCError m, MonadName m) => CConst -> m Type constType (CIntConst (CInteger _ _ flags) _) = return $ DirectType (TyIntegral (getIntType flags)) noTypeQuals noAttributes constType (CCharConst (CChar _ True) _) = return $ DirectType (TyIntegral TyInt) noTypeQuals noAttributes constType (CCharConst (CChar _ False) _) = return $ DirectType (TyIntegral TyChar) noTypeQuals noAttributes constType (CCharConst (CChars _ _) _) = return $ DirectType (TyIntegral TyInt) noTypeQuals noAttributes -- XXX constType (CFloatConst (CFloat fs) _) = return $ DirectType (TyFloating (getFloatType fs)) noTypeQuals noAttributes -- XXX: should strings have any type qualifiers or attributes? constType (CStrConst (CString chars wide) ni) = do n <- genName let charType | wide = TyInt -- XXX: this isn't universal | otherwise = TyChar ni' = mkNodeInfo (posOf ni) n arraySize = ArraySize True -- XXX: is it static? (CConst (CIntConst (cInteger (toInteger (length chars))) ni')) return $ ArrayType (DirectType (TyIntegral charType) noTypeQuals noAttributes) arraySize noTypeQuals [] -- | Determine whether two types are compatible. compatible :: Type -> Type -> Either String () compatible t1 t2 = compositeType t1 t2 >> return () -- | Determine the composite type of two compatible types. compositeType :: Type -> Type -> Either String Type compositeType t1 (DirectType (TyBuiltin TyAny) _ _) = return t1 compositeType (DirectType (TyBuiltin TyAny) _ _) t2 = return t2 compositeType t1@(DirectType tn1 q1 a1) t2@(DirectType tn2 q2 a2) = do tn <- case (tn1, tn2) of (TyVoid, TyVoid) -> return TyVoid (TyIntegral _, TyEnum _) -> return tn1 (TyEnum _, TyIntegral _) -> return tn2 (TyIntegral i1, TyIntegral i2) -> return $ TyIntegral (intConversion i1 i2) (TyFloating f1, TyFloating f2) -> return $ TyFloating (floatConversion f1 f2) (TyComplex f1, TyComplex f2) -> return $ TyComplex (floatConversion f1 f2) (TyComp c1, TyComp c2) -> do when (sueRef c1 /= sueRef c2) $ fail $ "incompatible composite types: " ++ pType t1 ++ ", " ++ pType t2 return tn1 (TyEnum e1, TyEnum e2) -> do when (sueRef e1 /= sueRef e2) $ fail $ "incompatible enumeration types: " ++ pType t1 ++ ", " ++ pType t2 return $ TyEnum e1 (TyBuiltin TyVaList, TyBuiltin TyVaList) -> return $ TyBuiltin TyVaList (TyBuiltin _, TyBuiltin _) -> fail $ "incompatible builtin types: " ++ pType t1 ++ ", " ++ pType t2 (_, _) -> fail $ "incompatible direct types: " ++ pType t1 ++ ", " ++ pType t2 return $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2) compositeType (PtrType t1 q1 a1) (PtrType (DirectType TyVoid _ _) q2 _) = return $ PtrType t1 (mergeTypeQuals q1 q2) a1 compositeType (PtrType (DirectType TyVoid _ _) q1 _) (PtrType t2 q2 a2) = return $ PtrType t2 (mergeTypeQuals q1 q2) a2 compositeType (PtrType t1 q1 a1) t2 | isIntegralType t2 = return $ PtrType t1 (mergeTypeQuals q1 (typeQuals t2)) a1 compositeType t1 (PtrType t2 q2 a2) | isIntegralType t1 = return $ PtrType t2 (mergeTypeQuals (typeQuals t1) q2) a2 compositeType (ArrayType t1 sz1 q1 a1) t2 | isIntegralType t2 = return $ PtrType t1 q1 a1 compositeType t1 (ArrayType t2 sz2 q2 a2) | isIntegralType t1 = return $ PtrType t2 q2 a2 compositeType (ArrayType t1 s1 q1 a1) (ArrayType t2 s2 q2 a2) = do t <- compositeType t1 t2 s <- compositeSize s1 s2 let quals = mergeTypeQuals q1 q2 attrs = mergeAttrs a1 a2 return (ArrayType t s quals attrs) compositeType t1 t2 | isPointerType t1 && isPointerType t2 = do t <- compositeType (baseType t1) (baseType t2) let quals = mergeTypeQuals (typeQuals t1) (typeQuals t2) attrs = mergeAttrs (typeAttrs t1) (typeAttrs t2) return (PtrType t quals attrs) compositeType (TypeDefType tdr1 q1 a1) (TypeDefType tdr2 q2 a2) = case (tdr1, tdr2) of (TypeDefRef i1 Nothing _, TypeDefRef i2 _ _) -> doTypeDef i1 i2 tdr1 (TypeDefRef i1 _ _, TypeDefRef i2 Nothing _) -> doTypeDef i1 i2 tdr2 (TypeDefRef _ (Just t1) _, TypeDefRef _ (Just t2) _) -> compositeType t1 t2 where doTypeDef i1 i2 tdr = do when (i1 /= i2) $ fail $ "incompatible typedef types: " ++ identToString i1 ++ ", " ++ identToString i2 return (TypeDefType tdr (mergeTypeQuals q1 q2) (mergeAttributes a1 a2)) compositeType (FunctionType ft1 attrs1) (FunctionType ft2 attrs2) = case (ft1, ft2) of (FunType rt1 args1 varargs1, FunType rt2 args2 varargs2) -> do {- when (length args1 /= length args2) $ fail "different numbers of arguments in function types" -} args <- mapM (uncurry compositeParamDecl) (zip args1 args2) when (varargs1 /= varargs2) $ fail "incompatible varargs declarations" doFunType rt1 rt2 args varargs1 (FunType rt1 args1 varargs1, FunTypeIncomplete rt2) -> doFunType rt1 rt2 args1 varargs1 (FunTypeIncomplete rt1, FunType rt2 args2 varargs2) -> doFunType rt1 rt2 args2 varargs2 (FunTypeIncomplete rt1, FunTypeIncomplete rt2) -> do rt <- compositeType rt1 rt2 return (FunctionType (FunTypeIncomplete rt) (mergeAttrs attrs1 attrs2)) where doFunType rt1 rt2 args varargs = do rt <- compositeType rt1 rt2 return (FunctionType (FunType rt args varargs) (mergeAttrs attrs1 attrs2)) compositeType t1 t2 = fail $ "incompatible types: " ++ pType t1 ++ ", " ++ pType t2 -- XXX: this may not be correct compositeSize :: ArraySize -> ArraySize -> Either String ArraySize compositeSize (UnknownArraySize _) s2 = return s2 compositeSize s1 (UnknownArraySize _) = return s1 compositeSize (ArraySize s1 e1) (ArraySize s2 e2) | s1 == s2 && sizeEqual e1 e2 = return $ ArraySize s1 e1 | otherwise = return $ ArraySize s1 e1 {- fail $ "incompatible array sizes: " ++ (render . pretty) e1 ++ ", " ++ (render . pretty) e2 -} sizeEqual :: CExpr -> CExpr -> Bool sizeEqual (CConst (CIntConst i1 _)) (CConst (CIntConst i2 _)) = i1 == i2 sizeEqual e1 e2 = nodeInfo e1 == nodeInfo e2 mergeAttrs :: Attributes -> Attributes -> Attributes mergeAttrs = (++) -- XXX: ultimately this should be smarter compositeParamDecl :: ParamDecl -> ParamDecl -> Either String ParamDecl compositeParamDecl (ParamDecl vd1 ni1) (ParamDecl vd2 _) = compositeParamDecl' ParamDecl vd1 vd2 ni1 compositeParamDecl (AbstractParamDecl vd1 _) (ParamDecl vd2 ni2) = compositeParamDecl' ParamDecl vd1 vd2 ni2 compositeParamDecl (ParamDecl vd1 ni1) (AbstractParamDecl vd2 _) = compositeParamDecl' ParamDecl vd1 vd2 ni1 compositeParamDecl (AbstractParamDecl vd1 ni1) (AbstractParamDecl vd2 _) = compositeParamDecl' AbstractParamDecl vd1 vd2 ni1 compositeParamDecl' :: (VarDecl -> NodeInfo -> ParamDecl) -> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl compositeParamDecl' f (VarDecl n1 attrs1 t1) (VarDecl n2 attrs2 t2) dni = do vd <- compositeVarDecl (VarDecl n1 attrs1 t1') (VarDecl n2 attrs2 t2') return $ f vd dni where t1' = canonicalType t1 t2' = canonicalType t2 compositeVarDecl :: VarDecl -> VarDecl -> Either String VarDecl compositeVarDecl (VarDecl n1 attrs1 t1) (VarDecl _ attrs2 t2) = do t <- compositeType t1 t2 return (VarDecl n1 (compositeDeclAttrs attrs1 attrs2) t) -- XXX: bad treatement of inline and storage compositeDeclAttrs :: DeclAttrs -> DeclAttrs -> DeclAttrs compositeDeclAttrs (DeclAttrs inl stor attrs1) (DeclAttrs _ _ attrs2) = DeclAttrs inl stor (mergeAttrs attrs1 attrs2) castCompatible :: Type -> Type -> Either String () castCompatible t1 t2 = case (canonicalType t1, canonicalType t2) of (DirectType TyVoid _ _, _) -> return () (_, _) -> checkScalar t1 >> checkScalar t2 -- | Determine whether two types are compatible in an assignment expression. assignCompatible :: CAssignOp -> Type -> Type -> Either String () assignCompatible CAssignOp t1 t2 = case (canonicalType t1, canonicalType t2) of (DirectType (TyBuiltin TyAny) _ _, _) -> return () (_, DirectType (TyBuiltin TyAny) _ _) -> return () -- XXX: check qualifiers (PtrType (DirectType TyVoid _ _) _ _, t2') | isPointerType t2' -> return () -- XXX: check qualifiers (t1', PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> return () (PtrType _ _ _, t2') | isIntegralType t2' -> return () (t1', t2') | isPointerType t1' && isPointerType t2' -> do compatible (baseType t1') (baseType t2') --unless (typeQuals t2 <= typeQuals t1) $ -- fail $ -- "incompatible qualifiers in pointer assignment: " -- ++ pType t1 ++ ", " ++ pType t2 (DirectType (TyComp c1) _ _, DirectType (TyComp c2) _ _) | sueRef c1 == sueRef c2 -> return () | otherwise -> fail $ "incompatible compound types in assignment: " ++ pType t1 ++ ", " ++ pType t2 (DirectType (TyBuiltin TyVaList) _ _, DirectType (TyBuiltin TyVaList) _ _) -> return () (DirectType tn1 _ _, DirectType tn2 _ _) | isJust (arithmeticConversion tn1 tn2) -> return () | otherwise -> fail $ "incompatible direct types in assignment: " ++ pType t1 ++ ", " ++ pType t2 (t1', t2') -> compatible t1' t2' assignCompatible op t1 t2 = binopType (assignBinop op) t1 t2 >> return () -- | Determine the type of a binary operation. binopType :: CBinaryOp -> Type -> Type -> Either String Type binopType op t1 t2 = case (op, canonicalType t1, canonicalType t2) of (_, t1', t2') | isLogicOp op -> checkScalar t1' >> checkScalar t2' >> return boolType | isCmpOp op -> case (t1', t2') of (DirectType tn1 _ _, DirectType tn2 _ _) -> case arithmeticConversion tn1 tn2 of Just _ -> return boolType Nothing -> fail "incompatible arithmetic types in comparison" (PtrType (DirectType TyVoid _ _) _ _, _) | isPointerType t2' -> return boolType (_, PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> return boolType (_, _) | isPointerType t1' && isIntegralType t2' -> return boolType | isIntegralType t1' && isPointerType t2' -> return boolType | isPointerType t1' && isPointerType t2' -> compatible t1' t2' >> return boolType (_, _) -> fail "incompatible types in comparison" (CSubOp, ArrayType t1' _ _ _, ArrayType t2' _ _ _) -> compatible t1' t2' >> return ptrDiffType (CSubOp, ArrayType t1' _ _ _, PtrType t2' _ _) -> compatible t1' t2' >> return ptrDiffType (CSubOp, PtrType t1' _ _, ArrayType t2' _ _ _) -> compatible t1' t2' >> return ptrDiffType (CSubOp, PtrType t1' _ _, PtrType t2' _ _) -> compatible t1' t2' >> return ptrDiffType (_, PtrType _ _ _, t2') | isPtrOp op && isIntegralType t2' -> return t1 | otherwise -> fail $ "invalid pointer operation: " ++ render (pretty op) (CAddOp, t1', PtrType _ _ _) | isIntegralType t1' -> return t2 (_, ArrayType _ _ _ _, t2') | isPtrOp op && isIntegralType t2' -> return t1 | otherwise -> fail $ "invalid pointer operation: " ++ render (pretty op) (CAddOp, t1', ArrayType _ _ _ _) | isIntegralType t1' -> return t2 (_, DirectType tn1 q1 a1, DirectType tn2 q2 a2) -> do when (isBitOp op) (checkIntegral t1 >> checkIntegral t2) case arithmeticConversion tn1 tn2 of Just tn -> return $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2) Nothing -> fail $ render $ text "invalid binary operation:" <+> pretty t1 <+> pretty op <+> pretty t2 (_, _, _) -> fail $ render $ text "unhandled binary operation:" <+> pretty t1 <+> pretty op <+> pretty t2 -- | Determine the type of a conditional expression. conditionalType :: Type -> Type -> Either String Type conditionalType t1 t2 = case (canonicalType t1, canonicalType t2) of (PtrType (DirectType TyVoid _ _) _ _, t2') | isPointerType t2' -> return t2 (t1', PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> return t1 (ArrayType t1' _ q1 a1, ArrayType t2' _ q2 a2) -> do t <- compositeType t1' t2' return $ ArrayType t (UnknownArraySize False) (mergeTypeQuals q1 q2) (mergeAttrs a1 a2) (t1'@(DirectType tn1 q1 a1), t2'@(DirectType tn2 q2 a2)) -> case arithmeticConversion tn1 tn2 of Just tn -> return $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2) Nothing -> compositeType t1' t2' (t1', t2') -> compositeType t1' t2' derefType :: Type -> Either String Type derefType (PtrType t _ _) = return t derefType (ArrayType t _ _ _) = return t derefType t = -- XXX: is it good to use canonicalType here? case canonicalType t of PtrType t' _ _ -> return t' ArrayType t' _ _ _ -> return t' _ -> fail $ "dereferencing non-pointer: " ++ pType t varAddrType :: IdentDecl -> Either String Type varAddrType d = do case declStorage d of Auto True -> fail "address of register variable" _ -> return () case t of ArrayType _ _ q a -> return $ PtrType t q a _ -> return $ simplePtr t where t = declType d -- | Get the type of field @m@ of type @t@ fieldType :: (MonadCError m, MonadSymtab m) => NodeInfo -> Ident -> Type -> m Type fieldType ni m t = case canonicalType t of DirectType (TyComp ctr) _ _ -> do td <- lookupSUE ni (sueRef ctr) ms <- tagMembers ni td case lookup m ms of Just ft -> return ft Nothing -> typeError ni $ "field not found: " ++ identToString m _t' -> astError ni $ "field of non-composite type: " ++ identToString m ++ ", " ++ pType t -- | Get all members of a struct, union, or enum, with their -- types. Collapse fields of anonymous members. tagMembers :: (MonadCError m, MonadSymtab m) => NodeInfo -> TagDef -> m [(Ident, Type)] tagMembers ni td = case td of CompDef (CompType _ _ ms _ _) -> getMembers ms EnumDef (EnumType _ es _ _) -> getMembers es where getMembers ds = do let ts = map declType ds ns = map declName ds concat `liftM` mapM (expandAnonymous ni) (zip ns ts) -- | Expand an anonymous composite type into a list of member names -- and their associated types. expandAnonymous :: (MonadCError m, MonadSymtab m) => NodeInfo -> (VarName, Type) -> m [(Ident, Type)] expandAnonymous ni (NoName, DirectType (TyComp ctr) _ _) = lookupSUE ni (sueRef ctr) >>= tagMembers ni expandAnonymous _ (NoName, _) = return [] expandAnonymous _ (VarName n _, t) = return [(n, t)] lookupSUE :: (MonadCError m, MonadSymtab m) => NodeInfo -> SUERef -> m TagDef lookupSUE ni sue = do dt <- getDefTable case lookupTag sue dt of Just (Right td) -> return td _ -> typeError ni $ "unknown composite type: " ++ (render . pretty) sue deepTypeAttrs :: (MonadCError m, MonadSymtab m) => Type -> m Attributes deepTypeAttrs (DirectType (TyComp (CompTypeRef sue _ ni)) _ attrs) = (attrs ++) `liftM` sueAttrs ni sue deepTypeAttrs (DirectType (TyEnum (EnumTypeRef sue ni)) _ attrs) = (attrs ++) `liftM` sueAttrs ni sue deepTypeAttrs (DirectType _ _ attrs) = return attrs deepTypeAttrs (PtrType t _ attrs) = (attrs ++) `liftM` deepTypeAttrs t deepTypeAttrs (ArrayType t _ _ attrs) = (attrs ++) `liftM` deepTypeAttrs t deepTypeAttrs (FunctionType (FunType t _ _) attrs) = (attrs ++) `liftM` deepTypeAttrs t deepTypeAttrs (FunctionType (FunTypeIncomplete t) attrs) = (attrs ++) `liftM` deepTypeAttrs t deepTypeAttrs (TypeDefType (TypeDefRef i _ ni) _ attrs) = (attrs ++) `liftM` typeDefAttrs ni i typeDefAttrs :: (MonadCError m, MonadSymtab m) => NodeInfo -> Ident -> m Attributes typeDefAttrs ni i = do dt <- getDefTable case lookupIdent i dt of Nothing -> astError ni $ "can't find typedef name: " ++ identToString i Just (Left (TypeDef _ t attrs _)) -> (attrs ++) `liftM` deepTypeAttrs t Just (Right _) -> astError ni $ "not a typedef name: " ++ identToString i sueAttrs :: (MonadCError m, MonadSymtab m) => NodeInfo -> SUERef -> m Attributes sueAttrs ni sue = do dt <- getDefTable case lookupTag sue dt of Nothing -> astError ni $ "SUE not found: " ++ render (pretty sue) Just (Left _) -> return [] Just (Right (CompDef (CompType _ _ _ attrs _))) -> return attrs Just (Right (EnumDef (EnumType _ _ attrs _))) -> return attrs language-c-0.4.7/src/Language/C/Analysis/TypeConversions.hs0000644000000000000000000000307112425376061021707 0ustar0000000000000000module Language.C.Analysis.TypeConversions ( arithmeticConversion, floatConversion, intConversion ) where import Language.C.Analysis.SemRep -- | For an arithmetic operator, if the arguments are of the given -- types, return the type of the full expression. arithmeticConversion :: TypeName -> TypeName -> Maybe TypeName -- XXX: I'm assuming that double `op` complex float = complex -- double. The standard seems somewhat unclear on whether this is -- really the case. arithmeticConversion (TyComplex t1) (TyComplex t2) = Just $ TyComplex $ floatConversion t1 t2 arithmeticConversion (TyComplex t1) (TyFloating t2) = Just $ TyComplex $ floatConversion t1 t2 arithmeticConversion (TyFloating t1) (TyComplex t2) = Just $ TyComplex $ floatConversion t1 t2 arithmeticConversion t1@(TyComplex _) (TyIntegral _) = Just t1 arithmeticConversion (TyIntegral _) t2@(TyComplex _) = Just t2 arithmeticConversion (TyFloating t1) (TyFloating t2) = Just $ TyFloating $ floatConversion t1 t2 arithmeticConversion t1@(TyFloating _) (TyIntegral _) = Just t1 arithmeticConversion (TyIntegral _) t2@(TyFloating _) = Just t2 arithmeticConversion (TyIntegral t1) (TyIntegral t2) = Just $ TyIntegral $ intConversion t1 t2 arithmeticConversion (TyEnum _) (TyEnum _) = Just $ TyIntegral TyInt arithmeticConversion (TyEnum _) t2 = Just $ t2 arithmeticConversion t1 (TyEnum _) = Just $ t1 arithmeticConversion _ _ = Nothing floatConversion :: FloatType -> FloatType -> FloatType floatConversion = max intConversion :: IntType -> IntType -> IntType intConversion t1 t2 = max TyInt (max t1 t2) language-c-0.4.7/src/Language/C/Analysis/TypeUtils.hs0000644000000000000000000002100212425376061020471 0ustar0000000000000000module Language.C.Analysis.TypeUtils ( -- * Constructors integral, floating, simplePtr, size_tType, ptrDiffType, boolType, voidType, voidPtr, constVoidPtr, charPtr, constCharPtr, stringType, valistType, -- * Classifiers isIntegralType, isFloatingType, isPointerType, isScalarType, isFunctionType, -- Extractors typeQuals, typeQualsUpd, typeAttrs, typeAttrsUpd, baseType, derefTypeDef, deepDerefTypeDef, canonicalType, -- * Other utilities getIntType, getFloatType ) where import Language.C.Analysis.SemRep import Language.C.Syntax.Constants instance Eq TypeQuals where (==) (TypeQuals c1 v1 r1) (TypeQuals c2 v2 r2) = c1 == c2 && v1 == v2 && r1 == r2 instance Ord TypeQuals where (<=) (TypeQuals c1 v1 r1) (TypeQuals c2 v2 r2) = c1 <= c2 && v1 <= v2 && r1 <= r2 -- | Constructor for a simple integral type. integral :: IntType -> Type integral ty = DirectType (TyIntegral ty) noTypeQuals noAttributes -- | Constructor for a simple floating-point type. floating :: FloatType -> Type floating ty = DirectType (TyFloating ty) noTypeQuals noAttributes -- | A simple pointer with no qualifiers simplePtr :: Type -> Type simplePtr t = PtrType t noTypeQuals [] -- | A pointer with the @const@ qualifier. constPtr :: Type -> Type constPtr t = PtrType t (TypeQuals True False False) [] -- | The type returned by sizeof (size_t). For now, this is just @int@. size_tType :: Type size_tType = integral TyInt -- | The type of pointer differences (ptrdiff_t). For now, this is just @int@. ptrDiffType :: Type ptrDiffType = integral TyInt -- | The type of comparisons\/guards. This is always just @int@. boolType :: Type boolType = integral TyInt -- | Simple @void@ type. voidType :: Type voidType = DirectType TyVoid noTypeQuals noAttributes -- | An unqualified @void@ pointer. voidPtr :: Type voidPtr = simplePtr voidType -- | A @const@-qualified @void@ pointer. constVoidPtr :: Type constVoidPtr = constPtr voidType -- | An unqualified @char@ pointer. charPtr :: Type charPtr = simplePtr (integral TyChar) -- | A @const@-qualified @char@ pointer. constCharPtr :: Type constCharPtr = constPtr (integral TyChar) -- | The type of a constant string. stringType :: Type stringType = ArrayType (DirectType (TyIntegral TyChar) (TypeQuals True False False) noAttributes) (UnknownArraySize False) noTypeQuals [] -- | The builtin type of variable-length argument lists. valistType :: Type valistType = DirectType (TyBuiltin TyVaList) noTypeQuals noAttributes -- | Check whether a type is an integral type. This includes @enum@ -- types. This function does not attempt to resolve @typedef@ types. isIntegralType :: Type -> Bool isIntegralType (DirectType (TyIntegral _) _ _) = True isIntegralType (DirectType (TyEnum _) _ _) = True isIntegralType _ = False -- | Check whether a type is a floating-point numeric type. This -- function does not attempt to resolve @typedef@ types. isFloatingType :: Type -> Bool isFloatingType (DirectType (TyFloating _) _ _) = True isFloatingType _ = False -- | Check whether a type is an pointer type. This includes array -- types. This function does not attempt to resolve @typedef@ types. isPointerType :: Type -> Bool isPointerType (PtrType _ _ _) = True isPointerType (ArrayType _ _ _ _) = True isPointerType _ = False -- | Check whether a type is a scalar type. Scalar types include -- arithmetic types and pointer types. isScalarType :: Type -> Bool isScalarType t = isIntegralType t || isPointerType t || isFloatingType t -- | return @True@ if the given type is a function type -- -- Result is undefined in the presence of undefined typeDefs isFunctionType :: Type -> Bool isFunctionType ty = case ty of TypeDefType (TypeDefRef _ (Just actual_ty) _) _ _ -> isFunctionType actual_ty TypeDefType _ _ _ -> error "isFunctionType: unresolved typeDef" FunctionType _ _ -> True _ -> False -- | Return the qualifiers of a type. typeQuals :: Type -> TypeQuals typeQuals (DirectType _ q _) = q typeQuals (PtrType _ q _) = q typeQuals (ArrayType _ _ q _) = q typeQuals (FunctionType _ _) = noTypeQuals typeQuals (TypeDefType (TypeDefRef _ Nothing _) q _) = q typeQuals (TypeDefType (TypeDefRef _ (Just t) _) q _) = mergeTypeQuals q (typeQuals t) -- |Update type qualifiers -- For function types, it is an error to change any type qualifiers -- For typedef types, the result is stored in the typedef attribute field typeQualsUpd :: (TypeQuals -> TypeQuals) -> Type -> Type typeQualsUpd f ty = case ty of DirectType ty_name ty_quals ty_attrs -> DirectType ty_name (f ty_quals) ty_attrs PtrType ty_inner ty_quals ty_attrs -> PtrType ty_inner (f ty_quals) ty_attrs ArrayType ty_inner sz ty_quals ty_attrs -> ArrayType ty_inner sz (f ty_quals) ty_attrs FunctionType ty_inner ty_attrs -> FunctionType ty_inner ty_attrs TypeDefType ty_ref ty_quals ty_attrs -> TypeDefType ty_ref (f ty_quals) ty_attrs -- | Return the attributes of a type. typeAttrs :: Type -> Attributes typeAttrs (DirectType _ _ a) = a typeAttrs (PtrType _ _ a) = a typeAttrs (ArrayType _ _ _ a) = a typeAttrs (FunctionType _ a) = a typeAttrs (TypeDefType (TypeDefRef _ Nothing _) _ a) = a typeAttrs (TypeDefType (TypeDefRef _ (Just t) _) _ a) = mergeAttributes a (typeAttrs t) -- |Update type attributes typeAttrsUpd :: (Attributes -> Attributes) -> Type -> Type typeAttrsUpd f ty = case ty of DirectType ty_name ty_quals ty_attrs -> DirectType ty_name ty_quals (f ty_attrs) PtrType ty_inner ty_quals ty_attrs -> PtrType ty_inner ty_quals (f ty_attrs) ArrayType ty_inner sz ty_quals ty_attrs -> ArrayType ty_inner sz ty_quals (f ty_attrs) FunctionType ty_inner ty_attrs -> FunctionType ty_inner (f ty_attrs) TypeDefType ty_ref ty_quals ty_attrs -> TypeDefType ty_ref ty_quals (f ty_attrs) -- | Return the base type of a pointer or array type. It is an error -- to call this function with a type that is not in one of those two -- categories. baseType :: Type -> Type baseType (PtrType t _ _) = t baseType (ArrayType t _ _ _) = t baseType _ = error "base of non-pointer type" -- | resolve typedefs, if possible derefTypeDef :: Type -> Type derefTypeDef (TypeDefType (TypeDefRef _ (Just t) _) q a) = (typeAttrsUpd (mergeAttributes a) . typeQualsUpd (mergeTypeQuals q)) (derefTypeDef t) derefTypeDef ty = ty -- | Attempt to remove all references to @typedef@ types from a given type. -- Note that this does not dereference the types of structure or union -- fields, so there are still cases where further dereferencing is -- needed. deepDerefTypeDef :: Type -> Type deepDerefTypeDef (PtrType t quals attrs) = PtrType (deepDerefTypeDef t) quals attrs deepDerefTypeDef (ArrayType t size quals attrs) = ArrayType (deepDerefTypeDef t) size quals attrs deepDerefTypeDef (FunctionType (FunType rt params varargs) attrs) = FunctionType (FunType (deepDerefTypeDef rt) params varargs) attrs deepDerefTypeDef (FunctionType (FunTypeIncomplete rt) attrs) = FunctionType (FunTypeIncomplete (deepDerefTypeDef rt)) attrs deepDerefTypeDef (TypeDefType (TypeDefRef _ (Just t) _) q a) = (typeAttrsUpd (mergeAttributes a) . typeQualsUpd (mergeTypeQuals q)) (deepDerefTypeDef t) deepDerefTypeDef t = t canonicalType :: Type -> Type canonicalType t = case deepDerefTypeDef t of FunctionType ft attrs -> simplePtr (FunctionType ft attrs) t' -> t' -- XXX: move to be with other flag functions testFlags :: Enum f => [f] -> Flags f -> Bool testFlags flags fi = and $ map ((flip testFlag) fi) flags -- XXX: deal with FlagImag. No representation for it in Complex. -- XXX: deal with invalid combinations of flags? getIntType :: Flags CIntFlag -> IntType getIntType flags | testFlags [FlagLongLong, FlagUnsigned] flags = TyULLong | testFlag FlagLongLong flags = TyLLong | testFlags [FlagLong, FlagUnsigned] flags = TyULong | testFlag FlagLong flags = TyLong | testFlag FlagUnsigned flags = TyUInt | otherwise = TyInt getFloatType :: String -> FloatType getFloatType fs | last fs `elem` ['f', 'F'] = TyFloat | last fs `elem` ['l', 'L'] = TyLDouble | otherwise = TyDouble language-c-0.4.7/src/Language/C/Data/0000755000000000000000000000000012425376061015266 5ustar0000000000000000language-c-0.4.7/src/Language/C/Data/Error.hs0000644000000000000000000001415612425376061016722 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Data.Error -- Copyright : (c) 2008 Benedikt Huber, Manuel M. T. Chakravarty -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- Base type for errors occurring in parsing, analysing and pretty-printing. -- With ideas from Simon Marlow's -- "An extensible dynamically-typed hierarchy of execeptions [2006]" ----------------------------------------------------------------------------- module Language.C.Data.Error ( -- * Severity Level ErrorLevel(..), isHardError, -- * Error class Error(..), errorPos, errorLevel, errorMsgs, -- * Error 'supertype' CError(..), -- * Infos attached to errors ErrorInfo(..),showError,showErrorInfo,mkErrorInfo, -- * Default error types UnsupportedFeature, unsupportedFeature, unsupportedFeature_, UserError, userErr, -- * Raising internal errors internalErr, ) where import Data.Typeable import Data.Generics import Language.C.Data.Node import Language.C.Data.Position -- | Error levels (severity) data ErrorLevel = LevelWarn | LevelError | LevelFatal deriving (Eq, Ord) instance Show ErrorLevel where show LevelWarn = "WARNING" show LevelError = "ERROR" show LevelFatal = "FATAL ERROR" -- | return @True@ when the given error makes it impossible to continue -- analysis or compilation. isHardError :: (Error ex) => ex -> Bool isHardError = ( > LevelWarn) . errorLevel -- | information attached to every error in Language.C data ErrorInfo = ErrorInfo ErrorLevel Position [String] deriving Typeable -- to facilitate newtype deriving instance Show ErrorInfo where show = showErrorInfo "error" instance Error ErrorInfo where errorInfo = id changeErrorLevel (ErrorInfo _ pos msgs) lvl' = ErrorInfo lvl' pos msgs mkErrorInfo :: ErrorLevel -> String -> NodeInfo -> ErrorInfo mkErrorInfo lvl msg node = ErrorInfo lvl (posOfNode node) (lines msg) -- | `supertype' of all errors data CError = forall err. (Error err) => CError err deriving Typeable -- | errors in Language.C are instance of 'Error' class (Typeable e, Show e) => Error e where -- | obtain source location etc. of an error errorInfo :: e -> ErrorInfo -- | wrap error in 'CError' toError :: e -> CError -- | try to cast a generic 'CError' to the specific error type fromError :: CError -> (Maybe e) -- | modify the error level changeErrorLevel :: e -> ErrorLevel -> e -- default implementation fromError (CError e) = cast e toError = CError changeErrorLevel e lvl = if errorLevel e == lvl then e else error $ "changeErrorLevel: not possible for " ++ show e instance Show CError where show (CError e) = show e instance Error CError where errorInfo (CError err) = errorInfo err toError = id fromError = Just changeErrorLevel (CError e) = CError . changeErrorLevel e -- | position of an @Error@ errorPos :: (Error e) => e -> Position errorPos = ( \(ErrorInfo _ pos _) -> pos ) . errorInfo -- | severity level of an @Error@ errorLevel :: (Error e) => e -> ErrorLevel errorLevel = ( \(ErrorInfo lvl _ _) -> lvl ) . errorInfo -- | message lines of an @Error@ errorMsgs :: (Error e) => e -> [String] errorMsgs = ( \(ErrorInfo _ _ msgs) -> msgs ) . errorInfo -- | error raised if a operation requires an unsupported or not yet implemented feature. data UnsupportedFeature = UnsupportedFeature String Position deriving Typeable instance Error UnsupportedFeature where errorInfo (UnsupportedFeature msg pos) = ErrorInfo LevelError pos (lines msg) instance Show UnsupportedFeature where show = showError "Unsupported Feature" unsupportedFeature :: (Pos a) => String -> a -> UnsupportedFeature unsupportedFeature msg a = UnsupportedFeature msg (posOf a) unsupportedFeature_ :: String -> UnsupportedFeature unsupportedFeature_ msg = UnsupportedFeature msg internalPos -- | unspecified error raised by the user (in case the user does not want to define -- her own error types). newtype UserError = UserError ErrorInfo deriving Typeable instance Error UserError where errorInfo (UserError info) = info instance Show UserError where show = showError "User Error" userErr :: String -> UserError userErr msg = UserError (ErrorInfo LevelError internalPos (lines msg)) -- other errors to be defined elsewhere showError :: (Error e) => String -> e -> String showError short_msg = showErrorInfo short_msg . errorInfo -- | converts an error into a string using a fixed format -- -- * either the lines of the long error message or the short message has to be non-empty -- -- * the format is -- -- > :: (column ) [] -- > >>> -- > -- > ... -- > showErrorInfo :: String -> ErrorInfo -> String showErrorInfo short_msg (ErrorInfo level pos msgs) = header ++ showMsgLines (if null short_msg then msgs else short_msg:msgs) where header = showPos pos ++ "[" ++ show level ++ "]" showPos p | isSourcePos p = (posFile p) ++ ":" ++ show (posRow pos) ++ ": " ++ "(column " ++ show (posColumn pos) ++ ") " | otherwise = show p ++ ":: " showMsgLines [] = internalErr "No short message or error message provided." showMsgLines (x:xs) = indent ++ ">>> " ++ x ++ "\n" ++ unlines (map (indent++) xs) -- internal errors internalErrPrefix :: String internalErrPrefix = unlines [ "Language.C : Internal Error" , "This is propably a bug, and should be reported at "++ "http://www.sivity.net/projects/language.c/newticket"] -- | raise a fatal internal error; message may have multiple lines internalErr :: String -> a internalErr msg = error (internalErrPrefix ++ "\n" ++ indentLines msg ++ "\n") indent :: String indent = " " indentLines :: String -> String indentLines = unlines . map (indent++) . lines language-c-0.4.7/src/Language/C/Data/Ident.hs0000644000000000000000000001160612425376061016671 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Data.Ident -- Copyright : (c) [1995..1999] Manuel M. T. Chakravarty -- (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- This module provides the notion of identifiers in C, speed up using hashing. -- Identifiers are associated optionally associated with a 'NodeInfo', i.e. with -- a unique 'Name' and a source location ('Position'). The ordering relation on -- identifiers is based on the hash and does not follow the lexical order. ----------------------------------------------------------------------------- module Language.C.Data.Ident ( Ident(..), SUERef(..), isAnonymousRef, mkIdent, builtinIdent, internalIdent, internalIdentAt, isInternalIdent, identToString, dumpIdent) where -- TODO (comment from manuel): -- * Hashing is not 8bit clean. import Data.Char import Language.C.Data.Position import Language.C.Data.Node import Language.C.Data.Name (Name,nameId) import Data.Generics -- | References uniquely determining a struct, union or enum type. -- Those are either identified by an string identifier, or by a unique -- name (anonymous types). data SUERef = AnonymousRef Name | NamedRef Ident deriving (Typeable, Data, Ord, Eq, Show) --, Read -- | Return true if the struct\/union\/enum reference is anonymous. isAnonymousRef :: SUERef -> Bool isAnonymousRef (AnonymousRef _) = True isAnonymousRef _ = False -- | C identifiers data Ident = Ident String -- lexeme {-# UNPACK #-} !Int -- hash to speed up equality check NodeInfo -- attributes of this ident. incl. position deriving (Data,Typeable,Show) -- Read -- the definition of the equality allows identifiers to be equal that are -- defined at different source text positions, and aims at speeding up the -- equality test, by comparing the lexemes only if the two numbers are equal -- instance Eq Ident where (Ident s h _) == (Ident s' h' _) = (h == h') && (s == s') -- this does *not* follow the alphanumerical ordering of the lexemes -- instance Ord Ident where compare (Ident s h _) (Ident s' h' _) = compare (h, s) (h', s') -- identifiers are attributed instance CNode Ident where nodeInfo (Ident _ _ at) = at instance Pos Ident where posOf = posOfNode . nodeInfo -- to speed up the equality test we compute some hash-like value for each -- identifiers lexeme and store it in the identifiers representation -- hash function from the dragon book pp437; assumes 7 bit characters and needs -- the (nearly) full range of values guaranteed for `Int' by the Haskell -- language definition; can handle 8 bit characters provided we have 29 bit -- for the `Int's without sign -- quad :: String -> Int quad (c1:c2:c3:c4:s) = ((ord c4 * bits21 + ord c3 * bits14 + ord c2 * bits7 + ord c1) `mod` bits28) + (quad s `mod` bits28) quad (c1:c2:c3:[] ) = ord c3 * bits14 + ord c2 * bits7 + ord c1 quad (c1:c2:[] ) = ord c2 * bits7 + ord c1 quad (c1:[] ) = ord c1 quad ([] ) = 0 bits7 :: Int bits7 = 2^(7::Int) bits14 :: Int bits14 = 2^(14::Int) bits21 :: Int bits21 = 2^(21::Int) bits28 :: Int bits28 = 2^(28::Int) -- | build an identifier from a string. -- -- * only minimal error checking, e.g., the characters of the identifier are -- not checked for being alphanumerical only; the correct lexis of the -- identifier should be ensured by the caller, e.g., the scanner. -- -- * for reasons of simplicity the complete lexeme is hashed. mkIdent :: Position -> String -> Name -> Ident mkIdent pos s name = Ident s (quad s) (mkNodeInfo' pos (pos,length s) name) -- | returns an /internal/ identifier (has internal position and no unique name) internalIdent :: String -> Ident internalIdent s = Ident s (quad s) (mkNodeInfoOnlyPos internalPos) -- | return an /internal/ identifier with position info internalIdentAt :: Position -> String -> Ident internalIdentAt pos s = Ident s (quad s) (mkNodeInfoPosLen pos (pos, length s)) -- | returns a /builtin/ identifier (has builtin position and no unique name) builtinIdent :: String -> Ident builtinIdent s = Ident s (quad s) (mkNodeInfoOnlyPos builtinPos) -- | return @True@ if the given identifier is /internal/ isInternalIdent :: Ident -> Bool isInternalIdent (Ident _ _ nodeinfo) = isInternalPos (posOfNode nodeinfo) -- | string of an identifier identToString :: Ident -> String identToString (Ident s _ _) = s -- | dump the identifier string and its positions for debugging purposes dumpIdent :: Ident -> String dumpIdent ide = identToString ide ++ " at " ++ show (nodeInfo ide) language-c-0.4.7/src/Language/C/Data/InputStream.hs0000644000000000000000000000564612425376061020110 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns #-} {-# OPTIONS -Wall #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Data.InputStream -- Copyright : (c) 2008,2011 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- Compile time input abstraction for the parser, relying on ByteString. -- The String interface only supports Latin-1 since alex-3, as alex now requires -- byte based access to the input stream. ------------------------------------------------------------------------------- module Language.C.Data.InputStream ( InputStream, readInputStream,inputStreamToString,inputStreamFromString, takeByte, takeChar, inputStreamEmpty, takeChars, countLines, ) where import Data.Word #ifndef NO_BYTESTRING import Data.ByteString (ByteString) import qualified Data.ByteString as BSW import qualified Data.ByteString.Char8 as BSC #else import qualified Data.Char as Char #endif -- Generic InputStream stuff -- | read a file into an 'InputStream' readInputStream :: FilePath -> IO InputStream -- | convert 'InputStream' to 'String' inputStreamToString :: InputStream -> String {-# INLINE inputStreamToString #-} -- | convert a 'String' to an 'InputStream' inputStreamFromString :: String -> InputStream -- | @(b,is') = takeByte is@ reads and removes -- the first byte @b@ from the 'InputStream' @is@ takeByte :: InputStream -> (Word8, InputStream) {-# INLINE takeByte #-} -- | @(c,is') = takeChar is@ reads and removes -- the first character @c@ from the 'InputStream' @is@ takeChar :: InputStream -> (Char, InputStream) {-# INLINE takeChar #-} -- | return @True@ if the given input stream is empty inputStreamEmpty :: InputStream -> Bool {-# INLINE inputStreamEmpty #-} -- | @str = takeChars n is@ returns the first @n@ characters -- of the given input stream, without removing them takeChars :: Int -> InputStream -> [Char] {-# INLINE takeChars #-} -- | @countLines@ returns the number of text lines in the -- given 'InputStream' countLines :: InputStream -> Int #ifndef NO_BYTESTRING type InputStream = ByteString takeByte bs = BSW.head bs `seq` (BSW.head bs, BSW.tail bs) takeChar bs = BSC.head bs `seq` (BSC.head bs, BSC.tail bs) inputStreamEmpty = BSW.null #ifndef __HADDOCK__ takeChars !n bstr = BSC.unpack $ BSC.take n bstr --leaks #endif readInputStream = BSW.readFile inputStreamToString = BSC.unpack inputStreamFromString = BSC.pack countLines = length . BSC.lines #else type InputStream = String takeByte bs | Char.isLatin1 c = let b = fromIntegral (Char.ord c) in b `seq` (b, tail bs) | otherwise = error "takeByte: not a latin-1 character" where c = head bs takeChar bs = (head bs, tail bs) inputStreamEmpty = null takeChars n str = take n str readInputStream = readFile inputStreamToString = id inputStreamFromString = id countLines = length . lines #endif language-c-0.4.7/src/Language/C/Data/Name.hs0000644000000000000000000000200412425376061016476 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Data.Name -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- Unique Names with fast equality (newtype 'Int') module Language.C.Data.Name ( Name(..),newNameSupply, namesStartingFrom ) where import Data.Ix import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Generics -- | Name is a unique identifier newtype Name = Name { nameId :: Int } deriving (Show, Read, Eq, Ord, Ix, Data, Typeable) instance Enum Name where toEnum = Name fromEnum (Name n) = n -- | return an infinite stream of 'Name's starting with @nameId@ 0 newNameSupply :: [Name] newNameSupply = namesStartingFrom 0 -- | get the infinite stream of unique names starting from the given integer namesStartingFrom :: Int -> [Name] namesStartingFrom k = [Name k..] language-c-0.4.7/src/Language/C/Data/Node.hs0000644000000000000000000001142412425376061016511 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Syntax.Attributes -- Copyright : (c) [1995..1999] Manuel M. T. Chakravarty -- (c) 2008 Benedikt Huber (stripped radically) -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- source position and unqiue name ----------------------------------------------------------------------------- module Language.C.Data.Node ( NodeInfo(..), undefNode, isUndefNode, mkNodeInfoOnlyPos,mkNodeInfoPosLen, mkNodeInfo,mkNodeInfo', internalNode, -- deprecated, use undefNode CNode(nodeInfo), fileOfNode, posOfNode, nameOfNode, getLastTokenPos, lengthOfNode, eqByName, ) where import Language.C.Data.Position import Language.C.Data.Name (Name) import Data.Generics -- | Parsed entity attribute data NodeInfo = OnlyPos Position {-# UNPACK #-} !PosLength -- only pos and last token (for internal stuff only) | NodeInfo Position {-# UNPACK #-} !PosLength !Name -- pos, last token and unique name deriving (Data,Typeable) instance Show NodeInfo where showsPrec d (OnlyPos p l) = (showString "(OnlyPos ") . (showsPrec d p) . (showString " ") . (showsPrec d l) . (showString ")") showsPrec d (NodeInfo p l n) = (showString "(NodeInfo ") . (showsPrec d p) . (showString " ") . (showsPrec d l) . (showString " ") . (showsPrec d n) . (showString ")") -- name equality of attributes, used to define (name) equality of objects instance Eq NodeInfo where (NodeInfo _ _ id1) == (NodeInfo _ _ id2) = id1 == id2 _ == _ = error "Attributes: Attempt to compare `OnlyPos' attributes!" -- attribute ordering instance Ord NodeInfo where (NodeInfo _ _ id1) <= (NodeInfo _ _ id2) = id1 <= id2 _ <= _ = error "Attributes: Attempt to compare `OnlyPos' attributes!" instance Pos NodeInfo where posOf (OnlyPos pos _) = pos posOf (NodeInfo pos _ _) = pos -- | get the number of characters an AST node spans lengthOfNode :: NodeInfo -> Maybe Int lengthOfNode ni = len where len = case ni of NodeInfo firstPos lastTok _ -> computeLength firstPos lastTok OnlyPos firstPos lastTok -> computeLength firstPos lastTok computeLength pos (lastPos,len) | len < 0 = Nothing | otherwise = Just (posOffset lastPos + len - posOffset pos) -- | get the position and length of the last token getLastTokenPos :: NodeInfo -> PosLength getLastTokenPos (NodeInfo _ lastTok _) = lastTok getLastTokenPos (OnlyPos _ lastTok) = lastTok -- | a class for convenient access to the attributes of an attributed object class CNode a where nodeInfo :: a -> NodeInfo instance CNode NodeInfo where nodeInfo = id instance (CNode a, CNode b) => CNode (Either a b) where nodeInfo = either nodeInfo nodeInfo nameOfNode :: NodeInfo -> Maybe Name nameOfNode (OnlyPos _ _) = Nothing nameOfNode (NodeInfo _ _ name) = Just name posOfNode :: NodeInfo -> Position posOfNode ni = case ni of (OnlyPos pos _) -> pos; (NodeInfo pos _ _) -> pos fileOfNode :: (CNode a) => a -> Maybe FilePath fileOfNode = fmap posFile . justIf isSourcePos . posOfNode . nodeInfo where justIf predicate x | predicate x = Just x | otherwise = Nothing -- | equality by name eqByName :: CNode a => a -> a -> Bool eqByName obj1 obj2 = (nodeInfo obj1) == (nodeInfo obj2) -- attribute identifier creation -- ----------------------------- {-# DEPRECATED internalNode "use undefNode instead" #-} internalNode :: NodeInfo internalNode = undefNode -- | create a node with neither name nor positional information undefNode :: NodeInfo undefNode = OnlyPos nopos (nopos,-1) -- | return True if the node carries neither name nor positional information isUndefNode :: NodeInfo -> Bool isUndefNode (OnlyPos p _) | isNoPos p = True | otherwise = False isUndefNode _ = False -- | -- | Given only a source position, create a new node attribute mkNodeInfoOnlyPos :: Position -> NodeInfo mkNodeInfoOnlyPos pos = OnlyPos pos (nopos,-1) -- | Given a source position and the position and length of the last token, create a new node attribute mkNodeInfoPosLen :: Position -> PosLength -> NodeInfo mkNodeInfoPosLen = OnlyPos -- | Given a source position and a unique name, create a new attribute -- identifier mkNodeInfo :: Position -> Name -> NodeInfo mkNodeInfo pos name = NodeInfo pos (nopos,-1) name -- | Given a source position, the position and length of the last token and a unique name, create a new attribute -- identifier. Strict in mkNodeInfo' :: Position -> PosLength -> Name -> NodeInfo mkNodeInfo' pos lasttok name = NodeInfo pos lasttok name language-c-0.4.7/src/Language/C/Data/Position.hs0000644000000000000000000001061412425376061017430 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Data.Position -- Copyright : (c) [1995..2000] Manuel M. T. Chakravarty -- [2008..2009] Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- Source code position ----------------------------------------------------------------------------- module Language.C.Data.Position ( -- -- source text positions -- Position(), position, PosLength, posFile,posRow,posColumn,posOffset, initPos, isSourcePos, nopos, isNoPos, builtinPos, isBuiltinPos, internalPos, isInternalPos, incPos, retPos, adjustPos, incOffset, Pos(..), ) where import Data.Generics -- | uniform representation of source file positions data Position = Position { posOffset :: {-# UNPACK #-} !Int -- ^ absolute offset in the preprocessed file , posFile :: String -- ^ source file , posRow :: {-# UNPACK #-} !Int -- ^ row (line) in the original file. Affected by #LINE pragmas. , posColumn :: {-# UNPACK #-} !Int -- ^ column in the preprocessed file. Inaccurate w.r.t. to the original -- file in the presence of preprocessor macros. } | NoPosition | BuiltinPosition | InternalPosition deriving (Eq, Ord, Typeable, Data) -- | Position and length of a token type PosLength = (Position,Int) instance Show Position where show (Position _ fname row _) = "(" ++ show fname ++ ": line " ++ show row ++ ")" show NoPosition = "" show BuiltinPosition = "" show InternalPosition = "" {-# DEPRECATED posColumn "column number information is inaccurate in presence of macros - do not rely on it." #-} -- | @position absoluteOffset fileName lineNumber columnNumber@ initializes a @Position@ using the given arguments position :: Int -> String -> Int -> Int -> Position position = Position -- | class of type which aggregate a source code location class Pos a where posOf :: a -> Position -- | initialize a Position to the start of the translation unit starting in the given file initPos :: FilePath -> Position initPos file = Position 0 file 1 1 -- | returns @True@ if the given position refers to an actual source file isSourcePos :: Position -> Bool isSourcePos (Position _ _ _ _) = True isSourcePos _ = False -- | no position (for unknown position information) nopos :: Position nopos = NoPosition -- | returns @True@ if the there is no position information available isNoPos :: Position -> Bool isNoPos NoPosition = True isNoPos _ = False -- | position attached to built-in objects -- builtinPos :: Position builtinPos = BuiltinPosition -- | returns @True@ if the given position refers to a builtin definition isBuiltinPos :: Position -> Bool isBuiltinPos BuiltinPosition = True isBuiltinPos _ = False -- | position used for internal errors internalPos :: Position internalPos = InternalPosition -- | returns @True@ if the given position is internal isInternalPos :: Position -> Bool isInternalPos InternalPosition = True isInternalPos _ = False {-# INLINE incPos #-} -- | advance column incPos :: Position -> Int -> Position incPos (Position offs fname row col) n = Position (offs + n) fname row (col + n) incPos p _ = p {-# INLINE retPos #-} -- | advance to next line retPos :: Position -> Position retPos (Position offs fname row _) = Position (offs+1) fname (row + 1) 1 retPos p = p {-# INLINE adjustPos #-} -- | adjust position: change file and line number, reseting column to 1. This is usually -- used for #LINE pragmas. The absolute offset is not changed - this can be done -- by @adjustPos newFile line . incPos (length pragma)@. adjustPos :: FilePath -> Int -> Position -> Position adjustPos fname row (Position offs _ _ _) = Position offs fname row 1 adjustPos _ _ p = p {-# INLINE incOffset #-} -- | advance just the offset incOffset :: Position -> Int -> Position incOffset (Position o f r c) n = Position (o + n) f r c incOffset p n = p language-c-0.4.7/src/Language/C/Data/RList.hs0000644000000000000000000000323612425376061016663 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.C.Data.RList -- Copyright : (c) [2007..2008] Duncan Coutts, Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- Due to the way the grammar is constructed we very often have to build lists -- in reverse. To make sure we do this consistently and correctly we have a -- newtype to wrap the reversed style of list: ----------------------------------------------------------------------------- module Language.C.Data.RList ( RList,Reversed(..), empty,singleton,snoc,rappend,appendr,rappendr,rmap,reverse, viewr, ) where import Prelude hiding (reverse) import qualified Data.List as List newtype Reversed a = Reversed a type RList a = Reversed [a] empty :: Reversed [a] empty = Reversed [] singleton :: a -> Reversed [a] singleton x = Reversed [x] snoc :: Reversed [a] -> a -> Reversed [a] snoc (Reversed xs) x = Reversed (x : xs) infixr 5 `snoc` rappend :: Reversed [a] -> [a] -> Reversed [a] rappend (Reversed xs) ys = Reversed (List.reverse ys ++ xs) appendr :: [a] -> Reversed [a] -> Reversed [a] appendr xs (Reversed ys) = Reversed (ys ++ List.reverse xs) rappendr :: Reversed [a] -> Reversed [a] -> Reversed [a] rappendr (Reversed xs) (Reversed ys) = Reversed (ys ++ xs) rmap :: (a -> b) -> Reversed [a] -> Reversed [b] rmap f (Reversed xs) = Reversed (map f xs) reverse :: Reversed [a] -> [a] reverse (Reversed xs) = List.reverse xs viewr :: Reversed [a] -> (Reversed [a] , a) viewr (Reversed []) = error "viewr: empty RList" viewr (Reversed (x:xs)) = (Reversed xs, x) language-c-0.4.7/src/Language/C/Parser/0000755000000000000000000000000012425376061015651 5ustar0000000000000000language-c-0.4.7/src/Language/C/Parser/Builtin.hs0000644000000000000000000000117012425376061017612 0ustar0000000000000000-- | -- Module : Language.C.Parser.Builtin -- Copyright : (c) 2001 Manuel M. T. Chakravarty -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Portability : portable -- -- This module provides information about builtin entities. -- -- Currently, only builtin type names are supported. The only builtin type -- name is `__builtin_va_list', which is a builtin of GNU C. -- module Language.C.Parser.Builtin ( builtinTypeNames ) where import Language.C.Data.Ident (Ident, builtinIdent) -- predefined type names -- builtinTypeNames :: [Ident] builtinTypeNames = [builtinIdent "__builtin_va_list"] language-c-0.4.7/src/Language/C/Parser/Lexer.x0000644000000000000000000005221212425376061017123 0ustar0000000000000000----------------------------------------------------------------------------- -- Module : Lexer.x -- Copyright : (c) [1999..2004] Manuel M T Chakravarty -- (c) 2005 Duncan Coutts -- (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Portability : portable -- -- Lexer for C files, after being processed by the C preprocessor -- -- We assume that the input already went through cpp. Thus, we do not handle -- comments and preprocessor directives here. It supports the -- C99 `restrict' extension: as -- well as inline functions. -- -- Comments: -- -- * Universal character names and multi-character character constants, -- as well as trigraphs are unsupported. They are lexed, but yield an error. -- -- * We add `typedef-name' (K&R 8.9) as a token, as proposed in K&R A13. -- However, as these tokens cannot be recognized lexically, but require a -- context analysis, they are never produced by the lexer, but instead have -- to be introduced in a later phase (by converting the corresponding -- identifiers). -- -- * We also recognize GNU C `__attribute__', `__extension__', `__complex__', -- `__const', `__const__', `__imag', `__imag__', `__inline', `__inline__', -- `__real', `__real__, `__restrict', and `__restrict__'. -- -- * Any line starting with `#pragma' is ignored. -- -- With K&R we refer to ``The C Programming Language'', second edition, Brain -- W. Kernighan and Dennis M. Ritchie, Prentice Hall, 1988. -- -- With C99 we refer to ``ISO/IEC 9899:TC3'', -- available online at http://www.open-std.org/JTC1/SC22/WG14/www/docs/n1256.pdf. -- --- TODO ---------------------------------------------------------------------- -- -- * There are more GNU C specific keywords. Add them and change `Parser.y' -- correspondingly (in particular, most tokens within __attribute ((...)) -- expressions are actually keywords, but we handle them as identifiers at -- the moment). -- -- * Add support for bytestrings { module Language.C.Parser.Lexer (lexC, parseError) where import Data.Char (chr, isDigit) import Data.Word (Word8) import Control.Monad (liftM, when) import Language.C.Data.InputStream (InputStream, inputStreamEmpty, takeByte, takeChar, takeChars) -- ( InputStream, readInputStream,inputStreamToString,inputStreamFromString, -- takeByte, takeChar, inputStreamEmpty, takeChars, -- countLines, -- ) import Language.C.Data.Position import Language.C.Data.Ident (mkIdent) import Language.C.Syntax.Constants import Language.C.Parser.Tokens import Language.C.Parser.ParserMonad } $space = [ \ \t ] -- horizontal white space $eol = \n -- end of line $letter = [a-zA-Z] $identletter = [a-zA-Z_\$] -- GNU extension: allow $ in variable names $octdigit = 0-7 $digit = 0-9 $digitNZ = 1-9 $hexdigit = [0-9a-fA-F] $inchar = . # [ \\ \' \n \r ] -- valid character in char constant $instr = . # [ \\ \" \n \r ] -- valid character in a string literal $infname = . # [ \\ \" ] -- valid character in a filename @sp = $space* -- character escape sequence (follows K&R A2.5.2) -- -- * also used for strings -- * C99: 6.4.4.4 @charesc = \\([ntvbrfaeE\\\?\'\"]|$octdigit{1,3}|x$hexdigit+) @ucn = \\u$hexdigit{4}|\\U$hexdigit{8} -- components of integer constants -- -- * C99: 6.4.4.1 @int = $digitNZ$digit* -- integer suffixes @llsuffix = ll|LL @gnusuffix = [ij]? @intsuffix = [uU][lL]?|[uU]@llsuffix|[lL][uU]?|@llsuffix[uU]? @intgnusuffix = @intsuffix@gnusuffix?|@gnusuffix@intsuffix? -- components of float constants (follows K&R A2.5.3) -- -- * C99: 6.4.4.2 @digits = $digit+ @intpart = @digits @fractpart = @digits @mantpart = @intpart?\.@fractpart|@intpart\. @exppart = [eE][\+\-]?@digits @hexprefix = 0x @hexdigits = $hexdigit+ @hexmant = @hexdigits?\.@hexdigits|@hexdigits\. @binexp = [pP][\+\-]?@digits @floatsuffix = [fFlL] @floatgnusuffix = @floatsuffix@gnusuffix?|@gnusuffix@floatsuffix? tokens :- -- whitespace (follows K&R A2.1) -- -- * horizontal and vertical tabs, newlines, and form feeds are filter out by -- `Lexers.ctrlLexer' -- -- * comments are not handled, as we assume the input already went through cpp -- $white+ ; -- #line directive (K&R A12.6) -- -- * allows further ints after the file name a la GCC; as the GCC CPP docu -- doesn't say how many ints there can be, we allow an unbound number -- \#$space*@int$space*(\"($infname|@charesc)*\"$space*)?(@int$space*)*\r?$eol { \pos len str -> setPos (adjustLineDirective len (takeChars len str) pos) >> lexToken' False } -- #pragma directive (K&R A12.8) -- -- * we simply ignore any #pragma (but take care to update the position -- information) -- \#$space*pragma.*$eol ; -- #ident directive, eg used by rcs/cvs -- -- * we simply ignore any #ident (but take care to update the position -- information) -- \#$space*ident.*$eol ; -- identifiers and keywords (follows K&R A2.3 and A2.4) -- $identletter($identletter|$digit)* { \pos len str -> idkwtok (takeChars len str) pos } -- constants (follows K&R A2.5) -- -- * K&R,C99 explicitly mention `enumeration-constants'; however, as they are -- lexically identifiers, we do not have an extra case for them -- -- integer constants (follows K&R A2.5.1, C99 6.4.4.1) -- NOTE: 0 is lexed as octal integer constant, and readCOctal takes care of this 0$octdigit*@intgnusuffix? { token_plus CTokILit readCOctal } $digitNZ$digit*@intgnusuffix? { token_plus CTokILit (readCInteger DecRepr) } 0[xX]$hexdigit+@intgnusuffix? { token_plus CTokILit (readCInteger HexRepr . drop 2) } (0$octdigit*|$digitNZ$digit*|0[xX]$hexdigit+)[uUlL]+ { token_fail "Invalid integer constant suffix" } -- character constants (follows K&R A2.5.2, C99 6.4.4.4) -- -- * Universal Character Names are unsupported and cause an error. \'($inchar|@charesc)\' { token CTokCLit (cChar . fst . unescapeChar . tail) } L\'($inchar|@charesc)\' { token CTokCLit (cChar_w . fst . unescapeChar . tail . tail) } \'($inchar|@charesc){2,}\' { token CTokCLit (flip cChars False . unescapeMultiChars .tail) } L\'($inchar|@charesc){2,}\' { token CTokCLit (flip cChars True . unescapeMultiChars . tail . tail) } -- float constants (follows K&R A2.5.3. C99 6.4.4.2) -- -- * NOTE: Hexadecimal floating constants without binary exponents are forbidden. -- They generate a lexer error, because they are hard to recognize in the parser. (@mantpart@exppart?|@intpart@exppart)@floatgnusuffix? { token CTokFLit readCFloat } @hexprefix(@hexmant|@hexdigits)@binexp@floatgnusuffix? { token CTokFLit readCFloat } @hexprefix@hexmant { token_fail "Hexadecimal floating constant requires an exponent" } -- string literal (follows K&R A2.6) -- C99: 6.4.5. \"($instr|@charesc)*\" { token CTokSLit (cString . unescapeString . init . tail) } L\"($instr|@charesc)*\" { token CTokSLit (cString_w . unescapeString . init . tail . tail) } L?\'@ucn\' { token_fail "Universal character names are unsupported" } L?\'\\[^0-7'\"\?\\abfnrtvuUx]\' { token_fail "Invalid escape sequence" } L?\"($inchar|@charesc)*@ucn($inchar|@charesc|@ucn)*\" { token_fail "Universal character names in string literals are unsupported"} -- operators and separators -- "(" { token_ 1 CTokLParen } ")" { token_ 1 CTokRParen } "[" { token_ 1 CTokLBracket } "]" { token_ 1 CTokRBracket } "->" { token_ 2 CTokArrow } "." { token_ 1 CTokDot } "!" { token_ 1 CTokExclam } "~" { token_ 1 CTokTilde } "++" { token_ 2 CTokInc } "--" { token_ 2 CTokDec } "+" { token_ 1 CTokPlus } "-" { token_ 1 CTokMinus } "*" { token_ 1 CTokStar } "/" { token_ 1 CTokSlash } "%" { token_ 1 CTokPercent } "&" { token_ 1 CTokAmper } "<<" { token_ 2 CTokShiftL } ">>" { token_ 2 CTokShiftR } "<" { token_ 1 CTokLess } "<=" { token_ 2 CTokLessEq } ">" { token_ 1 CTokHigh } ">=" { token_ 2 CTokHighEq } "==" { token_ 2 CTokEqual } "!=" { token_ 2 CTokUnequal } "^" { token_ 1 CTokHat } "|" { token_ 1 CTokBar } "&&" { token_ 2 CTokAnd } "||" { token_ 2 CTokOr } "?" { token_ 1 CTokQuest } ":" { token_ 1 CTokColon } "=" { token_ 1 CTokAssign } "+=" { token_ 2 CTokPlusAss } "-=" { token_ 2 CTokMinusAss } "*=" { token_ 2 CTokStarAss } "/=" { token_ 2 CTokSlashAss } "%=" { token_ 2 CTokPercAss } "&=" { token_ 2 CTokAmpAss } "^=" { token_ 2 CTokHatAss } "|=" { token_ 2 CTokBarAss } "<<=" { token_ 3 CTokSLAss } ">>=" { token_ 3 CTokSRAss } "," { token_ 1 CTokComma } \; { token_ 1 CTokSemic } "{" { token_ 1 CTokLBrace } "}" { token_ 1 CTokRBrace } "..." { token_ 3 CTokEllipsis } { -- Fix the 'octal' lexing of '0' readCOctal :: String -> Either String CInteger readCOctal s@('0':r) = case r of (c:_) | isDigit c -> readCInteger OctalRepr r _ -> readCInteger DecRepr s -- We use the odd looking list of string patterns here rather than normal -- string literals since GHC converts the latter into a sequence of string -- comparisons (ie a linear search) but it translates the former using its -- effecient pattern matching which gives us the expected radix-style search. -- This change makes a significant performance difference [chak] -- -- To make this a little more maintainable, we autogenerate it from this list, -- using the script GenerateKeywordMatch.hs (in /src) {- alignof @__, asm @__, auto break, bool _Bool, case, char, const @__, continue, complex _Complex __complex__ default, do, double, else, enum, extern, float, for, goto, if, inline @__, int, long, register, restrict @__, return short, signed @__, sizeof, static, struct, switch, typedef, typeof @__, thread __thread, union, unsigned, void, volatile @__, while, label __label__ (CTokGnuC GnuCAttrTok) __attribute __attribute__ (CTokGnuC GnuCExtTok) __extension__ (CTokGnuC GnuCComplexReal) __real __real__ (CTokGnuC GnuCComplexImag) __imag __imag__ (CTokGnuC GnuCVaArg) __builtin_va_arg (CTokGnuC GnuCOffsetof) __builtin_offsetof (CTokGnuC GnuCTyCompat) __builtin_types_compatible_p -} -- Tokens: alignof __alignof __alignof__ asm __asm __asm__ __attribute __attribute__ auto _Bool break __builtin_offsetof __builtin_types_compatible_p __builtin_va_arg case char _Complex __complex__ const __const __const__ continue default do double else enum __extension__ extern float for goto if __imag __imag__ inline __inline __inline__ int __label__ long __real __real__ register __restrict __restrict__ return short signed __signed __signed__ sizeof static struct switch __thread typedef typeof __typeof __typeof__ union unsigned void volatile __volatile __volatile__ while idkwtok ('_' : 'B' : 'o' : 'o' : 'l' : []) = tok 5 CTokBool idkwtok ('_' : 'C' : 'o' : 'm' : 'p' : 'l' : 'e' : 'x' : []) = tok 8 CTokComplex idkwtok ('_' : '_' : 'a' : 'l' : 'i' : 'g' : 'n' : 'o' : 'f' : []) = tok 9 CTokAlignof idkwtok ('a' : 'l' : 'i' : 'g' : 'n' : 'o' : 'f' : []) = tok 7 CTokAlignof idkwtok ('_' : '_' : 'a' : 'l' : 'i' : 'g' : 'n' : 'o' : 'f' : '_' : '_' : []) = tok 11 CTokAlignof idkwtok ('_' : '_' : 'a' : 's' : 'm' : []) = tok 5 CTokAsm idkwtok ('a' : 's' : 'm' : []) = tok 3 CTokAsm idkwtok ('_' : '_' : 'a' : 's' : 'm' : '_' : '_' : []) = tok 7 CTokAsm idkwtok ('_' : '_' : 'a' : 't' : 't' : 'r' : 'i' : 'b' : 'u' : 't' : 'e' : []) = tok 11 (CTokGnuC GnuCAttrTok) idkwtok ('_' : '_' : 'a' : 't' : 't' : 'r' : 'i' : 'b' : 'u' : 't' : 'e' : '_' : '_' : []) = tok 13 (CTokGnuC GnuCAttrTok) idkwtok ('a' : 'u' : 't' : 'o' : []) = tok 4 CTokAuto idkwtok ('b' : 'r' : 'e' : 'a' : 'k' : []) = tok 5 CTokBreak idkwtok ('_' : '_' : 'b' : 'u' : 'i' : 'l' : 't' : 'i' : 'n' : '_' : 'o' : 'f' : 'f' : 's' : 'e' : 't' : 'o' : 'f' : []) = tok 18 (CTokGnuC GnuCOffsetof) idkwtok ('_' : '_' : 'b' : 'u' : 'i' : 'l' : 't' : 'i' : 'n' : '_' : 't' : 'y' : 'p' : 'e' : 's' : '_' : 'c' : 'o' : 'm' : 'p' : 'a' : 't' : 'i' : 'b' : 'l' : 'e' : '_' : 'p' : []) = tok 28 (CTokGnuC GnuCTyCompat) idkwtok ('_' : '_' : 'b' : 'u' : 'i' : 'l' : 't' : 'i' : 'n' : '_' : 'v' : 'a' : '_' : 'a' : 'r' : 'g' : []) = tok 16 (CTokGnuC GnuCVaArg) idkwtok ('c' : 'a' : 's' : 'e' : []) = tok 4 CTokCase idkwtok ('c' : 'h' : 'a' : 'r' : []) = tok 4 CTokChar idkwtok ('_' : '_' : 'c' : 'o' : 'm' : 'p' : 'l' : 'e' : 'x' : '_' : '_' : []) = tok 11 CTokComplex idkwtok ('_' : '_' : 'c' : 'o' : 'n' : 's' : 't' : []) = tok 7 CTokConst idkwtok ('c' : 'o' : 'n' : 's' : 't' : []) = tok 5 CTokConst idkwtok ('_' : '_' : 'c' : 'o' : 'n' : 's' : 't' : '_' : '_' : []) = tok 9 CTokConst idkwtok ('c' : 'o' : 'n' : 't' : 'i' : 'n' : 'u' : 'e' : []) = tok 8 CTokContinue idkwtok ('d' : 'e' : 'f' : 'a' : 'u' : 'l' : 't' : []) = tok 7 CTokDefault idkwtok ('d' : 'o' : []) = tok 2 CTokDo idkwtok ('d' : 'o' : 'u' : 'b' : 'l' : 'e' : []) = tok 6 CTokDouble idkwtok ('e' : 'l' : 's' : 'e' : []) = tok 4 CTokElse idkwtok ('e' : 'n' : 'u' : 'm' : []) = tok 4 CTokEnum idkwtok ('_' : '_' : 'e' : 'x' : 't' : 'e' : 'n' : 's' : 'i' : 'o' : 'n' : '_' : '_' : []) = tok 13 (CTokGnuC GnuCExtTok) idkwtok ('e' : 'x' : 't' : 'e' : 'r' : 'n' : []) = tok 6 CTokExtern idkwtok ('f' : 'l' : 'o' : 'a' : 't' : []) = tok 5 CTokFloat idkwtok ('f' : 'o' : 'r' : []) = tok 3 CTokFor idkwtok ('g' : 'o' : 't' : 'o' : []) = tok 4 CTokGoto idkwtok ('i' : 'f' : []) = tok 2 CTokIf idkwtok ('_' : '_' : 'i' : 'm' : 'a' : 'g' : []) = tok 6 (CTokGnuC GnuCComplexImag) idkwtok ('_' : '_' : 'i' : 'm' : 'a' : 'g' : '_' : '_' : []) = tok 8 (CTokGnuC GnuCComplexImag) idkwtok ('_' : '_' : 'i' : 'n' : 'l' : 'i' : 'n' : 'e' : []) = tok 8 CTokInline idkwtok ('i' : 'n' : 'l' : 'i' : 'n' : 'e' : []) = tok 6 CTokInline idkwtok ('_' : '_' : 'i' : 'n' : 'l' : 'i' : 'n' : 'e' : '_' : '_' : []) = tok 10 CTokInline idkwtok ('i' : 'n' : 't' : []) = tok 3 CTokInt idkwtok ('_' : '_' : 'l' : 'a' : 'b' : 'e' : 'l' : '_' : '_' : []) = tok 9 CTokLabel idkwtok ('l' : 'o' : 'n' : 'g' : []) = tok 4 CTokLong idkwtok ('_' : '_' : 'r' : 'e' : 'a' : 'l' : []) = tok 6 (CTokGnuC GnuCComplexReal) idkwtok ('_' : '_' : 'r' : 'e' : 'a' : 'l' : '_' : '_' : []) = tok 8 (CTokGnuC GnuCComplexReal) idkwtok ('r' : 'e' : 'g' : 'i' : 's' : 't' : 'e' : 'r' : []) = tok 8 CTokRegister idkwtok ('_' : '_' : 'r' : 'e' : 's' : 't' : 'r' : 'i' : 'c' : 't' : []) = tok 10 CTokRestrict idkwtok ('r' : 'e' : 's' : 't' : 'r' : 'i' : 'c' : 't' : []) = tok 8 CTokRestrict idkwtok ('_' : '_' : 'r' : 'e' : 's' : 't' : 'r' : 'i' : 'c' : 't' : '_' : '_' : []) = tok 12 CTokRestrict idkwtok ('r' : 'e' : 't' : 'u' : 'r' : 'n' : []) = tok 6 CTokReturn idkwtok ('s' : 'h' : 'o' : 'r' : 't' : []) = tok 5 CTokShort idkwtok ('_' : '_' : 's' : 'i' : 'g' : 'n' : 'e' : 'd' : []) = tok 8 CTokSigned idkwtok ('s' : 'i' : 'g' : 'n' : 'e' : 'd' : []) = tok 6 CTokSigned idkwtok ('_' : '_' : 's' : 'i' : 'g' : 'n' : 'e' : 'd' : '_' : '_' : []) = tok 10 CTokSigned idkwtok ('s' : 'i' : 'z' : 'e' : 'o' : 'f' : []) = tok 6 CTokSizeof idkwtok ('s' : 't' : 'a' : 't' : 'i' : 'c' : []) = tok 6 CTokStatic idkwtok ('s' : 't' : 'r' : 'u' : 'c' : 't' : []) = tok 6 CTokStruct idkwtok ('s' : 'w' : 'i' : 't' : 'c' : 'h' : []) = tok 6 CTokSwitch idkwtok ('_' : '_' : 't' : 'h' : 'r' : 'e' : 'a' : 'd' : []) = tok 8 CTokThread idkwtok ('t' : 'y' : 'p' : 'e' : 'd' : 'e' : 'f' : []) = tok 7 CTokTypedef idkwtok ('_' : '_' : 't' : 'y' : 'p' : 'e' : 'o' : 'f' : []) = tok 8 CTokTypeof idkwtok ('t' : 'y' : 'p' : 'e' : 'o' : 'f' : []) = tok 6 CTokTypeof idkwtok ('_' : '_' : 't' : 'y' : 'p' : 'e' : 'o' : 'f' : '_' : '_' : []) = tok 10 CTokTypeof idkwtok ('u' : 'n' : 'i' : 'o' : 'n' : []) = tok 5 CTokUnion idkwtok ('u' : 'n' : 's' : 'i' : 'g' : 'n' : 'e' : 'd' : []) = tok 8 CTokUnsigned idkwtok ('v' : 'o' : 'i' : 'd' : []) = tok 4 CTokVoid idkwtok ('_' : '_' : 'v' : 'o' : 'l' : 'a' : 't' : 'i' : 'l' : 'e' : []) = tok 10 CTokVolatile idkwtok ('v' : 'o' : 'l' : 'a' : 't' : 'i' : 'l' : 'e' : []) = tok 8 CTokVolatile idkwtok ('_' : '_' : 'v' : 'o' : 'l' : 'a' : 't' : 'i' : 'l' : 'e' : '_' : '_' : []) = tok 12 CTokVolatile idkwtok ('w' : 'h' : 'i' : 'l' : 'e' : []) = tok 5 CTokWhile idkwtok cs = \pos -> do name <- getNewName let len = case length cs of l -> l let ident = mkIdent pos cs name tyident <- isTypeIdent ident if tyident then return (CTokTyIdent (pos,len) ident) else return (CTokIdent (pos,len) ident) ignoreAttribute :: P () ignoreAttribute = skipTokens (0::Int) where skipTokens :: Int -> P () skipTokens n = do tok <- lexToken' False case tok of CTokRParen _ | n == 1 -> return () | otherwise -> skipTokens (n-1) CTokLParen _ -> skipTokens (n+1) _ -> skipTokens n tok :: Int -> (PosLength -> CToken) -> Position -> P CToken tok len tc pos = return (tc (pos,len)) adjustLineDirective :: Int -> String -> Position -> Position adjustLineDirective pragmaLen str pos = offs' `seq` fname' `seq` row' `seq` (position offs' fname' row' 1) where offs' = (posOffset pos) + pragmaLen str' = dropWhite . drop 1 $ str (rowStr, str'') = span isDigit str' row' = read rowStr str''' = dropWhite str'' fnameStr = takeWhile (/= '"') . drop 1 $ str''' fname = posFile pos fname' | null str''' || head str''' /= '"' = fname -- try and get more sharing of file name strings | fnameStr == fname = fname | otherwise = fnameStr -- dropWhite = dropWhile (\c -> c == ' ' || c == '\t') -- special utility for the lexer unescapeMultiChars :: String -> [Char] unescapeMultiChars cs@(_ : _ : _) = case unescapeChar cs of (c,cs') -> c : unescapeMultiChars cs' unescapeMultiChars ('\'' : []) = [] unescapeMultiChars _ = error "Unexpected end of multi-char constant" {-# INLINE token_ #-} -- token that ignores the string token_ :: Int -> (PosLength -> CToken) -> Position -> Int -> InputStream -> P CToken token_ len tok pos _ _ = return (tok (pos,len)) {-# INLINE token_fail #-} -- error token token_fail :: String -> Position -> Int -> InputStream -> P CToken token_fail errmsg pos _ _ = failP pos [ "Lexical Error !", errmsg ] {-# INLINE token #-} -- token that uses the string token :: (PosLength -> a -> CToken) -> (String -> a) -> Position -> Int -> InputStream -> P CToken token tok read pos len str = return (tok (pos,len) (read $ takeChars len str)) {-# INLINE token_plus #-} -- token that may fail token_plus :: (PosLength -> a -> CToken) -> (String -> Either String a) -> Position -> Int -> InputStream -> P CToken token_plus tok read pos len str = case read (takeChars len str) of Left err -> failP pos [ "Lexical error ! ", err ] Right ok -> return $! tok (pos,len) ok -- ----------------------------------------------------------------------------- -- The input type type AlexInput = (Position, -- current position, InputStream) -- current input string alexInputPrevChar :: AlexInput -> Char alexInputPrevChar _ = error "alexInputPrevChar not used" -- for alex-3.0 alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) alexGetByte (p,is) | inputStreamEmpty is = Nothing | otherwise = let (b,s) = takeByte is in -- this is safe for latin-1, but ugly let p' = alexMove p (chr (fromIntegral b)) in p' `seq` Just (b, (p', s)) alexGetChar :: AlexInput -> Maybe (Char,AlexInput) alexGetChar (p,is) | inputStreamEmpty is = Nothing | otherwise = let (c,s) = takeChar is in let p' = alexMove p c in p' `seq` Just (c, (p', s)) alexMove :: Position -> Char -> Position alexMove pos ' ' = incPos pos 1 alexMove pos '\n' = retPos pos alexMove pos '\r' = incOffset pos 1 alexMove pos _ = incPos pos 1 lexicalError :: P a lexicalError = do pos <- getPos (c,cs) <- liftM takeChar getInput failP pos ["Lexical error !", "The character " ++ show c ++ " does not fit here."] parseError :: P a parseError = do tok <- getLastToken failP (posOf tok) ["Syntax error !", "The symbol `" ++ show tok ++ "' does not fit here."] -- there is a problem with ignored tokens here (that aren't skipped) -- consider -- 1 > int x; -- 2 > LINE "ex.c" 4 -- 4 > int y; -- when we get to LINE, we have [int (1,1),x (1,4)] in the token cache. -- Now we run -- > action (pos 2,0) 14 "LINE \"ex.c\" 3\n" -- which in turn adjusts the position and then calls lexToken again -- we get `int (pos 4,0)', and have [x (1,4), int (4,1) ] in the token cache (fine) -- but then, we again call setLastToken when returning and get [int (4,1),int (4,1)] in the token cache (bad) -- to resolve this, recursive calls invoke lexToken' False. lexToken :: P CToken lexToken = lexToken' True lexToken' :: Bool -> P CToken lexToken' modifyCache = do pos <- getPos inp <- getInput case alexScan (pos, inp) 0 of AlexEOF -> do handleEofToken return CTokEof AlexError inp' -> lexicalError AlexSkip (pos', inp') len -> do setPos pos' setInput inp' lexToken' modifyCache AlexToken (pos', inp') len action -> do setPos pos' setInput inp' tok <- action pos len inp when modifyCache $ setLastToken tok return tok lexC :: (CToken -> P a) -> P a lexC cont = do tok <- lexToken cont tok } language-c-0.4.7/src/Language/C/Parser/Parser.y0000644000000000000000000023377412425376061017317 0ustar0000000000000000----------------------------------------------------------------------------- -- Module : Parser.y -- Copyright : (c) 2005-2007 Duncan Coutts -- (c) 2008 Benedikt Huber -- (c) [1999..2004] Manuel M T Chakravarty -- Portions copyright 1989, 1990 James A. Roskind -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Portability : portable -- -- Parser for C translation units, which have already been run through the C -- preprocessor. It is recommended to use the `strict' flag for happy. -- -- The parser recognizes all of ISO C 99 and most GNU C extensions. -- -- With C99 we refer to the ISO C99 standard, specifically the section numbers -- used below refer to this report: -- -- -- -- GNU extensions are documented in the gcc parser -- -- -- -- and in: -- -- The set of supported extensions is documented in -- -- ------------------------------------------------------------------ { module Language.C.Parser.Parser ( -- * Parse a C translation unit parseC, -- * Exposed Parsers translUnitP, extDeclP, statementP, expressionP ) where -- Relevant C99 sections: -- -- 6.5 Expressions .1 - .17 and 6.6 (almost literally) -- Supported GNU extensions: -- - Allow a compound statement as an expression -- - Various __builtin_* forms that take type parameters -- - `alignof' expression or type -- - `__extension__' to suppress warnings about extensions -- - Allow taking address of a label with: && label -- - Omitting the `then' part of conditional expressions -- - complex numbers -- -- 6.7 C Declarations .1 -.8 -- Supported GNU extensions: -- - '__thread' thread local storage (6.7.1) -- -- 6.8 Statements .1 - .8 -- Supported GNU extensions: -- - case ranges (C99 6.8.1) -- - '__label__ ident;' declarations (C99 6.8.2) -- - computed gotos (C99 6.8.6) -- -- 6.9 Translation unit -- Supported GNU extensions: -- - allow empty translation_unit -- - allow redundant ';' -- - allow extension keyword before external declaration -- - asm definitions -- -- Since some of the grammar productions are quite difficult to read, -- (especially those involved with the decleration syntax) we document them -- with an extended syntax that allows a more consise representation: -- -- Ordinary rules -- -- foo named terminal or non-terminal -- -- 'c' terminal, literal character token -- -- A B concatenation -- -- A | B alternation -- -- (A) grouping -- -- Extended rules -- -- A? optional, short hand for (A|) or [A]{ 0==A || 1==A } -- -- ... stands for some part of the grammar omitted for clarity -- -- {A} represents sequences, 0 or more. -- -- modifier which states that any permutation of the immediate subterms is valid -- -- --- TODO ---------------------------------------------------------------------- -- -- !* We ignore the C99 static keyword (see C99 6.7.5.3) -- !* We do not distinguish in the AST between incomplete array types and -- complete variable length arrays ([ '*' ] means the latter). (see C99 6.7.5.2) -- !* The AST doesn't allow recording __attribute__ of unnamed struct field -- (see , struct_default_declaring_list, struct_identifier_declarator) -- !* see `We're being far to liberal here' (... struct definition within structs) -- * Documentation isn't complete and consistent yet. import Prelude hiding (reverse) import qualified Data.List as List import Control.Monad (mplus) import Language.C.Parser.Builtin (builtinTypeNames) import Language.C.Parser.Lexer (lexC, parseError) import Language.C.Parser.Tokens (CToken(..), GnuCTok(..), posLenOfTok) import Language.C.Parser.ParserMonad (P, failP, execParser, getNewName, addTypedef, shadowTypedef, getCurrentPosition, enterScope, leaveScope, getLastToken, getSavedToken, ParseError(..)) import Language.C.Data.RList import Language.C.Data.InputStream import Language.C.Data.Ident import Language.C.Data.Name import Language.C.Data.Node import Language.C.Data.Position import Language.C.Syntax } -- in order to document the parsers, we have to alias them %name translation_unit translation_unit %name external_declaration external_declaration %name statement statement %name expression expression %tokentype { CToken } %monad { P } { >>= } { return } %lexer { lexC } { CTokEof } %expect 1 %token '(' { CTokLParen _ } ')' { CTokRParen _ } '[' { CTokLBracket _ } ']' { CTokRBracket _ } "->" { CTokArrow _ } '.' { CTokDot _ } '!' { CTokExclam _ } '~' { CTokTilde _ } "++" { CTokInc _ } "--" { CTokDec _ } '+' { CTokPlus _ } '-' { CTokMinus _ } '*' { CTokStar _ } '/' { CTokSlash _ } '%' { CTokPercent _ } '&' { CTokAmper _ } "<<" { CTokShiftL _ } ">>" { CTokShiftR _ } '<' { CTokLess _ } "<=" { CTokLessEq _ } '>' { CTokHigh _ } ">=" { CTokHighEq _ } "==" { CTokEqual _ } "!=" { CTokUnequal _ } '^' { CTokHat _ } '|' { CTokBar _ } "&&" { CTokAnd _ } "||" { CTokOr _ } '?' { CTokQuest _ } ':' { CTokColon _ } '=' { CTokAssign _ } "+=" { CTokPlusAss _ } "-=" { CTokMinusAss _ } "*=" { CTokStarAss _ } "/=" { CTokSlashAss _ } "%=" { CTokPercAss _ } "&=" { CTokAmpAss _ } "^=" { CTokHatAss _ } "|=" { CTokBarAss _ } "<<=" { CTokSLAss _ } ">>=" { CTokSRAss _ } ',' { CTokComma _ } ';' { CTokSemic _ } '{' { CTokLBrace _ } '}' { CTokRBrace _ } "..." { CTokEllipsis _ } alignof { CTokAlignof _ } asm { CTokAsm _ } auto { CTokAuto _ } break { CTokBreak _ } "_Bool" { CTokBool _ } case { CTokCase _ } char { CTokChar _ } const { CTokConst _ } continue { CTokContinue _ } "_Complex" { CTokComplex _ } default { CTokDefault _ } do { CTokDo _ } double { CTokDouble _ } else { CTokElse _ } enum { CTokEnum _ } extern { CTokExtern _ } float { CTokFloat _ } for { CTokFor _ } goto { CTokGoto _ } if { CTokIf _ } inline { CTokInline _ } int { CTokInt _ } long { CTokLong _ } "__label__" { CTokLabel _ } register { CTokRegister _ } restrict { CTokRestrict _ } return { CTokReturn _ } short { CTokShort _ } signed { CTokSigned _ } sizeof { CTokSizeof _ } static { CTokStatic _ } struct { CTokStruct _ } switch { CTokSwitch _ } typedef { CTokTypedef _ } typeof { CTokTypeof _ } "__thread" { CTokThread _ } union { CTokUnion _ } unsigned { CTokUnsigned _ } void { CTokVoid _ } volatile { CTokVolatile _ } while { CTokWhile _ } cchar { CTokCLit _ _ } -- character constant cint { CTokILit _ _ } -- integer constant cfloat { CTokFLit _ _ } -- float constant cstr { CTokSLit _ _ } -- string constant (no escapes) ident { CTokIdent _ $$ } -- identifier tyident { CTokTyIdent _ $$ } -- `typedef-name' identifier "__attribute__" { CTokGnuC GnuCAttrTok _ } -- special GNU C tokens "__extension__" { CTokGnuC GnuCExtTok _ } -- special GNU C tokens "__real__" { CTokGnuC GnuCComplexReal _ } "__imag__" { CTokGnuC GnuCComplexImag _ } -- special GNU C builtin 'functions' that actually take types as parameters: "__builtin_va_arg" { CTokGnuC GnuCVaArg _ } "__builtin_offsetof" { CTokGnuC GnuCOffsetof _ } "__builtin_types_compatible_p" { CTokGnuC GnuCTyCompat _ } %% -- parse a complete C translation unit -- we have to take special care of empty translation units translation_unit :: { CTranslUnit } translation_unit : ext_decl_list {% let decls = reverse $1 in case decls of [] -> do{ n <- getNewName; p <- getCurrentPosition; return $ CTranslUnit decls (mkNodeInfo' p (p,0) n) } (d:ds) -> withNodeInfo d $ CTranslUnit decls } -- parse a list of external declarations, making up a C translation unit (C99 6.9) -- -- * GNU extensions: -- allow empty translation_unit -- allow redundant ';' -- ext_decl_list :: { Reversed [CExtDecl] } ext_decl_list : {- empty -} { empty } | ext_decl_list ';' { $1 } | ext_decl_list external_declaration { $1 `snoc` $2 } -- parse external C declaration (C99 6.9) -- -- * GNU extensions: -- allow extension keyword before external declaration -- asm definitions external_declaration :: { CExtDecl } external_declaration : function_definition { CFDefExt $1 } | declaration { CDeclExt $1 } | "__extension__" external_declaration { $2 } | asm '(' string_literal ')' ';' {% withNodeInfo $1 $ CAsmExt $3 } -- parse C function definition (C99 6.9.1) -- -- function_definition :- specifiers? fun-declarator compound-statement -- specifiers? old-fun-declarator declaration-list compound-statement -- -- The specifiers are a list consisting of type-names (int, struct foo, ...), -- storage-class specifiers (extern, static,...) and type qualifiers (const, volatile, ...). -- -- declaration_specifier :- type-qualifier* storage-class+ typename+ "extern unsigned static volatile int f()" -- type_specifier :- type-qualifier* typename+ "const int f()", "long int f()" -- declaration_qualifier_list :- type_qualifier* storage-class+ "extern static const f()" -- type_qualifier_list :- type-qualifier+ "const f()" -- -- * GNU extension: -- __attribute__ annotations -- function_definition :: { CFunDef } function_definition : function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef [] $1 [] $2) } | attrs function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftCAttrs $1) $2 [] $3) } | declaration_specifier function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) } | type_specifier function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) } | declaration_qualifier_list function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef (reverse $1) $2 [] $3) } | type_qualifier_list function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 [] $3) } | type_qualifier_list attrs function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1 ++ liftCAttrs $2) $3 [] $4) } -- old function declarators | function_declarator_old declaration_list compound_statement {% withNodeInfo $1 $ CFunDef [] $1 (reverse $2) $3 } | attrs function_declarator_old declaration_list compound_statement {% withNodeInfo $2 $ CFunDef (liftCAttrs $1) $2 (reverse $3) $4 } | declaration_specifier function_declarator_old declaration_list compound_statement {% withNodeInfo $1 $ CFunDef $1 $2 (reverse $3) $4 } | type_specifier function_declarator_old declaration_list compound_statement {% withNodeInfo $1 $ CFunDef $1 $2 (reverse $3) $4 } | declaration_qualifier_list function_declarator_old declaration_list compound_statement {% withNodeInfo $1 $ CFunDef (reverse $1) $2 (reverse $3) $4 } | type_qualifier_list function_declarator_old declaration_list compound_statement {% withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 (reverse $3) $4 } | type_qualifier_list attrs function_declarator_old declaration_list compound_statement {% withNodeInfo $1 $ CFunDef (liftTypeQuals $1 ++ liftCAttrs $2) $3 (reverse $4) $5 } -- Read declarator and put function function_declarator :: { CDeclr } function_declarator : identifier_declarator {% let declr = reverseDeclr $1 in enterScope >> doFuncParamDeclIdent declr >> return declr } -- parse C statement (C99 6.8) -- -- * GNU extension: ' __asm__ (...); ' statements -- statement :: { CStat } statement : labeled_statement { $1 } | compound_statement { $1 } | expression_statement { $1 } | selection_statement { $1 } | iteration_statement { $1 } | jump_statement { $1 } | asm_statement {% withNodeInfo $1 (CAsm $1) } -- parse C labeled statement (C99 6.8.1) -- -- * GNU extension: case ranges -- labeled_statement :: { CStat } labeled_statement : identifier ':' attrs_opt statement {% withNodeInfo $1 $ CLabel $1 $4 $3 } | case constant_expression ':' statement {% withNodeInfo $1 $ CCase $2 $4 } | default ':' statement {% withNodeInfo $1 $ CDefault $3 } | case constant_expression "..." constant_expression ':' statement {% withNodeInfo $1 $ CCases $2 $4 $6 } -- parse C compound statement (C99 6.8.2) -- -- * GNU extension: '__label__ ident;' declarations -- compound_statement :: { CStat } compound_statement : '{' enter_scope block_item_list leave_scope '}' {% withNodeInfo $1 $ CCompound [] (reverse $3) } | '{' enter_scope label_declarations block_item_list leave_scope '}' {% withNodeInfo $1 $ CCompound (reverse $3) (reverse $4) } -- No syntax for these, just side effecting semantic actions. -- enter_scope :: { () } enter_scope : {% enterScope } leave_scope :: { () } leave_scope : {% leaveScope } block_item_list :: { Reversed [CBlockItem] } block_item_list : {- empty -} { empty } | block_item_list block_item { $1 `snoc` $2 } block_item :: { CBlockItem } block_item : statement { CBlockStmt $1 } | nested_declaration { $1 } nested_declaration :: { CBlockItem } nested_declaration : declaration { CBlockDecl $1 } | nested_function_definition { CNestedFunDef $1 } | "__extension__" nested_declaration { $2 } nested_function_definition :: { CFunDef } nested_function_definition : declaration_specifier function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) } | type_specifier function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) } | declaration_qualifier_list function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef (reverse $1) $2 [] $3) } | type_qualifier_list function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 [] $3) } | type_qualifier_list attrs function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1 ++ liftCAttrs $2) $3 [] $4) } label_declarations :: { Reversed [Ident] } label_declarations : "__label__" identifier_list ';' { $2 } --TODO | label_declarations "__label__" identifier_list ';' { $1 `rappendr` $3 } -- parse C expression statement (C99 6.8.3) -- expression_statement :: { CStat } expression_statement : ';' {% withNodeInfo $1 $ CExpr Nothing } | expression ';' {% withNodeInfo $1 $ CExpr (Just $1) } -- parse C selection statement (C99 6.8.4) -- selection_statement :: { CStat } selection_statement : if '(' expression ')' statement {% withNodeInfo $1 $ CIf $3 $5 Nothing } | if '(' expression ')' statement else statement {% withNodeInfo $1 $ CIf $3 $5 (Just $7) } | switch '(' expression ')' statement {% withNodeInfo $1 $ CSwitch $3 $5 } -- parse C iteration statement (C99 6.8.5) -- iteration_statement :: { CStat } iteration_statement : while '(' expression ')' statement {% withNodeInfo $1 $ CWhile $3 $5 False } | do statement while '(' expression ')' ';' {% withNodeInfo $1 $ CWhile $5 $2 True } | for '(' expression_opt ';' expression_opt ';' expression_opt ')' statement {% withNodeInfo $1 $ CFor (Left $3) $5 $7 $9 } | for '(' enter_scope declaration expression_opt ';' expression_opt ')' statement leave_scope {% withNodeInfo $1 $ CFor (Right $4) $5 $7 $9 } -- parse C jump statement (C99 6.8.6) -- -- * GNU extension: computed gotos -- jump_statement :: { CStat } jump_statement : goto identifier ';' {% withNodeInfo $1 $ CGoto $2 } | goto '*' expression ';' {% withNodeInfo $1 $ CGotoPtr $3 } | continue ';' {% withNodeInfo $1 $ CCont } | break ';' {% withNodeInfo $1 $ CBreak } | return expression_opt ';' {% withNodeInfo $1 $ CReturn $2 } -- parse GNU C __asm__ statement (compatible with C99: J.5.10) -- -- asm_stmt :- asm volatile? ( "asm..." : output-operands : input-operands : asm-clobbers ) -- asm_operand :- [operand-name] "constraint" ( expr ) -- asm_clobber :- "r1", "r2", ... -- asm_statement :: { CAsmStmt } asm_statement : asm maybe_type_qualifier '(' string_literal ')' ';' {% withNodeInfo $1 $ CAsmStmt $2 $4 [] [] [] } | asm maybe_type_qualifier '(' string_literal ':' asm_operands ')' ';' {% withNodeInfo $1 $ CAsmStmt $2 $4 $6 [] [] } | asm maybe_type_qualifier '(' string_literal ':' asm_operands ':' asm_operands ')' ';' {% withNodeInfo $1 $ CAsmStmt $2 $4 $6 $8 [] } | asm maybe_type_qualifier '(' string_literal ':' asm_operands ':' asm_operands ':' asm_clobbers ')' ';' {% withNodeInfo $1 $ CAsmStmt $2 $4 $6 $8 (reverse $10) } maybe_type_qualifier :: { Maybe CTypeQual } maybe_type_qualifier : {- empty -} { Nothing } | type_qualifier { Just $1 } asm_operands :: { [CAsmOperand] } asm_operands : {- empty -} { [] } | nonnull_asm_operands { reverse $1 } nonnull_asm_operands :: { Reversed [CAsmOperand] } nonnull_asm_operands : asm_operand { singleton $1 } | nonnull_asm_operands ',' asm_operand { $1 `snoc` $3 } asm_operand :: { CAsmOperand } asm_operand : string_literal '(' expression ')' {% withNodeInfo $1 $ CAsmOperand Nothing $1 $3 } | '[' ident ']' string_literal '(' expression ')' {% withNodeInfo $1 $ CAsmOperand (Just $2) $4 $6 } | '[' tyident ']' string_literal '(' expression ')' {% withNodeInfo $1 $ CAsmOperand (Just $2) $4 $6 } asm_clobbers :: { Reversed [CStrLit] } asm_clobbers : string_literal { singleton $1 } | asm_clobbers ',' string_literal { $1 `snoc` $3 } {- --------------------------------------------------------------------------------------------------------------- --------------------------------------------------------------------------------------------------------------- -- Declarations --------------------------------------------------------------------------------------------------------------- --------------------------------------------------------------------------------------------------------------- Declarations are the most complicated part of the grammar, and shall be summarized here. To allow a lightweight notation, we will use the modifier to indicate that the order of the immidieate right-hand sides doesn't matter. - a* b+ c === any sequence of a's, b's and c's, which contains exactly 1 'c' and at least one 'b' -- storage class and type qualifier --------------------------------------------------------------------------------------------------------------- attr :- __attribute__((..)) storage_class :- typedef | extern | static | auto | register | __thread type_qualifier :- const | volatile | restrict | inline type_qualifier_list :- type_qualifier+ declaration_qualifier :- storage_class | type_qualifier declaration_qualifier_list :- type_qualifier* storage_class+ qualifiers :- declaration_qualifier_list | type_qualifier_list := (type_qualifier|storage_class)+ -- type names --------------------------------------------------------------------------------------------------------------- declaration_specifier :- type_qualifier* storage_class+ (basic_type_name+ | elaborated_type_name | tyident ) type_specifier :- type_qualifier* (basic_type_name+ | elaborated_type_name | tyident) specifiers :- declaration_specifier | type_specifier := type_qualifier* storage_class* (basic_type_name+ | elaborated_type_name | tyident ) -- struct/union/enum declarations --------------------------------------------------------------------------------------------------------------- sue_declaration_specifier :- type_qualifier* storage_class+ elaborated_type_name sue_type_specifier :- type_qualifier* elaborated_type_name sue_declaration := sue_declaration_specifier | sue_type_specifier :- type_qualifier* storage_class* elaborated_type_name -- declarators --------------------------------------------------------------------------------------------------------------- identifier_declarator :- ( '*' (type_qualifier | attr)* ) * ident [ array_decl | "(" parameter-list ")" ] plus additional parenthesis' ending ^^ here typedef_declartor :- declarator :- identifier_declarator | typedef_declarator -- Declaration lists --------------------------------------------------------------------------------------------------------------- default_declaring_list :- qualifiers ( identifier_declarator asm*attrs* initializer? )_comma_list declaring_list :- specifiers ( declarator asm*attrs* initializer? )_comma_list declaration_list := default_declaring_list | declaring_list -- Declaration --------------------------------------------------------------------------------------------------------------- declaration = sue_declaration | declaration_list --------------------------------------------------------------------------------------------------------------- --------------------------------------------------------------------------------------------------------------- -- Attributes -- (citing http://gcc.gnu.org/onlinedocs/gcc/Attribute-Syntax.html) --------------------------------------------------------------------------------------------------------------- --------------------------------------------------------------------------------------------------------------- "Attributes may appear after the colon following a label (expect case and default)" labeled_statement :- identifier ':' attrs_opt statement "Attributes may go either immediately after the struct/union/enum keyword or after the closing brace" struct attrs_opt ... struct ... { } attrs_opt "In general: Attributes appear as part of declarations, either belonging to a declaration or declarator" "Any list of specifiers and qualifiers at the start of a declaration may contain attribute specifiers" "An attribute list may appear immediately before the comma, = or semicolon terminating a declaration of an identifier" --------------------------------------------------------------------------------------------------------------- For the parser, we modified the following rules to be interleaved with attributes: default_declaring_list' :- (declaration_qualifier_list' | type_qualifier_list' attr*) identifier_declarator asm*attr* initializer? { ',' attr* identifier_declarator asm*attr* initializer? } declaring_list' :- specifier' declarator asm*attr* initializer? { ',' attr* declarator asm*attr* initializer? } type_qualifier_list' is like type_qualifier_list, but with preceeding and/or interleaving (but not terminating) __attribute__ annotations. declaration_qualifier_list', declaration_specifier' and type_specifier' are like their unprimed variants, but with arbitrary preceeding, interleaving and/or terminating __attribute__ annotations. "An attribute list may appear immediately before a declarator other than the first in a comma seperated list of declarators" "The attribute specifiers may be the only specifiers present (implicit int)" [not supported] "Attribute specifiers may be mixed with type qualifiers appearing inside the [] of an parameter array declarator" tbc. -} -- parse C declaration (C99 6.7) declaration :: { CDecl } declaration : sue_declaration_specifier ';' {% withNodeInfo $1 $ CDecl (reverse $1) [] } | sue_type_specifier ';' {% withNodeInfo $1 $ CDecl (reverse $1) [] } | declaring_list ';' {% case $1 of CDecl declspecs dies at -> withLength at (CDecl declspecs (List.reverse dies)) } | default_declaring_list ';' {% case $1 of CDecl declspecs dies at -> withLength at (CDecl declspecs (List.reverse dies)) } declaration_list :: { Reversed [CDecl] } declaration_list : {- empty -} { empty } | declaration_list declaration { $1 `snoc` $2 } -- * SUMMARY: default_declaring_list :- qualifier* identifier_declarator asm_attrs initializer? -- { ',' identifier_declarator asm_attrs initializer? } -- -- * GNU extensions -- __attribute__ annotations imm. before an declarator (see Attribute Syntax, paragraph 11) -- asm + __attribute__ annotations (end of declarations, see Attribute Syntax, paragraph 12) -- The assembler annotation is used to specifiy an assembler name for the declarator. -- default_declaring_list :: { CDecl } default_declaring_list : declaration_qualifier_list identifier_declarator asm_attrs_opt {-{}-} initializer_opt {% let declspecs = reverse $1 in do{ declr <- withAsmNameAttrs $3 $2 ; doDeclIdent declspecs declr ; withNodeInfo $1 $ CDecl declspecs [(Just (reverseDeclr declr), $4, Nothing)] }} | type_qualifier_list identifier_declarator asm_attrs_opt {-{}-} initializer_opt {% let declspecs = liftTypeQuals $1 in do{ declr <- withAsmNameAttrs $3 $2 ; doDeclIdent declspecs declr ; withNodeInfo $1 $ CDecl declspecs [(Just (reverseDeclr declr), $4, Nothing)] }} | type_qualifier_list attrs identifier_declarator asm_attrs_opt {-{}-} initializer_opt -- FIX 1600 {% let declspecs = liftTypeQuals $1 in do{ declr <- withAsmNameAttrs $4 $3 ; doDeclIdent declspecs declr ; withNodeInfo $1 $ CDecl (declspecs ++ liftCAttrs $2) [(Just (reverseDeclr declr), $5, Nothing)] }} -- GNU extension: __attribute__ as the only qualifier | attrs identifier_declarator asm_attrs_opt {-{}-} initializer_opt {% let declspecs = liftCAttrs $1 in do{ declr <- withAsmNameAttrs $3 $2 ; doDeclIdent declspecs declr ; withNodeInfo $1 $ CDecl declspecs [(Just (reverseDeclr declr), $4, Nothing)] }} | default_declaring_list ',' attrs_opt identifier_declarator asm_attrs_opt {-{}-} initializer_opt {% case $1 of CDecl declspecs dies at -> do declr <- withAsmNameAttrs (fst $5, snd $5 ++ $3) $4 doDeclIdent declspecs declr withLength at $ CDecl declspecs ((Just (reverseDeclr declr), $6, Nothing) : dies) } -- assembler, followed by attribute annotation asm_attrs_opt :: { (Maybe CStrLit, [CAttr]) } asm_attrs_opt : asm_opt attrs_opt { ($1,$2) } -- -- SUMMARY: declaring_list :- specifier* declarator asm_attrs initializer? -- { ',' declarator asm_attrs initializer? } -- -- GNU extensions: -- __attribute__ annotations imm. before an declarator (see Attribute Syntax, paragraph 11) -- asm + __attribute__ annotations (end of declarations, see Attribute Syntax, paragraph 12) -- declaring_list :: { CDecl } declaring_list : declaration_specifier declarator asm_attrs_opt initializer_opt {% do{ declr <- withAsmNameAttrs $3 $2; doDeclIdent $1 declr; withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr declr), $4, Nothing)] } } | type_specifier declarator asm_attrs_opt initializer_opt {% do{ declr <- withAsmNameAttrs $3 $2; doDeclIdent $1 declr; withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr declr), $4, Nothing)] } } | declaring_list ',' attrs_opt declarator asm_attrs_opt initializer_opt {% case $1 of CDecl declspecs dies at -> do declr <- withAsmNameAttrs (fst $5, snd $5 ++ $3) $4 doDeclIdent declspecs declr return (CDecl declspecs ((Just (reverseDeclr declr), $6, Nothing) : dies) at) } -- parse C declaration specifiers (C99 6.7) -- -- * type_qualifier* storage_class+ (basic_type_name+ | elaborated_type_name | tyident ) -- declaration_specifier :: { [CDeclSpec] } declaration_specifier : basic_declaration_specifier { reverse $1 } -- Arithmetic or void | sue_declaration_specifier { reverse $1 } -- Struct/Union/Enum | typedef_declaration_specifier { reverse $1 } -- Typedef -- A mixture of type qualifiers (const, volatile, restrict, inline) and storage class specifiers -- (extern, static, auto, register, __thread), in any order, but containing at least one storage class specifier. -- -- declaration_qualifier_list :- type_qualifier* storage_class+ -- -- GNU extensions -- * arbitrary interleaved __attribute__ annotations -- declaration_qualifier_list :: { Reversed [CDeclSpec] } declaration_qualifier_list : storage_class { singleton (CStorageSpec $1) } | attrs storage_class { reverseList (liftCAttrs $1) `snoc` (CStorageSpec $2) } | type_qualifier_list storage_class { rmap CTypeQual $1 `snoc` CStorageSpec $2 } | type_qualifier_list attrs storage_class { (rmap CTypeQual $1 `rappend` liftCAttrs $2) `snoc` CStorageSpec $3 } | declaration_qualifier_list declaration_qualifier { $1 `snoc` $2 } | declaration_qualifier_list attr { addTrailingAttrs $1 $2 } -- -- declaration_qualifier :- storage_class | type_qualifier -- declaration_qualifier :: { CDeclSpec } declaration_qualifier : storage_class { CStorageSpec $1 } | type_qualifier { CTypeQual $1 } -- const or volatile -- parse C storage class specifier (C99 6.7.1) -- -- * GNU extensions: '__thread' thread local storage -- storage_class :: { CStorageSpec } storage_class : typedef {% withNodeInfo $1 $ CTypedef } | extern {% withNodeInfo $1 $ CExtern } | static {% withNodeInfo $1 $ CStatic } | auto {% withNodeInfo $1 $ CAuto } | register {% withNodeInfo $1 $ CRegister } | "__thread" {% withNodeInfo $1 $ CThread } -- parse C type specifier (C99 6.7.2) -- -- This recignises a whole list of type specifiers rather than just one -- as in the C99 grammar. -- -- type_specifier :- type_qualifier* (basic_type_name+ | elaborated_type_name | g) -- type_specifier :: { [CDeclSpec] } type_specifier : basic_type_specifier { reverse $1 } -- Arithmetic or void | sue_type_specifier { reverse $1 } -- Struct/Union/Enum | typedef_type_specifier { reverse $1 } -- Typedef basic_type_name :: { CTypeSpec } basic_type_name : void {% withNodeInfo $1 $ CVoidType } | char {% withNodeInfo $1 $ CCharType } | short {% withNodeInfo $1 $ CShortType } | int {% withNodeInfo $1 $ CIntType } | long {% withNodeInfo $1 $ CLongType } | float {% withNodeInfo $1 $ CFloatType } | double {% withNodeInfo $1 $ CDoubleType } | signed {% withNodeInfo $1 $ CSignedType } | unsigned {% withNodeInfo $1 $ CUnsigType } | "_Bool" {% withNodeInfo $1 $ CBoolType } | "_Complex" {% withNodeInfo $1 $ CComplexType } -- A mixture of type qualifiers, storage class and basic type names in any -- order, but containing at least one basic type name and at least one storage -- class specifier. -- -- basic_declaration_specifier :- type_qualifier* storage_class+ basic_type_name+ -- -- GNU extensions -- arbitrary interleaved __attribute__ annotations -- basic_declaration_specifier :: { Reversed [CDeclSpec] } basic_declaration_specifier : declaration_qualifier_list basic_type_name { $1 `snoc` CTypeSpec $2 } | basic_type_specifier storage_class { $1 `snoc` CStorageSpec $2 } | basic_declaration_specifier declaration_qualifier { $1 `snoc` $2 } | basic_declaration_specifier basic_type_name { $1 `snoc` CTypeSpec $2 } | basic_declaration_specifier attr { addTrailingAttrs $1 $2 } -- A mixture of type qualifiers and basic type names in any order, but -- containing at least one basic type name. -- -- basic_type_specifier :- type_qualifier* basic_type_name+ -- -- GNU extensions -- arbitrary interleaved __attribute__ annotations -- basic_type_specifier :: { Reversed [CDeclSpec] } basic_type_specifier -- Arithmetic or void : basic_type_name { singleton (CTypeSpec $1) } | attrs basic_type_name { (reverseList $ liftCAttrs $1) `snoc` (CTypeSpec $2) } | type_qualifier_list basic_type_name { rmap CTypeQual $1 `snoc` CTypeSpec $2 } | type_qualifier_list attrs basic_type_name { rmap CTypeQual $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec $3 } | basic_type_specifier type_qualifier { $1 `snoc` CTypeQual $2 } | basic_type_specifier basic_type_name { $1 `snoc` CTypeSpec $2 } | basic_type_specifier attr { addTrailingAttrs $1 $2 } -- A named or anonymous struct, union or enum type along with at least one -- storage class and any mix of type qualifiers. -- -- * Summary: -- sue_declaration_specifier :- type_qualifier* storage_class+ elaborated_type_name -- sue_declaration_specifier :: { Reversed [CDeclSpec] } sue_declaration_specifier : declaration_qualifier_list elaborated_type_name { $1 `snoc` CTypeSpec $2 } | sue_type_specifier storage_class { $1 `snoc` CStorageSpec $2 } | sue_declaration_specifier declaration_qualifier { $1 `snoc` $2 } | sue_declaration_specifier attr { addTrailingAttrs $1 $2 } -- A struct, union or enum type (named or anonymous) with optional leading and -- trailing type qualifiers. -- -- * Summary: -- sue_type_specifier :- type_qualifier* elaborated_type_name -- -- * GNU Extensions: records __attribute__ annotations -- sue_type_specifier :: { Reversed [CDeclSpec] } sue_type_specifier -- struct/union/enum : elaborated_type_name { singleton (CTypeSpec $1) } | attrs elaborated_type_name { (reverseList $ liftCAttrs $1) `snoc` (CTypeSpec $2) } | type_qualifier_list elaborated_type_name { rmap CTypeQual $1 `snoc` CTypeSpec $2 } | type_qualifier_list attrs elaborated_type_name { rmap CTypeQual $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec $3 } | sue_type_specifier type_qualifier { $1 `snoc` CTypeQual $2 } | sue_type_specifier attr { addTrailingAttrs $1 $2 } -- A typedef'ed type identifier with at least one storage qualifier and any -- number of type qualifiers -- -- * Summary: -- typedef_declaration_specifier :- type_qualifier* storage_class+ tyident -- -- * Note: -- the tyident can also be a: typeof '(' ... ')' -- typedef_declaration_specifier :: { Reversed [CDeclSpec] } typedef_declaration_specifier : typedef_type_specifier storage_class { $1 `snoc` CStorageSpec $2 } | declaration_qualifier_list tyident {% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (CTypeDef $2 at) } | declaration_qualifier_list typeof '(' expression ')' {% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (CTypeOfExpr $4 at) } | declaration_qualifier_list typeof '(' type_name ')' {% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (CTypeOfType $4 at) } | typedef_declaration_specifier declaration_qualifier { $1 `snoc` $2 } | typedef_declaration_specifier attr { addTrailingAttrs $1 $2 } -- typedef'ed type identifier with optional leading and trailing type qualifiers -- -- * Summary: -- type_qualifier* ( tyident | typeof '('...')' ) type_qualifier* -- typedef_type_specifier :: { Reversed [CDeclSpec] } typedef_type_specifier : tyident {% withNodeInfo $1 $ \at -> singleton (CTypeSpec (CTypeDef $1 at)) } | typeof '(' expression ')' {% withNodeInfo $1 $ \at -> singleton (CTypeSpec (CTypeOfExpr $3 at)) } | typeof '(' type_name ')' {% withNodeInfo $1 $ \at -> singleton (CTypeSpec (CTypeOfType $3 at)) } | type_qualifier_list tyident {% withNodeInfo $2 $ \at -> rmap CTypeQual $1 `snoc` CTypeSpec (CTypeDef $2 at) } | type_qualifier_list typeof '(' expression ')' {% withNodeInfo $2 $ \at -> rmap CTypeQual $1 `snoc` CTypeSpec (CTypeOfExpr $4 at) } | type_qualifier_list typeof '(' type_name ')' {% withNodeInfo $2 $ \at -> rmap CTypeQual $1 `snoc` CTypeSpec (CTypeOfType $4 at) } -- repeat with attrs (this could be easier if type qualifier list wouldn't allow leading attributes) | attrs tyident {% withNodeInfo $2 $ \at -> reverseList (liftCAttrs $1) `snoc` (CTypeSpec (CTypeDef $2 at)) } | attrs typeof '(' expression ')' {% withNodeInfo $1 $ \at -> reverseList (liftCAttrs $1) `snoc` (CTypeSpec (CTypeOfExpr $4 at)) } | attrs typeof '(' type_name ')' {% withNodeInfo $2 $ \at -> reverseList (liftCAttrs $1) `snoc` (CTypeSpec (CTypeOfType $4 at)) } | type_qualifier_list attrs tyident {% withNodeInfo $3 $ \at -> rmap CTypeQual $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec (CTypeDef $3 at) } | type_qualifier_list attrs typeof '(' expression ')' {% withNodeInfo $3 $ \at -> rmap CTypeQual $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec (CTypeOfExpr $5 at) } | type_qualifier_list attrs typeof '(' type_name ')' {% withNodeInfo $3 $ \at -> rmap CTypeQual $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec (CTypeOfType $5 at) } | typedef_type_specifier type_qualifier { $1 `snoc` CTypeQual $2 } | typedef_type_specifier attr { addTrailingAttrs $1 $2 } -- A named or anonymous struct, union or enum type. -- -- * Summary: -- (struct|union|enum) (identifier? '{' ... '}' | identifier) -- elaborated_type_name :: { CTypeSpec } elaborated_type_name : struct_or_union_specifier {% withNodeInfo $1 $ CSUType $1 } | enum_specifier {% withNodeInfo $1 $ CEnumType $1 } -- parse C structure or union declaration (C99 6.7.2.1) -- -- * Summary: -- (struct|union) (identifier? '{' ... '}' | identifier) -- struct_or_union_specifier :: { CStructUnion } struct_or_union_specifier : struct_or_union attrs_opt identifier '{' struct_declaration_list '}' {% withNodeInfo $1 $ CStruct (unL $1) (Just $3) (Just$ reverse $5) $2 } | struct_or_union attrs_opt '{' struct_declaration_list '}' {% withNodeInfo $1 $ CStruct (unL $1) Nothing (Just$ reverse $4) $2 } | struct_or_union attrs_opt identifier {% withNodeInfo $1 $ CStruct (unL $1) (Just $3) Nothing $2 } struct_or_union :: { Located CStructTag } struct_or_union : struct { L CStructTag (posOf $1) } | union { L CUnionTag (posOf $1) } struct_declaration_list :: { Reversed [CDecl] } struct_declaration_list : {- empty -} { empty } | struct_declaration_list ';' { $1 } | struct_declaration_list struct_declaration { $1 `snoc` $2 } -- parse C structure declaration (C99 6.7.2.1) -- struct_declaration :: { CDecl } struct_declaration : struct_declaring_list ';' { case $1 of CDecl declspecs dies at -> CDecl declspecs (List.reverse dies) at } | struct_default_declaring_list';' { case $1 of CDecl declspecs dies at -> CDecl declspecs (List.reverse dies) at } | "__extension__" struct_declaration { $2 } -- -- * Note: doesn't redeclare typedef -- -- TODO: FIXME: AST doesn't allow recording attributes of unnamed struct members struct_default_declaring_list :: { CDecl } struct_default_declaring_list : type_qualifier_list attrs_opt struct_identifier_declarator {% withNodeInfo $1 $ case $3 of (d,s) -> CDecl (liftTypeQuals $1 ++ liftCAttrs $2) [(d,Nothing,s)] } -- GNU extension: __attribute__ as only type qualifier | attrs struct_identifier_declarator {% withNodeInfo $1 $ case $2 of (d,s) -> CDecl (liftCAttrs $1) [(d,Nothing,s)] } -- attrs_opt apply to the declared object | struct_default_declaring_list ',' attrs_opt struct_identifier_declarator { case $1 of CDecl declspecs dies at -> case $4 of (Just d,s) -> CDecl declspecs ((Just $ appendObjAttrs $3 d,Nothing,s) : dies) at (Nothing,s) -> CDecl declspecs ((Nothing,Nothing,s) : dies) at } -- FIXME -- * GNU extensions: -- allow anonymous nested structures and unions -- FIXME: cannot record attribute of unnamed field struct_declaring_list :: { CDecl } struct_declaring_list : type_specifier struct_declarator attrs_opt {% withNodeInfo $1 $ case $2 of { (Just d,s) -> CDecl $1 [(Just $! appendObjAttrs $3 d,Nothing,s)] ; (Nothing,s) -> CDecl $1 [(Nothing,Nothing,s)] } } {- DO FIXME -} | struct_declaring_list ',' attrs_opt struct_declarator attrs_opt { case $1 of CDecl declspecs dies attr -> case $4 of (Just d,s) -> CDecl declspecs ((Just$ appendObjAttrs ($3++$5) d,Nothing,s) : dies) attr (Nothing,s) -> CDecl declspecs ((Nothing,Nothing,s) : dies) attr } -- FIXME: We're being far too liberal in the parsing here, we really want to just -- allow unnamed struct and union fields but we're actually allowing any -- unnamed struct member. Making it allow only unnamed structs or unions in -- the parser is far too tricky, it makes things ambiguous. So we'll have to -- diagnose unnamed fields that are not structs/unions in a later stage. -- Note that a plain type specifier can have a trailing attribute | type_specifier {% withNodeInfo $1 $ CDecl $1 [] } -- parse C structure declarator (C99 6.7.2.1) -- struct_declarator :: { (Maybe CDeclr, Maybe CExpr) } struct_declarator : declarator { (Just (reverseDeclr $1), Nothing) } | ':' constant_expression { (Nothing, Just $2) } | declarator ':' constant_expression { (Just (reverseDeclr $1), Just $3) } -- FIXME: anonymous bitfield doesn't allow recording of attributes struct_identifier_declarator :: { (Maybe CDeclr, Maybe CExpr) } struct_identifier_declarator : identifier_declarator { (Just (reverseDeclr $1), Nothing) } | ':' constant_expression { (Nothing, Just $2) } | identifier_declarator ':' constant_expression { (Just (reverseDeclr $1), Just $3) } | struct_identifier_declarator attr { case $1 of { (Nothing,expr) -> (Nothing,expr) {- FIXME -} ; (Just (CDeclr name derived asmname attrs node), bsz) -> (Just (CDeclr name derived asmname (attrs++$2) node),bsz) } } -- parse C enumeration declaration (C99 6.7.2.2) -- -- * Summary: -- enum (identifier? '{' ... '}' | identifier) -- enum_specifier :: { CEnum } enum_specifier : enum attrs_opt '{' enumerator_list '}' {% withNodeInfo $1 $ CEnum Nothing (Just$ reverse $4) $2 } | enum attrs_opt '{' enumerator_list ',' '}' {% withNodeInfo $1 $ CEnum Nothing (Just$ reverse $4) $2 } | enum attrs_opt identifier '{' enumerator_list '}' {% withNodeInfo $1 $ CEnum (Just $3) (Just$ reverse $5) $2 } | enum attrs_opt identifier '{' enumerator_list ',' '}' {% withNodeInfo $1 $ CEnum (Just $3) (Just$ reverse $5) $2 } | enum attrs_opt identifier {% withNodeInfo $1 $ CEnum (Just $3) Nothing $2 } enumerator_list :: { Reversed [(Ident, Maybe CExpr)] } enumerator_list : enumerator { singleton $1 } | enumerator_list ',' enumerator { $1 `snoc` $3 } enumerator :: { (Ident, Maybe CExpr) } enumerator : identifier { ($1, Nothing) } | identifier attr { ($1, Nothing) } | identifier attr '=' constant_expression { ($1, Just $4) } | identifier '=' constant_expression { ($1, Just $3) } -- parse C type qualifier (C99 6.7.3) -- type_qualifier :: { CTypeQual } type_qualifier : const {% withNodeInfo $1 $ CConstQual } | volatile {% withNodeInfo $1 $ CVolatQual } | restrict {% withNodeInfo $1 $ CRestrQual } | inline {% withNodeInfo $1 $ CInlineQual } -- a list containing at least one type_qualifier (const, volatile, restrict, inline) -- and additionally CAttrs type_qualifier_list :: { Reversed [CTypeQual] } type_qualifier_list : attrs_opt type_qualifier { reverseList (map CAttrQual $1) `snoc` $2 } | type_qualifier_list type_qualifier { $1 `snoc` $2 } | type_qualifier_list attrs type_qualifier { ($1 `rappend` map CAttrQual $2) `snoc` $3} -- parse C declarator (C99 6.7.5) -- declarator :: { CDeclrR } declarator : identifier_declarator { $1 } | typedef_declarator { $1 } -- Parse GNU C's asm annotations -- -- Those annotations allow to give an assembler name to a function or identifier. asm_opt :: { Maybe CStrLit } asm_opt : {- empty -} { Nothing } | asm '(' string_literal ')' { Just $3 } -- -- typedef_declarator :- typedef_declarator :: { CDeclrR } typedef_declarator -- would be ambiguous as parameter : paren_typedef_declarator { $1 } -- not ambiguous as param | parameter_typedef_declarator { $1 } -- parameter_typedef_declarator :- tyident declarator_postfix? -- | '(' attrs? clean_typedef_declarator ')' declarator_postfix? -- | '*' attrs? type_qualifier_list? parameter_typedef_declarator -- parameter_typedef_declarator :: { CDeclrR } parameter_typedef_declarator : tyident {% withNodeInfo $1 $ mkVarDeclr $1 } | tyident postfixing_abstract_declarator {% withNodeInfo $1 $ \at -> $2 (mkVarDeclr $1 at) } | clean_typedef_declarator { $1 } -- The following have at least one '*'. -- There is no (redundant) '(' between the '*' and the tyident. -- -- clean_typedef_declarator :- '(' attrs? clean_typedef_declarator ')' declarator_postfix? -- | '*' attrs? type_qualifier_list? parameter_typedef_declarator -- clean_typedef_declarator :: { CDeclrR } clean_typedef_declarator : clean_postfix_typedef_declarator { $1 } | '*' parameter_typedef_declarator {% withNodeInfo $1 $ ptrDeclr $2 [] } | '*' attrs parameter_typedef_declarator {% withAttribute $1 $2 $ ptrDeclr $3 [] } | '*' type_qualifier_list parameter_typedef_declarator {% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) } | '*' type_qualifier_list attrs parameter_typedef_declarator {% withAttribute $1 $3 $ ptrDeclr $4 (reverse $2) } -- clean_postfix_typedef_declarator :- ( attrs? clean_typedef_declarator ) declarator_postfix? -- clean_postfix_typedef_declarator :: { CDeclrR } clean_postfix_typedef_declarator : '(' clean_typedef_declarator ')' { $2 } | '(' clean_typedef_declarator ')' postfixing_abstract_declarator { $4 $2 } | '(' attrs clean_typedef_declarator ')' { appendDeclrAttrs $2 $3 } | '(' attrs clean_typedef_declarator ')' postfixing_abstract_declarator { appendDeclrAttrs $2 ($5 $3) } -- The following have a redundant '(' placed -- immediately to the left of the tyident -- paren_typedef_declarator :: { CDeclrR } paren_typedef_declarator : paren_postfix_typedef_declarator { $1 } -- redundant paren | '*' '(' simple_paren_typedef_declarator ')' {% withNodeInfo $1 $ ptrDeclr $3 [] } | '*' type_qualifier_list '(' simple_paren_typedef_declarator ')' {% withNodeInfo $1 $ ptrDeclr $4 (reverse $2) } | '*' type_qualifier_list attrs '(' simple_paren_typedef_declarator ')' {% withAttribute $1 $3 $ ptrDeclr $5 (reverse $2) } | '*' paren_typedef_declarator {% withNodeInfo $1 $ ptrDeclr $2 [] } | '*' type_qualifier_list paren_typedef_declarator {% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) } | '*' type_qualifier_list attrs paren_typedef_declarator {% withAttribute $1 $3 $ ptrDeclr $4 (reverse $2) } -- redundant paren to left of tname paren_postfix_typedef_declarator :: { CDeclrR } paren_postfix_typedef_declarator : '(' paren_typedef_declarator ')' { $2 } -- redundant paren | '(' simple_paren_typedef_declarator postfixing_abstract_declarator ')' { $3 $2 } | '(' paren_typedef_declarator ')' postfixing_abstract_declarator { $4 $2 } -- Just a type name in any number of nested brackets -- simple_paren_typedef_declarator :: { CDeclrR } simple_paren_typedef_declarator : tyident {% withNodeInfo $1 $ mkVarDeclr $1 } | '(' simple_paren_typedef_declarator ')' { $2 } -- -- Declarators -- * Summary -- declarator :- ( '*' (type_qualifier | attr)* )* ident ( array_decl | "(" parameter-list ")" )? -- + additional parenthesis -- identifier_declarator :: { CDeclrR } identifier_declarator : unary_identifier_declarator { $1 } | paren_identifier_declarator { $1 } unary_identifier_declarator :: { CDeclrR } unary_identifier_declarator : postfix_identifier_declarator { $1 } | '*' identifier_declarator {% withNodeInfo $1 $ ptrDeclr $2 [] } | '*' attrs identifier_declarator {% withAttribute $1 $2 $ ptrDeclr $3 [] } | '*' type_qualifier_list identifier_declarator {% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) } | '*' type_qualifier_list attrs identifier_declarator {% withAttribute $1 $3 $ ptrDeclr $4 (reverse $2) } postfix_identifier_declarator :: { CDeclrR } postfix_identifier_declarator : paren_identifier_declarator postfixing_abstract_declarator { $2 $1 } | '(' unary_identifier_declarator ')' { $2 } | '(' unary_identifier_declarator ')' postfixing_abstract_declarator { $4 $2 } | '(' attrs unary_identifier_declarator ')' { appendDeclrAttrs $2 $3 } | '(' attrs unary_identifier_declarator ')' postfixing_abstract_declarator { appendDeclrAttrs $2 ($5 $3) } -- just an identifier in any number of nested parenthesis paren_identifier_declarator :: { CDeclrR } paren_identifier_declarator : ident {% withNodeInfo $1 $ mkVarDeclr $1 } | '(' paren_identifier_declarator ')' { $2 } | '(' attrs paren_identifier_declarator ')' { appendDeclrAttrs $2 $3 } function_declarator_old :: { CDeclr } function_declarator_old : old_function_declarator { reverseDeclr $1 } old_function_declarator :: { CDeclrR } old_function_declarator : postfix_old_function_declarator { $1 } | '*' old_function_declarator {% withNodeInfo $1 $ ptrDeclr $2 [] } -- FIXME: no attr possible here ??? | '*' type_qualifier_list old_function_declarator {% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) } postfix_old_function_declarator :: { CDeclrR } postfix_old_function_declarator : paren_identifier_declarator '(' identifier_list ')' {% withNodeInfo $1 $ funDeclr $1 (Left $ reverse $3) [] } | '(' old_function_declarator ')' { $2 } | '(' old_function_declarator ')' postfixing_abstract_declarator { $4 $2 } -- parse C parameter type list (C99 6.7.5) -- parameter_type_list :: { ([CDecl], Bool) } parameter_type_list : {- empty -} { ([], False)} | parameter_list { (reverse $1, False) } | parameter_list ',' "..." { (reverse $1, True) } parameter_list :: { Reversed [CDecl] } parameter_list : parameter_declaration { singleton $1 } | parameter_list ',' parameter_declaration { $1 `snoc` $3 } parameter_declaration :: { CDecl } parameter_declaration : declaration_specifier {% withNodeInfo $1 $ CDecl $1 [] } | declaration_specifier abstract_declarator {% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $2), Nothing, Nothing)] } | declaration_specifier identifier_declarator attrs_opt {% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] } | declaration_specifier parameter_typedef_declarator attrs_opt {% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] } | declaration_qualifier_list {% withNodeInfo $1 $ CDecl (reverse $1) [] } | declaration_qualifier_list abstract_declarator {% withNodeInfo $1 $ CDecl (reverse $1) [(Just (reverseDeclr $2), Nothing, Nothing)] } | declaration_qualifier_list identifier_declarator attrs_opt {% withNodeInfo $1 $ CDecl (reverse $1) [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] } | type_specifier {% withNodeInfo $1 $ CDecl $1 [] } | type_specifier abstract_declarator {% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $2), Nothing, Nothing)] } | type_specifier identifier_declarator attrs_opt {% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] } | type_specifier parameter_typedef_declarator attrs_opt {% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] } | type_qualifier_list {% withNodeInfo $1 $ CDecl (liftTypeQuals $1) [] } | type_qualifier_list attr {% withNodeInfo $1 $ CDecl (liftTypeQuals $1 ++ liftCAttrs $2) [] } | type_qualifier_list abstract_declarator {% withNodeInfo $1 $ CDecl (liftTypeQuals $1) [(Just (reverseDeclr $2), Nothing, Nothing)] } | type_qualifier_list identifier_declarator attrs_opt {% withNodeInfo $1 $ CDecl (liftTypeQuals $1) [(Just (reverseDeclr$ appendDeclrAttrs $3 $2), Nothing, Nothing)] } identifier_list :: { Reversed [Ident] } identifier_list : ident { singleton $1 } | identifier_list ',' ident { $1 `snoc` $3 } -- parse C type name (C99 6.7.6) -- type_name :: { CDecl } type_name : type_specifier {% withNodeInfo $1 $ CDecl $1 [] } | type_specifier abstract_declarator {% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $2), Nothing, Nothing)] } | type_qualifier_list attr {% withNodeInfo $1 $ CDecl (liftTypeQuals $1 ++ liftCAttrs $2) [] } | type_qualifier_list abstract_declarator {% withNodeInfo $1 $ CDecl (liftTypeQuals $1) [(Just (reverseDeclr $2), Nothing, Nothing)] } -- parse C abstract declarator (C99 6.7.6) -- -- postfix starts with '(' -- postfixing starts with '(' or '[' -- unary start with '*' abstract_declarator :: { CDeclrR } abstract_declarator : unary_abstract_declarator { $1 } | postfix_abstract_declarator { $1 } | postfixing_abstract_declarator { $1 emptyDeclr } -- -- FIXME -- | postfixing_abstract_declarator attrs_opt { $1 emptyDeclr } postfixing_abstract_declarator :: { CDeclrR -> CDeclrR } postfixing_abstract_declarator : array_abstract_declarator { $1 } | '(' parameter_type_list ')' {% withNodeInfo $1 $ \at declr -> case $2 of (params, variadic) -> funDeclr declr (Right (params,variadic)) [] at } -- * TODO: Note that we recognise but ignore the C99 static keyword (see C99 6.7.5.3) -- -- * TODO: We do not distinguish in the AST between incomplete array types and -- complete variable length arrays ([ '*' ] means the latter). (see C99 6.7.5.2) -- array_abstract_declarator :: { CDeclrR -> CDeclrR } array_abstract_declarator : postfix_array_abstract_declarator { $1 } | array_abstract_declarator postfix_array_abstract_declarator { \decl -> $2 ($1 decl) } -- -- TODO: record static postfix_array_abstract_declarator :: { CDeclrR -> CDeclrR } postfix_array_abstract_declarator : '[' assignment_expression_opt ']' {% withNodeInfo $1 $ \at declr -> arrDeclr declr [] False False $2 at } | '[' attrs assignment_expression_opt ']' {% withAttributePF $1 $2 $ \at declr -> arrDeclr declr [] False False $3 at } | '[' type_qualifier_list assignment_expression_opt ']' {% withNodeInfo $1 $ \at declr -> arrDeclr declr (reverse $2) False False $3 at } | '[' type_qualifier_list attrs assignment_expression_opt ']' {% withAttributePF $1 $3 $ \at declr -> arrDeclr declr (reverse $2) False False $4 at } | '[' static attrs_opt assignment_expression ']' {% withAttributePF $1 $3 $ \at declr -> arrDeclr declr [] False True (Just $4) at } | '[' static type_qualifier_list attrs_opt assignment_expression ']' {% withAttributePF $1 $4 $ \at declr -> arrDeclr declr (reverse $3) False True (Just $5) at } | '[' type_qualifier_list attrs_opt static attrs_opt assignment_expression ']' {% withAttributePF $1 ($3 ++ $5) $ \at declr -> arrDeclr declr (reverse $2) False True (Just $6) at } | '[' '*' attrs_opt ']' {% withAttributePF $1 $3 $ \at declr -> arrDeclr declr [] True False Nothing at } | '[' attrs '*' attrs_opt ']' {% withAttributePF $1 ($2 ++ $4) $ \at declr -> arrDeclr declr [] True False Nothing at } | '[' type_qualifier_list '*' attrs_opt ']' {% withAttributePF $1 $4 $ \at declr -> arrDeclr declr (reverse $2) True False Nothing at } | '[' type_qualifier_list attrs '*' attrs_opt ']' {% withAttributePF $1 ($3 ++ $5) $ \at declr -> arrDeclr declr (reverse $2) True False Nothing at } unary_abstract_declarator :: { CDeclrR } unary_abstract_declarator : '*' {% withNodeInfo $1 $ ptrDeclr emptyDeclr [] } | '*' type_qualifier_list attrs_opt {% withAttribute $1 $3 $ ptrDeclr emptyDeclr (reverse $2) } | '*' abstract_declarator {% withNodeInfo $1 $ ptrDeclr $2 [] } | '*' type_qualifier_list abstract_declarator {% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) } | '*' attrs {% withAttribute $1 $2 $ ptrDeclr emptyDeclr [] } | '*' attrs abstract_declarator {% withAttribute $1 $2 $ ptrDeclr $3 [] } -- postfix_ad starts with '(', postfixing with '(' or '[', unary_abstract starts with '*' postfix_abstract_declarator :: { CDeclrR } postfix_abstract_declarator : '(' unary_abstract_declarator ')' { $2 } | '(' postfix_abstract_declarator ')' { $2 } | '(' postfixing_abstract_declarator ')' { $2 emptyDeclr } | '(' unary_abstract_declarator ')' postfixing_abstract_declarator { $4 $2 } -- FIX 0700 | '(' attrs unary_abstract_declarator ')' { appendDeclrAttrs $2 $3 } | '(' attrs postfix_abstract_declarator ')' { appendDeclrAttrs $2 $3 } | '(' attrs postfixing_abstract_declarator ')' { appendDeclrAttrs $2 ($3 emptyDeclr) } | '(' attrs unary_abstract_declarator ')' postfixing_abstract_declarator { appendDeclrAttrs $2 ($5 $3) } | postfix_abstract_declarator attr { appendDeclrAttrs $2 $1 } -- parse C initializer (C99 6.7.8) -- initializer :: { CInit } initializer : assignment_expression {% withNodeInfo $1 $ CInitExpr $1 } | '{' initializer_list '}' {% withNodeInfo $1 $ CInitList (reverse $2) } | '{' initializer_list ',' '}' {% withNodeInfo $1 $ CInitList (reverse $2) } initializer_opt :: { Maybe CInit } initializer_opt : {- empty -} { Nothing } | '=' initializer { Just $2 } initializer_list :: { Reversed CInitList } initializer_list : {- empty -} { empty } | initializer { singleton ([],$1) } | designation initializer { singleton ($1,$2) } | initializer_list ',' initializer { $1 `snoc` ([],$3) } | initializer_list ',' designation initializer { $1 `snoc` ($3,$4) } -- designation -- -- * GNU extensions: -- old style member designation: 'ident :' -- array range designation -- designation :: { [CDesignator] } designation : designator_list '=' { reverse $1 } | identifier ':' {% withNodeInfo $1 $ \at -> [CMemberDesig $1 at] } | array_designator { [$1] } designator_list :: { Reversed [CDesignator] } designator_list : designator { singleton $1 } | designator_list designator { $1 `snoc` $2 } designator :: { CDesignator } designator : '[' constant_expression ']' {% withNodeInfo $1 $ CArrDesig $2 } | '.' identifier {% withNodeInfo $1 $ CMemberDesig $2 } | array_designator { $1 } array_designator :: { CDesignator } array_designator : '[' constant_expression "..." constant_expression ']' {% withNodeInfo $1 $ CRangeDesig $2 $4 } -- parse C primary expression (C99 6.5.1) -- -- We cannot use a typedef name as a variable -- -- * GNU extensions: -- allow a compound statement as an expression -- __builtin_va_arg -- __builtin_offsetof -- __builtin_types_compatible_p primary_expression :: { CExpr } primary_expression : ident {% withNodeInfo $1 $ CVar $1 } | constant { CConst $1 } | string_literal { CConst (liftStrLit $1) } | '(' expression ')' { $2 } -- GNU extensions | '(' compound_statement ')' {% withNodeInfo $1 $ CStatExpr $2 } | "__builtin_va_arg" '(' assignment_expression ',' type_name ')' {% withNodeInfo $1 $ CBuiltinExpr . CBuiltinVaArg $3 $5 } | "__builtin_offsetof" '(' type_name ',' offsetof_member_designator ')' {% withNodeInfo $1 $ CBuiltinExpr . CBuiltinOffsetOf $3 (reverse $5) } | "__builtin_types_compatible_p" '(' type_name ',' type_name ')' {% withNodeInfo $1 $ CBuiltinExpr . CBuiltinTypesCompatible $3 $5 } offsetof_member_designator :: { Reversed [CDesignator] } offsetof_member_designator : identifier {% withNodeInfo $1 $ singleton . CMemberDesig $1 } | offsetof_member_designator '.' identifier {% withNodeInfo $3 $ ($1 `snoc`) . CMemberDesig $3 } | offsetof_member_designator '[' expression ']' {% withNodeInfo $3 $ ($1 `snoc`) . CArrDesig $3 } -- parse C postfix expression (C99 6.5.2) -- postfix_expression :: { CExpr } postfix_expression : primary_expression { $1 } | postfix_expression '[' expression ']' {% withNodeInfo $1 $ CIndex $1 $3 } | postfix_expression '(' ')' {% withNodeInfo $1 $ CCall $1 [] } | postfix_expression '(' argument_expression_list ')' {% withNodeInfo $1 $ CCall $1 (reverse $3) } | postfix_expression '.' identifier {% withNodeInfo $1 $ CMember $1 $3 False } | postfix_expression "->" identifier {% withNodeInfo $1 $ CMember $1 $3 True } | postfix_expression "++" {% withNodeInfo $1 $ CUnary CPostIncOp $1 } | postfix_expression "--" {% withNodeInfo $1 $ CUnary CPostDecOp $1 } | '(' type_name ')' '{' initializer_list '}' {% withNodeInfo $1 $ CCompoundLit $2 (reverse $5) } | '(' type_name ')' '{' initializer_list ',' '}' {% withNodeInfo $1 $ CCompoundLit $2 (reverse $5) } argument_expression_list :: { Reversed [CExpr] } argument_expression_list : assignment_expression { singleton $1 } | argument_expression_list ',' assignment_expression { $1 `snoc` $3 } -- parse C unary expression (C99 6.5.3) -- -- * GNU extensions: -- 'alignof' expression or type -- '__real' and '__imag' expression -- '__extension__' to suppress warnings about extensions -- allow taking address of a label with: && label -- unary_expression :: { CExpr } unary_expression : postfix_expression { $1 } | "++" unary_expression {% withNodeInfo $1 $ CUnary CPreIncOp $2 } | "--" unary_expression {% withNodeInfo $1 $ CUnary CPreDecOp $2 } | "__extension__" cast_expression { $2 } | unary_operator cast_expression {% withNodeInfo $1 $ CUnary (unL $1) $2 } | sizeof unary_expression {% withNodeInfo $1 $ CSizeofExpr $2 } | sizeof '(' type_name ')' {% withNodeInfo $1 $ CSizeofType $3 } -- GNU: alignof, complex and && extension | alignof unary_expression {% withNodeInfo $1 $ CAlignofExpr $2 } | alignof '(' type_name ')' {% withNodeInfo $1 $ CAlignofType $3 } | "__real__" unary_expression {% withNodeInfo $1 $ CComplexReal $2 } | "__imag__" unary_expression {% withNodeInfo $1 $ CComplexImag $2 } | "&&" identifier {% withNodeInfo $1 $ CLabAddrExpr $2 } unary_operator :: { Located CUnaryOp } unary_operator : '&' { L CAdrOp (posOf $1) } | '*' { L CIndOp (posOf $1) } | '+' { L CPlusOp (posOf $1) } | '-' { L CMinOp (posOf $1) } | '~' { L CCompOp (posOf $1) } | '!' { L CNegOp (posOf $1) } -- parse C cast expression (C99 6.5.4) -- cast_expression :: { CExpr } cast_expression : unary_expression { $1 } | '(' type_name ')' cast_expression {% withNodeInfo $1 $ CCast $2 $4 } -- parse C multiplicative expression (C99 6.5.5) -- multiplicative_expression :: { CExpr } multiplicative_expression : cast_expression { $1 } | multiplicative_expression '*' cast_expression {% withNodeInfo $1 $ CBinary CMulOp $1 $3 } | multiplicative_expression '/' cast_expression {% withNodeInfo $1 $ CBinary CDivOp $1 $3 } | multiplicative_expression '%' cast_expression {% withNodeInfo $1 $ CBinary CRmdOp $1 $3 } -- parse C additive expression (C99 6.5.6) -- additive_expression :: { CExpr } additive_expression : multiplicative_expression { $1 } | additive_expression '+' multiplicative_expression {% withNodeInfo $1 $ CBinary CAddOp $1 $3 } | additive_expression '-' multiplicative_expression {% withNodeInfo $1 $ CBinary CSubOp $1 $3 } -- parse C shift expression (C99 6.5.7) -- shift_expression :: { CExpr } shift_expression : additive_expression { $1 } | shift_expression "<<" additive_expression {% withNodeInfo $1 $ CBinary CShlOp $1 $3 } | shift_expression ">>" additive_expression {% withNodeInfo $1 $ CBinary CShrOp $1 $3 } -- parse C relational expression (C99 6.5.8) -- relational_expression :: { CExpr } relational_expression : shift_expression { $1 } | relational_expression '<' shift_expression {% withNodeInfo $1 $ CBinary CLeOp $1 $3 } | relational_expression '>' shift_expression {% withNodeInfo $1 $ CBinary CGrOp $1 $3 } | relational_expression "<=" shift_expression {% withNodeInfo $1 $ CBinary CLeqOp $1 $3 } | relational_expression ">=" shift_expression {% withNodeInfo $1 $ CBinary CGeqOp $1 $3 } -- parse C equality expression (C99 6.5.9) -- equality_expression :: { CExpr } equality_expression : relational_expression { $1 } | equality_expression "==" relational_expression {% withNodeInfo $1 $ CBinary CEqOp $1 $3 } | equality_expression "!=" relational_expression {% withNodeInfo $1 $ CBinary CNeqOp $1 $3 } -- parse C bitwise and expression (C99 6.5.10) -- and_expression :: { CExpr } and_expression : equality_expression { $1 } | and_expression '&' equality_expression {% withNodeInfo $1 $ CBinary CAndOp $1 $3 } -- parse C bitwise exclusive or expression (C99 6.5.11) -- exclusive_or_expression :: { CExpr } exclusive_or_expression : and_expression { $1 } | exclusive_or_expression '^' and_expression {% withNodeInfo $1 $ CBinary CXorOp $1 $3 } -- parse C bitwise or expression (C99 6.5.12) -- inclusive_or_expression :: { CExpr } inclusive_or_expression : exclusive_or_expression { $1 } | inclusive_or_expression '|' exclusive_or_expression {% withNodeInfo $1 $ CBinary COrOp $1 $3 } -- parse C logical and expression (C99 6.5.13) -- logical_and_expression :: { CExpr } logical_and_expression : inclusive_or_expression { $1 } | logical_and_expression "&&" inclusive_or_expression {% withNodeInfo $1 $ CBinary CLndOp $1 $3 } -- parse C logical or expression (C99 6.5.14) -- logical_or_expression :: { CExpr } logical_or_expression : logical_and_expression { $1 } | logical_or_expression "||" logical_and_expression {% withNodeInfo $1 $ CBinary CLorOp $1 $3 } -- parse C conditional expression (C99 6.5.15) -- -- * GNU extensions: -- omitting the `then' part conditional_expression :: { CExpr } conditional_expression : logical_or_expression { $1 } | logical_or_expression '?' expression ':' conditional_expression {% withNodeInfo $1 $ CCond $1 (Just $3) $5 } | logical_or_expression '?' ':' conditional_expression {% withNodeInfo $1 $ CCond $1 Nothing $4 } -- parse C assignment expression (C99 6.5.16) -- -- * NOTE: LHS of assignment is more restricted than in gcc. -- `x ? y : z = 3' parses in gcc as `(x ? y : z) = 3', -- but `x ? y : z' is not an unary expression. assignment_expression :: { CExpr } assignment_expression : conditional_expression { $1 } | unary_expression assignment_operator assignment_expression {% withNodeInfo $1 $ CAssign (unL $2) $1 $3 } assignment_operator :: { Located CAssignOp } assignment_operator : '=' { L CAssignOp (posOf $1) } | "*=" { L CMulAssOp (posOf $1) } | "/=" { L CDivAssOp (posOf $1) } | "%=" { L CRmdAssOp (posOf $1) } | "+=" { L CAddAssOp (posOf $1) } | "-=" { L CSubAssOp (posOf $1) } | "<<=" { L CShlAssOp (posOf $1) } | ">>=" { L CShrAssOp (posOf $1) } | "&=" { L CAndAssOp (posOf $1) } | "^=" { L CXorAssOp (posOf $1) } | "|=" { L COrAssOp (posOf $1) } -- parse C expression (C99 6.5.17) -- expression :: { CExpr } expression : assignment_expression { $1 } | assignment_expression ',' comma_expression {% let es = reverse $3 in withNodeInfo es $ CComma ($1:es) } comma_expression :: { Reversed [CExpr] } comma_expression : assignment_expression { singleton $1 } | comma_expression ',' assignment_expression { $1 `snoc` $3 } -- The following was used for clarity expression_opt :: { Maybe CExpr } expression_opt : {- empty -} { Nothing } | expression { Just $1 } -- The following was used for clarity assignment_expression_opt :: { Maybe CExpr } assignment_expression_opt : {- empty -} { Nothing } | assignment_expression { Just $1 } -- parse C constant expression (C99 6.6) -- constant_expression :: { CExpr } constant_expression : conditional_expression { $1 } -- parse C constants -- constant :: { CConst } constant : cint {% withNodeInfo $1 $ case $1 of CTokILit _ i -> CIntConst i } | cchar {% withNodeInfo $1 $ case $1 of CTokCLit _ c -> CCharConst c } | cfloat {% withNodeInfo $1 $ case $1 of CTokFLit _ f -> CFloatConst f } string_literal :: { CStrLit } string_literal : cstr {% withNodeInfo $1 $ case $1 of CTokSLit _ s -> CStrLit s } | cstr string_literal_list {% withNodeInfo $1 $ case $1 of CTokSLit _ s -> CStrLit (concatCStrings (s : reverse $2)) } string_literal_list :: { Reversed [CString] } string_literal_list : cstr { case $1 of CTokSLit _ s -> singleton s } | string_literal_list cstr { case $2 of CTokSLit _ s -> $1 `snoc` s } identifier :: { Ident } identifier : ident { $1 } | tyident { $1 } -- parse GNU C attribute annotation attrs_opt :: { [CAttr] } attrs_opt : {- empty -} { [] } | attrs { $1 } -- GNU C attribute annotation attrs :: { [CAttr] } attrs : attr { $1 } | attrs attr { $1 ++ $2 } attr :: { [CAttr] } attr : "__attribute__" '(' '(' attribute_list ')' ')' { reverse $4 } attribute_list :: { Reversed [CAttr] } : attribute { case $1 of Nothing -> empty; Just attr -> singleton attr } | attribute_list ',' attribute { (maybe id (flip snoc) $3) $1 } attribute :: { Maybe CAttr } attribute : {- empty -} { Nothing } | ident {% withNodeInfo $1 $ Just . CAttr $1 [] } | const {% withNodeInfo $1 $ Just . CAttr (internalIdent "const") [] } | ident '(' attribute_params ')' {% withNodeInfo $1 $ Just . CAttr $1 (reverse $3) } | ident '(' ')' {% withNodeInfo $1 $ Just . CAttr $1 [] } -- OS X 10.9 (Mavericks) makes use of more liberal attribute syntax -- that includes assignment-like expressions referencing version -- numbers. attribute_params :: { Reversed [CExpr] } attribute_params : constant_expression { singleton $1 } | unary_expression assignment_operator unary_expression { Reversed [] } | attribute_params ',' constant_expression { $1 `snoc` $3 } | attribute_params ',' unary_expression assignment_operator unary_expression { $1 } { -- sometimes it is neccessary to reverse an unreversed list reverseList :: [a] -> Reversed [a] reverseList = Reversed . List.reverse -- We occasionally need things to have a location when they don't naturally -- have one built in as tokens and most AST elements do. -- data Located a = L !a !Position unL :: Located a -> a unL (L a pos) = a instance Pos (Located a) where posOf (L _ pos) = pos -- FIXME: the next 3 inlines here increase the object file size by 70% -- Check whether the speed win is worth it {-# INLINE withNodeInfo #-} withNodeInfo :: Pos node => node -> (NodeInfo -> a) -> P a withNodeInfo node mkAttrNode = do name <- getNewName lastTok <- getSavedToken let firstPos = posOf node let attrs = mkNodeInfo' firstPos (posLenOfTok $! lastTok) name attrs `seq` return (mkAttrNode attrs) {-# INLINE withLength #-} withLength :: NodeInfo -> (NodeInfo -> a) -> P a withLength nodeinfo mkAttrNode = do lastTok <- getSavedToken let firstPos = posOfNode nodeinfo let attrs = mkNodeInfo' firstPos (posLenOfTok $! lastTok) (maybe (error "nameOfNode") id (nameOfNode nodeinfo)) attrs `seq` return (mkAttrNode attrs) data CDeclrR = CDeclrR (Maybe Ident) (Reversed [CDerivedDeclr]) (Maybe CStrLit) [CAttr] NodeInfo reverseDeclr :: CDeclrR -> CDeclr reverseDeclr (CDeclrR ide reversedDDs asmname cattrs at) = CDeclr ide (reverse reversedDDs) asmname cattrs at instance CNode (CDeclrR) where nodeInfo (CDeclrR _ _ _ _ n) = n instance Pos (CDeclrR) where posOf (CDeclrR _ _ _ _ n) = posOf n {-# INLINE withAttribute #-} withAttribute :: Pos node => node -> [CAttr] -> (NodeInfo -> CDeclrR) -> P CDeclrR withAttribute node cattrs mkDeclrNode = do name <- getNewName let attrs = mkNodeInfo (posOf node) name let newDeclr = appendDeclrAttrs cattrs $ mkDeclrNode attrs attrs `seq` newDeclr `seq` return newDeclr -- postfixing variant {-# INLINE withAttributePF #-} withAttributePF :: Pos node => node -> [CAttr] -> (NodeInfo -> CDeclrR -> CDeclrR) -> P (CDeclrR -> CDeclrR) withAttributePF node cattrs mkDeclrCtor = do name <- getNewName let attrs = mkNodeInfo (posOf node) name let newDeclr = appendDeclrAttrs cattrs . mkDeclrCtor attrs attrs `seq` newDeclr `seq` return newDeclr -- add top level attributes for a declarator. -- -- In the following example -- -- > int declr1, __attribute__((a1)) * __attribute__((a2)) y() __asm__("$" "y") __attribute__((a3)); -- -- the attributes `a1' and `a3' are top-level attributes for y. -- The (pseudo)-AST for the second declarator is -- -- > CDeclr "y" -- > [CFunDeclr ..., CPtrDeclr __attribute__((a2)) ... ] -- > (asm "$y") -- > [__attribute__((a1)), __attribute__((a3)) ] -- -- So assembler names and preceeding and trailing attributes are recorded in object declarator. -- appendObjAttrs :: [CAttr] -> CDeclr -> CDeclr appendObjAttrs newAttrs (CDeclr ident indirections asmname cAttrs at) = CDeclr ident indirections asmname (cAttrs ++ newAttrs) at appendObjAttrsR :: [CAttr] -> CDeclrR -> CDeclrR appendObjAttrsR newAttrs (CDeclrR ident indirections asmname cAttrs at) = CDeclrR ident indirections asmname (cAttrs ++ newAttrs) at setAsmName :: Maybe CStrLit -> CDeclrR -> P CDeclrR setAsmName mAsmName (CDeclrR ident indirections oldName cattrs at) = case combineName mAsmName oldName of Left (n1,n2) -> failP (posOf n2) ["Duplicate assembler name: ",showName n1,showName n2] Right newName -> return $ CDeclrR ident indirections newName cattrs at where combineName Nothing Nothing = Right Nothing combineName Nothing oldname@(Just _) = Right oldname combineName newname@(Just _) Nothing = Right newname combineName (Just n1) (Just n2) = Left (n1,n2) showName (CStrLit cstr _) = show cstr withAsmNameAttrs :: (Maybe CStrLit, [CAttr]) -> CDeclrR -> P CDeclrR withAsmNameAttrs (mAsmName, newAttrs) declr = setAsmName mAsmName (appendObjAttrsR newAttrs declr) appendDeclrAttrs :: [CAttr] -> CDeclrR -> CDeclrR appendDeclrAttrs newAttrs (CDeclrR ident (Reversed []) asmname cattrs at) = CDeclrR ident empty asmname (cattrs ++ newAttrs) at appendDeclrAttrs newAttrs (CDeclrR ident (Reversed (x:xs)) asmname cattrs at) = CDeclrR ident (Reversed (appendAttrs x : xs)) asmname cattrs at where appendAttrs (CPtrDeclr typeQuals at) = CPtrDeclr (typeQuals ++ map CAttrQual newAttrs) at appendAttrs (CArrDeclr typeQuals arraySize at) = CArrDeclr (typeQuals ++ map CAttrQual newAttrs) arraySize at appendAttrs (CFunDeclr parameters cattrs at) = CFunDeclr parameters (cattrs ++ newAttrs) at ptrDeclr :: CDeclrR -> [CTypeQual] -> NodeInfo -> CDeclrR ptrDeclr (CDeclrR ident derivedDeclrs asmname cattrs dat) tyquals at = CDeclrR ident (derivedDeclrs `snoc` CPtrDeclr tyquals at) asmname cattrs dat funDeclr :: CDeclrR -> (Either [Ident] ([CDecl],Bool)) -> [CAttr] -> NodeInfo -> CDeclrR funDeclr (CDeclrR ident derivedDeclrs asmname dcattrs dat) params cattrs at = CDeclrR ident (derivedDeclrs `snoc` CFunDeclr params cattrs at) asmname dcattrs dat arrDeclr :: CDeclrR -> [CTypeQual] -> Bool -> Bool -> Maybe CExpr -> NodeInfo -> CDeclrR arrDeclr (CDeclrR ident derivedDeclrs asmname cattrs dat) tyquals var_sized static_size size_expr_opt at = arr_sz `seq` ( CDeclrR ident (derivedDeclrs `snoc` CArrDeclr tyquals arr_sz at) asmname cattrs dat ) where arr_sz = case size_expr_opt of Just e -> CArrSize static_size e Nothing -> CNoArrSize var_sized liftTypeQuals :: Reversed [CTypeQual] -> [CDeclSpec] liftTypeQuals = map CTypeQual . reverse -- lift CAttrs to DeclSpecs -- liftCAttrs :: [CAttr] -> [CDeclSpec] liftCAttrs = map (CTypeQual . CAttrQual) -- when we parsed (decl_spec_1,...,decl_spec_n,attrs), add the __attributes__s to the declspec list -- needs special care when @decl_spec_n@ is a SUE definition addTrailingAttrs :: Reversed [CDeclSpec] -> [CAttr] -> Reversed [CDeclSpec] addTrailingAttrs declspecs new_attrs = case viewr declspecs of (specs_init, CTypeSpec (CSUType (CStruct tag name (Just def) def_attrs su_node) node)) -> (specs_init `snoc` CTypeSpec (CSUType (CStruct tag name (Just def) (def_attrs ++ new_attrs) su_node) node)) (specs_init, CTypeSpec (CEnumType (CEnum name (Just def) def_attrs e_node) node)) -> (specs_init `snoc` CTypeSpec (CEnumType (CEnum name (Just def) (def_attrs ++ new_attrs) e_node) node)) _ -> declspecs `rappend` (liftCAttrs new_attrs) -- convenient instance, the position of a list of things is the position of -- the first thing in the list -- instance Pos a => Pos [a] where posOf (x:_) = posOf x instance Pos a => Pos (Reversed a) where posOf (Reversed x) = posOf x emptyDeclr :: CDeclrR emptyDeclr = CDeclrR Nothing empty Nothing [] undefNode mkVarDeclr :: Ident -> NodeInfo -> CDeclrR mkVarDeclr ident = CDeclrR (Just ident) empty Nothing [] -- Take the identifiers and use them to update the typedef'ed identifier set -- if the decl is defining a typedef then we add it to the set, -- if it's a var decl then that shadows typedefed identifiers -- doDeclIdent :: [CDeclSpec] -> CDeclrR -> P () doDeclIdent declspecs (CDeclrR mIdent _ _ _ _) = case mIdent of Nothing -> return () Just ident | any iypedef declspecs -> addTypedef ident | otherwise -> shadowTypedef ident where iypedef (CStorageSpec (CTypedef _)) = True iypedef _ = False doFuncParamDeclIdent :: CDeclr -> P () doFuncParamDeclIdent (CDeclr _ (CFunDeclr params _ _ : _) _ _ _) = sequence_ [ case getCDeclrIdent declr of Nothing -> return () Just ident -> shadowTypedef ident | CDecl _ dle _ <- either (const []) fst params , (Just declr, _, _) <- dle ] doFuncParamDeclIdent _ = return () -- extract all identifiers getCDeclrIdent :: CDeclr -> Maybe Ident getCDeclrIdent (CDeclr mIdent _ _ _ _) = mIdent happyError :: P a happyError = parseError -- * public interface -- | @parseC input initialPos@ parses the given preprocessed C-source input and returns the AST or a list of parse errors. parseC :: InputStream -> Position -> Either ParseError CTranslUnit parseC input initialPosition = fmap fst $ execParser translUnitP input initialPosition builtinTypeNames (namesStartingFrom 0) -- | @translUnitP@ provides a parser for a complete C translation unit, i.e. a list of external declarations. translUnitP :: P CTranslUnit translUnitP = translation_unit -- | @extDeclP@ provides a parser for an external (file-scope) declaration extDeclP :: P CExtDecl extDeclP = external_declaration -- | @statementP@ provides a parser for C statements statementP :: P CStat statementP = statement -- | @expressionP@ provides a parser for C expressions expressionP :: P CExpr expressionP = expression } language-c-0.4.7/src/Language/C/Parser/ParserMonad.hs0000644000000000000000000001465212425376061020430 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.C.Syntax.ParserMonad -- Copyright : (c) [1999..2004] Manuel M T Chakravarty -- (c) 2005-2007 Duncan Coutts -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Portability : portable -- -- Monad for the C lexer and parser -- -- This monad has to be usable with Alex and Happy. Some things in it are -- dictated by that, eg having to be able to remember the last token. -- -- The monad also provides a unique name supply (via the Name module) -- -- For parsing C we have to maintain a set of identifiers that we know to be -- typedef'ed type identifiers. We also must deal correctly with scope so we -- keep a list of sets of identifiers so we can save the outer scope when we -- enter an inner scope. module Language.C.Parser.ParserMonad ( P, execParser, failP, getNewName, -- :: P Name addTypedef, -- :: Ident -> P () shadowTypedef, -- :: Ident -> P () isTypeIdent, -- :: Ident -> P Bool enterScope, -- :: P () leaveScope, -- :: P () setPos, -- :: Position -> P () getPos, -- :: P Position getInput, -- :: P String setInput, -- :: String -> P () getLastToken, -- :: P CToken getSavedToken, -- :: P CToken setLastToken, -- :: CToken -> P () handleEofToken, -- :: P () getCurrentPosition,-- :: P Position ParseError(..), ) where import Language.C.Data.Error (internalErr, showErrorInfo,ErrorInfo(..),ErrorLevel(..)) import Language.C.Data.Position (Position(..)) import Language.C.Data.InputStream import Language.C.Data.Name (Name) import Language.C.Data.Ident (Ident) import Language.C.Parser.Tokens (CToken(CTokEof)) import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap) import Data.Set (Set) import qualified Data.Set as Set (fromList, insert, member, delete) newtype ParseError = ParseError ([String],Position) instance Show ParseError where show (ParseError (msgs,pos)) = showErrorInfo "Syntax Error !" (ErrorInfo LevelError pos msgs) data ParseResult a = POk !PState a | PFailed [String] Position -- The error message and position data PState = PState { curPos :: !Position, -- position at current input location curInput :: !InputStream, -- the current input prevToken :: CToken, -- the previous token savedToken :: CToken, -- and the token before that namesupply :: ![Name], -- the name unique supply tyidents :: !(Set Ident), -- the set of typedef'ed identifiers scopes :: ![Set Ident] -- the tyident sets for outer scopes } newtype P a = P { unP :: PState -> ParseResult a } instance Functor P where fmap = liftM instance Applicative P where pure = return (<*>) = ap instance Monad P where return = returnP (>>=) = thenP fail m = getPos >>= \pos -> failP pos [m] -- | execute the given parser on the supplied input stream. -- returns 'ParseError' if the parser failed, and a pair of -- result and remaining name supply otherwise -- -- Synopsis: @execParser parser inputStream initialPos predefinedTypedefs uniqNameSupply@ execParser :: P a -> InputStream -> Position -> [Ident] -> [Name] -> Either ParseError (a,[Name]) execParser (P parser) input pos builtins names = case parser initialState of PFailed message errpos -> Left (ParseError (message,errpos)) POk st result -> Right (result, namesupply st) where initialState = PState { curPos = pos, curInput = input, prevToken = internalErr "CLexer.execParser: Touched undefined token!", savedToken = internalErr "CLexer.execParser: Touched undefined token (safed token)!", namesupply = names, tyidents = Set.fromList builtins, scopes = [] } {-# INLINE returnP #-} returnP :: a -> P a returnP a = P $ \s -> POk s a {-# INLINE thenP #-} thenP :: P a -> (a -> P b) -> P b (P m) `thenP` k = P $ \s -> case m s of POk s' a -> (unP (k a)) s' PFailed err pos -> PFailed err pos failP :: Position -> [String] -> P a failP pos msg = P $ \_ -> PFailed msg pos getNewName :: P Name getNewName = P $ \s@PState{namesupply=(n:ns)} -> n `seq` POk s{namesupply=ns} n setPos :: Position -> P () setPos pos = P $ \s -> POk s{curPos=pos} () getPos :: P Position getPos = P $ \s@PState{curPos=pos} -> POk s pos addTypedef :: Ident -> P () addTypedef ident = (P $ \s@PState{tyidents=tyids} -> POk s{tyidents = ident `Set.insert` tyids} ()) shadowTypedef :: Ident -> P () shadowTypedef ident = (P $ \s@PState{tyidents=tyids} -> -- optimisation: mostly the ident will not be in -- the tyident set so do a member lookup to avoid -- churn induced by calling delete POk s{tyidents = if ident `Set.member` tyids then ident `Set.delete` tyids else tyids } ()) isTypeIdent :: Ident -> P Bool isTypeIdent ident = P $ \s@PState{tyidents=tyids} -> POk s $! Set.member ident tyids enterScope :: P () enterScope = P $ \s@PState{tyidents=tyids,scopes=ss} -> POk s{scopes=tyids:ss} () leaveScope :: P () leaveScope = P $ \s@PState{scopes=ss} -> case ss of [] -> error "leaveScope: already in global scope" (tyids:ss') -> POk s{tyidents=tyids, scopes=ss'} () getInput :: P InputStream getInput = P $ \s@PState{curInput=i} -> POk s i setInput :: InputStream -> P () setInput i = P $ \s -> POk s{curInput=i} () getLastToken :: P CToken getLastToken = P $ \s@PState{prevToken=tok} -> POk s tok getSavedToken :: P CToken getSavedToken = P $ \s@PState{savedToken=tok} -> POk s tok -- | @setLastToken modifyCache tok@ setLastToken :: CToken -> P () setLastToken CTokEof = P $ \s -> POk s{savedToken=(prevToken s)} () setLastToken tok = P $ \s -> POk s{prevToken=tok,savedToken=(prevToken s)} () -- | handle an End-Of-File token (changes savedToken) handleEofToken :: P () handleEofToken = P $ \s -> POk s{savedToken=(prevToken s)} () getCurrentPosition :: P Position getCurrentPosition = P $ \s@PState{curPos=pos} -> POk s poslanguage-c-0.4.7/src/Language/C/Parser/Tokens.hs0000644000000000000000000004135712425376061017462 0ustar0000000000000000{-# OPTIONS #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Parser.Tokens -- Copyright : [1999..2004] Manuel M T Chakravarty -- 2005 Duncan Coutts -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Portability : portable -- -- C Tokens for the C lexer. -- ----------------------------------------------------------------------------- module Language.C.Parser.Tokens (CToken(..), posLenOfTok, GnuCTok(..)) where import Language.C.Data.Position (Position, Pos(..), PosLength) import Language.C.Data.Ident (Ident, identToString) import Language.C.Syntax.Constants (CChar, CInteger, CFloat, CString) -- token definition -- ---------------- -- possible tokens (EXPORTED) -- data CToken = CTokLParen !PosLength -- `(' | CTokRParen !PosLength -- `)' | CTokLBracket !PosLength -- `[' | CTokRBracket !PosLength -- `]' | CTokArrow !PosLength -- `->' | CTokDot !PosLength -- `.' | CTokExclam !PosLength -- `!' | CTokTilde !PosLength -- `~' | CTokInc !PosLength -- `++' | CTokDec !PosLength -- `--' | CTokPlus !PosLength -- `+' | CTokMinus !PosLength -- `-' | CTokStar !PosLength -- `*' | CTokSlash !PosLength -- `/' | CTokPercent !PosLength -- `%' | CTokAmper !PosLength -- `&' | CTokShiftL !PosLength -- `<<' | CTokShiftR !PosLength -- `>>' | CTokLess !PosLength -- `<' | CTokLessEq !PosLength -- `<=' | CTokHigh !PosLength -- `>' | CTokHighEq !PosLength -- `>=' | CTokEqual !PosLength -- `==' | CTokUnequal !PosLength -- `!=' | CTokHat !PosLength -- `^' | CTokBar !PosLength -- `|' | CTokAnd !PosLength -- `&&' | CTokOr !PosLength -- `||' | CTokQuest !PosLength -- `?' | CTokColon !PosLength -- `:' | CTokAssign !PosLength -- `=' | CTokPlusAss !PosLength -- `+=' | CTokMinusAss !PosLength -- `-=' | CTokStarAss !PosLength -- `*=' | CTokSlashAss !PosLength -- `/=' | CTokPercAss !PosLength -- `%=' | CTokAmpAss !PosLength -- `&=' | CTokHatAss !PosLength -- `^=' | CTokBarAss !PosLength -- `|=' | CTokSLAss !PosLength -- `<<=' | CTokSRAss !PosLength -- `>>=' | CTokComma !PosLength -- `,' | CTokSemic !PosLength -- `;' | CTokLBrace !PosLength -- `{' | CTokRBrace !PosLength -- `}' | CTokEllipsis !PosLength -- `...' | CTokAlignof !PosLength -- `alignof' -- (or `__alignof', -- `__alignof__') | CTokAsm !PosLength -- `asm' -- (or `__asm', -- `__asm__') | CTokAuto !PosLength -- `auto' | CTokBreak !PosLength -- `break' | CTokBool !PosLength -- `_Bool' | CTokCase !PosLength -- `case' | CTokChar !PosLength -- `char' | CTokConst !PosLength -- `const' -- (or `__const', `__const__') | CTokContinue !PosLength -- `continue' | CTokComplex !PosLength -- `_Complex' | CTokDefault !PosLength -- `default' | CTokDo !PosLength -- `do' | CTokDouble !PosLength -- `double' | CTokElse !PosLength -- `else' | CTokEnum !PosLength -- `enum' | CTokExtern !PosLength -- `extern' | CTokFloat !PosLength -- `float' | CTokFor !PosLength -- `for' | CTokGoto !PosLength -- `goto' | CTokIf !PosLength -- `if' | CTokInline !PosLength -- `inline' -- (or `__inline', -- `__inline__') | CTokInt !PosLength -- `int' | CTokLong !PosLength -- `long' | CTokLabel !PosLength -- `__label__' | CTokRegister !PosLength -- `register' | CTokRestrict !PosLength -- `restrict' -- (or `__restrict', -- `__restrict__') | CTokReturn !PosLength -- `return' | CTokShort !PosLength -- `short' | CTokSigned !PosLength -- `signed' -- (or `__signed', -- `__signed__') | CTokSizeof !PosLength -- `sizeof' | CTokStatic !PosLength -- `static' | CTokStruct !PosLength -- `struct' | CTokSwitch !PosLength -- `switch' | CTokTypedef !PosLength -- `typedef' | CTokTypeof !PosLength -- `typeof' | CTokThread !PosLength -- `__thread' | CTokUnion !PosLength -- `union' | CTokUnsigned !PosLength -- `unsigned' | CTokVoid !PosLength -- `void' | CTokVolatile !PosLength -- `volatile' -- (or `__volatile', -- `__volatile__') | CTokWhile !PosLength -- `while' | CTokCLit !PosLength !CChar -- character constant | CTokILit !PosLength !CInteger -- integer constant | CTokFLit !PosLength CFloat -- float constant | CTokSLit !PosLength CString -- string constant | CTokIdent !PosLength !Ident -- identifier -- not generated here, but in `CParser.parseCHeader' | CTokTyIdent !PosLength !Ident -- `typedef-name' identifier | CTokGnuC !GnuCTok !PosLength -- special GNU C tokens | CTokEof -- end of file -- special tokens used in GNU C extensions to ANSI C -- data GnuCTok = GnuCAttrTok -- `__attribute__' | GnuCExtTok -- `__extension__' | GnuCVaArg -- `__builtin_va_arg' | GnuCOffsetof -- `__builtin_offsetof' | GnuCTyCompat -- `__builtin_types_compatible_p' | GnuCComplexReal -- `__real__' | GnuCComplexImag -- `__imag__' instance Pos CToken where posOf = fst . posLenOfTok -- token position and length posLenOfTok :: CToken -> (Position,Int) posLenOfTok (CTokLParen pos ) = pos posLenOfTok (CTokRParen pos ) = pos posLenOfTok (CTokLBracket pos ) = pos posLenOfTok (CTokRBracket pos ) = pos posLenOfTok (CTokArrow pos ) = pos posLenOfTok (CTokDot pos ) = pos posLenOfTok (CTokExclam pos ) = pos posLenOfTok (CTokTilde pos ) = pos posLenOfTok (CTokInc pos ) = pos posLenOfTok (CTokDec pos ) = pos posLenOfTok (CTokPlus pos ) = pos posLenOfTok (CTokMinus pos ) = pos posLenOfTok (CTokStar pos ) = pos posLenOfTok (CTokSlash pos ) = pos posLenOfTok (CTokPercent pos ) = pos posLenOfTok (CTokAmper pos ) = pos posLenOfTok (CTokShiftL pos ) = pos posLenOfTok (CTokShiftR pos ) = pos posLenOfTok (CTokLess pos ) = pos posLenOfTok (CTokLessEq pos ) = pos posLenOfTok (CTokHigh pos ) = pos posLenOfTok (CTokHighEq pos ) = pos posLenOfTok (CTokEqual pos ) = pos posLenOfTok (CTokUnequal pos ) = pos posLenOfTok (CTokHat pos ) = pos posLenOfTok (CTokBar pos ) = pos posLenOfTok (CTokAnd pos ) = pos posLenOfTok (CTokOr pos ) = pos posLenOfTok (CTokQuest pos ) = pos posLenOfTok (CTokColon pos ) = pos posLenOfTok (CTokAssign pos ) = pos posLenOfTok (CTokPlusAss pos ) = pos posLenOfTok (CTokMinusAss pos ) = pos posLenOfTok (CTokStarAss pos ) = pos posLenOfTok (CTokSlashAss pos ) = pos posLenOfTok (CTokPercAss pos ) = pos posLenOfTok (CTokAmpAss pos ) = pos posLenOfTok (CTokHatAss pos ) = pos posLenOfTok (CTokBarAss pos ) = pos posLenOfTok (CTokSLAss pos ) = pos posLenOfTok (CTokSRAss pos ) = pos posLenOfTok (CTokComma pos ) = pos posLenOfTok (CTokSemic pos ) = pos posLenOfTok (CTokLBrace pos ) = pos posLenOfTok (CTokRBrace pos ) = pos posLenOfTok (CTokEllipsis pos ) = pos posLenOfTok (CTokAlignof pos ) = pos posLenOfTok (CTokAsm pos ) = pos posLenOfTok (CTokAuto pos ) = pos posLenOfTok (CTokBreak pos ) = pos posLenOfTok (CTokBool pos ) = pos posLenOfTok (CTokCase pos ) = pos posLenOfTok (CTokChar pos ) = pos posLenOfTok (CTokConst pos ) = pos posLenOfTok (CTokContinue pos ) = pos posLenOfTok (CTokComplex pos ) = pos posLenOfTok (CTokDefault pos ) = pos posLenOfTok (CTokDo pos ) = pos posLenOfTok (CTokDouble pos ) = pos posLenOfTok (CTokElse pos ) = pos posLenOfTok (CTokEnum pos ) = pos posLenOfTok (CTokExtern pos ) = pos posLenOfTok (CTokFloat pos ) = pos posLenOfTok (CTokFor pos ) = pos posLenOfTok (CTokGoto pos ) = pos posLenOfTok (CTokInt pos ) = pos posLenOfTok (CTokInline pos ) = pos posLenOfTok (CTokIf pos ) = pos posLenOfTok (CTokLong pos ) = pos posLenOfTok (CTokLabel pos ) = pos posLenOfTok (CTokRegister pos ) = pos posLenOfTok (CTokRestrict pos ) = pos posLenOfTok (CTokReturn pos ) = pos posLenOfTok (CTokShort pos ) = pos posLenOfTok (CTokSigned pos ) = pos posLenOfTok (CTokSizeof pos ) = pos posLenOfTok (CTokStatic pos ) = pos posLenOfTok (CTokStruct pos ) = pos posLenOfTok (CTokSwitch pos ) = pos posLenOfTok (CTokTypedef pos ) = pos posLenOfTok (CTokTypeof pos ) = pos posLenOfTok (CTokThread pos ) = pos posLenOfTok (CTokUnion pos ) = pos posLenOfTok (CTokUnsigned pos ) = pos posLenOfTok (CTokVoid pos ) = pos posLenOfTok (CTokVolatile pos ) = pos posLenOfTok (CTokWhile pos ) = pos posLenOfTok (CTokCLit pos _) = pos posLenOfTok (CTokILit pos _) = pos posLenOfTok (CTokFLit pos _) = pos posLenOfTok (CTokSLit pos _) = pos posLenOfTok (CTokIdent pos _) = pos posLenOfTok (CTokTyIdent pos _) = pos posLenOfTok (CTokGnuC _ pos ) = pos posLenOfTok CTokEof = error "tokenPos: Eof" instance Show CToken where showsPrec _ (CTokLParen _ ) = showString "(" showsPrec _ (CTokRParen _ ) = showString ")" showsPrec _ (CTokLBracket _ ) = showString "[" showsPrec _ (CTokRBracket _ ) = showString "]" showsPrec _ (CTokArrow _ ) = showString "->" showsPrec _ (CTokDot _ ) = showString "." showsPrec _ (CTokExclam _ ) = showString "!" showsPrec _ (CTokTilde _ ) = showString "~" showsPrec _ (CTokInc _ ) = showString "++" showsPrec _ (CTokDec _ ) = showString "--" showsPrec _ (CTokPlus _ ) = showString "+" showsPrec _ (CTokMinus _ ) = showString "-" showsPrec _ (CTokStar _ ) = showString "*" showsPrec _ (CTokSlash _ ) = showString "/" showsPrec _ (CTokPercent _ ) = showString "%" showsPrec _ (CTokAmper _ ) = showString "&" showsPrec _ (CTokShiftL _ ) = showString "<<" showsPrec _ (CTokShiftR _ ) = showString ">>" showsPrec _ (CTokLess _ ) = showString "<" showsPrec _ (CTokLessEq _ ) = showString "<=" showsPrec _ (CTokHigh _ ) = showString ">" showsPrec _ (CTokHighEq _ ) = showString ">=" showsPrec _ (CTokEqual _ ) = showString "==" showsPrec _ (CTokUnequal _ ) = showString "!=" showsPrec _ (CTokHat _ ) = showString "^" showsPrec _ (CTokBar _ ) = showString "|" showsPrec _ (CTokAnd _ ) = showString "&&" showsPrec _ (CTokOr _ ) = showString "||" showsPrec _ (CTokQuest _ ) = showString "?" showsPrec _ (CTokColon _ ) = showString ":" showsPrec _ (CTokAssign _ ) = showString "=" showsPrec _ (CTokPlusAss _ ) = showString "+=" showsPrec _ (CTokMinusAss _ ) = showString "-=" showsPrec _ (CTokStarAss _ ) = showString "*=" showsPrec _ (CTokSlashAss _ ) = showString "/=" showsPrec _ (CTokPercAss _ ) = showString "%=" showsPrec _ (CTokAmpAss _ ) = showString "&=" showsPrec _ (CTokHatAss _ ) = showString "^=" showsPrec _ (CTokBarAss _ ) = showString "|=" showsPrec _ (CTokSLAss _ ) = showString "<<=" showsPrec _ (CTokSRAss _ ) = showString ">>=" showsPrec _ (CTokComma _ ) = showString "," showsPrec _ (CTokSemic _ ) = showString ";" showsPrec _ (CTokLBrace _ ) = showString "{" showsPrec _ (CTokRBrace _ ) = showString "}" showsPrec _ (CTokEllipsis _ ) = showString "..." showsPrec _ (CTokAlignof _ ) = showString "alignof" showsPrec _ (CTokAsm _ ) = showString "asm" showsPrec _ (CTokAuto _ ) = showString "auto" showsPrec _ (CTokBool _) = showString "_Bool" showsPrec _ (CTokBreak _ ) = showString "break" showsPrec _ (CTokCase _ ) = showString "case" showsPrec _ (CTokChar _ ) = showString "char" showsPrec _ (CTokComplex _) = showString "_Complex" showsPrec _ (CTokConst _ ) = showString "const" showsPrec _ (CTokContinue _ ) = showString "continue" showsPrec _ (CTokDefault _ ) = showString "default" showsPrec _ (CTokDouble _ ) = showString "double" showsPrec _ (CTokDo _ ) = showString "do" showsPrec _ (CTokElse _ ) = showString "else" showsPrec _ (CTokEnum _ ) = showString "enum" showsPrec _ (CTokExtern _ ) = showString "extern" showsPrec _ (CTokFloat _ ) = showString "float" showsPrec _ (CTokFor _ ) = showString "for" showsPrec _ (CTokGoto _ ) = showString "goto" showsPrec _ (CTokIf _ ) = showString "if" showsPrec _ (CTokInline _ ) = showString "inline" showsPrec _ (CTokInt _ ) = showString "int" showsPrec _ (CTokLong _ ) = showString "long" showsPrec _ (CTokLabel _ ) = showString "__label__" showsPrec _ (CTokRegister _ ) = showString "register" showsPrec _ (CTokRestrict _ ) = showString "restrict" showsPrec _ (CTokReturn _ ) = showString "return" showsPrec _ (CTokShort _ ) = showString "short" showsPrec _ (CTokSigned _ ) = showString "signed" showsPrec _ (CTokSizeof _ ) = showString "sizeof" showsPrec _ (CTokStatic _ ) = showString "static" showsPrec _ (CTokStruct _ ) = showString "struct" showsPrec _ (CTokSwitch _ ) = showString "switch" showsPrec _ (CTokTypedef _ ) = showString "typedef" showsPrec _ (CTokTypeof _ ) = showString "typeof" showsPrec _ (CTokThread _ ) = showString "__thread" showsPrec _ (CTokUnion _ ) = showString "union" showsPrec _ (CTokUnsigned _ ) = showString "unsigned" showsPrec _ (CTokVoid _ ) = showString "void" showsPrec _ (CTokVolatile _ ) = showString "volatile" showsPrec _ (CTokWhile _ ) = showString "while" showsPrec _ (CTokCLit _ c) = shows c showsPrec _ (CTokILit _ i) = shows i showsPrec _ (CTokFLit _ f) = shows f showsPrec _ (CTokSLit _ s) = shows s showsPrec _ (CTokIdent _ i) = (showString . identToString) i showsPrec _ (CTokTyIdent _ i) = (showString . identToString) i showsPrec _ (CTokGnuC GnuCAttrTok _) = showString "__attribute__" showsPrec _ (CTokGnuC GnuCExtTok _) = showString "__extension__" showsPrec _ (CTokGnuC GnuCComplexReal _) = showString "__real__" showsPrec _ (CTokGnuC GnuCComplexImag _) = showString "__imag__" showsPrec _ (CTokGnuC GnuCVaArg _) = showString "__builtin_va_arg" showsPrec _ (CTokGnuC GnuCOffsetof _) = showString "__builtin_offsetof" showsPrec _ (CTokGnuC GnuCTyCompat _) = showString "__builtin_types_compatible_p" showsPrec _ CTokEof = error "show CToken : CTokEof" language-c-0.4.7/src/Language/C/Syntax/0000755000000000000000000000000012425376061015703 5ustar0000000000000000language-c-0.4.7/src/Language/C/Syntax/AST.hs0000644000000000000000000015153212425376061016675 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Syntax.AST -- Copyright : (c) [1999..2007] Manuel M T Chakravarty -- (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- Abstract syntax of C source and header files. -- -- The tree structure is based on the grammar in Appendix A of K&R. The -- abstract syntax simplifies the concrete syntax by merging similar concrete -- constructs into a single type of abstract tree structure: declarations are -- merged with structure declarations, parameter declarations and type names, -- and declarators are merged with abstract declarators. -- -- With K&R we refer to ``The C Programming Language'', second edition, Brain -- W. Kernighan and Dennis M. Ritchie, Prentice Hall, 1988. The AST supports all -- of C99 and several -- GNU extensions . ----------------------------------------------------------------------------- module Language.C.Syntax.AST ( -- * C translation units CTranslUnit, CExtDecl, CTranslationUnit(..), CExternalDeclaration(..), -- * Declarations CFunDef, CDecl, CStructUnion, CEnum, CFunctionDef(..), CDeclaration(..), CStructTag(..), CStructureUnion(..), CEnumeration(..), -- * Declaration attributes CDeclSpec, partitionDeclSpecs, CStorageSpec, CTypeSpec, isSUEDef, CTypeQual, CAttr, CDeclarationSpecifier(..), CStorageSpecifier(..), CTypeSpecifier(..), CTypeQualifier(..), CAttribute(..), -- * Declarators CDeclr,CDerivedDeclr,CArrSize, CDeclarator(..), CDerivedDeclarator(..), CArraySize(..), -- * Initialization CInit, CInitList, CDesignator, CInitializer(..), CInitializerList, CPartDesignator(..), -- * Statements CStat, CBlockItem, CAsmStmt, CAsmOperand, CStatement(..), CCompoundBlockItem(..), CAssemblyStatement(..), CAssemblyOperand(..), -- * Expressions CExpr, CExpression(..), CAssignOp(..), CBinaryOp(..), CUnaryOp(..), CBuiltin, CBuiltinThing(..), -- * Constants CConst, CStrLit, cstringOfLit, liftStrLit, CConstant(..), CStringLiteral(..), -- * Annoated type class Annotated(..) ) where import Data.List import Language.C.Syntax.Constants import Language.C.Syntax.Ops import Language.C.Data.Ident import Language.C.Data.Node import Language.C.Data.Position import Data.Generics -- | Complete C tranlsation unit (C99 6.9, K&R A10) -- -- A complete C translation unit, for example representing a C header or source file. -- It consists of a list of external (i.e. toplevel) declarations. type CTranslUnit = CTranslationUnit NodeInfo data CTranslationUnit a = CTranslUnit [CExternalDeclaration a] a deriving (Show, Data, Typeable {-! ,CNode ,Functor, Annotated !-}) -- | External C declaration (C99 6.9, K&R A10) -- -- Either a toplevel declaration, function definition or external assembler. type CExtDecl = CExternalDeclaration NodeInfo data CExternalDeclaration a = CDeclExt (CDeclaration a) | CFDefExt (CFunctionDef a) | CAsmExt (CStringLiteral a) a deriving (Show, Data,Typeable {-! ,CNode ,Functor, Annotated !-}) -- | C function definition (C99 6.9.1, K&R A10.1) -- -- A function definition is of the form @CFunDef specifiers declarator decllist? stmt@. -- -- * @specifiers@ are the type and storage-class specifiers of the function. -- The only storage-class specifiers allowed are /extern/ and /static/. -- -- * The @declarator@ must be such that the declared identifier has /function type/. -- The return type shall be void or an object type other than array type. -- -- * The optional declaration list @decllist@ is for old-style function declarations. -- -- * The statement @stmt@ is a compound statement. type CFunDef = CFunctionDef NodeInfo data CFunctionDef a = CFunDef [CDeclarationSpecifier a] -- type specifier and qualifier (CDeclarator a) -- declarator [CDeclaration a] -- optional declaration list (CStatement a) -- compound statement a deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | C declarations (K&R A8, C99 6.7), including structure declarations, parameter -- declarations and type names. -- -- A declaration is of the form @CDecl specifiers init-declarator-list@, where the form of the declarator list's -- elements depends on the kind of declaration: -- -- 1) Toplevel declarations (K&R A8, C99 6.7 declaration) -- -- * C99 requires that there is at least one specifier, though this is merely a syntactic restriction -- -- * at most one storage class specifier is allowed per declaration -- -- * the elements of the non-empty @init-declarator-list@ are of the form @(Just declr, init?, Nothing)@. -- The declarator @declr@ has to be present and non-abstract and the initialization expression is -- optional. -- -- 2) Structure declarations (K&R A8.3, C99 6.7.2.1 struct-declaration) -- -- Those are the declarations of a structure's members. -- -- * do not allow storage specifiers -- -- * in strict C99, the list of declarators has to be non-empty -- -- * the elements of @init-declarator-list@ are either of the form @(Just declr, Nothing, size?)@, -- representing a member with optional bit-field size, or of the form @(Nothing, Nothing, Just size)@, -- for unnamed bitfields. @declr@ has to be non-abstract. -- -- * no member of a structure shall have incomplete type -- -- 3) Parameter declarations (K&R A8.6.3, C99 6.7.5 parameter-declaration) -- -- * @init-declarator-list@ must contain at most one triple of the form @(Just declr, Nothing, Nothing)@, -- i.e. consist of a single declarator, which is allowed to be abstract (i.e. unnamed). -- -- 4) Type names (A8.8, C99 6.7.6) -- -- * do not allow storage specifiers -- -- * @init-declarator-list@ must contain at most one triple of the form @(Just declr, Nothing, Nothing)@. -- where @declr@ is an abstract declarator (i.e. doesn't contain a declared identifier) -- type CDecl = CDeclaration NodeInfo data CDeclaration a = CDecl [CDeclarationSpecifier a] -- type specifier and qualifier, __attribute__ [(Maybe (CDeclarator a), -- declarator (may be omitted) Maybe (CInitializer a), -- optional initialize Maybe (CExpression a))] -- optional size (const expr) a deriving (Show, Data,Typeable {-! ,CNode ,Annotated !-}) -- Derive instance is a little bit ugly instance Functor CDeclaration where fmap f (CDecl specs declarators annot) = CDecl (map (fmap f) specs) (map fmap3m declarators) (f annot) where fmap3m (a,b,c) = (fmap (fmap f) a, fmap (fmap f) b, fmap (fmap f) c) -- | C declarator (K&R A8.5, C99 6.7.5) and abstract declarator (K&R A8.8, C99 6.7.6) -- -- A declarator declares a single object, function, or type. It is always associated with -- a declaration ('CDecl'), which specifies the declaration's type and the additional storage qualifiers and -- attributes, which apply to the declared object. -- -- A declarator is of the form @CDeclr name? indirections asm-name? attrs _@, where -- @name@ is the name of the declared object (missing for abstract declarators), -- @declquals@ is a set of additional declaration specifiers, -- @asm-name@ is the optional assembler name and attributes is a set of -- attrs is a set of @__attribute__@ annotations for the declared object. -- -- @indirections@ is a set of pointer, array and function declarators, which modify the type of the declared object as -- described below. If the /declaration/ specifies the non-derived type @T@, -- and we have @indirections = [D1, D2, ..., Dn]@ than the declared object has type -- @(D1 `indirect` (D2 `indirect` ... (Dn `indirect` T)))@, where -- -- * @(CPtrDeclr attrs) `indirect` T@ is /attributed pointer to T/ -- -- * @(CFunDeclr attrs) `indirect` T@ is /attributed function returning T/ -- -- * @(CArrayDeclr attrs) `indirect` T@ is /attributed array of elemements of type T/ -- -- Examples (simplified attributes): -- -- * /x/ is an int -- -- > int x; -- > CDeclr "x" [] -- -- * /x/ is a restrict pointer to a const pointer to int -- -- > const int * const * restrict x; -- > CDeclr "x" [CPtrDeclr [restrict], CPtrDeclr [const]] -- -- * /f/ is an function return a constant pointer to int -- -- > int* const f(); -- > CDeclr "f" [CFunDeclr [],CPtrDeclr [const]] -- -- * /f/ is a constant pointer to a function returning int -- -- > int (* const f)(); ==> -- > CDeclr "f" [CPtrDeclr [const], CFunDeclr []] type CDeclr = CDeclarator NodeInfo data CDeclarator a = CDeclr (Maybe Ident) [CDerivedDeclarator a] (Maybe (CStringLiteral a)) [CAttribute a] a deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | Derived declarators, see 'CDeclr' -- -- Indirections are qualified using type-qualifiers and generic attributes, and additionally -- -- * The size of an array is either a constant expression, variable length ('*') or missing; in the last case, the -- type of the array is incomplete. The qualifier static is allowed for function arguments only, indicating that -- the supplied argument is an array of at least the given size. -- -- * New style parameter lists have the form @Right (declarations, isVariadic)@, old style parameter lists have the -- form @Left (parameter-names)@ type CDerivedDeclr = CDerivedDeclarator NodeInfo data CDerivedDeclarator a = CPtrDeclr [CTypeQualifier a] a -- ^ Pointer declarator @CPtrDeclr tyquals declr@ | CArrDeclr [CTypeQualifier a] (CArraySize a) a -- ^ Array declarator @CArrDeclr declr tyquals size-expr?@ | CFunDeclr (Either [Ident] ([CDeclaration a],Bool)) [CAttribute a] a -- ^ Function declarator @CFunDeclr declr (old-style-params | new-style-params) c-attrs@ deriving (Show, Data,Typeable {-! ,CNode , Annotated !-}) -- Derived instance relies on fmap2 instance Functor CDerivedDeclarator where fmap _f (CPtrDeclr a1 a2) = CPtrDeclr (fmap (fmap _f) a1) (_f a2) fmap _f (CArrDeclr a1 a2 a3) = CArrDeclr (fmap (fmap _f) a1) (fmap _f a2) (_f a3) fmap _f (CFunDeclr a1 a2 a3) = CFunDeclr (fmap (fmapFirst (fmap (fmap _f))) a1) (fmap (fmap _f) a2) (_f a3) where fmapFirst f (a,b) = (f a, b) -- | Size of an array type CArrSize = CArraySize NodeInfo data CArraySize a = CNoArrSize Bool -- ^ @CUnknownSize isCompleteType@ | CArrSize Bool (CExpression a) -- ^ @CArrSize isStatic expr@ deriving (Show, Data,Typeable {-! , Functor !-}) -- | C statement (K&R A9, C99 6.8) -- type CStat = CStatement NodeInfo data CStatement a -- | An (attributed) label followed by a statement = CLabel Ident (CStatement a) [CAttribute a] a -- | A statement of the form @case expr : stmt@ | CCase (CExpression a) (CStatement a) a -- | A case range of the form @case lower ... upper : stmt@ | CCases (CExpression a) (CExpression a) (CStatement a) a -- | The default case @default : stmt@ | CDefault (CStatement a) a -- | A simple statement, that is in C: evaluating an expression with -- side-effects and discarding the result. | CExpr (Maybe (CExpression a)) a -- | compound statement @CCompound localLabels blockItems at@ | CCompound [Ident] [CCompoundBlockItem a] a -- | conditional statement @CIf ifExpr thenStmt maybeElseStmt at@ | CIf (CExpression a) (CStatement a) (Maybe (CStatement a)) a -- | switch statement @CSwitch selectorExpr switchStmt@, where -- @switchStmt@ usually includes /case/, /break/ and /default/ -- statements | CSwitch (CExpression a) (CStatement a) a -- | while or do-while statement @CWhile guard stmt isDoWhile at@ | CWhile (CExpression a) (CStatement a) Bool a -- | for statement @CFor init expr-2 expr-3 stmt@, where @init@ is -- either a declaration or initializing expression | CFor (Either (Maybe (CExpression a)) (CDeclaration a)) (Maybe (CExpression a)) (Maybe (CExpression a)) (CStatement a) a -- | goto statement @CGoto label@ | CGoto Ident a -- | computed goto @CGotoPtr labelExpr@ | CGotoPtr (CExpression a) a -- | continue statement | CCont a -- | break statement | CBreak a -- | return statement @CReturn returnExpr@ | CReturn (Maybe (CExpression a)) a -- | assembly statement | CAsm (CAssemblyStatement a) a deriving (Show, Data,Typeable {-! , CNode , Annotated !-}) -- Derived instance relies on fmap2 :( instance Functor CStatement where fmap _f (CLabel a1 a2 a3 a4) = CLabel a1 (fmap _f a2) (fmap (fmap _f) a3) (_f a4) fmap _f (CCase a1 a2 a3) = CCase (fmap _f a1) (fmap _f a2) (_f a3) fmap _f (CCases a1 a2 a3 a4) = CCases (fmap _f a1) (fmap _f a2) (fmap _f a3) (_f a4) fmap _f (CDefault a1 a2) = CDefault (fmap _f a1) (_f a2) fmap _f (CExpr a1 a2) = CExpr (fmap (fmap _f) a1) (_f a2) fmap _f (CCompound a1 a2 a3) = CCompound a1 (fmap (fmap _f) a2) (_f a3) fmap _f (CIf a1 a2 a3 a4) = CIf (fmap _f a1) (fmap _f a2) (fmap (fmap _f) a3) (_f a4) fmap _f (CSwitch a1 a2 a3) = CSwitch (fmap _f a1) (fmap _f a2) (_f a3) fmap _f (CWhile a1 a2 a3 a4) = CWhile (fmap _f a1) (fmap _f a2) a3 (_f a4) fmap _f (CFor a1 a2 a3 a4 a5) = CFor (mapEither (fmap (fmap _f)) (fmap _f) a1) (fmap (fmap _f) a2) (fmap (fmap _f) a3) (fmap _f a4) (_f a5) where mapEither f1 f2 = either (Left . f1) (Right . f2) fmap _f (CGoto a1 a2) = CGoto a1 (_f a2) fmap _f (CGotoPtr a1 a2) = CGotoPtr (fmap _f a1) (_f a2) fmap _f (CCont a1) = CCont (_f a1) fmap _f (CBreak a1) = CBreak (_f a1) fmap _f (CReturn a1 a2) = CReturn (fmap (fmap _f) a1) (_f a2) fmap _f (CAsm a1 a2) = CAsm (fmap _f a1) (_f a2) -- | GNU Assembler statement -- -- > CAssemblyStatement type-qual? asm-expr out-ops in-ops clobbers _ -- -- is an inline assembler statement. -- The only type-qualifier (if any) allowed is /volatile/. -- @asm-expr@ is the actual assembler epxression (a string), @out-ops@ and @in-ops@ are the input -- and output operands of the statement. -- @clobbers@ is a list of registers which are clobbered when executing the assembler statement type CAsmStmt = CAssemblyStatement NodeInfo data CAssemblyStatement a = CAsmStmt (Maybe (CTypeQualifier a)) -- maybe volatile (CStringLiteral a) -- assembler expression (String) [CAssemblyOperand a] -- output operands [CAssemblyOperand a] -- input operands [CStringLiteral a] -- Clobbers a deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | Assembler operand -- -- @CAsmOperand argName? constraintExpr arg@ specifies an operand for an assembler -- statement. type CAsmOperand = CAssemblyOperand NodeInfo data CAssemblyOperand a = CAsmOperand (Maybe Ident) -- argument name (CStringLiteral a) -- constraint expr (CExpression a) -- argument a deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | C99 Block items -- -- Things that may appear in compound statements: either statements, declarations -- or nested function definitions. type CBlockItem = CCompoundBlockItem NodeInfo data CCompoundBlockItem a = CBlockStmt (CStatement a) -- ^ A statement | CBlockDecl (CDeclaration a) -- ^ A local declaration | CNestedFunDef (CFunctionDef a) -- ^ A nested function (GNU C) deriving (Show, Data,Typeable {-! , CNode , Functor, Annotated !-}) -- | C declaration specifiers and qualifiers -- -- Declaration specifiers include at most one storage-class specifier (C99 6.7.1), -- type specifiers (6.7.2) and type qualifiers (6.7.3). type CDeclSpec = CDeclarationSpecifier NodeInfo data CDeclarationSpecifier a = CStorageSpec (CStorageSpecifier a) -- ^ storage-class specifier or typedef | CTypeSpec (CTypeSpecifier a) -- ^ type name | CTypeQual (CTypeQualifier a) -- ^ type qualifier deriving (Show, Data,Typeable {-! ,CNode ,Functor, Annotated !-}) -- | Separate the declaration specifiers -- -- Note that inline isn't actually a type qualifier, but a function specifier. -- @__attribute__@ of a declaration qualify declarations or declarators (but not types), -- and are therefore separated as well. partitionDeclSpecs :: [CDeclarationSpecifier a] -> ( [CStorageSpecifier a], [CAttribute a] , [CTypeQualifier a], [CTypeSpecifier a], Bool) partitionDeclSpecs = foldr deals ([],[],[],[],False) where deals (CTypeQual (CInlineQual _)) (sts,ats,tqs,tss,_) = (sts,ats,tqs,tss,True) deals (CStorageSpec sp) (sts,ats,tqs,tss,inline) = (sp:sts,ats,tqs,tss,inline) deals (CTypeQual (CAttrQual attr)) (sts,ats,tqs,tss,inline) = (sts,attr:ats,tqs,tss,inline) deals (CTypeQual tq) (sts,ats,tqs,tss,inline) = (sts,ats,tq:tqs,tss,inline) deals (CTypeSpec ts) (sts,ats,tqs,tss,inline) = (sts,ats,tqs,ts:tss,inline) -- | C storage class specifier (and typedefs) (K&R A8.1, C99 6.7.1) type CStorageSpec = CStorageSpecifier NodeInfo data CStorageSpecifier a = CAuto a -- ^ auto | CRegister a -- ^ register | CStatic a -- ^ static | CExtern a -- ^ extern | CTypedef a -- ^ typedef | CThread a -- ^ GNUC thread local storage deriving (Show, Eq,Ord,Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | C type specifier (K&R A8.2, C99 6.7.2) -- -- Type specifiers are either basic types such as @char@ or @int@, -- @struct@, @union@ or @enum@ specifiers or typedef names. -- -- As a GNU extension, a @typeof@ expression also is a type specifier. type CTypeSpec = CTypeSpecifier NodeInfo data CTypeSpecifier a = CVoidType a | CCharType a | CShortType a | CIntType a | CLongType a | CFloatType a | CDoubleType a | CSignedType a | CUnsigType a | CBoolType a | CComplexType a | CSUType (CStructureUnion a) a -- ^ Struct or Union specifier | CEnumType (CEnumeration a) a -- ^ Enumeration specifier | CTypeDef Ident a -- ^ Typedef name | CTypeOfExpr (CExpression a) a -- ^ @typeof(expr)@ | CTypeOfType (CDeclaration a) a -- ^ @typeof(type)@ deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | returns @True@ if the given typespec is a struct, union or enum /definition/ isSUEDef :: CTypeSpecifier a -> Bool isSUEDef (CSUType (CStruct _ _ (Just _) _ _) _) = True isSUEDef (CEnumType (CEnum _ (Just _) _ _) _) = True isSUEDef _ = False -- | C type qualifiers (K&R A8.2, C99 6.7.3), function specifiers (C99 6.7.4), and attributes. -- -- @const@, @volatile@ and @restrict@ type qualifiers and @inline@ function specifier. -- Additionally, @__attribute__@ annotations for declarations and declarators. type CTypeQual = CTypeQualifier NodeInfo data CTypeQualifier a = CConstQual a | CVolatQual a | CRestrQual a | CInlineQual a | CAttrQual (CAttribute a) deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | C structure or union specifiers (K&R A8.3, C99 6.7.2.1) -- -- @CStruct tag identifier struct-decls c-attrs@ represents a struct or union specifier (depending on @tag@). -- -- * either @identifier@ or the declaration list @struct-decls@ (or both) have to be present. -- -- Example: in @struct foo x;@, the identifier is present, in @struct { int y; } x@ the declaration list, and -- in @struct foo { int y; } x;@ both of them. -- -- * @c-attrs@ is a list of @__attribute__@ annotations associated with the struct or union specifier type CStructUnion = CStructureUnion NodeInfo data CStructureUnion a = CStruct CStructTag (Maybe Ident) (Maybe [CDeclaration a]) -- member declarations [CAttribute a] -- __attribute__s a deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | A tag to determine wheter we refer to a @struct@ or @union@, see 'CStructUnion'. data CStructTag = CStructTag | CUnionTag deriving (Show, Eq,Data,Typeable) -- | C enumeration specifier (K&R A8.4, C99 6.7.2.2) -- -- @CEnum identifier enumerator-list attrs@ represent as enum specifier -- -- * Either the identifier or the enumerator-list (or both) have to be present. -- -- * If @enumerator-list@ is present, it has to be non-empty. -- -- * The enumerator list is of the form @(enumeration-constant, enumeration-value?)@, where the latter -- is an optional constant integral expression. -- -- * @attrs@ is a list of @__attribute__@ annotations associated with the enumeration specifier type CEnum = CEnumeration NodeInfo data CEnumeration a = CEnum (Maybe Ident) (Maybe [(Ident, -- variant name Maybe (CExpression a))]) -- explicit variant value [CAttribute a] -- __attribute__s a deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | C initialization (K&R A8.7, C99 6.7.8) -- -- Initializers are either assignment expressions or initializer lists -- (surrounded in curly braces), whose elements are themselves -- initializers, paired with an optional list of designators. type CInit = CInitializer NodeInfo data CInitializer a -- | assignment expression = CInitExpr (CExpression a) a -- | initialization list (see 'CInitList') | CInitList (CInitializerList a) a deriving (Show, Data,Typeable {-! ,CNode , Annotated !-}) -- deriving Functor does not work (type synonym) instance Functor CInitializer where fmap _f (CInitExpr a1 a2) = CInitExpr (fmap _f a1) (_f a2) fmap _f (CInitList a1 a2) = CInitList (fmapInitList _f a1) (_f a2) fmapInitList :: (a->b) -> (CInitializerList a) -> (CInitializerList b) fmapInitList _f = map (\(desigs, initializer) -> (fmap (fmap _f) desigs, fmap _f initializer)) -- | Initializer List -- -- The members of an initializer list are of the form @(designator-list,initializer)@. -- The @designator-list@ specifies one member of the compound type which is initialized. -- It is allowed to be empty - in this case the initializer refers to the -- ''next'' member of the compound type (see C99 6.7.8). -- -- Examples (simplified expressions and identifiers): -- -- > -- int x[3][4] = { [0][3] = 4, [2] = 5, 8 }; -- > -- corresponds to the assignments -- > -- x[0][3] = 4; x[2][0] = 5; x[2][1] = 8; -- > let init1 = ([CArrDesig 0, CArrDesig 3], CInitExpr 4) -- > init2 = ([CArrDesig 2] , CInitExpr 5) -- > init3 = ([] , CInitExpr 8) -- > in CInitList [init1, init2, init3] -- -- > -- struct { struct { int a[2]; int b[2]; int c[2]; } s; } x = { .s = { {2,3} , .c[0] = 1 } }; -- > -- corresponds to the assignments -- > -- x.s.a[0] = 2; x.s.a[1] = 3; x.s.c[0] = 1; -- > let init_s_0 = CInitList [ ([], CInitExpr 2), ([], CInitExpr 3)] -- > init_s = CInitList [ -- > ([], init_s_0), -- > ([CMemberDesig "c", CArrDesig 0], CInitExpr 1) -- > ] -- > in CInitList [(CMemberDesig "s", init_s)] type CInitList = CInitializerList NodeInfo type CInitializerList a = [([CPartDesignator a], CInitializer a)] -- | Designators -- -- A designator specifies a member of an object, either an element or range of an array, -- or the named member of a struct \/ union. type CDesignator = CPartDesignator NodeInfo data CPartDesignator a -- | array position designator = CArrDesig (CExpression a) a -- | member designator | CMemberDesig Ident a -- | array range designator @CRangeDesig from to _@ (GNU C) | CRangeDesig (CExpression a) (CExpression a) a deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | @__attribute__@ annotations -- -- Those are of the form @CAttr attribute-name attribute-parameters@, -- and serve as generic properties of some syntax tree elements. type CAttr = CAttribute NodeInfo data CAttribute a = CAttr Ident [CExpression a] a deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | C expression (K&R A7) -- -- * these can be arbitrary expression, as the argument of `sizeof' can be -- arbitrary, even if appearing in a constant expression -- -- * GNU C extensions: @alignof@, @__real@, @__imag@, @({ stmt-expr })@, @&& label@ and built-ins -- type CExpr = CExpression NodeInfo data CExpression a = CComma [CExpression a] -- comma expression list, n >= 2 a | CAssign CAssignOp -- assignment operator (CExpression a) -- l-value (CExpression a) -- r-value a | CCond (CExpression a) -- conditional (Maybe (CExpression a)) -- true-expression (GNU allows omitting) (CExpression a) -- false-expression a | CBinary CBinaryOp -- binary operator (CExpression a) -- lhs (CExpression a) -- rhs a | CCast (CDeclaration a) -- type name (CExpression a) a | CUnary CUnaryOp -- unary operator (CExpression a) a | CSizeofExpr (CExpression a) a | CSizeofType (CDeclaration a) -- type name a | CAlignofExpr (CExpression a) a | CAlignofType (CDeclaration a) -- type name a | CComplexReal (CExpression a) -- real part of complex number a | CComplexImag (CExpression a) -- imaginary part of complex number a | CIndex (CExpression a) -- array (CExpression a) -- index a | CCall (CExpression a) -- function [CExpression a] -- arguments a | CMember (CExpression a) -- structure Ident -- member name Bool -- deref structure? (True for `->') a | CVar Ident -- identifier (incl. enumeration const) a | CConst (CConstant a) -- ^ integer, character, floating point and string constants | CCompoundLit (CDeclaration a) (CInitializerList a) -- type name & initialiser list a -- ^ C99 compound literal | CStatExpr (CStatement a) a -- ^ GNU C compound statement as expr | CLabAddrExpr Ident a -- ^ GNU C address of label | CBuiltinExpr (CBuiltinThing a) -- ^ builtin expressions, see 'CBuiltin' deriving (Data,Typeable,Show {-! ,CNode , Annotated !-}) -- deriving Functor does not work (type synonyms) instance Functor CExpression where fmap _f (CComma a1 a2) = CComma (fmap (fmap _f) a1) (_f a2) fmap _f (CAssign a1 a2 a3 a4) = CAssign a1 (fmap _f a2) (fmap _f a3) (_f a4) fmap _f (CCond a1 a2 a3 a4) = CCond (fmap _f a1) (fmap (fmap _f) a2) (fmap _f a3) (_f a4) fmap _f (CBinary a1 a2 a3 a4) = CBinary a1 (fmap _f a2) (fmap _f a3) (_f a4) fmap _f (CCast a1 a2 a3) = CCast (fmap _f a1) (fmap _f a2) (_f a3) fmap _f (CUnary a1 a2 a3) = CUnary a1 (fmap _f a2) (_f a3) fmap _f (CSizeofExpr a1 a2) = CSizeofExpr (fmap _f a1) (_f a2) fmap _f (CSizeofType a1 a2) = CSizeofType (fmap _f a1) (_f a2) fmap _f (CAlignofExpr a1 a2) = CAlignofExpr (fmap _f a1) (_f a2) fmap _f (CAlignofType a1 a2) = CAlignofType (fmap _f a1) (_f a2) fmap _f (CComplexReal a1 a2) = CComplexReal (fmap _f a1) (_f a2) fmap _f (CComplexImag a1 a2) = CComplexImag (fmap _f a1) (_f a2) fmap _f (CIndex a1 a2 a3) = CIndex (fmap _f a1) (fmap _f a2) (_f a3) fmap _f (CCall a1 a2 a3) = CCall (fmap _f a1) (fmap (fmap _f) a2) (_f a3) fmap _f (CMember a1 a2 a3 a4) = CMember (fmap _f a1) a2 a3 (_f a4) fmap _f (CVar a1 a2) = CVar a1 (_f a2) fmap _f (CConst a1) = CConst (fmap _f a1) fmap _f (CCompoundLit a1 a2 a3) = CCompoundLit (fmap _f a1) (fmapInitList _f a2) (_f a3) fmap _f (CStatExpr a1 a2) = CStatExpr (fmap _f a1) (_f a2) fmap _f (CLabAddrExpr a1 a2) = CLabAddrExpr a1 (_f a2) fmap _f (CBuiltinExpr a1) = CBuiltinExpr (fmap _f a1) -- | GNU Builtins, which cannot be typed in C99 type CBuiltin = CBuiltinThing NodeInfo data CBuiltinThing a = CBuiltinVaArg (CExpression a) (CDeclaration a) a -- ^ @(expr, type)@ | CBuiltinOffsetOf (CDeclaration a) [CPartDesignator a] a -- ^ @(type, designator-list)@ | CBuiltinTypesCompatible (CDeclaration a) (CDeclaration a) a -- ^ @(type,type)@ deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | C constant (K&R A2.5 & A7.2) type CConst = CConstant NodeInfo data CConstant a = CIntConst CInteger a | CCharConst CChar a | CFloatConst CFloat a | CStrConst CString a deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) -- | Attributed string literals type CStrLit = CStringLiteral NodeInfo data CStringLiteral a = CStrLit CString a deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-}) cstringOfLit :: CStringLiteral a -> CString cstringOfLit (CStrLit cstr _) = cstr -- | Lift a string literal to a C constant liftStrLit :: CStringLiteral a -> CConstant a liftStrLit (CStrLit str at) = CStrConst str at -- | All AST nodes are annotated. Inspired by the Annotated -- class of Niklas Broberg's haskell-src-exts package. -- In principle, we could have Copointed superclass instead -- of @ann@, for the price of another dependency. class (Functor ast) => Annotated ast where -- | get the annotation of an AST node annotation :: ast a -> a -- | change the annotation (non-recursively) -- of an AST node. Use fmap for recursively -- modifying the annotation. amap :: (a->a) -> ast a -> ast a -- fmap2 :: (a->a') -> (a,b) -> (a',b) -- fmap2 f (a,b) = (f a, b) -- Instances generated using derive-2.* -- GENERATED START instance (CNode t1) => CNode (CTranslationUnit t1) where nodeInfo (CTranslUnit _ n) = nodeInfo n instance (CNode t1) => Pos (CTranslationUnit t1) where posOf x = posOf (nodeInfo x) instance Functor CTranslationUnit where fmap _f (CTranslUnit a1 a2) = CTranslUnit (fmap (fmap _f) a1) (_f a2) instance Annotated CTranslationUnit where annotation (CTranslUnit _ n) = n amap f (CTranslUnit a_1 a_2) = CTranslUnit a_1 (f a_2) instance (CNode t1) => CNode (CExternalDeclaration t1) where nodeInfo (CDeclExt d) = nodeInfo d nodeInfo (CFDefExt d) = nodeInfo d nodeInfo (CAsmExt _ n) = nodeInfo n instance (CNode t1) => Pos (CExternalDeclaration t1) where posOf x = posOf (nodeInfo x) instance Functor CExternalDeclaration where fmap _f (CDeclExt a1) = CDeclExt (fmap _f a1) fmap _f (CFDefExt a1) = CFDefExt (fmap _f a1) fmap _f (CAsmExt a1 a2) = CAsmExt (fmap _f a1) (_f a2) instance Annotated CExternalDeclaration where annotation (CDeclExt n) = annotation n annotation (CFDefExt n) = annotation n annotation (CAsmExt _ n) = n amap f (CDeclExt n) = CDeclExt (amap f n) amap f (CFDefExt n) = CFDefExt (amap f n) amap f (CAsmExt a_1 a_2) = CAsmExt a_1 (f a_2) instance (CNode t1) => CNode (CFunctionDef t1) where nodeInfo (CFunDef _ _ _ _ n) = nodeInfo n instance (CNode t1) => Pos (CFunctionDef t1) where posOf x = posOf (nodeInfo x) instance Functor CFunctionDef where fmap _f (CFunDef a1 a2 a3 a4 a5) = CFunDef (fmap (fmap _f) a1) (fmap _f a2) (fmap (fmap _f) a3) (fmap _f a4) (_f a5) instance Annotated CFunctionDef where annotation (CFunDef _ _ _ _ n) = n amap f (CFunDef a_1 a_2 a_3 a_4 a_5) = CFunDef a_1 a_2 a_3 a_4 (f a_5) instance (CNode t1) => CNode (CDeclaration t1) where nodeInfo (CDecl _ _ n) = nodeInfo n instance (CNode t1) => Pos (CDeclaration t1) where posOf x = posOf (nodeInfo x) instance Annotated CDeclaration where annotation (CDecl _ _ n) = n amap f (CDecl a_1 a_2 a_3) = CDecl a_1 a_2 (f a_3) instance (CNode t1) => CNode (CDeclarator t1) where nodeInfo (CDeclr _ _ _ _ n) = nodeInfo n instance (CNode t1) => Pos (CDeclarator t1) where posOf x = posOf (nodeInfo x) instance Functor CDeclarator where fmap _f (CDeclr a1 a2 a3 a4 a5) = CDeclr a1 (fmap (fmap _f) a2) (fmap (fmap _f) a3) (fmap (fmap _f) a4) (_f a5) instance Annotated CDeclarator where annotation (CDeclr _ _ _ _ n) = n amap f (CDeclr a_1 a_2 a_3 a_4 a_5) = CDeclr a_1 a_2 a_3 a_4 (f a_5) instance (CNode t1) => CNode (CDerivedDeclarator t1) where nodeInfo (CPtrDeclr _ n) = nodeInfo n nodeInfo (CArrDeclr _ _ n) = nodeInfo n nodeInfo (CFunDeclr _ _ n) = nodeInfo n instance (CNode t1) => Pos (CDerivedDeclarator t1) where posOf x = posOf (nodeInfo x) instance Annotated CDerivedDeclarator where annotation (CPtrDeclr _ n) = n annotation (CArrDeclr _ _ n) = n annotation (CFunDeclr _ _ n) = n amap f (CPtrDeclr a_1 a_2) = CPtrDeclr a_1 (f a_2) amap f (CArrDeclr a_1 a_2 a_3) = CArrDeclr a_1 a_2 (f a_3) amap f (CFunDeclr a_1 a_2 a_3) = CFunDeclr a_1 a_2 (f a_3) instance Functor CArraySize where fmap _ (CNoArrSize a1) = CNoArrSize a1 fmap _f (CArrSize a1 a2) = CArrSize a1 (fmap _f a2) instance (CNode t1) => CNode (CStatement t1) where nodeInfo (CLabel _ _ _ n) = nodeInfo n nodeInfo (CCase _ _ n) = nodeInfo n nodeInfo (CCases _ _ _ n) = nodeInfo n nodeInfo (CDefault _ n) = nodeInfo n nodeInfo (CExpr _ n) = nodeInfo n nodeInfo (CCompound _ _ n) = nodeInfo n nodeInfo (CIf _ _ _ n) = nodeInfo n nodeInfo (CSwitch _ _ n) = nodeInfo n nodeInfo (CWhile _ _ _ n) = nodeInfo n nodeInfo (CFor _ _ _ _ n) = nodeInfo n nodeInfo (CGoto _ n) = nodeInfo n nodeInfo (CGotoPtr _ n) = nodeInfo n nodeInfo (CCont d) = nodeInfo d nodeInfo (CBreak d) = nodeInfo d nodeInfo (CReturn _ n) = nodeInfo n nodeInfo (CAsm _ n) = nodeInfo n instance (CNode t1) => Pos (CStatement t1) where posOf x = posOf (nodeInfo x) instance Annotated CStatement where annotation (CLabel _ _ _ n) = n annotation (CCase _ _ n) = n annotation (CCases _ _ _ n) = n annotation (CDefault _ n) = n annotation (CExpr _ n) = n annotation (CCompound _ _ n) = n annotation (CIf _ _ _ n) = n annotation (CSwitch _ _ n) = n annotation (CWhile _ _ _ n) = n annotation (CFor _ _ _ _ n) = n annotation (CGoto _ n) = n annotation (CGotoPtr _ n) = n annotation (CCont n) = n annotation (CBreak n) = n annotation (CReturn _ n) = n annotation (CAsm _ n) = n amap f (CLabel a_1 a_2 a_3 a_4) = CLabel a_1 a_2 a_3 (f a_4) amap f (CCase a_1 a_2 a_3) = CCase a_1 a_2 (f a_3) amap f (CCases a_1 a_2 a_3 a_4) = CCases a_1 a_2 a_3 (f a_4) amap f (CDefault a_1 a_2) = CDefault a_1 (f a_2) amap f (CExpr a_1 a_2) = CExpr a_1 (f a_2) amap f (CCompound a_1 a_2 a_3) = CCompound a_1 a_2 (f a_3) amap f (CIf a_1 a_2 a_3 a_4) = CIf a_1 a_2 a_3 (f a_4) amap f (CSwitch a_1 a_2 a_3) = CSwitch a_1 a_2 (f a_3) amap f (CWhile a_1 a_2 a_3 a_4) = CWhile a_1 a_2 a_3 (f a_4) amap f (CFor a_1 a_2 a_3 a_4 a_5) = CFor a_1 a_2 a_3 a_4 (f a_5) amap f (CGoto a_1 a_2) = CGoto a_1 (f a_2) amap f (CGotoPtr a_1 a_2) = CGotoPtr a_1 (f a_2) amap f (CCont a_1) = CCont (f a_1) amap f (CBreak a_1) = CBreak (f a_1) amap f (CReturn a_1 a_2) = CReturn a_1 (f a_2) amap f (CAsm a_1 a_2) = CAsm a_1 (f a_2) instance (CNode t1) => CNode (CAssemblyStatement t1) where nodeInfo (CAsmStmt _ _ _ _ _ n) = nodeInfo n instance (CNode t1) => Pos (CAssemblyStatement t1) where posOf x = posOf (nodeInfo x) instance Functor CAssemblyStatement where fmap _f (CAsmStmt a1 a2 a3 a4 a5 a6) = CAsmStmt (fmap (fmap _f) a1) (fmap _f a2) (fmap (fmap _f) a3) (fmap (fmap _f) a4) (fmap (fmap _f) a5) (_f a6) instance Annotated CAssemblyStatement where annotation (CAsmStmt _ _ _ _ _ n) = n amap f (CAsmStmt a_1 a_2 a_3 a_4 a_5 a_6) = CAsmStmt a_1 a_2 a_3 a_4 a_5 (f a_6) instance (CNode t1) => CNode (CAssemblyOperand t1) where nodeInfo (CAsmOperand _ _ _ n) = nodeInfo n instance (CNode t1) => Pos (CAssemblyOperand t1) where posOf x = posOf (nodeInfo x) instance Functor CAssemblyOperand where fmap _f (CAsmOperand a1 a2 a3 a4) = CAsmOperand a1 (fmap _f a2) (fmap _f a3) (_f a4) instance Annotated CAssemblyOperand where annotation (CAsmOperand _ _ _ n) = n amap f (CAsmOperand a_1 a_2 a_3 a_4) = CAsmOperand a_1 a_2 a_3 (f a_4) instance (CNode t1) => CNode (CCompoundBlockItem t1) where nodeInfo (CBlockStmt d) = nodeInfo d nodeInfo (CBlockDecl d) = nodeInfo d nodeInfo (CNestedFunDef d) = nodeInfo d instance (CNode t1) => Pos (CCompoundBlockItem t1) where posOf x = posOf (nodeInfo x) instance Functor CCompoundBlockItem where fmap _f (CBlockStmt a1) = CBlockStmt (fmap _f a1) fmap _f (CBlockDecl a1) = CBlockDecl (fmap _f a1) fmap _f (CNestedFunDef a1) = CNestedFunDef (fmap _f a1) instance Annotated CCompoundBlockItem where annotation (CBlockStmt n) = annotation n annotation (CBlockDecl n) = annotation n annotation (CNestedFunDef n) = annotation n amap f (CBlockStmt n) = CBlockStmt (amap f n) amap f (CBlockDecl n) = CBlockDecl (amap f n) amap f (CNestedFunDef n) = CNestedFunDef (amap f n) instance (CNode t1) => CNode (CDeclarationSpecifier t1) where nodeInfo (CStorageSpec d) = nodeInfo d nodeInfo (CTypeSpec d) = nodeInfo d nodeInfo (CTypeQual d) = nodeInfo d instance (CNode t1) => Pos (CDeclarationSpecifier t1) where posOf x = posOf (nodeInfo x) instance Functor CDeclarationSpecifier where fmap _f (CStorageSpec a1) = CStorageSpec (fmap _f a1) fmap _f (CTypeSpec a1) = CTypeSpec (fmap _f a1) fmap _f (CTypeQual a1) = CTypeQual (fmap _f a1) instance Annotated CDeclarationSpecifier where annotation (CStorageSpec n) = annotation n annotation (CTypeSpec n) = annotation n annotation (CTypeQual n) = annotation n amap f (CStorageSpec n) = CStorageSpec (amap f n) amap f (CTypeSpec n) = CTypeSpec (amap f n) amap f (CTypeQual n) = CTypeQual (amap f n) instance (CNode t1) => CNode (CStorageSpecifier t1) where nodeInfo (CAuto d) = nodeInfo d nodeInfo (CRegister d) = nodeInfo d nodeInfo (CStatic d) = nodeInfo d nodeInfo (CExtern d) = nodeInfo d nodeInfo (CTypedef d) = nodeInfo d nodeInfo (CThread d) = nodeInfo d instance (CNode t1) => Pos (CStorageSpecifier t1) where posOf x = posOf (nodeInfo x) instance Functor CStorageSpecifier where fmap _f (CAuto a1) = CAuto (_f a1) fmap _f (CRegister a1) = CRegister (_f a1) fmap _f (CStatic a1) = CStatic (_f a1) fmap _f (CExtern a1) = CExtern (_f a1) fmap _f (CTypedef a1) = CTypedef (_f a1) fmap _f (CThread a1) = CThread (_f a1) instance Annotated CStorageSpecifier where annotation (CAuto n) = n annotation (CRegister n) = n annotation (CStatic n) = n annotation (CExtern n) = n annotation (CTypedef n) = n annotation (CThread n) = n amap f (CAuto a_1) = CAuto (f a_1) amap f (CRegister a_1) = CRegister (f a_1) amap f (CStatic a_1) = CStatic (f a_1) amap f (CExtern a_1) = CExtern (f a_1) amap f (CTypedef a_1) = CTypedef (f a_1) amap f (CThread a_1) = CThread (f a_1) instance (CNode t1) => CNode (CTypeSpecifier t1) where nodeInfo (CVoidType d) = nodeInfo d nodeInfo (CCharType d) = nodeInfo d nodeInfo (CShortType d) = nodeInfo d nodeInfo (CIntType d) = nodeInfo d nodeInfo (CLongType d) = nodeInfo d nodeInfo (CFloatType d) = nodeInfo d nodeInfo (CDoubleType d) = nodeInfo d nodeInfo (CSignedType d) = nodeInfo d nodeInfo (CUnsigType d) = nodeInfo d nodeInfo (CBoolType d) = nodeInfo d nodeInfo (CComplexType d) = nodeInfo d nodeInfo (CSUType _ n) = nodeInfo n nodeInfo (CEnumType _ n) = nodeInfo n nodeInfo (CTypeDef _ n) = nodeInfo n nodeInfo (CTypeOfExpr _ n) = nodeInfo n nodeInfo (CTypeOfType _ n) = nodeInfo n instance (CNode t1) => Pos (CTypeSpecifier t1) where posOf x = posOf (nodeInfo x) instance Functor CTypeSpecifier where fmap _f (CVoidType a1) = CVoidType (_f a1) fmap _f (CCharType a1) = CCharType (_f a1) fmap _f (CShortType a1) = CShortType (_f a1) fmap _f (CIntType a1) = CIntType (_f a1) fmap _f (CLongType a1) = CLongType (_f a1) fmap _f (CFloatType a1) = CFloatType (_f a1) fmap _f (CDoubleType a1) = CDoubleType (_f a1) fmap _f (CSignedType a1) = CSignedType (_f a1) fmap _f (CUnsigType a1) = CUnsigType (_f a1) fmap _f (CBoolType a1) = CBoolType (_f a1) fmap _f (CComplexType a1) = CComplexType (_f a1) fmap _f (CSUType a1 a2) = CSUType (fmap _f a1) (_f a2) fmap _f (CEnumType a1 a2) = CEnumType (fmap _f a1) (_f a2) fmap _f (CTypeDef a1 a2) = CTypeDef a1 (_f a2) fmap _f (CTypeOfExpr a1 a2) = CTypeOfExpr (fmap _f a1) (_f a2) fmap _f (CTypeOfType a1 a2) = CTypeOfType (fmap _f a1) (_f a2) instance Annotated CTypeSpecifier where annotation (CVoidType n) = n annotation (CCharType n) = n annotation (CShortType n) = n annotation (CIntType n) = n annotation (CLongType n) = n annotation (CFloatType n) = n annotation (CDoubleType n) = n annotation (CSignedType n) = n annotation (CUnsigType n) = n annotation (CBoolType n) = n annotation (CComplexType n) = n annotation (CSUType _ n) = n annotation (CEnumType _ n) = n annotation (CTypeDef _ n) = n annotation (CTypeOfExpr _ n) = n annotation (CTypeOfType _ n) = n amap f (CVoidType a_1) = CVoidType (f a_1) amap f (CCharType a_1) = CCharType (f a_1) amap f (CShortType a_1) = CShortType (f a_1) amap f (CIntType a_1) = CIntType (f a_1) amap f (CLongType a_1) = CLongType (f a_1) amap f (CFloatType a_1) = CFloatType (f a_1) amap f (CDoubleType a_1) = CDoubleType (f a_1) amap f (CSignedType a_1) = CSignedType (f a_1) amap f (CUnsigType a_1) = CUnsigType (f a_1) amap f (CBoolType a_1) = CBoolType (f a_1) amap f (CComplexType a_1) = CComplexType (f a_1) amap f (CSUType a_1 a_2) = CSUType a_1 (f a_2) amap f (CEnumType a_1 a_2) = CEnumType a_1 (f a_2) amap f (CTypeDef a_1 a_2) = CTypeDef a_1 (f a_2) amap f (CTypeOfExpr a_1 a_2) = CTypeOfExpr a_1 (f a_2) amap f (CTypeOfType a_1 a_2) = CTypeOfType a_1 (f a_2) instance (CNode t1) => CNode (CTypeQualifier t1) where nodeInfo (CConstQual d) = nodeInfo d nodeInfo (CVolatQual d) = nodeInfo d nodeInfo (CRestrQual d) = nodeInfo d nodeInfo (CInlineQual d) = nodeInfo d nodeInfo (CAttrQual d) = nodeInfo d instance (CNode t1) => Pos (CTypeQualifier t1) where posOf x = posOf (nodeInfo x) instance Functor CTypeQualifier where fmap _f (CConstQual a1) = CConstQual (_f a1) fmap _f (CVolatQual a1) = CVolatQual (_f a1) fmap _f (CRestrQual a1) = CRestrQual (_f a1) fmap _f (CInlineQual a1) = CInlineQual (_f a1) fmap _f (CAttrQual a1) = CAttrQual (fmap _f a1) instance Annotated CTypeQualifier where annotation (CConstQual n) = n annotation (CVolatQual n) = n annotation (CRestrQual n) = n annotation (CInlineQual n) = n annotation (CAttrQual n) = annotation n amap f (CConstQual a_1) = CConstQual (f a_1) amap f (CVolatQual a_1) = CVolatQual (f a_1) amap f (CRestrQual a_1) = CRestrQual (f a_1) amap f (CInlineQual a_1) = CInlineQual (f a_1) amap f (CAttrQual n) = CAttrQual (amap f n) instance (CNode t1) => CNode (CStructureUnion t1) where nodeInfo (CStruct _ _ _ _ n) = nodeInfo n instance (CNode t1) => Pos (CStructureUnion t1) where posOf x = posOf (nodeInfo x) instance Functor CStructureUnion where fmap _f (CStruct a1 a2 a3 a4 a5) = CStruct a1 a2 (fmap (fmap (fmap _f)) a3) (fmap (fmap _f) a4) (_f a5) instance Annotated CStructureUnion where annotation (CStruct _ _ _ _ n) = n amap f (CStruct a_1 a_2 a_3 a_4 a_5) = CStruct a_1 a_2 a_3 a_4 (f a_5) instance (CNode t1) => CNode (CEnumeration t1) where nodeInfo (CEnum _ _ _ n) = nodeInfo n instance (CNode t1) => Pos (CEnumeration t1) where posOf x = posOf (nodeInfo x) instance Functor CEnumeration where fmap _f (CEnum a1 a2 a3 a4) = CEnum a1 (fmap (fmap (fmap (fmap (fmap _f)))) a2) (fmap (fmap _f) a3) (_f a4) instance Annotated CEnumeration where annotation (CEnum _ _ _ n) = n amap f (CEnum a_1 a_2 a_3 a_4) = CEnum a_1 a_2 a_3 (f a_4) instance (CNode t1) => CNode (CInitializer t1) where nodeInfo (CInitExpr _ n) = nodeInfo n nodeInfo (CInitList _ n) = nodeInfo n instance (CNode t1) => Pos (CInitializer t1) where posOf x = posOf (nodeInfo x) instance Annotated CInitializer where annotation (CInitExpr _ n) = n annotation (CInitList _ n) = n amap f (CInitExpr a_1 a_2) = CInitExpr a_1 (f a_2) amap f (CInitList a_1 a_2) = CInitList a_1 (f a_2) instance (CNode t1) => CNode (CPartDesignator t1) where nodeInfo (CArrDesig _ n) = nodeInfo n nodeInfo (CMemberDesig _ n) = nodeInfo n nodeInfo (CRangeDesig _ _ n) = nodeInfo n instance (CNode t1) => Pos (CPartDesignator t1) where posOf x = posOf (nodeInfo x) instance Functor CPartDesignator where fmap _f (CArrDesig a1 a2) = CArrDesig (fmap _f a1) (_f a2) fmap _f (CMemberDesig a1 a2) = CMemberDesig a1 (_f a2) fmap _f (CRangeDesig a1 a2 a3) = CRangeDesig (fmap _f a1) (fmap _f a2) (_f a3) instance Annotated CPartDesignator where annotation (CArrDesig _ n) = n annotation (CMemberDesig _ n) = n annotation (CRangeDesig _ _ n) = n amap f (CArrDesig a_1 a_2) = CArrDesig a_1 (f a_2) amap f (CMemberDesig a_1 a_2) = CMemberDesig a_1 (f a_2) amap f (CRangeDesig a_1 a_2 a_3) = CRangeDesig a_1 a_2 (f a_3) instance (CNode t1) => CNode (CAttribute t1) where nodeInfo (CAttr _ _ n) = nodeInfo n instance (CNode t1) => Pos (CAttribute t1) where posOf x = posOf (nodeInfo x) instance Functor CAttribute where fmap _f (CAttr a1 a2 a3) = CAttr a1 (fmap (fmap _f) a2) (_f a3) instance Annotated CAttribute where annotation (CAttr _ _ n) = n amap f (CAttr a_1 a_2 a_3) = CAttr a_1 a_2 (f a_3) instance (CNode t1) => CNode (CExpression t1) where nodeInfo (CComma _ n) = nodeInfo n nodeInfo (CAssign _ _ _ n) = nodeInfo n nodeInfo (CCond _ _ _ n) = nodeInfo n nodeInfo (CBinary _ _ _ n) = nodeInfo n nodeInfo (CCast _ _ n) = nodeInfo n nodeInfo (CUnary _ _ n) = nodeInfo n nodeInfo (CSizeofExpr _ n) = nodeInfo n nodeInfo (CSizeofType _ n) = nodeInfo n nodeInfo (CAlignofExpr _ n) = nodeInfo n nodeInfo (CAlignofType _ n) = nodeInfo n nodeInfo (CComplexReal _ n) = nodeInfo n nodeInfo (CComplexImag _ n) = nodeInfo n nodeInfo (CIndex _ _ n) = nodeInfo n nodeInfo (CCall _ _ n) = nodeInfo n nodeInfo (CMember _ _ _ n) = nodeInfo n nodeInfo (CVar _ n) = nodeInfo n nodeInfo (CConst d) = nodeInfo d nodeInfo (CCompoundLit _ _ n) = nodeInfo n nodeInfo (CStatExpr _ n) = nodeInfo n nodeInfo (CLabAddrExpr _ n) = nodeInfo n nodeInfo (CBuiltinExpr d) = nodeInfo d instance (CNode t1) => Pos (CExpression t1) where posOf x = posOf (nodeInfo x) instance Annotated CExpression where annotation (CComma _ n) = n annotation (CAssign _ _ _ n) = n annotation (CCond _ _ _ n) = n annotation (CBinary _ _ _ n) = n annotation (CCast _ _ n) = n annotation (CUnary _ _ n) = n annotation (CSizeofExpr _ n) = n annotation (CSizeofType _ n) = n annotation (CAlignofExpr _ n) = n annotation (CAlignofType _ n) = n annotation (CComplexReal _ n) = n annotation (CComplexImag _ n) = n annotation (CIndex _ _ n) = n annotation (CCall _ _ n) = n annotation (CMember _ _ _ n) = n annotation (CVar _ n) = n annotation (CConst n) = annotation n annotation (CCompoundLit _ _ n) = n annotation (CStatExpr _ n) = n annotation (CLabAddrExpr _ n) = n annotation (CBuiltinExpr n) = annotation n amap f (CComma a_1 a_2) = CComma a_1 (f a_2) amap f (CAssign a_1 a_2 a_3 a_4) = CAssign a_1 a_2 a_3 (f a_4) amap f (CCond a_1 a_2 a_3 a_4) = CCond a_1 a_2 a_3 (f a_4) amap f (CBinary a_1 a_2 a_3 a_4) = CBinary a_1 a_2 a_3 (f a_4) amap f (CCast a_1 a_2 a_3) = CCast a_1 a_2 (f a_3) amap f (CUnary a_1 a_2 a_3) = CUnary a_1 a_2 (f a_3) amap f (CSizeofExpr a_1 a_2) = CSizeofExpr a_1 (f a_2) amap f (CSizeofType a_1 a_2) = CSizeofType a_1 (f a_2) amap f (CAlignofExpr a_1 a_2) = CAlignofExpr a_1 (f a_2) amap f (CAlignofType a_1 a_2) = CAlignofType a_1 (f a_2) amap f (CComplexReal a_1 a_2) = CComplexReal a_1 (f a_2) amap f (CComplexImag a_1 a_2) = CComplexImag a_1 (f a_2) amap f (CIndex a_1 a_2 a_3) = CIndex a_1 a_2 (f a_3) amap f (CCall a_1 a_2 a_3) = CCall a_1 a_2 (f a_3) amap f (CMember a_1 a_2 a_3 a_4) = CMember a_1 a_2 a_3 (f a_4) amap f (CVar a_1 a_2) = CVar a_1 (f a_2) amap f (CConst n) = CConst (amap f n) amap f (CCompoundLit a_1 a_2 a_3) = CCompoundLit a_1 a_2 (f a_3) amap f (CStatExpr a_1 a_2) = CStatExpr a_1 (f a_2) amap f (CLabAddrExpr a_1 a_2) = CLabAddrExpr a_1 (f a_2) amap f (CBuiltinExpr n) = CBuiltinExpr (amap f n) instance (CNode t1) => CNode (CBuiltinThing t1) where nodeInfo (CBuiltinVaArg _ _ n) = nodeInfo n nodeInfo (CBuiltinOffsetOf _ _ n) = nodeInfo n nodeInfo (CBuiltinTypesCompatible _ _ n) = nodeInfo n instance (CNode t1) => Pos (CBuiltinThing t1) where posOf x = posOf (nodeInfo x) instance Functor CBuiltinThing where fmap _f (CBuiltinVaArg a1 a2 a3) = CBuiltinVaArg (fmap _f a1) (fmap _f a2) (_f a3) fmap _f (CBuiltinOffsetOf a1 a2 a3) = CBuiltinOffsetOf (fmap _f a1) (fmap (fmap _f) a2) (_f a3) fmap _f (CBuiltinTypesCompatible a1 a2 a3) = CBuiltinTypesCompatible (fmap _f a1) (fmap _f a2) (_f a3) instance Annotated CBuiltinThing where annotation (CBuiltinVaArg _ _ n) = n annotation (CBuiltinOffsetOf _ _ n) = n annotation (CBuiltinTypesCompatible _ _ n) = n amap f (CBuiltinVaArg a_1 a_2 a_3) = CBuiltinVaArg a_1 a_2 (f a_3) amap f (CBuiltinOffsetOf a_1 a_2 a_3) = CBuiltinOffsetOf a_1 a_2 (f a_3) amap f (CBuiltinTypesCompatible a_1 a_2 a_3) = CBuiltinTypesCompatible a_1 a_2 (f a_3) instance (CNode t1) => CNode (CConstant t1) where nodeInfo (CIntConst _ n) = nodeInfo n nodeInfo (CCharConst _ n) = nodeInfo n nodeInfo (CFloatConst _ n) = nodeInfo n nodeInfo (CStrConst _ n) = nodeInfo n instance (CNode t1) => Pos (CConstant t1) where posOf x = posOf (nodeInfo x) instance Functor CConstant where fmap _f (CIntConst a1 a2) = CIntConst a1 (_f a2) fmap _f (CCharConst a1 a2) = CCharConst a1 (_f a2) fmap _f (CFloatConst a1 a2) = CFloatConst a1 (_f a2) fmap _f (CStrConst a1 a2) = CStrConst a1 (_f a2) instance Annotated CConstant where annotation (CIntConst _ n) = n annotation (CCharConst _ n) = n annotation (CFloatConst _ n) = n annotation (CStrConst _ n) = n amap f (CIntConst a_1 a_2) = CIntConst a_1 (f a_2) amap f (CCharConst a_1 a_2) = CCharConst a_1 (f a_2) amap f (CFloatConst a_1 a_2) = CFloatConst a_1 (f a_2) amap f (CStrConst a_1 a_2) = CStrConst a_1 (f a_2) instance (CNode t1) => CNode (CStringLiteral t1) where nodeInfo (CStrLit _ n) = nodeInfo n instance (CNode t1) => Pos (CStringLiteral t1) where posOf x = posOf (nodeInfo x) instance Functor CStringLiteral where fmap _f (CStrLit a1 a2) = CStrLit a1 (_f a2) instance Annotated CStringLiteral where annotation (CStrLit _ n) = n amap f (CStrLit a_1 a_2) = CStrLit a_1 (f a_2) -- GENERATED STOP language-c-0.4.7/src/Language/C/Syntax/Constants.hs0000644000000000000000000002377612425376061020232 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Syntax.Constants -- Copyright : (c) 2007..2008 Duncan Coutts, Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- This module provides support for representing, checking and exporting c -- constants, i.e. integral, float, character and string constants. ----------------------------------------------------------------------------- module Language.C.Syntax.Constants ( -- * Utilities escapeChar, unescapeChar, unescapeString, Flags(..), noFlags, setFlag, clearFlag, testFlag, -- * C char constants (and multi-character character constants) cChar, cChar_w, cChars, CChar(..), getCChar, getCCharAsInt, isWideChar, showCharConst, -- * C integral constants CIntFlag(..), CIntRepr(..), cInteger, CInteger(..), getCInteger,readCInteger, -- * C floating point constants cFloat, CFloat(..), readCFloat, -- * C string literals cString, cString_w, CString(..), getCString, showStringLit, concatCStrings, ) where import Data.Bits import Data.Char import Numeric (showOct, showHex, readHex, readOct, readDec) import Language.C.Data.Node import Language.C.Data.Position import Data.Generics -- | C char constants (abstract) data CChar = CChar !Char !Bool -- wide flag | CChars [Char] -- multi-character character constant !Bool -- wide flag deriving (Eq,Ord,Data,Typeable) instance Show CChar where showsPrec _ (CChar c wideflag) = _showWideFlag wideflag . showCharConst c showsPrec _ (CChars cs wideflag) = _showWideFlag wideflag . (sQuote $ concatMap escapeCChar cs) -- | @showCharConst c@ prepends _a_ String representing the C char constant corresponding to @c@. -- If necessary uses octal or hexadecimal escape sequences. showCharConst :: Char -> ShowS showCharConst c = sQuote $ escapeCChar c _showWideFlag :: Bool -> ShowS _showWideFlag flag = if flag then showString "L" else id -- | get the haskell representation of a char constant getCChar :: CChar -> [Char] getCChar (CChar c _) = [c] getCChar (CChars cs _) = cs -- | get integer value of a C char constant -- undefined result for multi-char char constants getCCharAsInt :: CChar -> Integer getCCharAsInt (CChar c _) = fromIntegral (fromEnum c) getCCharAsInt (CChars _cs _) = error "integer value of multi-character character constants is implementation defined" -- | return @true@ if the character constant is /wide/. isWideChar :: CChar -> Bool isWideChar (CChar _ wideFlag) = wideFlag isWideChar (CChars _ wideFlag) = wideFlag -- | construct a character constant from a haskell 'Char' -- Use 'cchar_w' if you want a wide character constant. cChar :: Char -> CChar cChar c = CChar c False -- | construct a wide chararacter constant cChar_w :: Char -> CChar cChar_w c = CChar c True -- | create a multi-character character constant cChars :: [Char] -> Bool -> CChar cChars = CChars -- | datatype for memorizing the representation of an integer data CIntRepr = DecRepr | HexRepr | OctalRepr deriving (Eq,Ord,Enum,Bounded,Data,Typeable) -- | datatype representing type flags for integers data CIntFlag = FlagUnsigned | FlagLong | FlagLongLong | FlagImag deriving (Eq,Ord,Enum,Bounded,Data,Typeable) instance Show CIntFlag where show FlagUnsigned = "u" show FlagLong = "L" show FlagLongLong = "LL" show FlagImag = "i" {-# SPECIALIZE setFlag :: CIntFlag -> Flags CIntFlag -> Flags CIntFlag #-} {-# SPECIALIZE clearFlag :: CIntFlag -> Flags CIntFlag -> Flags CIntFlag #-} {-# SPECIALIZE testFlag :: CIntFlag -> Flags CIntFlag -> Bool #-} data CInteger = CInteger !Integer !CIntRepr !(Flags CIntFlag) -- integer flags deriving (Eq,Ord,Data,Typeable) instance Show CInteger where showsPrec _ (CInteger i repr flags) = showInt i . showString (concatMap showIFlag [FlagUnsigned .. ]) where showIFlag f = if testFlag f flags then show f else [] showInt i = case repr of DecRepr -> shows i OctalRepr -> showString "0" . showOct i HexRepr -> showString "0x" . showHex i -- To be used in the lexer -- Note that the flag lexer won't scale readCInteger :: CIntRepr -> String -> Either String CInteger readCInteger repr str = case readNum str of [(n,suffix)] -> mkCInt n suffix parseFailed -> Left $ "Bad Integer literal: "++show parseFailed where readNum = case repr of DecRepr -> readDec; HexRepr -> readHex; OctalRepr -> readOct mkCInt n suffix = either Left (Right . CInteger n repr) $ readSuffix suffix readSuffix = parseFlags noFlags parseFlags flags [] = Right flags parseFlags flags ('l':'l':fs) = parseFlags (setFlag FlagLongLong flags) fs parseFlags flags ('L':'L':fs) = parseFlags (setFlag FlagLongLong flags) fs parseFlags flags (f:fs) = let go1 flag = parseFlags (setFlag flag flags) fs in case f of 'l' -> go1 FlagLong ; 'L' -> go1 FlagLong 'u' -> go1 FlagUnsigned ; 'U' -> go1 FlagUnsigned 'i' -> go1 FlagImag ; 'I' -> go1 FlagImag; 'j' -> go1 FlagImag; 'J' -> go1 FlagImag _ -> Left $ "Unexpected flag " ++ show f getCInteger :: CInteger -> Integer getCInteger (CInteger i _ _) = i -- | construct a integer constant (without type flags) from a haskell integer cInteger :: Integer -> CInteger cInteger i = CInteger i DecRepr noFlags -- | Floats (represented as strings) data CFloat = CFloat !String deriving (Eq,Ord,Data,Typeable) instance Show CFloat where showsPrec _ (CFloat internal) = showString internal cFloat :: Float -> CFloat cFloat = CFloat . show -- dummy implementation readCFloat :: String -> CFloat readCFloat = CFloat -- | C String literals data CString = CString [Char] -- characters Bool -- wide flag deriving (Eq,Ord,Data,Typeable) instance Show CString where showsPrec _ (CString str wideflag) = _showWideFlag wideflag . showStringLit str -- construction cString :: String -> CString cString str = CString str False cString_w :: String -> CString cString_w str = CString str True -- selectors getCString :: CString -> String getCString (CString str _) = str isWideString :: CString -> Bool isWideString (CString _ wideflag) = wideflag -- | concatenate a list of C string literals concatCStrings :: [CString] -> CString concatCStrings cs = CString (concatMap getCString cs) (any isWideString cs) -- | @showStringLiteral s@ prepends a String representing the C string literal corresponding to @s@. -- If necessary it uses octal or hexadecimal escape sequences. showStringLit :: String -> ShowS showStringLit = dQuote . concatMap showStringChar where showStringChar c | isSChar c = return c | c == '"' = "\\\"" | otherwise = escapeChar c -- | @isAsciiSourceChar b@ returns @True@ if the given character is a character which -- may appear in a ASCII C source file and is printable. isAsciiSourceChar :: Char -> Bool isAsciiSourceChar c = isAscii c && isPrint c -- | @isCChar c@ returns true, if c is a source character which does not have to be escaped in -- C char constants (C99: 6.4.4.4) isCChar :: Char -> Bool isCChar '\\' = False isCChar '\'' = False isCChar '\n' = False isCChar c = isAsciiSourceChar c -- | @escapeCChar c@ escapes c for use in a char constant escapeCChar :: Char -> String escapeCChar '\'' = "\\'" escapeCChar c | isCChar c = [c] | otherwise = escapeChar c -- | @isSChar c@ returns true if c is a source character which does not have to be escaped in C string -- literals (C99: 6.4.5) isSChar :: Char -> Bool isSChar '\\' = False isSChar '\"' = False isSChar '\n' = False isSChar c = isAsciiSourceChar c showOct' :: Int -> String showOct' i = replicate (3 - length s) '0' ++ s where s = showOct i "" escapeChar :: Char -> String escapeChar '\\' = "\\\\" escapeChar '\a' = "\\a" escapeChar '\b' = "\\b" escapeChar '\ESC' = "\\e"; escapeChar '\f' = "\\f" escapeChar '\n' = "\\n" escapeChar '\r' = "\\r" escapeChar '\t' = "\\t" escapeChar '\v' = "\\v" escapeChar c | (ord c) < 512 = '\\' : showOct' (ord c) | otherwise = '\\' : 'x' : showHex (ord c) "" unescapeChar :: String -> (Char, String) unescapeChar ('\\':c:cs) = case c of 'n' -> ('\n', cs) 't' -> ('\t', cs) 'v' -> ('\v', cs) 'b' -> ('\b', cs) 'r' -> ('\r', cs) 'f' -> ('\f', cs) 'a' -> ('\a', cs) 'e' -> ('\ESC', cs) -- GNU extension 'E' -> ('\ESC', cs) -- GNU extension '\\' -> ('\\', cs) '?' -> ('?', cs) '\'' -> ('\'', cs) '"' -> ('"', cs) 'x' -> case head' "bad escape sequence" (readHex cs) of (i, cs') -> (toEnum i, cs') _ -> case head' "bad escape sequence" (readOct' (c:cs)) of (i, cs') -> (toEnum i, cs') unescapeChar (c :cs) = (c, cs) unescapeChar [] = error $ "unescape char: empty string" readOct' :: ReadS Int readOct' s = map (\(i, cs) -> (i, cs ++ rest)) (readOct octStr) where octStr = takeWhile isOctDigit $ take 3 s rest = drop (length octStr) s unescapeString :: String -> String unescapeString [] = [] unescapeString cs = case unescapeChar cs of (c, cs') -> c : unescapeString cs' -- helpers sQuote :: String -> ShowS sQuote s t = "'" ++ s ++ "'" ++ t dQuote :: String -> ShowS dQuote s t = ('"' : s) ++ "\"" ++ t head' :: String -> [a] -> a head' err [] = error err head' _ (x:_) = x -- TODO: Move to separate file ? newtype Flags f = Flags Integer deriving (Eq,Ord,Data,Typeable) noFlags :: Flags f noFlags = Flags 0 setFlag :: (Enum f) => f -> Flags f -> Flags f setFlag flag (Flags k) = Flags$ k `setBit` fromEnum flag clearFlag :: (Enum f) => f -> Flags f -> Flags f clearFlag flag (Flags k) = Flags$ k `clearBit` fromEnum flag testFlag :: (Enum f) => f -> Flags f -> Bool testFlag flag (Flags k) = k `testBit` fromEnum flag language-c-0.4.7/src/Language/C/Syntax/Ops.hs0000644000000000000000000000725512425376061017011 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Syntax.Ops -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : ghc -- -- Unary, binary and asssignment operators. Exported via AST. ----------------------------------------------------------------------------- module Language.C.Syntax.Ops ( -- * Assignment operators CAssignOp(..), assignBinop, -- * Binary operators CBinaryOp(..), isCmpOp, isPtrOp, isBitOp, isLogicOp, -- * Unary operators CUnaryOp(..), isEffectfulOp ) where import Data.Generics -- | C assignment operators (K&R A7.17) data CAssignOp = CAssignOp | CMulAssOp | CDivAssOp | CRmdAssOp -- ^ remainder and assignment | CAddAssOp | CSubAssOp | CShlAssOp | CShrAssOp | CAndAssOp | CXorAssOp | COrAssOp deriving (Eq,Ord,Show,Data,Typeable) assignBinop :: CAssignOp -> CBinaryOp assignBinop CAssignOp = error "direct assignment has no binary operator" assignBinop CMulAssOp = CMulOp assignBinop CDivAssOp = CDivOp assignBinop CRmdAssOp = CRmdOp assignBinop CAddAssOp = CAddOp assignBinop CSubAssOp = CSubOp assignBinop CShlAssOp = CShlOp assignBinop CShrAssOp = CShrOp assignBinop CAndAssOp = CAndOp assignBinop CXorAssOp = CXorOp assignBinop COrAssOp = COrOp -- | C binary operators (K&R A7.6-15) -- data CBinaryOp = CMulOp | CDivOp | CRmdOp -- ^ remainder of division | CAddOp | CSubOp | CShlOp -- ^ shift left | CShrOp -- ^ shift right | CLeOp -- ^ less | CGrOp -- ^ greater | CLeqOp -- ^ less or equal | CGeqOp -- ^ greater or equal | CEqOp -- ^ equal | CNeqOp -- ^ not equal | CAndOp -- ^ bitwise and | CXorOp -- ^ exclusive bitwise or | COrOp -- ^ inclusive bitwise or | CLndOp -- ^ logical and | CLorOp -- ^ logical or deriving (Eq,Ord,Show,Data,Typeable) isCmpOp :: CBinaryOp -> Bool isCmpOp op = op `elem` [ CLeqOp, CGeqOp, CLeOp, CGrOp, CEqOp, CNeqOp ] isPtrOp :: CBinaryOp -> Bool isPtrOp op = op `elem` [ CAddOp, CSubOp ] isBitOp :: CBinaryOp -> Bool isBitOp op = op `elem` [ CShlOp, CShrOp, CAndOp, COrOp, CXorOp ] isLogicOp :: CBinaryOp -> Bool isLogicOp op = op `elem` [ CLndOp, CLorOp ] -- | C unary operator (K&R A7.3-4) -- data CUnaryOp = CPreIncOp -- ^ prefix increment operator | CPreDecOp -- ^ prefix decrement operator | CPostIncOp -- ^ postfix increment operator | CPostDecOp -- ^ postfix decrement operator | CAdrOp -- ^ address operator | CIndOp -- ^ indirection operator | CPlusOp -- ^ prefix plus | CMinOp -- ^ prefix minus | CCompOp -- ^ one's complement | CNegOp -- ^ logical negation deriving (Eq,Ord,Show,Data,Typeable) isEffectfulOp :: CUnaryOp -> Bool isEffectfulOp op = op `elem` [ CPreIncOp, CPreDecOp, CPostIncOp, CPostDecOp ] language-c-0.4.7/src/Language/C/Syntax/Utils.hs0000644000000000000000000000541212425376061017341 0ustar0000000000000000module Language.C.Syntax.Utils ( -- * Generic operations getSubStmts, mapSubStmts, mapBlockItemStmts, -- * Concrete operations getLabels ) where import Data.List import Language.C.Data.Ident import Language.C.Syntax.AST -- XXX: This is should be generalized !!! -- Data.Generics sounds attractive, but we really need to control the evaluation order -- XXX: Expression statements (which are somewhat problematic anyway), aren't handled yet getSubStmts :: CStat -> [CStat] getSubStmts (CLabel _ s _ _) = [s] getSubStmts (CCase _ s _) = [s] getSubStmts (CCases _ _ s _) = [s] getSubStmts (CDefault s _) = [s] getSubStmts (CExpr _ _) = [] getSubStmts (CCompound _ body _) = concatMap compoundSubStmts body getSubStmts (CIf _ sthen selse _) = maybe [sthen] (\s -> [sthen,s]) selse getSubStmts (CSwitch _ s _) = [s] getSubStmts (CWhile _ s _ _) = [s] getSubStmts (CFor _ _ _ s _) = [s] getSubStmts (CGoto _ _) = [] getSubStmts (CGotoPtr _ _) = [] getSubStmts (CCont _) = [] getSubStmts (CBreak _) = [] getSubStmts (CReturn _ _) = [] getSubStmts (CAsm _ _) = [] mapSubStmts :: (CStat -> Bool) -> (CStat -> CStat) -> CStat -> CStat mapSubStmts stop _ s | stop s = s mapSubStmts stop f (CLabel i s attrs ni) = f (CLabel i (mapSubStmts stop f s) attrs ni) mapSubStmts stop f (CCase e s ni) = f (CCase e (mapSubStmts stop f s) ni) mapSubStmts stop f (CCases e1 e2 s ni) = f (CCases e1 e2 (mapSubStmts stop f s) ni) mapSubStmts stop f (CDefault s ni) = f (CDefault (mapSubStmts stop f s) ni) mapSubStmts stop f (CCompound ls body ni) = f (CCompound ls (map (mapBlockItemStmts stop f) body) ni) mapSubStmts stop f (CIf e sthen selse ni) = f (CIf e (mapSubStmts stop f sthen) (maybe Nothing (Just . mapSubStmts stop f) selse) ni) mapSubStmts stop f (CSwitch e s ni) = f (CSwitch e (mapSubStmts stop f s) ni) mapSubStmts stop f (CWhile e s isdo ni) = f (CWhile e (mapSubStmts stop f s) isdo ni) mapSubStmts stop f (CFor i t a s ni) = f (CFor i t a (mapSubStmts stop f s) ni) mapSubStmts _ f s = f s mapBlockItemStmts :: (CStat -> Bool) -> (CStat -> CStat) -> CBlockItem -> CBlockItem mapBlockItemStmts stop f (CBlockStmt s) = CBlockStmt (mapSubStmts stop f s) mapBlockItemStmts _ _ bi = bi compoundSubStmts :: CBlockItem -> [CStat] compoundSubStmts (CBlockStmt s) = [s] compoundSubStmts (CBlockDecl _) = [] compoundSubStmts (CNestedFunDef _) = [] getLabels :: CStat -> [Ident] getLabels (CLabel l s _ _) = l : getLabels s getLabels (CCompound ls body _) = concatMap (concatMap getLabels . compoundSubStmts) body \\ ls getLabels stmt = concatMap getLabels (getSubStmts stmt) language-c-0.4.7/src/Language/C/System/0000755000000000000000000000000012425376061015701 5ustar0000000000000000language-c-0.4.7/src/Language/C/System/GCC.hs0000644000000000000000000001133012425376061016627 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.System.Gcc -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : portable -- -- Invoking gcc for preprocessing and compiling. ----------------------------------------------------------------------------- module Language.C.System.GCC ( GCC,newGCC, ) where import Language.C.Data.RList as RList import Language.C.System.Preprocess import Data.Maybe import System.Process import System.Directory import Data.List -- | @GCC@ represents a reference to the gcc compiler newtype GCC = GCC { gccPath :: FilePath } -- | create a reference to @gcc@ newGCC :: FilePath -> GCC newGCC = GCC instance Preprocessor GCC where parseCPPArgs _ = gccParseCPPArgs runCPP gcc cpp_args = do -- copy the input to the outputfile, because in case the input is preprocessed, -- gcc -E will do nothing. maybe (return()) (copyWritable (inputFile cpp_args)) (outputFile cpp_args) rawSystem (gccPath gcc) (buildCppArgs cpp_args) where copyWritable source target = do copyFile source target p <- getPermissions target setPermissions target p{writable=True} -- | Parse arguments for preprocessing via GCC. -- At least one .c, .hc or .h file has to be present. -- For now we only support the most important gcc options. -- -- 1) Parse all flags relevant to CppArgs -- 2) Move -c,-S,-M? to other_args -- 3) Strip -E -- 4) The rest goes into extra_args gccParseCPPArgs :: [String] -> Either String (CppArgs, [String]) gccParseCPPArgs args = case mungeArgs ((Nothing,Nothing,RList.empty),(RList.empty,RList.empty)) args of Left err -> Left err Right ((Nothing,_,_),_) -> Left "No .c / .hc / .h source file given" Right ((Just input_file,output_file_opt,cpp_opts),(extra_args,other_args)) -> Right ((rawCppArgs (RList.reverse extra_args) input_file) { outputFile = output_file_opt, cppOptions = RList.reverse cpp_opts }, RList.reverse other_args) where mungeArgs :: ParseArgsState -> [String] -> Either String ParseArgsState mungeArgs parsed@( cpp_args@(inp,out,cpp_opts), unparsed@(extra,other)) unparsed_args = case unparsed_args of ("-E":rest) -> mungeArgs parsed rest (flag:rest) | flag == "-c" || flag == "-S" || "-M" `isPrefixOf` flag -> mungeArgs (cpp_args,(extra,other `snoc` flag)) rest ("-o":file:rest) | isJust out -> Left "two output files given" | otherwise -> mungeArgs ((inp,Just file,cpp_opts),unparsed) rest (cpp_opt:rest) | Just (opt,rest') <- getArgOpt cpp_opt rest -> mungeArgs ((inp,out,cpp_opts `snoc` opt),unparsed) rest' (cfile:rest) | any (flip isSuffixOf cfile) (words ".c .hc .h") -> if isJust inp then Left "two input files given" else mungeArgs ((Just cfile,out,cpp_opts),unparsed) rest (unknown:rest) -> mungeArgs (cpp_args,(extra `snoc` unknown,other)) rest [] -> Right parsed getArgOpt cpp_opt rest | "-I" `isPrefixOf` cpp_opt = Just (IncludeDir (drop 2 cpp_opt),rest) | "-U" `isPrefixOf` cpp_opt = Just (Undefine (drop 2 cpp_opt),rest) | "-D" `isPrefixOf` cpp_opt = Just (getDefine (drop 2 cpp_opt),rest) getArgOpt "-include" (f:rest') = Just (IncludeFile f, rest') getArgOpt _ _ = Nothing getDefine opt = let (key,val) = break (== '=') opt in Define key (if null val then "" else tail val) type ParseArgsState = ((Maybe FilePath, Maybe FilePath, RList CppOption), (RList String, RList String)) buildCppArgs :: CppArgs -> [String] buildCppArgs (CppArgs options extra_args _tmpdir input_file output_file_opt) = do (concatMap tOption options) ++ outputFileOpt ++ ["-E", input_file] ++ extra_args where tOption (IncludeDir incl) = ["-I",incl] tOption (Define key value) = [ "-D" ++ key ++ (if null value then "" else "=" ++ value) ] tOption (Undefine key) = [ "-U" ++ key ] tOption (IncludeFile f) = [ "-include", f] outputFileOpt = concat [ ["-o",output_file] | output_file <- maybeToList output_file_opt ] language-c-0.4.7/src/Language/C/System/Preprocess.hs0000644000000000000000000001071612425376061020367 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.C.Wrapper.Preprocess -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : experimental -- Portability : portable -- -- Invoking external preprocessors. ----------------------------------------------------------------------------- module Language.C.System.Preprocess ( Preprocessor(..), CppOption(..), CppArgs(..),rawCppArgs,addCppOption,addExtraOption, runPreprocessor, isPreprocessed, ) where import Language.C.Data.InputStream import System.Exit import System.Directory import System.FilePath import System.Environment import System.IO import Control.Exception import Control.Monad import Data.List -- | 'Preprocessor' encapsulates the abstract interface for invoking C preprocessors class Preprocessor cpp where -- | parse the given command line arguments, and return a pair of parsed and ignored arguments parseCPPArgs :: cpp -> [String] -> Either String (CppArgs, [String]) -- | run the preprocessor runCPP :: cpp -> CppArgs -> IO ExitCode -- | file extension of a preprocessed file preprocessedExt :: String preprocessedExt = ".i" -- | Generic Options for the preprocessor data CppOption = IncludeDir FilePath | Define String String | Undefine String | IncludeFile FilePath -- | Generic arguments for the preprocessor data CppArgs = CppArgs { cppOptions :: [CppOption], extraOptions :: [String], cppTmpDir :: Maybe FilePath, inputFile :: FilePath, outputFile :: Maybe FilePath } -- | Cpp arguments that only specify the input file name. cppFile :: FilePath -> CppArgs cppFile input_file = CppArgs { cppOptions = [], extraOptions = [], cppTmpDir = Nothing, inputFile = input_file, outputFile = Nothing } -- | use the given preprocessor arguments without analyzing them rawCppArgs :: [String] -> FilePath -> CppArgs rawCppArgs opts input_file = CppArgs { inputFile = input_file, cppOptions = [], extraOptions = opts, outputFile = Nothing, cppTmpDir = Nothing } -- | add a typed option to the given preprocessor arguments addCppOption :: CppArgs -> CppOption -> CppArgs addCppOption cpp_args opt = cpp_args { cppOptions = opt : (cppOptions cpp_args) } -- | add a string option to the given preprocessor arguments addExtraOption :: CppArgs -> String -> CppArgs addExtraOption cpp_args extra = cpp_args { extraOptions = extra : (extraOptions cpp_args) } -- | run the preprocessor and return an 'InputStream' if preprocesssing succeeded runPreprocessor :: (Preprocessor cpp) => cpp -> CppArgs -> IO (Either ExitCode InputStream) runPreprocessor cpp cpp_args = do bracket getActualOutFile -- remove outfile if it was temporary removeTmpOutFile -- invoke preprocessor invokeCpp where getActualOutFile :: IO FilePath getActualOutFile = maybe (mkOutputFile (cppTmpDir cpp_args) (inputFile cpp_args)) return (outputFile cpp_args) invokeCpp actual_out_file = do exit_code <- runCPP cpp (cpp_args { outputFile = Just actual_out_file}) case exit_code of ExitSuccess -> liftM Right (readInputStream actual_out_file) ExitFailure _ -> return $ Left exit_code removeTmpOutFile out_file = maybe (removeFile out_file) (\_ -> return ()) (outputFile cpp_args) -- | create an output file, given @Maybe tmpdir@ and @inputfile@ mkOutputFile :: Maybe FilePath -> FilePath -> IO FilePath mkOutputFile tmp_dir_opt input_file = do tmpDir <- getTempDir tmp_dir_opt mkTmpFile tmpDir (getOutputFileName input_file) where getTempDir (Just tmpdir) = return tmpdir getTempDir Nothing = getTemporaryDirectory -- | compute output file name from input file name getOutputFileName :: FilePath -> FilePath getOutputFileName fp | hasExtension fp = replaceExtension filename preprocessedExt | otherwise = addExtension filename preprocessedExt where filename = takeFileName fp -- | create a temporary file mkTmpFile :: FilePath -> FilePath -> IO FilePath mkTmpFile tmp_dir file_templ = do -- putStrLn $ "TmpDir: "++tmp_dir -- putStrLn $ "FileTempl: "++file_templ (path,file_handle) <- openTempFile tmp_dir file_templ hClose file_handle return path -- | guess whether a file is preprocessed (file end with .i) isPreprocessed :: FilePath -> Bool isPreprocessed = (".i" `isSuffixOf`)