language-c 0.4.7 → 0.10.2
raw patch · 45 files changed
Files
- AUTHORS +1/−0
- ChangeLog +0/−49
- ChangeLog.md +210/−0
- README +0/−39
- README.md +46/−0
- Setup.hs +0/−5
- language-c.cabal +113/−97
- src/Language/C.hs +1/−1
- src/Language/C/Analysis.hs +0/−1
- src/Language/C/Analysis/AstAnalysis.hs +137/−95
- src/Language/C/Analysis/Builtins.hs +14/−5
- src/Language/C/Analysis/ConstEval.hs +43/−17
- src/Language/C/Analysis/Debug.hs +14/−8
- src/Language/C/Analysis/DeclAnalysis.hs +123/−86
- src/Language/C/Analysis/DefTable.hs +6/−8
- src/Language/C/Analysis/Export.hs +88/−26
- src/Language/C/Analysis/MachineDescs.hs +119/−0
- src/Language/C/Analysis/NameSpaceMap.hs +5/−5
- src/Language/C/Analysis/SemError.hs +4/−5
- src/Language/C/Analysis/SemRep.hs +83/−80
- src/Language/C/Analysis/TravMonad.hs +87/−65
- src/Language/C/Analysis/TypeCheck.hs +98/−107
- src/Language/C/Analysis/TypeConversions.hs +2/−2
- src/Language/C/Analysis/TypeUtils.hs +132/−26
- src/Language/C/Data.hs +3/−2
- src/Language/C/Data/Error.hs +9/−9
- src/Language/C/Data/Ident.hs +17/−5
- src/Language/C/Data/InputStream.hs +1/−4
- src/Language/C/Data/Name.hs +7/−4
- src/Language/C/Data/Node.hs +16/−12
- src/Language/C/Data/Position.hs +38/−27
- src/Language/C/Data/RList.hs +1/−1
- src/Language/C/Parser/Builtin.hs +3/−1
- src/Language/C/Parser/Lexer.x +147/−46
- src/Language/C/Parser/Parser.y +341/−210
- src/Language/C/Parser/ParserMonad.hs +11/−2
- src/Language/C/Parser/Tokens.hs +66/−4
- src/Language/C/Pretty.hs +60/−21
- src/Language/C/Syntax/AST.hs +286/−180
- src/Language/C/Syntax/Constants.hs +42/−19
- src/Language/C/Syntax/Ops.hs +12/−4
- src/Language/C/Syntax/Utils.hs +1/−1
- src/Language/C/System/GCC.hs +8/−3
- src/Language/C/System/Preprocess.hs +5/−5
- test/harness/run-harness.hs +70/−0
AUTHORS view
@@ -7,6 +7,7 @@ Iavor Diatchki <iavor.diatchki@gmail.com> Kevin Charter <kcharter@gmail.com>+Aleksey Kliger This project originated from the C parser component of c2hs, for many additional contributors see AUTHORS.c2hs.
− ChangeLog
@@ -1,49 +0,0 @@-Changes 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 <bernauer@inf.ethz.ch>- * 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-
+ ChangeLog.md view
@@ -0,0 +1,210 @@+# Changelog++## 0.10.2++- Accept C23 `bool` keyword.++## 0.10.1++- Support `0.0f16` syntax.++## 0.10.0++- Support for half-precision floating point `__fp16`, `_Float16`, and `_Float16x`.+- Support for bfloat16 `__bf16`.+- Support alignment specifier `_Alignas` in struct declatations.++## 0.9.4++- Support `happy-2.1`.++## 0.9.3++- Add support for `__builtin_bit_cast` to support clang toolchain,+ enabling builds with GHC 9.4+ on Windows.++## 0.9.2++- Add support for 128 bit builtin integer types++## 0.9.1++- Support parsing an empty list of clobbers after a colon in `asm` statements++## 0.9.0.2++- Correct lower bound on GHC++## 0.9.0.1++- Scrap dependency on syb++Thanks to @vmchale++## 0.9++- Make `Trav` a monad transformer+- Add `runTravTWithTravState`+- Tests now use Cabal-3+- Implement alignment calculation and correct size calculation+- Add `Show` instance for `Type`+- Add machine descriptions for x86_64 and armv7l+- Small correction in output of prettyprinter+- Allow zeros as line numbers in preprocessed directives++Thanks to @aweinstock314, @ersran9, @expipiplus1, @jkoppel, @trofi and @visq++## Changes since 0.7.0++Wed May 23 07:08:02 2018 +0200+ * Support IEC 60559 types and literals. Closes #52.++Wed May 16 07:08:15 2018 +0200+ * introduce flag for optional IEC 60559 type support (see #43)++Wed May 16 06:36:04 2018 +0200+ * WIP: towards a complete Export (#51)++Thu Feb 22 13:22:50 2018 -0500+ * [syntax] GHC.Generics.Generic and Control.DeepSeq.NFData instances (#49)+ (.cabal) drop splitBase flag++Tue Feb 20 08:34:39 2018 +0300+ * Selectively hide Prelude.<>: GHC 8.4 compat (#45)++Tue Feb 20 00:09:16 2018 -0500+ * (Analysis) Minimal support for `__float128` (#47)++Sat Nov 25 08:59:59 2017 +0100+ * Consider builtin_convertvector from #34 for pretty printing++Sat Nov 25 00:46:33 2017 -0600+ * add support for `_Float128` (#41)++## Changes since 0.6.0++Mon Jul 31 2017+ * Improve TypeCheck output (#31)++Sun Jul 30 2017+ * Add `__float128` (fixes #33)++Mon Maz 22 2017+ * Support clang’s `__builtin_convertvector` (Fixes #34)++Wed Mar 8 2017+ * Move file and parent information to new datatype FilePosition for performance reasons++## Changes since 0.5.0++Thu Feb 23 2017+ * Make gccParseCPPArgs grab the arg to -MF -MT and -MQ++Wed Feb 15 2017+ * In enums, allow multiple attribute specifiers per enumerator++Tue Feb 21 2017+ * Allow typedef redefinition if it denotes the same type++Tue Feb 21 2017+ * Change TypeDefRef to store Type, not Maybe Type++Tue Feb 14 2017+ * Parse (and ignore) Clang __attribute__((availability(id=major.minor.rev)))++Sun Sep 11 2016+ * Add `__builtin_bswap32/64`.++Wed Jun 22 2016+ * Add `_Alignof` to Lexer.x (fixes #7)++Mon Jun 27 2016+ * Updates for C11 (part 1)+ * `_Nullable` and `_Nonnull` support as well as Warnings/lint fixes provided by Anthony Cowley (https://github.com/acowley)++Wed Mar 16 2016+ * Consider storage specifier "ThreadSpec" for global and local declarations++Tue Mar 15 2016+ * Support C11 `_NoReturn`, genearlize is_inline to FunSpecs (Syntax) / FunAttrs (SemRep)++## Changes since 0.4.3++Wed Mar 2 2016+ * Add direct base type BaseInt128 (complements previous `__int128` patch)+ ryan.gl.scott@gmail.com++Sun Feb 28 2016+ * Parse gcc-specific `__int128` type++Thu Dec 4 2014+ * Scott Kovach <dskovach@gmail.com>: added derived Eq,Ord instances to NodeInfo++## Changes since 0.4.2++Sat Jan 11 2014+ * Allow unicode characters in string/char literals and filenames++Mon Oct 27 2014+ * macos-attributes++Tue Aug 13 2013+ * Do not derive Error instances for newtypes (type parameter has non-parametric role)++Mon Aug 12 2013+ * Fix bug caused by applying posFile to nopos (reported by Mikhail Sosonkin)++## Changes since 0.4.1++Tue Mar 19 2013+ * TypeCheck: Return Left str instead of fail str (do not rely on MonadError instance of Either)+ * Improve printing of SUERefs and Ident++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++Fri Apr 15 2011: Alexander Bernauer <bernauer@inf.ethz.ch>+ * 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+
− README
@@ -1,39 +0,0 @@-= 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="<flags-seperated-by-space>"-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.
+ README.md view
@@ -0,0 +1,46 @@+# Language.C++Language.C is a parser and pretty-printer framework for C11 and the extensions of gcc.++See http://visq.github.io/language-c/++## C Language Compatibility++language-c has no comprehensive C23 support yet, but supports+ - the `bool` keyword++Currently unsupported C11 constructs:+ - static assertion 6.7.10 (`_Static_assert`)+ - generic selection 6.5.1.1 (`_Generic`)+ - `_Atomic`, `_Thread_local`+ - Universal character names++Currently unsupported GNU C extensions:+ - `__auto_type`+ - `__builtin_offsetof`+ `char a[__builtin_offsetof (struct S, sa->f)`+ - `_Decimal32`+ - Extended assembler+ `__asm__ __volatile__ ("" : : : )`;+ `__asm__ goto ("" : : : : label)`;+ - `__attribute__((packed))`: types featuring this attribute may have an+ incorrect size or alignment calculated.++### IEC 60559:++Since `language-c-0.8`, extended floating point types are supported (gcc 7 feature). Package maintainers may decide to disable these types (flag `iecFpExtension`) to work around the fact that the `_Float128` type is redefined by glibc >= 2.26 if gcc < 7 is used for preprocessing:++```+ /* The type _Float128 exists only since GCC 7.0. */+ # if !__GNUC_PREREQ (7, 0) || defined __cplusplus+ typedef __float128 _Float128;+ # endif+```++## Examples++A couple of small examples are available in `examples`.++## Testing++See `test/README`.
− Setup.hs
@@ -1,5 +0,0 @@-#!/usr/bin/env runhaskell--import Distribution.Simple--main = defaultMain
language-c.cabal view
@@ -1,109 +1,125 @@-Name: 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/+cabal-version: 2.2+name: language-c+version: 0.10.2+license: BSD-3-Clause+license-file: LICENSE+copyright: LICENSE+maintainer: language.c@monoid.al+author: AUTHORS+tested-with:+ ghc ==9.14.1 ghc ==9.12.2 ghc ==9.10.3 ghc ==9.8.4 ghc ==9.6.7+ ghc ==9.4.8 ghc ==9.2.8 ghc ==9.0.2 ghc ==8.10.7 ghc ==8.8.4+ ghc ==8.6.5 ghc ==8.4.4 ghc ==8.2.2 ghc ==8.0.2 -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+homepage: https://visq.github.io/language-c/+bug-reports: https://github.com/visq/language-c/issues/+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 C11 and clang/GNU extensions. -Extra-Source-Files: AUTHORS AUTHORS.c2hs ChangeLog README- src/Language/C/Parser/Lexer.x- src/Language/C/Parser/Parser.y+category: Language+build-type: Simple+extra-doc-files:+ ChangeLog.md+ README.md+ AUTHORS+ AUTHORS.c2hs -Source-Repository head- type: darcs- location: http://code.haskell.org/language-c+source-repository head+ type: git+ location: https://github.com/visq/language-c.git -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.+flag usebytestrings+ description: Use ByteString as InputStream datatype+ manual: True -Library- Extensions: CPP, DeriveDataTypeable, PatternGuards, BangPatterns, ExistentialQuantification, GeneralizedNewtypeDeriving, ScopedTypeVariables- Build-Depends: filepath+flag iecfpextension+ description:+ Support IEC 60559 floating point extension (defines _Float128) - if flag(splitBase)- Build-Depends: base >= 3 && < 5, process, directory, array, containers, pretty+ manual: True - If flag(separateSYB)- Build-Depends:- base >=4 && <5,- syb- Else- Build-Depends:- base <4- else- Build-Depends: base < 3+library+ exposed-modules:+ Language.C+ 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+ Language.C.Syntax+ Language.C.Syntax.AST+ Language.C.Syntax.Constants+ Language.C.Syntax.Ops+ Language.C.Syntax.Utils+ Language.C.Parser+ Language.C.Pretty+ Language.C.System.Preprocess+ Language.C.System.GCC+ 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+ Language.C.Analysis.MachineDescs+ Language.C.Analysis.Export - if flag(useByteStrings)- Build-Depends: bytestring >= 0.9.0+ build-tool-depends: happy:happy, alex:alex+ hs-source-dirs: src+ other-modules:+ Language.C.Data.RList+ Language.C.Parser.Builtin+ Language.C.Parser.Lexer+ Language.C.Parser.ParserMonad+ Language.C.Parser.Tokens+ Language.C.Parser.Parser++ default-language: Haskell2010+ default-extensions:+ CPP DeriveDataTypeable DeriveGeneric PatternGuards BangPatterns+ ExistentialQuantification GeneralizedNewtypeDeriving+ ScopedTypeVariables++ ghc-options: -Wall -Wno-redundant-constraints+ build-depends:+ base >=4.9 && <5,+ array <0.6,+ containers >=0.3 && <0.9,+ deepseq >=1.4.0.0 && <1.6,+ directory <1.4,+ filepath <1.6,+ mtl <2.4,+ pretty <1.2,+ process <1.7++ if flag(usebytestrings)+ build-depends: bytestring >=0.9.0 && <0.13+ 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+ if flag(iecfpextension)+ cpp-options: -DIEC_60559_TYPES_EXT +test-suite language-c-harness+ type: exitcode-stdio-1.0+ main-is: test/harness/run-harness.hs+ default-language: Haskell2010+ build-depends:+ base <5,+ directory,+ process,+ filepath
src/Language/C.hs view
@@ -33,7 +33,7 @@ -- -- > 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 :: (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 }
src/Language/C/Analysis.hs view
@@ -61,7 +61,6 @@ 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
src/Language/C/Analysis/AstAnalysis.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, PatternGuards #-}+{-# OPTIONS_GHC -Wwarn=incomplete-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Parser.Translation@@ -30,14 +31,11 @@ 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,+import Language.C.Analysis.DefTable (globalDefs, defineLabel, inFileScope, 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@@ -48,13 +46,12 @@ 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 Prelude hiding (mapM, mapM_, reverse)+import Control.Monad hiding (mapM, mapM_) import qualified Data.Map as Map import Data.Maybe+import Data.Traversable (mapM)+import Data.Foldable (mapM_) -- * analysis @@ -71,7 +68,7 @@ -- analyse all declarations, but recover from errors mapRecoverM_ analyseExt decls -- check we are in global scope afterwards- getDefTable >>= \dt -> when (not (inFileScope dt)) $+ getDefTable >>= \dt -> unless (inFileScope dt) $ error "Internal Error: Not in filescope after analysis" -- get the global definition table (XXX: remove ?) liftM globalDefs getDefTable@@ -92,14 +89,14 @@ 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+ let (VarDeclInfo name fun_spec 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'+ let var_decl = VarDecl name (DeclAttrs fun_spec fun_storage attrs) ty' -- callback for declaration handleVarDecl False (Decl var_decl node_info) -- process body@@ -109,20 +106,27 @@ where improveFunDefType (FunctionType (FunTypeIncomplete return_ty) attrs) = return $ FunctionType (FunType return_ty [] False) attrs- improveFunDefType ty = return $ ty+ improveFunDefType ty = return ty +voidM :: Monad m => m a -> m ()+voidM m = m >> return ()+ -- | Analyse a declaration other than a function definition+--+-- Note: static assertions are not analysed analyseDecl :: (MonadTrav m) => Bool -> CDecl -> m ()+analyseDecl _is_local (CStaticAssert _expr _strlit _annot) = return () -- TODO 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 ()+ Nothing -> voidM$ analyseTypeDecl decl | (Just declspecs') <- typedef_spec = mapM_ (uncurry (analyseTyDef declspecs')) declr_list- | otherwise = do let (storage_specs, attrs, typequals, typespecs, inline) =+ | otherwise = do let (storage_specs, attrs, typequals, typespecs, funspecs, _alignspecs) = partitionDeclSpecs declspecs canonTySpecs <- canonicalTypeSpec typespecs+ -- TODO: alignspecs not yet processed let specs =- (storage_specs, attrs, typequals, canonTySpecs, inline)+ (storage_specs, attrs, typequals, canonTySpecs, funspecs) mapM_ (uncurry (analyseVarDeclr specs)) declr_list where declr_list = zip (True : repeat False) declrs@@ -140,28 +144,29 @@ analyseVarDecl handle_sue_def storage_specs attrs typequals canonTySpecs inline declr [] Nothing -- declare / define the object- if (isFunctionType typ)+ 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)+ _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"+ 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+ (VarDeclInfo name fun_attrs storage_spec attrs ty _node) <- analyseVarDecl' handle_sue_def declspecs declr [] Nothing+ checkValidTypeDef fun_attrs 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 fun_attrs _ _ | fun_attrs /= noFunctionAttrs =+ astError node_info "inline specifier for typeDef" checkValidTypeDef _ NoStorageSpec _ = return () checkValidTypeDef _ bad_storage _ = astError node_info $ "storage specified for typeDef: " ++ show bad_storage @@ -173,12 +178,13 @@ -- 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 _ (StaticSpec _) = 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+ ClKernelSpec -> 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@@ -190,11 +196,11 @@ -- | handle a function prototype extFunProto :: (MonadTrav m) => VarDeclInfo -> m ()-extFunProto (VarDeclInfo var_name is_inline storage_spec attrs ty node_info) =+extFunProto (VarDeclInfo var_name fun_spec 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+ let decl = VarDecl var_name (DeclAttrs fun_spec (funDeclLinkage old_fun) attrs) ty handleVarDecl False (Decl decl node_info) -- XXX: structs should be handled in 'function prototype scope' too enterPrototypeScope@@ -219,17 +225,19 @@ -- 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 =+extVarDecl :: (MonadTrav m) => VarDeclInfo -> Maybe Initializer -> m ()+extVarDecl (VarDeclInfo var_name fun_spec 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+ let vardecl = VarDecl var_name (DeclAttrs fun_spec 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 _ | fun_spec /= noFunctionAttrs =+ astError node_info "invalid function specifier for external variable"+ globalStorage AutoSpec = astError node_info "file-scope declaration specifies storage `auto'" globalStorage RegSpec = do when (isJust init_opt) $ astError node_info "initializer given for global register variable" case var_name of@@ -240,51 +248,50 @@ 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)+ globalStorage NoStorageSpec = return (Static ExternalLinkage False, True)+ globalStorage ThreadSpec = return (Static ExternalLinkage True, True) -- tentative if there is no initializer, internal- globalStorage (StaticSpec thread_local) = return $ (Static InternalLinkage thread_local, True)+ 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)+ 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)+ return (Static ExternalLinkage thread_local, True) hasFunDef dt = any (isFuncDef . snd) (Map.toList $ gObjs $ globalDefs dt)- isFuncDef (FunctionDef fd) = not $ isInline $ declAttrs fd+ isFuncDef (FunctionDef fd) = not $ (isInline . functionAttrs) 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 =+localVarDecl :: (MonadTrav m) => VarDeclInfo -> Maybe Initializer -> m ()+localVarDecl (VarDeclInfo var_name fun_attrs 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+ let vardecl = VarDecl var_name (DeclAttrs fun_attrs 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)+ localStorage NoStorageSpec = return (Auto False,True)+ localStorage ThreadSpec = return (Auto True,True)+ localStorage RegSpec = return (Auto True,True) -- static no linkage localStorage (StaticSpec thread_local) =- return $ (Static NoLinkage thread_local,True)+ 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"+ localStorage _ = astError node_info "bad storage specifier for local" defineParams :: MonadTrav m => NodeInfo -> VarDecl -> m () defineParams ni decl =- case (getParams $ declType decl) of+ case getParams (declType decl) of Nothing -> astError ni "expecting complete function type in function definition" Just params -> mapM_ handleParamDecl params@@ -340,7 +347,7 @@ return t tStmt c (CIf e sthen selse _) = checkGuard c e >> tStmt c sthen- >> maybe (return ()) (\s -> tStmt c s >> return ()) selse+ >> maybe (return ()) (voidM . tStmt c) selse >> return voidType tStmt c (CSwitch e s ni) = tExpr c RValue e >>= checkIntegral' ni >>@@ -394,10 +401,10 @@ either (maybe (return ()) checkExpr) (analyseDecl True) i maybe (return ()) (checkGuard c) g maybe (return ()) checkExpr inc- tStmt (LoopCtx : c) s+ _ <- tStmt (LoopCtx : c) s leaveBlockScope return voidType- where checkExpr e = tExpr c RValue e >> return ()+ where checkExpr e = voidM$ tExpr c RValue e tStmt c (CGotoPtr e ni) = do t <- tExpr c RValue e case t of@@ -423,18 +430,20 @@ 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+ TyBool -> 1+ TyChar -> 1+ TySChar -> 1+ TyUChar -> 1+ TyShort -> 2+ TyUShort -> 2+ TyInt -> 4+ TyUInt -> 4+ TyLong -> 4+ TyULong -> 4+ TyLLong -> 8+ TyULLong -> 8+ TyInt128 -> 16+ TyUInt128 -> 16 , fSize = \ft -> case ft of TyFloat -> 4@@ -448,18 +457,20 @@ , 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+ TyBool -> 1+ TyChar -> 1+ TySChar -> 1+ TyUChar -> 1+ TyShort -> 2+ TyUShort -> 2+ TyInt -> 4+ TyUInt -> 4+ TyLong -> 4+ TyULong -> 4+ TyLLong -> 8+ TyULLong -> 8+ TyInt128 -> 16+ TyUInt128 -> 16 , fAlign = \ft -> case ft of TyFloat -> 4@@ -482,7 +493,7 @@ Just t -> return t Nothing -> do t <- tExpr' c side e- withDefTable (\dt -> (t, insertType dt n t))+ withDefTable (\dt' -> (t, insertType dt' n t)) Nothing -> tExpr' c side e -- | Typecheck an expression, with information about whether it@@ -528,7 +539,7 @@ do t2 <- tExpr c side e2 conditionalType' ni t2 t3 Nothing -> conditionalType' ni t1 t3-tExpr' c side (CMember e m deref ni) =+tExpr' c _ (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@@ -541,11 +552,11 @@ return dt tExpr' c side (CSizeofExpr e ni) = do when (side == LValue) $ typeError ni "sizeof as lvalue"- tExpr c RValue e+ _ <- 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+ _ <- 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@@ -563,7 +574,33 @@ typeError ni "alignoftype as lvalue" tExpr' _ LValue (CSizeofType _ ni) = typeError ni "sizeoftype as lvalue"-tExpr' _ side (CVar i ni) =+tExpr' ctx side (CGenericSelection expr list ni) = do+ ty_sel <- tExpr ctx side expr+ ty_list <- mapM analyseAssoc list+ def_expr_ty <-+ case dropWhile (isJust . fst) ty_list of+ [(Nothing,tExpr'')] -> return (Just tExpr'')+ [] -> return Nothing+ _ -> astError ni "more than one default clause in generic selection"+ case dropWhile (maybe True (not . typesMatch ty_sel) . fst) ty_list of+ ((_,expr_ty) : _ ) -> return expr_ty+ [] -> case def_expr_ty of+ (Just expr_ty) -> return expr_ty+ Nothing -> astError ni ("no clause matches for generic selection (not fully supported) - selector type is " ++ show (pretty ty_sel) +++ ", available types are " ++ show (map (pretty.fromJust.fst) (filter (isJust.fst) ty_list)))+ where+ analyseAssoc (mdecl,expr') = do+ tDecl <- mapM analyseTypeDecl mdecl+ tExpr'' <- tExpr ctx side expr'+ return (tDecl, tExpr'')+ typesMatch (DirectType tn1 _ _) (DirectType tn2 _ _) = directTypesMatch tn1 tn2+ typesMatch _ _ = False -- not fully supported+ directTypesMatch TyVoid TyVoid = True+ directTypesMatch (TyIntegral t1) (TyIntegral t2) = t1 == t2+ directTypesMatch (TyFloating t1) (TyFloating t2) = t1 == t2+ directTypesMatch (TyComplex t1) (TyComplex t2) = t1 == t2+ directTypesMatch _ _ = False -- TODO: not fully supported+tExpr' _ _ (CVar i ni) = lookupObject i >>= maybe (typeErrorOnLeft ni $ notFound i) (return . declType) tExpr' _ _ (CConst c) = constType c@@ -607,12 +644,12 @@ _ -> 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 ->+ if isTransparentUnion attrs+ then case canonicalType pty of DirectType (TyComp ctr) _ _ -> do td <- lookupSUE (nodeInfo arg) (sueRef ctr)- ms <- tagMembers (nodeInfo arg) td+ _ms <- tagMembers (nodeInfo arg) td {- when (null $ rights $ matches ms) $ astError (nodeInfo arg) $@@ -620,15 +657,16 @@ "of transparent union" -} return ()- where matches =- map (\d -> assignCompatible- CAssignOp- (snd d)- aty- )+ -- 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+ else+ assignCompatible' (nodeInfo arg) CAssignOp pty aty isTransparentUnion = any (\(Attr n _ _) -> identToString n == "__transparent_union__") tExpr' c _ (CAssign op le re ni) =@@ -650,8 +688,8 @@ return t tInitList :: MonadTrav m => NodeInfo -> Type -> CInitList -> m ()-tInitList ni t@(ArrayType (DirectType (TyIntegral TyChar) _ _) _ _ _)- [([], CInitExpr e@(CConst (CStrConst _ _)) _)] =+tInitList _ (ArrayType (DirectType (TyIntegral TyChar) _ _) _ _ _)+ [([], CInitExpr e@(CConst (CStrConst _ _)) _)] = tExpr [] RValue e >> return () tInitList ni t@(ArrayType _ _ _ _) initList = do let default_ds =@@ -662,9 +700,9 @@ ms <- tagMembers ni td let default_ds = map (\m -> CMemberDesig (fst m) ni) ms checkInits t default_ds initList-tInitList ni (PtrType (DirectType TyVoid _ _) _ _ ) _ =+tInitList _ (PtrType (DirectType TyVoid _ _) _ _ ) _ = return () -- XXX: more checking-tInitList _ t [([], i)] = tInit t i >> return ()+tInitList _ t [([], i)] = voidM$ tInit t i tInitList ni t _ = typeError ni $ "initializer list for type: " ++ pType t checkInits :: MonadTrav m => Type -> [CDesignator] -> CInitList -> m ()@@ -676,7 +714,7 @@ (dd' : rest, []) -> return (rest, [dd']) (_, d : _) -> return (advanceDesigList dds d, ds) t' <- tDesignator t ds'- tInit t' i+ _ <- tInit t' i checkInits t dds' is advanceDesigList :: [CDesignator] -> CDesignator -> [CDesignator]@@ -695,14 +733,16 @@ do tExpr [] RValue e1 >>= checkIntegral' ni tExpr [] RValue e2 >>= checkIntegral' ni tDesignator bt ds-tDesignator (ArrayType _ _ _ _) (d : ds) =+tDesignator (ArrayType _ _ _ _) (d : _) = 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 : _) =+tDesignator (DirectType (TyComp _) _ _) (d : _) = typeError (nodeInfo d) "array designator in compound initializer" tDesignator t [] = return t+tDesignator _t _ =+ error "unepxected type with designator" tInit :: MonadTrav m => Type -> CInit -> m Initializer tInit t i@(CInitExpr e ni) =@@ -726,6 +766,8 @@ builtinType (CBuiltinVaArg _ d _) = analyseTypeDecl d builtinType (CBuiltinOffsetOf _ _ _) = return size_tType builtinType (CBuiltinTypesCompatible _ _ _) = return boolType+builtinType (CBuiltinConvertVector _expr ty _) = analyseTypeDecl ty+builtinType (CBuiltinBitCast ty _expr _) = analyseTypeDecl ty -- return @Just declspecs@ without @CTypedef@ if the declaration specifier contain @typedef@ hasTypeDef :: [CDeclSpec] -> Maybe [CDeclSpec]@@ -734,5 +776,5 @@ (True,specs') -> Just specs' (False,_) -> Nothing where- hasTypeDefSpec (CStorageSpec (CTypedef n)) (_,specs) = (True, specs)+ hasTypeDefSpec (CStorageSpec (CTypedef _)) (_,specs) = (True, specs) hasTypeDefSpec spec (b,specs) = (b,spec:specs)
src/Language/C/Analysis/Builtins.hs view
@@ -1,10 +1,10 @@ module 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+import Language.C.Data.Ident+import Language.C.Data.Node builtins :: DefTable builtins = foldr doIdent (foldr doTypeDef emptyDefTable typedefs) idents@@ -13,10 +13,10 @@ dName s = VarName (builtinIdent s) Nothing param ty = ParamDecl (VarDecl NoName- (DeclAttrs False (Auto False) [])+ (DeclAttrs noFunctionAttrs (Auto False) []) ty) undefNode- fnAttrs = DeclAttrs False (FunLinkage ExternalLinkage) []- varAttrs = DeclAttrs False (Static InternalLinkage False) []+ fnAttrs = DeclAttrs noFunctionAttrs (FunLinkage ExternalLinkage) []+ varAttrs = DeclAttrs noFunctionAttrs (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@@ -36,6 +36,15 @@ idents = [ func "__builtin_expect" (integral TyLong) [integral TyLong, integral TyLong]+ , func "__builtin_bswap16"+ uint16_tType+ [uint16_tType]+ , func "__builtin_bswap32"+ uint32_tType+ [uint32_tType]+ , func "__builtin_bswap64"+ uint64_tType+ [uint64_tType] , func "__builtin_fabs" (floating TyDouble) [floating TyDouble]
src/Language/C/Analysis/ConstEval.hs view
@@ -1,14 +1,16 @@ {-# LANGUAGE RelaxedPolyRec #-} module Language.C.Analysis.ConstEval where +import Prelude hiding (Foldable(..)) import Control.Monad import Data.Bits+import Data.Foldable 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.Debug () import Language.C.Analysis.DeclAnalysis import Language.C.Analysis.DefTable import Language.C.Data@@ -42,11 +44,11 @@ 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 (TyComp ctr) _ _) = fst <$> compSizeAndAlign 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 _ (ArrayType _ (UnknownArraySize _) _ _) = return $ ptrSize md sizeofType md n (ArrayType bt (ArraySize _ sz) _ _) = do sz' <- constEval md Map.empty sz case sz' of@@ -58,27 +60,31 @@ 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 n (TypeDefType (TypeDefRef _ 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 (TyComp ctr) _ _) = snd <$> compSizeAndAlign md ctr 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 md _ (ArrayType _ (UnknownArraySize _) _ _) = return $ ptrAlign md+alignofType md n (ArrayType bt (ArraySize _ _) _ _) = alignofType md n bt+alignofType md n (TypeDefType (TypeDefRef _ 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 =+compSizeAndAlign+ :: MonadTrav m =>+ MachineDesc ->+ CompTypeRef ->+ m (Integer, Integer)+ -- ^ (size, alignment)+compSizeAndAlign md ctr = do dt <- getDefTable case lookupTag (sueRef ctr) dt of Just (Left _) -> astError (nodeInfo ctr)@@ -86,13 +92,33 @@ 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+ aligns <- mapM (alignofType md ni) ts+ let alignment = maximum (1 : aligns)+ size = case tag of+ UnionTag -> roundToAlignment alignment (maximum (0 : sizes))+ StructTag ->+ let sizeAndNextAlignment =+ zip sizes (drop 1 aligns ++ [alignment])+ offsets = foldl'+ (\offset (memberSize, nextAlign)+ -> roundToAlignment nextAlign (offset + memberSize))+ 0+ sizeAndNextAlignment+ in offsets+ return (size, alignment)+ Just (Right (EnumDef _)) -> return $ (iSize md TyInt, iAlign md TyInt) Nothing -> astError (nodeInfo ctr) "unknown composite" +-- | Find the next multiple of an alignment+roundToAlignment+ :: Integer+ -- ^ The alignment+ -> Integer+ -- ^ The value to align+ -> Integer+ -- ^ The next multiple of alignment+roundToAlignment alignment value =+ alignment * ((value + (alignment - 1)) `quot` alignment) {- Expression evaluation -} @@ -192,7 +218,7 @@ do t <- analyseTypeDecl d sz <- alignofType md d t intExpr ni sz-constEval md env e@(CVar i _) | Map.member i env =+constEval _ 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
src/Language/C/Analysis/Debug.hs view
@@ -25,8 +25,8 @@ import Language.C.Data import Language.C.Pretty-import Language.C.Syntax +import Prelude hiding ((<>)) import Text.PrettyPrint.HughesPJ import Data.Map (Map) ; import qualified Data.Map as Map @@ -34,12 +34,12 @@ 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)+ 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)+ pretty dt = text "DefTable" $$ nest 4 (vcat defMaps) where defMaps = [ prettyNSMap "idents" identDecls , prettyNSMap "tags" tagDecls@@ -125,9 +125,9 @@ 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])+ pretty (DeclAttrs fun_attrs storage attrs) =+ hsep [ pretty fun_attrs, pretty storage, pretty attrs]+ instance Pretty Type where pretty ty = pretty (exportTypeDecl ty) instance Pretty TypeQuals where@@ -136,10 +136,11 @@ | otherwise = empty instance Pretty CompType where- pretty (CompType sue_ref tag members attrs node) =+ 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 <+>@@ -151,11 +152,16 @@ 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+ 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 FunctionAttrs where+ pretty fattrs = hsep [pIf isInline "inline", pIf isNoreturn "_Noreturn"]+ where+ pIf isMatch txt = if isMatch fattrs then text txt else empty instance Pretty Storage where pretty NoStorage = empty
src/Language/C/Analysis/DeclAnalysis.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards, FlexibleContexts #-}+{-# OPTIONS_GHC -Wwarn=incomplete-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis.DeclAnalysis@@ -18,7 +19,7 @@ mergeOldStyle, -- * Dissecting type specs canonicalTypeSpec, NumBaseType(..),SignSpec(..),SizeMod(..),NumTypeSpec(..),TypeSpecAnalysis(..),- canonicalStorageSpec, StorageSpec(..),hasThreadLocalSpec, isTypeDef,+ canonicalStorageSpec, StorageSpec(..), hasThreadLocalSpec, hasClKernelSpec, isTypeDef, -- * Helpers VarDeclInfo(..), tAttr,mkVarName,getOnlyDeclr,nameOfDecl,analyseVarDecl,analyseVarDecl'@@ -30,17 +31,14 @@ 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.DefTable (TagFwdDecl(..), insertType) 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 Control.Monad (liftM,when,ap,unless,zipWithM)+import Data.List (intercalate, mapAccumL) import qualified Data.Map as Map import Text.PrettyPrint.HughesPJ @@ -50,16 +48,19 @@ -- | analyse and translate a parameter declaration -- Should be called in either prototype or block scope tParamDecl :: (MonadTrav m) => CDecl -> m ParamDecl+tParamDecl (CStaticAssert _ _ node) =+ astError node "expected parameter, not static assertion" 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")+ (VarDeclInfo name fun_spec storage_spec attrs ty declr_node) <- analyseVarDecl' True declspecs declr [] Nothing+ when (isInline fun_spec || isNoreturn fun_spec) $+ throwTravError (badSpecifierError node "parameter declaration with function 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+ return paramDecl where getParamDeclr = case declrs of@@ -67,7 +68,7 @@ [(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+ let vd = VarDecl name (DeclAttrs noFunctionAttrs storage attrs) ty in case name of NoName -> AbstractParamDecl vd declr_node _ -> ParamDecl vd declr_node@@ -76,76 +77,90 @@ computeParamStorage :: NodeInfo -> StorageSpec -> Either BadSpecifierError Storage computeParamStorage _ NoStorageSpec = Right (Auto False) computeParamStorage _ RegSpec = Right (Auto True)+computeParamStorage _ ClGlobalSpec = Right (Static NoLinkage False)+computeParamStorage _ ClLocalSpec = Right (Static NoLinkage 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+-- TODO storage specs, align specs and attributes are ignored+tMemberDecls (CStaticAssert _ _ node) =+ astError node "expected struct or union member, found static assertion" tMemberDecls (CDecl declspecs [] node) =- do let (storage_specs, _attrs, typequals, typespecs, is_inline) =+ do let (_storage_specs, _attrs, typequals, typespecs, funspecs, _alignspecs) = partitionDeclSpecs declspecs- when is_inline $ astError node "member declaration with inline specifier"+ unless (null funspecs) $ astError node "member declaration with function 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)+ (VarDecl NoName (DeclAttrs noFunctionAttrs 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)+tMemberDecls (CDecl declspecs declrs node) = zipWithM tMemberDecl (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+ let (VarDeclInfo name fun_spec storage_spec attrs ty _node_info) = var_decl --- checkValidMemberSpec is_inline storage_spec- return $ MemberDecl (VarDecl name (DeclAttrs False NoStorage attrs) ty) bit_field_size_opt node+ checkValidMemberSpec fun_spec storage_spec+ return $ MemberDecl (VarDecl name (DeclAttrs noFunctionAttrs 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+ do let (storage_specs, _attrs, typequals, typespecs, _funspecs, _alignspecs) = partitionDeclSpecs declspecs+ -- TODO: funspecs/alignspecs not yet processed+ _storage_spec <- canonicalStorageSpec storage_specs+ -- TODO: storage_spec not used 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"+ checkValidMemberSpec fun_spec storage_spec =+ do when (fun_spec /= noFunctionAttrs) $ 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+ | ClKernelSpec | ClGlobalSpec | ClLocalSpec deriving (Eq,Ord,Show,Read) hasThreadLocalSpec :: StorageSpec -> Bool hasThreadLocalSpec ThreadSpec = True+hasThreadLocalSpec ClLocalSpec = True hasThreadLocalSpec (StaticSpec b) = b hasThreadLocalSpec (ExternSpec b) = b hasThreadLocalSpec _ = False -data VarDeclInfo = VarDeclInfo VarName Bool {- is-inline? -} StorageSpec Attributes Type NodeInfo+hasClKernelSpec :: StorageSpec -> Bool+hasClKernelSpec ClKernelSpec = True +data VarDeclInfo = VarDeclInfo VarName FunctionAttrs StorageSpec Attributes Type NodeInfo+ analyseVarDecl' :: (MonadTrav m) => Bool -> [CDeclSpec] ->- CDeclr -> [CDecl] -> (Maybe CInit) -> m VarDeclInfo+ 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) =+ do let (storage_specs, attrs, type_quals, type_specs, funspecs, _alignspecs) = partitionDeclSpecs declspecs canonTySpecs <- canonicalTypeSpec type_specs- analyseVarDecl handle_sue_def storage_specs attrs type_quals canonTySpecs inline+ -- TODO: alignspecs not yet processed+ analyseVarDecl handle_sue_def storage_specs attrs type_quals canonTySpecs funspecs 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+ TypeSpecAnalysis -> [CFunSpec] ->+ CDeclr -> [CDecl] -> Maybe CInit -> m VarDeclInfo+analyseVarDecl handle_sue_def storage_specs decl_attrs typequals canonTySpecs fun_specs (CDeclr name_opt derived_declrs asmname_opt declr_attrs node)- oldstyle_params init_opt+ oldstyle_params _init_opt = do -- analyse the storage specifiers storage_spec <- canonicalStorageSpec storage_specs -- translate the type into semantic representation@@ -154,11 +169,11 @@ 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+ return $ VarDeclInfo name function_spec storage_spec attrs' typ node where- isInlineSpec (CInlineQual _) = True- isInlineSpec _ = False-+ updateFunSpec (CInlineQual _) f = f { isInline = True }+ updateFunSpec (CNoreturnQual _) f = f { isNoreturn = True }+ function_spec = foldr updateFunSpec noFunctionAttrs fun_specs -- return @True@ if the declarations is a type def isTypeDef :: [CDeclSpec] -> Bool@@ -180,13 +195,16 @@ -- -- We move attributes to the type, as they have no meaning for the abstract declarator analyseTypeDecl :: (MonadTrav m) => CDecl -> m Type+analyseTypeDecl (CStaticAssert _ _ node) =+ astError node "Expected type declaration, found static assert" 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"+ | (not (null storagespec) || not (null funspecs) || not (null alignspecs)) =+ astError node "storage, function or alignment specifier for type declaration" | otherwise = do canonTySpecs <- canonicalTypeSpec typespecs t <- tType True node (map CAttrQual (attrs++attrs_decl) ++ typequals)@@ -195,7 +213,7 @@ Just n -> withDefTable (\dt -> (t, insertType dt n t)) Nothing -> return t where- (storagespec, attrs_decl, typequals, typespecs, inline) = partitionDeclSpecs declspecs+ (storagespec, attrs_decl, typequals, typespecs, funspecs, alignspecs) = partitionDeclSpecs declspecs analyseTyDeclr _ = astError node "Non-abstract declarator in type declaration" @@ -253,10 +271,10 @@ | 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 (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"+ TSNonBasic t -> astError node ("Unexpected typespec: " ++ show t) -- | Merge type attributes --@@ -267,22 +285,19 @@ 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+ DirectType ty_name quals' attrs' -> merge quals' attrs' $ DirectType 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)+ FunctionType fty attrs'+ | quals /= noTypeQuals -> astError node_info "type qualifiers for function type"+ | otherwise -> return$ FunctionType fty (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)+typeDefRef t_node name = lookupTypeDef name >>= \ty -> return (TypeDefRef name ty t_node) -- extract a struct\/union -- we emit @declStructUnion@ and @defStructUnion@ actions@@ -298,9 +313,9 @@ let decl = CompTypeRef sue_ref tag' node_info handleTagDecl (CompDecl decl) -- when handle_def is true, enter the definition- when (handle_def) $ do+ when handle_def $ maybeM member_decls_opt $ \decls ->- tCompType sue_ref tag' decls (attrs') node_info+ tCompType sue_ref tag' decls attrs' node_info >>= (handleTagDef.CompDef) return decl @@ -328,7 +343,7 @@ = do sue_ref <- createSUERef node_info ident_opt attrs' <- mapM tAttr attrs let decl = EnumTypeRef sue_ref node_info- when handle_def $ do+ when handle_def $ maybeM enumerators_opt $ \enumerators -> tEnumType sue_ref enumerators attrs' node_info >>= (handleTagDef . EnumDef)@@ -346,7 +361,7 @@ 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 :: 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)@@ -358,12 +373,16 @@ tNumType (NumTypeSpec basetype sgn sz iscomplex) = case (basetype,sgn,sz) of (BaseChar,_,NoSizeMod) | Signed <- sgn -> intType TySChar- | Unsigned <- sgn -> intType TyUChar- | otherwise -> intType TyChar+ | Unsigned <- sgn -> intType TyUChar+ | otherwise -> intType TyChar (intbase, _, NoSizeMod) | optBase BaseInt intbase -> intType$ case sgn of Unsigned -> TyUInt _ -> TyInt+ (intbase, _, NoSizeMod) | optBase BaseInt128 intbase ->+ intType$ case sgn of+ Unsigned -> TyUInt128+ _ -> TyInt128 (intbase, signed, sizemod) | optBase BaseInt intbase, optSign Signed signed -> intType$ case sizemod of ShortMod -> TyShort LongMod -> TyLong@@ -377,6 +396,8 @@ (BaseFloat, NoSignSpec, NoSizeMod) -> floatType TyFloat (BaseDouble, NoSignSpec, NoSizeMod) -> floatType TyDouble (BaseDouble, NoSignSpec, LongMod) -> floatType TyLDouble+ (BaseBFloat16, NoSignSpec, NoSizeMod) -> floatType TyBFloat16+ (BaseFloatN n x, NoSignSpec, NoSizeMod) -> floatType (TyFloatN n x) -- TODO: error analysis (_,_,_) -> error "Bad AST analysis" where@@ -395,21 +416,25 @@ 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 (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 (CAtomicQual _) (tq,attrs) = return (tq { atomic = True },attrs) go (CAttrQual attr) (tq,attrs) = liftM (\attr' -> (tq,attr':attrs)) (tAttr attr)- go (CInlineQual node) (_tq,_attrs) = astError node "unexpected inline qualifier"-+ go (CNullableQual _) (tq,attrs) = return (tq { nullable = True }, attrs)+ go (CNonnullQual _) (tq,attrs) = return (tq { nonnull = True }, attrs)+ go (CClRdOnlyQual _) (tq,attrs) = return (tq { clrdonly = True },attrs)+ go (CClWrOnlyQual _) (tq,attrs) = return (tq { clwronly = True },attrs) -- * analysis {- To canoicalize type specifiers, we define a canonical form:-void | bool | (char|int|float|double) (signed|unsigned)? (long long?)? complex? | othertype+void | bool | (char|int|int128|float|double|floatNx)? (signed|unsigned)? (long long?)? complex? | othertype -}-data NumBaseType = NoBaseType | BaseChar | BaseInt | BaseFloat | BaseDouble deriving (Eq,Ord)+data NumBaseType = NoBaseType | BaseChar | BaseInt | BaseInt128 | BaseFloat | BaseBFloat16 |+ BaseFloatN Int Bool | 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 }@@ -427,18 +452,21 @@ 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 (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 (CInt128Type _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa+ = return$ TSNum$ nts { base = BaseInt128 } go (CFloatType _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa = return$ TSNum$ nts { base = BaseFloat }+ go (CBFloat16Type _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa+ = return$ TSNum$ nts { base = BaseBFloat16 }+ go (CFloatNType n x _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa+ = return$ TSNum$ nts { base = BaseFloatN n x } 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@@ -453,17 +481,22 @@ 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 (CTypeOfType d _ni) TSNone = liftM TSType $ analyseTypeDecl d go (CTypeOfExpr e _) TSNone = liftM TSType $ tExpr [] RValue e+ -- todo: atomic qualifier discarded+ go (CAtomicType d _ni) TSNone = liftM TSType $ analyseTypeDecl d 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 (CAuto _) NoStorageSpec = return AutoSpec+ updStorage (CRegister _) NoStorageSpec = return RegSpec+ updStorage (CThread _) NoStorageSpec = return ThreadSpec+ updStorage (CClKernel _) NoStorageSpec = return ClKernelSpec+ updStorage (CClGlobal _) NoStorageSpec = return ClGlobalSpec+ updStorage (CClLocal _) NoStorageSpec = return ClLocalSpec updStorage (CThread _) (StaticSpec _) = return$ StaticSpec True updStorage (CThread _) (ExternSpec _) = return$ ExternSpec True updStorage (CStatic _) NoStorageSpec = return$ StaticSpec False@@ -499,9 +532,9 @@ 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)+ unless (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)@@ -510,35 +543,38 @@ 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+ let nInfo = nodeInfo param_name in+ CDecl [CTypeSpec (CIntType nInfo)] [(Just (CDeclr (Just param_name) [] Nothing [] nInfo),Nothing,Nothing)] nInfo+ showParamMap = intercalate ", " . 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,+-- 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 |] ]+-- > [ [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@(CStaticAssert _ _ _) = return [decl] splitCDecl decl@(CDecl declspecs declrs node) = case declrs of [] -> internalErr "splitCDecl applied to empty declaration"- [declr] -> return [decl]+ -- single declarator, not need to split+ [_declr] -> return [decl]+ -- more than one declarator (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)+ (CEnumType (CEnum name _def _attrs enum_node) node_info) ->+ CTypeSpec (CEnumType (CEnum name Nothing [] enum_node) node_info)+ (CSUType (CStruct tag name _def _attrs su_node) node_info) ->+ CTypeSpec (CSUType (CStruct tag name Nothing [] su_node) node_info) _ -> declspec elideSUEDef declspec = declspec @@ -553,17 +589,18 @@ -- 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+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"+ (CDeclr (Just name) _ _ _ _node) -> 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"+getOnlyDeclr (CDecl _ _ _node) = internalErr "getOnlyDeclr: declaration doesn't have a unique declarator"+getOnlyDeclr (CStaticAssert _ _ _) = internalErr "getOnlyDeclr: static assertion doesn't have a unique declarator"
src/Language/C/Analysis/DefTable.hs view
@@ -37,12 +37,10 @@ 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+import Data.Data (Data) {- Name spaces, scopes and contexts [Scopes] @@ -108,7 +106,7 @@ -- | get the globally defined entries of a definition table globalDefs :: DefTable -> GlobalDecls-globalDefs deftbl = Map.foldWithKey insertDecl (GlobalDecls e gtags e) (globalNames $ identDecls deftbl)+globalDefs deftbl = Map.foldrWithKey insertDecl (GlobalDecls e gtags e) (globalNames $ identDecls deftbl) where e = Map.empty (_fwd_decls,gtags) = Map.mapEither id $ globalNames (tagDecls deftbl)@@ -169,7 +167,7 @@ | KeepDef t -- ^ new def was discarded | Shadowed t -- ^ new def shadows one in outer scope | KindMismatch t -- ^ kind mismatch- deriving (Data,Typeable)+ deriving (Data) declStatusDescr :: DeclarationStatus t -> String declStatusDescr NewDecl = "new" declStatusDescr (Redeclared _) = "redeclared"@@ -261,7 +259,7 @@ = (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)+ 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)@@ -280,8 +278,8 @@ (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+ Just fwd_decl@(Left _) | 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
src/Language/C/Analysis/Export.hs view
@@ -17,15 +17,66 @@ exportTypeDef, exportCompType, exportCompTypeDecl, exportCompTypeRef, exportEnumType, exportEnumTypeDecl, exportEnumTypeRef,+export, ) 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+import Data.List+import qualified Data.Map as Map+import Data.Maybe+import Language.C.Analysis.SemRep+import Language.C.Data.Ident+import Language.C.Data.Name (nameId)+import Language.C.Data.Node+import Language.C.Syntax.AST ++-- | Export global declarations+-- TODO: This does not export tags and type defs yet+export :: GlobalDecls -> CTranslUnit+export (GlobalDecls objs _tags _typedefs) = CTranslUnit (declarations ++ []) undefNode+ where declarations = fmap exportIdentDecl (filterBuiltins $ Map.toList objs)+ filterBuiltins = Prelude.filter noBuiltIns+ noBuiltIns (idn, _) = let n = identToString idn+ in not ("__builtin" `isPrefixOf` n) &&+ (n /= "__FUNCTION__") &&+ (n /= "__PRETTY_FUNCTION__") &&+ (n /= "__func__" )+++exportIdentDecl :: (Ident, IdentDecl) -> CExternalDeclaration NodeInfo+exportIdentDecl (_, Declaration decl) = CDeclExt $ exportDeclaration decl+exportIdentDecl (_, FunctionDef fundef) = CFDefExt $ exportFunDef fundef+exportIdentDecl (_, ObjectDef objdef) = CDeclExt $ exportObject objdef+exportIdentDecl (_, EnumeratorDef _) = error "not implemented: enumerator definition"++exportObject :: ObjDef -> CDeclaration NodeInfo+exportObject d@(ObjDef _ mInit nInf) = CDecl specs' [(Just decl, mInit, Nothing)] nInf+ where+ (DeclAttrs _ _ attrs) = declAttrs d+ specs = exportDeclarationSpecifiers (declAttrs d)+ (specs', decl) = exportDeclr specs (declType d) attrs (declName d)+++exportDeclaration :: Decl -> CDeclaration NodeInfo+exportDeclaration d = CDecl specs' [(Just decl, Nothing, Nothing)] undefNode+ where+ (DeclAttrs _ _ attrs) = declAttrs d+ specs = exportDeclarationSpecifiers (declAttrs d)+ (specs', decl) = exportDeclr specs (declType d) attrs (declName d)+++exportFunDef :: FunDef -> CFunctionDef NodeInfo+exportFunDef d@(FunDef _ stmt _) = CFunDef cDeclSpecs cDecl oldStyleParams stmt undefNode+ where+ (cDeclSpecs, cDecl) = exportDeclr specs (declType d) ([] :: Attributes) (declName d)+ oldStyleParams= [] :: [CDeclaration NodeInfo] -- TODO:?+ specs = exportDeclarationSpecifiers (declAttrs d):: [CDeclarationSpecifier NodeInfo]++exportDeclarationSpecifiers :: DeclAttrs -> [CDeclarationSpecifier NodeInfo]+exportDeclarationSpecifiers (DeclAttrs funcAttrs storage _attrs) = specifiers+ where specifiers = (CFunSpec <$> exportFunAttrs funcAttrs) ++ (CStorageSpec <$> exportStorage storage)++ -- |Export Declarator -- -- Synopsis: @exportDeclr other_specs type attributes variable-name@@@ -69,8 +120,8 @@ 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)+ 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)@@ -87,20 +138,20 @@ exportTypeQualsAttrs tyqs attrs = (exportTypeQuals tyqs ++ map CAttrQual (exportAttrs attrs)) exportArraySize :: ArraySize -> CArrSize-exportArraySize (ArraySize static e) = CArrSize static e+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+ 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]+ TyBuiltin TyAny -> [CTypeDef (internalIdent "__ty_any") ni] exportIntType :: IntType -> [CTypeSpec] exportIntType ty =@@ -113,6 +164,8 @@ TyUShort -> [CUnsigType ni, CShortType ni] TyInt -> [CIntType ni] TyUInt -> [CUnsigType ni, CIntType ni]+ TyInt128 -> [CInt128Type ni]+ TyUInt128 -> [CUnsigType ni, CInt128Type ni] TyLong -> [CLongType ni] TyULong -> [CUnsigType ni,CLongType ni] TyLLong -> [CLongType ni, CLongType ni]@@ -121,9 +174,11 @@ exportFloatType :: FloatType -> [CTypeSpec] exportFloatType ty = case ty of- TyFloat -> [CFloatType ni]- TyDouble -> [CDoubleType ni]- TyLDouble -> [CLongType ni, CDoubleType ni]+ TyFloat -> [CFloatType ni]+ TyDouble -> [CDoubleType ni]+ TyLDouble -> [CLongType ni, CDoubleType ni]+ TyBFloat16 -> [CBFloat16Type ni]+ TyFloatN n x -> [CFloatNType n x ni] exportComplexType :: FloatType -> [CTypeSpec] exportComplexType ty = (CComplexType ni) : exportFloatType ty@@ -185,11 +240,18 @@ 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)+exportDeclAttrs (DeclAttrs fun_attrs storage attrs) =+ map CFunSpec (exportFunAttrs fun_attrs)+ ++ map CStorageSpec (exportStorage storage) ++ map (CTypeQual . CAttrQual) (exportAttrs attrs) +-- | export function attributes to C function specifiers+exportFunAttrs :: FunctionAttrs -> [CFunSpec]+exportFunAttrs fattrs = catMaybes [inlQual, noretQual]+ where+ inlQual = if isInline fattrs then Just (CInlineQual ni) else Nothing+ noretQual = if isNoreturn fattrs then Just (CNoreturnQual ni) else Nothing+ -- | express storage in terms of storage specifiers. -- -- This isn't always possible and depends on the context the identifier is declared.@@ -208,16 +270,16 @@ threadLocal :: Bool -> [CStorageSpec] -> [CStorageSpec] threadLocal False = id-threadLocal True = ((CThread ni) :)+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"+fromDirectType (DirectType ty _ _) = ty+fromDirectType (TypeDefType (TypeDefRef _ ty _) _ _) = fromDirectType ty+fromDirectType _ = error "fromDirectType" ni :: NodeInfo ni = undefNode
+ src/Language/C/Analysis/MachineDescs.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+module Language.C.Analysis.MachineDescs+ where++import Language.C.Analysis.ConstEval+import Language.C.Analysis.SemRep++x86_64 :: MachineDesc+x86_64 =+ let iSize = \case+ TyBool -> 1+ TyChar -> 1+ TySChar -> 1+ TyUChar -> 1+ TyShort -> 2+ TyUShort -> 2+ TyInt -> 4+ TyUInt -> 4+ TyLong -> 8+ TyULong -> 8+ TyLLong -> 8+ TyULLong -> 8+ TyInt128 -> 16+ TyUInt128 -> 16+ fSize = \case+ TyFloat -> 4+ TyDouble -> 8+ TyLDouble -> 16+ TyBFloat16 -> error "TyBFloat16"+ TyFloatN{} -> error "TyFloatN"+ builtinSize = \case+ TyVaList -> 24+ TyAny -> error "TyAny"+ ptrSize = 8+ voidSize = 1+ iAlign = \case+ TyBool -> 1+ TyChar -> 1+ TySChar -> 1+ TyUChar -> 1+ TyShort -> 2+ TyUShort -> 2+ TyInt -> 4+ TyUInt -> 4+ TyLong -> 8+ TyULong -> 8+ TyLLong -> 8+ TyULLong -> 8+ TyInt128 -> 16+ TyUInt128 -> 16+ fAlign = \case+ TyFloat -> 4+ TyDouble -> 8+ TyLDouble -> 16+ TyBFloat16{} -> error "TyBFloat16"+ TyFloatN{} -> error "TyFloatN"+ builtinAlign = \case+ TyVaList -> 8+ TyAny -> error "TyAny"+ ptrAlign = 8+ voidAlign = 1+ in MachineDesc { .. }++armv7l :: MachineDesc+armv7l =+ let iSize = \case+ TyBool -> 1+ TyChar -> 1+ TySChar -> 1+ TyUChar -> 1+ TyShort -> 2+ TyUShort -> 2+ TyInt -> 4+ TyUInt -> 4+ TyLong -> 4+ TyULong -> 4+ TyLLong -> 8+ TyULLong -> 8+ TyInt128 -> error "TyInt128 on armv7l"+ TyUInt128 -> error "TyUInt128 on armv7l"+ fSize = \case+ TyFloat -> 4+ TyDouble -> 8+ TyLDouble -> 8+ TyBFloat16 -> 2+ TyFloatN{} -> error "TyFloatN"+ builtinSize = \case+ TyVaList -> 4+ TyAny -> error "TyAny"+ ptrSize = 4+ voidSize = 1+ iAlign = \case+ TyBool -> 1+ TyChar -> 1+ TySChar -> 1+ TyUChar -> 1+ TyShort -> 2+ TyUShort -> 2+ TyInt -> 4+ TyUInt -> 4+ TyLong -> 4+ TyULong -> 4+ TyLLong -> 8+ TyULLong -> 8+ TyInt128 -> error "TyInt128 on armv7l"+ TyUInt128 -> error "TyUInt128 on armv7l"+ fAlign = \case+ TyFloat -> 4+ TyDouble -> 8+ TyLDouble -> 8+ TyBFloat16 -> 2+ TyFloatN{} -> error "TyFloatN"+ builtinAlign = \case+ TyVaList -> 4+ TyAny -> error "TyAny"+ ptrAlign = 4+ voidAlign = 1+ in MachineDesc { .. }
src/Language/C/Analysis/NameSpaceMap.hs view
@@ -34,7 +34,6 @@ 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:@@ -121,14 +120,15 @@ -- if there is one. lookupName :: (Ord k) => NameSpaceMap k a -> k -> Maybe a lookupName ns@(NsMap _ localDefs) ident- = case (lookupLocal localDefs) of+ = 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+ 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
src/Language/C/Analysis/SemError.hs view
@@ -17,7 +17,6 @@ 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@@ -28,26 +27,26 @@ -- here are the errors available -- | InvalidASTError is caused by the violation of an invariant in the AST-newtype InvalidASTError = InvalidAST ErrorInfo deriving (Typeable)+newtype InvalidASTError = InvalidAST ErrorInfo 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)+newtype BadSpecifierError = BadSpecifierError ErrorInfo 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 RedefError = RedefError ErrorLevel RedefInfo data RedefInfo = RedefInfo String RedefKind NodeInfo NodeInfo data RedefKind = DuplicateDef | DiffKindRedecl | ShadowedDef | DisagreeLinkage | NoLinkageOld-data TypeMismatch = TypeMismatch String (NodeInfo,Type) (NodeInfo,Type) deriving Typeable+data TypeMismatch = TypeMismatch String (NodeInfo,Type) (NodeInfo,Type) -- Invalid AST -- ~~~~~~~~~~~
src/Language/C/Analysis/SemRep.hs view
@@ -30,6 +30,7 @@ VarDecl(..), -- * Declaration attributes DeclAttrs(..),isExtDecl,+FunctionAttrs(..), functionAttrs, noFunctionAttrs, Storage(..),declStorage,ThreadLocal,Register, Linkage(..),hasLinkage,declLinkage, -- * Types@@ -54,12 +55,10 @@ 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+import Data.Maybe+import Data.Data (Data) -- | accessor class : struct\/union\/enum names class HasSUERef a where@@ -70,9 +69,9 @@ compTag :: a -> CompTyKind -- | Composite type definitions (tags)-data TagDef = CompDef CompType --definition- | EnumDef EnumType -- enum definition- deriving (Typeable, Data {-! ,CNode !-})+data TagDef = CompDef CompType --composite definition+ | EnumDef EnumType --enum definition+ deriving (Data {-! ,CNode !-}, Show) instance HasSUERef TagDef where sueRef (CompDef ct) = sueRef ct@@ -111,10 +110,10 @@ -- | 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 !-})+ | ObjectDef ObjDef -- ^ object definition+ | FunctionDef FunDef -- ^ function definition+ | EnumeratorDef Enumerator -- ^ definition of an enumerator+ deriving (Data {-! ,CNode !-}, Show) instance Declaration IdentDecl where getVarDecl (Declaration decl) = getVarDecl decl@@ -137,7 +136,7 @@ ( 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))+splitIdentDecls include_all = Map.foldrWithKey (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)@@ -203,7 +202,7 @@ -- | Declarations, which aren't definitions data Decl = Decl VarDecl NodeInfo- deriving (Typeable, Data {-! ,CNode !-})+ deriving (Data {-! ,CNode !-}, Show) instance Declaration Decl where getVarDecl (Decl vd _) = vd@@ -215,20 +214,20 @@ -- 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 !-})+ deriving (Data {-! ,CNode !-}, Show) 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+isTentative (ObjDef decl init_opt _) | isExtDecl decl = isNothing 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 !-})+ deriving (Data {-! ,CNode !-}, Show) instance Declaration FunDef where getVarDecl (FunDef vd _ _) = vd @@ -236,7 +235,7 @@ -- | Parameter declaration data ParamDecl = ParamDecl VarDecl NodeInfo | AbstractParamDecl VarDecl NodeInfo- deriving (Typeable, Data {-! ,CNode !-} )+ deriving (Data {-! ,CNode !-}, Show) instance Declaration ParamDecl where getVarDecl (ParamDecl vd _) = vd@@ -247,17 +246,17 @@ -- ^ @MemberDecl vardecl bitfieldsize node@ | AnonBitField Type Expr NodeInfo -- ^ @AnonBitField typ size@- deriving (Typeable, Data {-! ,CNode !-} )+ deriving (Data {-! ,CNode !-}, Show) instance Declaration MemberDecl where getVarDecl (MemberDecl vd _ _) = vd- getVarDecl (AnonBitField ty _ _) = VarDecl NoName (DeclAttrs False NoStorage []) ty+ getVarDecl (AnonBitField ty _ _) = VarDecl NoName (DeclAttrs noFunctionAttrs 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 !-} )+ deriving (Data {-! ,CNode !-}, Show) -- | return the idenitifier of a @typedef@ identOfTypeDef :: TypeDef -> Ident@@ -265,7 +264,7 @@ -- | Generic variable declarations data VarDecl = VarDecl VarName DeclAttrs Type- deriving (Typeable, Data)+ deriving (Data, Show) instance Declaration VarDecl where getVarDecl = id@@ -277,14 +276,26 @@ -- | 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)+data DeclAttrs = DeclAttrs FunctionAttrs Storage Attributes+ -- ^ @DeclAttrs fspecs storage attrs@+ deriving (Data, Show) -- | get the 'Storage' of a declaration declStorage :: (Declaration d) => d -> Storage declStorage d = case declAttrs d of (DeclAttrs _ st _) -> st +-- | get the `function attributes' of a declaration+functionAttrs :: (Declaration d) => d -> FunctionAttrs+functionAttrs d = case declAttrs d of (DeclAttrs fa _ _) -> fa++-- Function attributes (inline, noreturn)+data FunctionAttrs = FunctionAttrs { isInline :: Bool, isNoreturn :: Bool }+ deriving (Eq, Ord, Data, Show)++noFunctionAttrs :: FunctionAttrs+noFunctionAttrs = FunctionAttrs { isInline = False, isNoreturn = False }++ -- In C we have -- Identifiers can either have internal, external or no linkage -- (same object everywhere, same object within the translation unit, unique).@@ -302,14 +313,14 @@ | 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)+ deriving (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)+ deriving (Data, Show, Eq, Ord) -- | return @True@ if the object has linkage hasLinkage :: Storage -> Bool@@ -341,14 +352,14 @@ -- ^ function type | TypeDefType TypeDefRef TypeQuals Attributes -- ^ a defined type- deriving (Typeable, Data)+ deriving (Data, Show) -- | 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)+ deriving (Data, Show) -- | 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/.@@ -357,7 +368,7 @@ -- ^ @UnknownArraySize is-starred@ | ArraySize Bool Expr -- ^ @FixedSizeArray is-static size-expr@- deriving (Typeable, Data)+ deriving (Data, Show) -- | normalized type representation data TypeName =@@ -368,17 +379,17 @@ | TyComp CompTypeRef | TyEnum EnumTypeRef | TyBuiltin BuiltinType- deriving (Typeable, Data)+ deriving (Data, Show) -- | Builtin type (va_list, anything) data BuiltinType = TyVaList | TyAny- deriving (Typeable, Data)+ deriving (Data, Show) -- | typdef references -- If the actual type is known, it is attached for convenience-data TypeDefRef = TypeDefRef Ident (Maybe Type) NodeInfo- deriving (Typeable, Data {-! ,CNode !-})+data TypeDefRef = TypeDefRef Ident Type NodeInfo+ deriving (Data {-! ,CNode !-}, Show) -- | integral types (C99 6.7.2.2) data IntType =@@ -390,11 +401,13 @@ | TyUShort | TyInt | TyUInt+ | TyInt128+ | TyUInt128 | TyLong | TyULong | TyLLong | TyULLong- deriving (Typeable, Data, Eq, Ord)+ deriving (Data, Eq, Ord) instance Show IntType where show TyBool = "_Bool"@@ -405,6 +418,8 @@ show TyUShort = "unsigned short" show TyInt = "int" show TyUInt = "unsigned int"+ show TyInt128 = "__int128"+ show TyUInt128 = "unsigned __int128" show TyLong = "long" show TyULong = "unsigned long" show TyLLong = "long long"@@ -415,27 +430,31 @@ TyFloat | TyDouble | TyLDouble- deriving (Typeable, Data, Eq, Ord)+ | TyBFloat16+ | TyFloatN Int Bool+ deriving (Data, Eq, Ord) instance Show FloatType where show TyFloat = "float" show TyDouble = "double" show TyLDouble = "long double"+ show TyBFloat16 = "__bf16"+ show (TyFloatN n x) = "_Float" ++ (show n) ++ (if x then "x" else "") -- | composite type declarations data CompTypeRef = CompTypeRef SUERef CompTyKind NodeInfo- deriving (Typeable, Data {-! ,CNode !-})+ deriving (Data {-! ,CNode !-}, Show) 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 !-})+ deriving (Data {-! ,CNode !-}, Show) 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 !-} )+ deriving (Data {-! ,CNode !-}, Show) instance HasSUERef CompType where sueRef (CompType ref _ _ _ _) = ref instance HasCompTyKind CompType where compTag (CompType _ tag _ _ _) = tag @@ -446,7 +465,7 @@ -- | a tag to determine wheter we refer to a @struct@ or @union@, see 'CompType'. data CompTyKind = StructTag | UnionTag- deriving (Eq,Ord,Typeable,Data)+ deriving (Eq,Ord,Data) instance Show CompTyKind where show StructTag = "struct"@@ -455,7 +474,7 @@ -- | Representation of C enumeration types data EnumType = EnumType SUERef [Enumerator] Attributes NodeInfo -- ^ @EnumType name enumeration-constants attrs node@- deriving (Typeable, Data {-! ,CNode !-} )+ deriving (Data {-! ,CNode !-}, Show) instance HasSUERef EnumType where sueRef (EnumType ref _ _ _) = ref @@ -465,25 +484,41 @@ -- | 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 !-})+ deriving (Data {-! ,CNode !-}, Show) instance Declaration Enumerator where getVarDecl (Enumerator ide _ enumty _) = VarDecl (VarName ide Nothing)- (DeclAttrs False NoStorage [])+ (DeclAttrs noFunctionAttrs NoStorage []) (DirectType (typeOfEnumDef enumty) noTypeQuals noAttributes) -- | Type qualifiers: constant, volatile and restrict-data TypeQuals = TypeQuals { constant :: Bool, volatile :: Bool, restrict :: Bool }- deriving (Typeable, Data)+data TypeQuals = TypeQuals { constant :: Bool, volatile :: Bool,+ restrict :: Bool, atomic :: Bool,+ nullable :: Bool, nonnull :: Bool,+ clrdonly :: Bool, clwronly :: Bool }+ deriving (Data, Show) +instance Eq TypeQuals where+ (==) (TypeQuals c1 v1 r1 a1 n1 nn1 rd1 wr1) (TypeQuals c2 v2 r2 a2 n2 nn2 rd2 wr2) =+ c1 == c2 && v1 == v2 && r1 == r2 && a1 == a2 && n1 == n2 && nn1 == nn2+ && rd1 == rd2 && wr1 == wr2++instance Ord TypeQuals where+ (<=) (TypeQuals c1 v1 r1 a1 n1 nn1 rd1 wr1) (TypeQuals c2 v2 r2 a2 n2 nn2 rd2 wr2) =+ c1 <= c2 && v1 <= v2 && r1 <= r2 && a1 <= a2 && n1 <= n2 && nn1 <= nn2+ && rd1 <= rd2 && wr1 <= wr2++ -- | no type qualifiers noTypeQuals :: TypeQuals-noTypeQuals = TypeQuals False False False+noTypeQuals = TypeQuals False False False False False 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)+mergeTypeQuals (TypeQuals c1 v1 r1 a1 n1 nn1 rd1 wr1) (TypeQuals c2 v2 r2 a2 n2 nn2 rd2 wr2) =+ TypeQuals (c1 && c2) (v1 && v2) (r1 && r2) (a1 && a2) (n1 && n2) (nn1 && nn2)+ (rd1 && rd2) (wr1 && wr2) -- * initializers @@ -505,7 +540,7 @@ -- | @VarName name assembler-name@ is a name of an declared object data VarName = VarName Ident (Maybe AsmName) | NoName- deriving (Typeable, Data)+ deriving (Data, Show) identOfVarName :: VarName -> Ident identOfVarName NoName = error "identOfVarName: NoName" identOfVarName (VarName ident _) = ident@@ -539,7 +574,7 @@ -- -- /TODO/: ultimatively, we want to parse attributes and represent them in a typed way data Attr = Attr Ident [Expr] NodeInfo- deriving (Typeable, Data {-! ,CNode !-})+ deriving (Data {-! ,CNode !-}, Show) type Attributes = [Attr] @@ -560,25 +595,20 @@ 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@@ -586,100 +616,73 @@ 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
src/Language/C/Analysis/TravMonad.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts,FlexibleInstances,- PatternGuards, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts,FlexibleInstances,+ PatternGuards, RankNTypes, ScopedTypeVariables, LambdaCase #-}+{-# OPTIONS_GHC -Wwarn=incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis.TravMonad@@ -40,8 +41,8 @@ hadHardErrors,handleTravError,throwOnLeft, astError, warn, -- * Trav - default MonadTrav implementation- Trav,- runTrav,runTrav_,+ Trav, TravT,+ runTravT, runTravTWithTravState, runTrav, runTrav_, TravState,initTravState,withExtDeclHandler,modifyUserState,userState, getUserState, TravOptions(..),modifyOptions,@@ -53,22 +54,25 @@ ) 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.TypeUtils (sameType) 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.IntMap (insert) import Data.Maybe import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap)-import Prelude hiding (lookup)+import Control.Monad.Identity (Identity, runIdentity)+import Control.Monad.State.Class (MonadState, get, put, modify, gets)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Prelude hiding (Applicative(..), lookup) class (Monad m) => MonadName m where -- | unique name generation@@ -119,7 +123,7 @@ handleTagDecl :: (MonadCError m, MonadSymtab m) => TagFwdDecl -> m () handleTagDecl decl = do redecl <- withDefTable $ declareTag (sueRef decl) decl- checkRedef (show $ sueRef decl) decl redecl+ checkRedef (sueRefToString $ sueRef decl) decl redecl -- | define the given composite type or enumeration -- If there is a declaration visible, overwrite it with the definition.@@ -128,20 +132,27 @@ handleTagDef :: (MonadTrav m) => TagDef -> m () handleTagDef def = do redecl <- withDefTable $ defineTag (sueRef def) def- checkRedef (show $ sueRef def) def redecl+ checkRedef (sueRefToString $ 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+ checkRedef (identToString ident) ident redecl return () handleTypeDef :: (MonadTrav m) => TypeDef -> m ()-handleTypeDef typeDef@(TypeDef ident _ _ _) = do+handleTypeDef typeDef@(TypeDef ident t1 _ _) = do redecl <- withDefTable $ defineTypeDef ident typeDef- checkRedef (show ident) typeDef redecl+ -- C11 6.7/3 If an identifier has no linkage, there shall be no more than+ -- one declaration of the identifier (in a declarator or type specifier)+ -- with the same scope and in the same name space, except that: a typedef+ -- name may be redefined to denote the same type as it currently does,+ -- provided that type is not a variably modified type;+ case redecl of+ Redeclared (Left (TypeDef _ t2 _ _)) | sameType t1 t2 -> return ()+ _ -> checkRedef (identToString ident) typeDef redecl handleDecl (TypeDefEvent typeDef) return () @@ -151,16 +162,16 @@ 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)+ throwTravError $ redefinition lvl (identToString 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) =+_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) =+_checkIdentTyRedef (Left tydef) (Redeclared old_def) = redefErr (identOfTypeDef tydef) LevelError tydef old_def DuplicateDef-checkIdentTyRedef (Left _tydef) _ = return ()+_checkIdentTyRedef (Left _tydef) _ = return () -- Check whether it is ok to declare a variable already in scope checkVarRedef :: (MonadCError m) => IdentDecl -> (DeclarationStatus IdentEntry) -> m ()@@ -185,19 +196,19 @@ _ -> 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+ linkageErr new_def old_def =+ case (declLinkage new_def, declLinkage old_def) of+ (NoLinkage, _) -> redefErr (declIdent new_def) LevelError new_def old_def NoLinkageOld+ _ -> redefErr (declIdent new_def) LevelError new_def old_def DisagreeLinkage new_ty = declType def canBeOverwritten (Declaration _) = True canBeOverwritten (ObjectDef od) = isTentative od canBeOverwritten _ = False- agreeOnLinkage def old_def+ agreeOnLinkage new_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+ | not (hasLinkage $ declStorage new_def) || not (hasLinkage $ declStorage old_def) = False+ | (declLinkage new_def) /= (declLinkage old_def) = False | otherwise = True -- | handle variable declarations (external object declarations and function prototypes)@@ -251,7 +262,7 @@ handleObjectDef local ident obj_def = do let def = ObjectDef obj_def redecl <- withDefTable $- defineScopedIdentWhen (\old -> shouldOverride def old) ident def+ defineScopedIdentWhen (shouldOverride def) ident def checkVarRedef def redecl handleDecl ((if local then LocalEvent else DeclEvent) def) where@@ -356,7 +367,7 @@ -- | check wheter non-recoverable errors occurred hadHardErrors :: [CError] -> Bool-hadHardErrors = (not . null . filter isHardError)+hadHardErrors = any isHardError -- | raise an error caused by a malformed AST astError :: (MonadCError m) => NodeInfo -> String -> m a@@ -373,56 +384,62 @@ -- * 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))+newtype TravT s m a = TravT { unTravT :: TravState m s -> m (Either CError (a, TravState m s)) } +instance Monad m => MonadState (TravState m s) (TravT s m) where+ get = TravT (\s -> return (Right (s,s)))+ put s = TravT (\_ -> return (Right ((),s))) -runTrav :: forall s a. s -> Trav s a -> Either [CError] (a, TravState s)-runTrav state traversal =- case unTrav action (initTravState state) of+runTravT :: forall m s a. Monad m => s -> TravT s m a -> m (Either [CError] (a, TravState m s))+runTravT state traversal =+ runTravTWithTravState (initTravState state) $ do+ withDefTable (const ((), builtins))+ traversal++runTravTWithTravState :: forall s m a. Monad m => TravState m s -> TravT s m a -> m (Either [CError] (a, TravState m s))+runTravTWithTravState state traversal =+ unTravT traversal state >>= pure . \case 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 :: forall s a. s -> Trav s a -> Either [CError] (a, TravState Identity s)+runTrav state traversal = runIdentity (runTravT state (unTrav 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 :: Monad m => TravT s m a -> (DeclEvent -> TravT s m ()) -> TravT s m a withExtDeclHandler action handler = do modify $ \st -> st { doHandleExtDecl = handler } action -instance Functor (Trav s) where+instance Monad f => Functor (TravT s f) where fmap = liftM -instance Applicative (Trav s) where- pure = return+instance Monad f => Applicative (TravT s f) where+ pure x = TravT (\s -> return (Right (x,s))) (<*>) = 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 Monad m => Monad (TravT s m) where+ m >>= k = TravT (\s -> unTravT m s >>= \y -> case y of+ Right (x,s1) -> unTravT (k x) s1+ Left e -> return (Left e)) -instance MonadName (Trav s) where+instance MonadTrans (TravT s) where+ lift m = TravT (\s -> (\x -> Right (x, s)) <$> m)++instance MonadIO m => MonadIO (TravT s m) where+ liftIO = lift . liftIO++instance Monad m => MonadName (TravT s m) where -- unique name generation genName = generateName -instance MonadSymtab (Trav s) where+instance Monad m => MonadSymtab (TravT s m) where -- symbol table handling getDefTable = gets symbolTable withDefTable f = do@@ -431,19 +448,24 @@ put $ ts { symbolTable = symt' } return r -instance MonadCError (Trav s) where+instance Monad m => MonadCError (TravT s m) 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)+ throwTravError e = TravT (\_ -> return (Left (toError e)))+ catchTravError a handler = TravT (\s -> unTravT a s >>= \x -> case x of+ Left e -> unTravT (handler e) s+ Right r -> return (Right r)) recordError e = modify $ \st -> st { rerrors = (rerrors st) `snoc` toError e } getErrors = gets (RList.reverse . rerrors) -instance MonadTrav (Trav s) where+instance Monad m => MonadTrav (TravT s m) where -- handling declarations and definitions handleDecl d = ($ d) =<< gets doHandleExtDecl +type Trav s a = TravT s Identity a++unTrav :: Trav s a -> TravT s Identity a+unTrav = id+ -- | The variety of the C language to accept. Note: this is not yet enforced. data CLanguage = C89 | C99 | GNU89 | GNU99 @@ -452,20 +474,20 @@ language :: CLanguage } -data TravState s =+data TravState m s = TravState { symbolTable :: DefTable, rerrors :: RList CError, nameGenerator :: [Name],- doHandleExtDecl :: (DeclEvent -> Trav s ()),+ doHandleExtDecl :: (DeclEvent -> TravT s m ()), userState :: s, options :: TravOptions } -travErrors :: TravState s -> [CError]+travErrors :: TravState m s -> [CError] travErrors = RList.reverse . rerrors -initTravState :: s -> TravState s+initTravState :: Monad m => s -> TravState m s initTravState userst = TravState { symbolTable = emptyDefTable,@@ -486,7 +508,7 @@ modifyOptions :: (TravOptions -> TravOptions) -> Trav s () modifyOptions f = modify $ \ts -> ts { options = f (options ts) } -generateName :: Trav s Name+generateName :: Monad m => TravT s m Name generateName = get >>= \ts -> do let (new_name : gen') = nameGenerator ts
src/Language/C/Analysis/TypeCheck.hs view
@@ -2,7 +2,6 @@ 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@@ -11,12 +10,12 @@ 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 Language.C.Analysis.Debug () import Text.PrettyPrint.HughesPJ -- We used to re-implement and export the standard Either instance for@@ -64,16 +63,16 @@ checkScalar :: Type -> Either String () checkScalar t = case canonicalType t of- DirectType _ _ _ -> return ()- PtrType _ _ _ -> return ()- ArrayType _ _ _ _ -> return () -- because it's just a pointer- t' -> fail $+ DirectType _ _ _ -> Right ()+ PtrType _ _ _ -> Right ()+ ArrayType _ _ _ _ -> Right () -- because it's just a pointer+ t' -> Left $ "expected scalar type, got: " ++ pType t ++ " (" ++ pType t' ++ ")" checkIntegral :: Type -> Either String ()-checkIntegral t | isIntegralType (canonicalType t) = return ()- | otherwise = fail $+checkIntegral t | isIntegralType (canonicalType t) = Right ()+ | otherwise = Left $ "expected integral type, got: " ++ pType t ++ " (" ++ pType (canonicalType t) ++ ")"@@ -106,82 +105,73 @@ -- | Determine whether two types are compatible. compatible :: Type -> Type -> Either String ()-compatible t1 t2 = compositeType t1 t2 >> return ()+compatible t1 t2 = void$ compositeType t1 t2 -- | 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 (TyBuiltin TyAny) _ _) = Right t1+compositeType (DirectType (TyBuiltin TyAny) _ _) t2 = Right 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+ (TyVoid, TyVoid) -> Right TyVoid+ (TyIntegral _, TyEnum _) -> Right tn1+ (TyEnum _, TyIntegral _) -> Right tn2 (TyIntegral i1, TyIntegral i2) ->- return $ TyIntegral (intConversion i1 i2)+ Right $ TyIntegral (intConversion i1 i2) (TyFloating f1, TyFloating f2) ->- return $ TyFloating (floatConversion f1 f2)+ Right $ TyFloating (floatConversion f1 f2) (TyComplex f1, TyComplex f2) ->- return $ TyComplex (floatConversion f1 f2)+ Right $ TyComplex (floatConversion f1 f2) (TyComp c1, TyComp c2) -> do when (sueRef c1 /= sueRef c2) $- fail $ "incompatible composite types: "+ Left $ "incompatible composite types: " ++ pType t1 ++ ", " ++ pType t2- return tn1+ Right tn1 (TyEnum e1, TyEnum e2) -> do when (sueRef e1 /= sueRef e2) $- fail $ "incompatible enumeration types: "+ Left $ "incompatible enumeration types: " ++ pType t1 ++ ", " ++ pType t2- return $ TyEnum e1+ Right $ TyEnum e1 (TyBuiltin TyVaList, TyBuiltin TyVaList) ->- return $ TyBuiltin TyVaList- (TyBuiltin _, TyBuiltin _) ->- fail $ "incompatible builtin types: "- ++ pType t1 ++ ", " ++ pType t2- (_, _) -> fail $ "incompatible direct types: "+ Right $ TyBuiltin TyVaList+ (_, _) -> Left $ "incompatible direct types: " ++ pType t1 ++ ", " ++ pType t2- return $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2)+ Right $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2) compositeType (PtrType t1 q1 a1) (PtrType (DirectType TyVoid _ _) q2 _) =- return $ PtrType t1 (mergeTypeQuals q1 q2) a1+ Right $ PtrType t1 (mergeTypeQuals q1 q2) a1 compositeType (PtrType (DirectType TyVoid _ _) q1 _) (PtrType t2 q2 a2) =- return $ PtrType t2 (mergeTypeQuals q1 q2) a2+ Right $ PtrType t2 (mergeTypeQuals q1 q2) a2 compositeType (PtrType t1 q1 a1) t2 | isIntegralType t2 =- return $ PtrType t1 (mergeTypeQuals q1 (typeQuals t2)) a1+ Right $ 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+ Right $ PtrType t2 (mergeTypeQuals (typeQuals t1) q2) a2+compositeType (ArrayType t1 _sz1 q1 a1) t2 | isIntegralType t2 =+ Right $ PtrType t1 q1 a1+compositeType t1 (ArrayType t2 _sz2 q2 a2) | isIntegralType t1 =+ Right $ 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)+ Right (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) =+ Right (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) _) ->+ (TypeDefRef _ t1 _, TypeDefRef _ 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)+ Left "different numbers of arguments in function types" -}+ args <- zipWithM compositeParamDecl args1 args2 when (varargs1 /= varargs2) $- fail "incompatible varargs declarations"+ Left "incompatible varargs declarations" doFunType rt1 rt2 args varargs1 (FunType rt1 args1 varargs1, FunTypeIncomplete rt2) -> doFunType rt1 rt2 args1 varargs1@@ -189,22 +179,22 @@ doFunType rt1 rt2 args2 varargs2 (FunTypeIncomplete rt1, FunTypeIncomplete rt2) -> do rt <- compositeType rt1 rt2- return (FunctionType (FunTypeIncomplete rt) (mergeAttrs attrs1 attrs2))+ Right (FunctionType (FunTypeIncomplete rt) (mergeAttrs attrs1 attrs2)) where doFunType rt1 rt2 args varargs = do rt <- compositeType rt1 rt2- return (FunctionType+ Right (FunctionType (FunType rt args varargs) (mergeAttrs attrs1 attrs2))-compositeType t1 t2 = fail $ "incompatible types: "+compositeType t1 t2 = Left $ "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 (UnknownArraySize _) s2 = Right s2+compositeSize s1 (UnknownArraySize _) = Right s1 compositeSize (ArraySize s1 e1) (ArraySize s2 e2)- | s1 == s2 && sizeEqual e1 e2 = return $ ArraySize s1 e1- | otherwise = return $ ArraySize s1 e1+ | s1 == s2 && sizeEqual e1 e2 = Right $ ArraySize s1 e1+ | otherwise = Right $ ArraySize s1 e1 {- fail $ "incompatible array sizes: " ++ (render . pretty) e1 ++ ", " ++ (render . pretty) e2@@ -234,14 +224,14 @@ -> 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+ Right $ 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)+ Right (VarDecl n1 (compositeDeclAttrs attrs1 attrs2) t) -- XXX: bad treatement of inline and storage compositeDeclAttrs :: DeclAttrs -> DeclAttrs -> DeclAttrs@@ -251,39 +241,39 @@ castCompatible :: Type -> Type -> Either String () castCompatible t1 t2 = case (canonicalType t1, canonicalType t2) of- (DirectType TyVoid _ _, _) -> return ()+ (DirectType TyVoid _ _, _) -> Right () (_, _) -> 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 ()+ (DirectType (TyBuiltin TyAny) _ _, _) -> Right ()+ (_, DirectType (TyBuiltin TyAny) _ _) -> Right () -- XXX: check qualifiers- (PtrType (DirectType TyVoid _ _) _ _, t2') | isPointerType t2' -> return ()+ (PtrType (DirectType TyVoid _ _) _ _, t2') | isPointerType t2' -> Right () -- XXX: check qualifiers- (t1', PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> return ()- (PtrType _ _ _, t2') | isIntegralType t2' -> return ()+ (t1', PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> Right ()+ (PtrType _ _ _, t2') | isIntegralType t2' -> Right () (t1', t2') | isPointerType t1' && isPointerType t2' ->- do compatible (baseType t1') (baseType t2')+ compatible (baseType t1') (baseType t2') --unless (typeQuals t2 <= typeQuals t1) $- -- fail $+ -- Left $ -- "incompatible qualifiers in pointer assignment: " -- ++ pType t1 ++ ", " ++ pType t2 (DirectType (TyComp c1) _ _, DirectType (TyComp c2) _ _)- | sueRef c1 == sueRef c2 -> return ()- | otherwise -> fail $+ | sueRef c1 == sueRef c2 -> Right ()+ | otherwise -> Left $ "incompatible compound types in assignment: " ++ pType t1 ++ ", " ++ pType t2 (DirectType (TyBuiltin TyVaList) _ _, DirectType (TyBuiltin TyVaList) _ _) ->- return ()+ Right () (DirectType tn1 _ _, DirectType tn2 _ _)- | isJust (arithmeticConversion tn1 tn2) -> return ()- | otherwise -> fail $ "incompatible direct types in assignment: "+ | isJust (arithmeticConversion tn1 tn2) -> Right ()+ | otherwise -> Left $ "incompatible direct types in assignment: " ++ pType t1 ++ ", " ++ pType t2 (t1', t2') -> compatible t1' t2'-assignCompatible op t1 t2 = binopType (assignBinop op) t1 t2 >> return ()+assignCompatible op t1 t2 = void$ binopType (assignBinop op) t1 t2 -- | Determine the type of a binary operation. binopType :: CBinaryOp -> Type -> Type -> Either String Type@@ -291,83 +281,84 @@ case (op, canonicalType t1, canonicalType t2) of (_, t1', t2') | isLogicOp op ->- checkScalar t1' >> checkScalar t2' >> return boolType+ checkScalar t1' >> checkScalar t2' >> Right 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"+ Just _ -> Right boolType+ Nothing -> Left $ render $+ text "incompatible arithmetic types in comparison: "+ <+> pretty t1 <+> text "and" <+> pretty t2 (PtrType (DirectType TyVoid _ _) _ _, _)- | isPointerType t2' -> return boolType+ | isPointerType t2' -> Right boolType (_, PtrType (DirectType TyVoid _ _) _ _)- | isPointerType t1' -> return boolType+ | isPointerType t1' -> Right boolType (_, _)- | isPointerType t1' && isIntegralType t2' -> return boolType- | isIntegralType t1' && isPointerType t2' -> return boolType+ | isPointerType t1' && isIntegralType t2' -> Right boolType+ | isIntegralType t1' && isPointerType t2' -> Right boolType | isPointerType t1' && isPointerType t2' ->- compatible t1' t2' >> return boolType- (_, _) -> fail "incompatible types in comparison"+ compatible t1' t2' >> Right boolType+ (_, _) -> Left "incompatible types in comparison" (CSubOp, ArrayType t1' _ _ _, ArrayType t2' _ _ _) ->- compatible t1' t2' >> return ptrDiffType+ compatible t1' t2' >> Right ptrDiffType (CSubOp, ArrayType t1' _ _ _, PtrType t2' _ _) ->- compatible t1' t2' >> return ptrDiffType+ compatible t1' t2' >> Right ptrDiffType (CSubOp, PtrType t1' _ _, ArrayType t2' _ _ _) ->- compatible t1' t2' >> return ptrDiffType+ compatible t1' t2' >> Right ptrDiffType (CSubOp, PtrType t1' _ _, PtrType t2' _ _) ->- compatible t1' t2' >> return ptrDiffType+ compatible t1' t2' >> Right ptrDiffType (_, PtrType _ _ _, t2')- | isPtrOp op && isIntegralType t2' -> return t1- | otherwise -> fail $ "invalid pointer operation: " ++ render (pretty op)- (CAddOp, t1', PtrType _ _ _) | isIntegralType t1' -> return t2+ | isPtrOp op && isIntegralType t2' -> Right t1+ | otherwise -> Left $ "invalid pointer operation: " ++ render (pretty op)+ (CAddOp, t1', PtrType _ _ _) | isIntegralType t1' -> Right t2 (_, ArrayType _ _ _ _, t2')- | isPtrOp op && isIntegralType t2' -> return t1- | otherwise -> fail $ "invalid pointer operation: " ++ render (pretty op)- (CAddOp, t1', ArrayType _ _ _ _) | isIntegralType t1' -> return t2+ | isPtrOp op && isIntegralType t2' -> Right t1+ | otherwise -> Left $ "invalid pointer operation: " ++ render (pretty op)+ (CAddOp, t1', ArrayType _ _ _ _) | isIntegralType t1' -> Right 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 $+ Just tn -> Right $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2)+ Nothing -> Left $ render $ text "invalid binary operation:" <+> pretty t1 <+> pretty op <+> pretty t2- (_, _, _) -> fail $ render $+ (_, _, _) -> Left $ 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+ (PtrType (DirectType TyVoid _ _) _ _, t2') | isPointerType t2' -> Right t2+ (t1', PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> Right t1 (ArrayType t1' _ q1 a1, ArrayType t2' _ q2 a2) -> do t <- compositeType t1' t2'- return $ ArrayType t (UnknownArraySize False)+ Right $ 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)+ Just tn -> Right $ 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 (PtrType t _ _) = Right t+derefType (ArrayType t _ _ _) = Right 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+ PtrType t' _ _ -> Right t'+ ArrayType t' _ _ _ -> Right t'+ _ -> Left $ "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 ()+ Auto True -> Left "address of register variable"+ _ -> Right () case t of- ArrayType _ _ q a -> return $ PtrType t q a- _ -> return $ simplePtr t+ ArrayType _ _ q a -> Right $ PtrType t q a+ _ -> Right $ simplePtr t where t = declType d -- | Get the type of field @m@ of type @t@
src/Language/C/Analysis/TypeConversions.hs view
@@ -27,8 +27,8 @@ 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 (TyEnum _) t2 = Just t2+arithmeticConversion t1 (TyEnum _) = Just t1 arithmeticConversion _ _ = Nothing floatConversion :: FloatType -> FloatType -> FloatType
src/Language/C/Analysis/TypeUtils.hs view
@@ -3,6 +3,9 @@ integral, floating, simplePtr,+ uint16_tType,+ uint32_tType,+ uint64_tType, size_tType, ptrDiffType, boolType,@@ -28,22 +31,18 @@ derefTypeDef, deepDerefTypeDef, canonicalType,+ -- * Type comparisons+ sameType, -- * Other utilities getIntType, getFloatType ) where import Language.C.Analysis.SemRep+import Language.C.Data.Node (CNode(..))+import Language.C.Syntax.AST (CExpression (..), CConstant (..)) 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@@ -58,8 +57,20 @@ -- | A pointer with the @const@ qualifier. constPtr :: Type -> Type-constPtr t = PtrType t (TypeQuals True False False) []+constPtr t = PtrType t (noTypeQuals { constant = True }) [] +-- | The underlying type for @uint16_t@. For now, this is just @unsigned short@.+uint16_tType :: Type+uint16_tType = integral TyUShort++-- | The underlying type for @uint32_t@. For now, this is just @unsigned int@.+uint32_tType :: Type+uint32_tType = integral TyUInt++-- | The underlying type for @uint64_t@. For now, this is just @unsigned long long@.+uint64_tType :: Type+uint64_tType = integral TyULLong+ -- | The type returned by sizeof (size_t). For now, this is just @int@. size_tType :: Type size_tType = integral TyInt@@ -95,7 +106,9 @@ -- | The type of a constant string. stringType :: Type stringType = ArrayType- (DirectType (TyIntegral TyChar) (TypeQuals True False False) noAttributes)+ (DirectType (TyIntegral TyChar)+ (noTypeQuals { constant = True })+ noAttributes) (UnknownArraySize False) noTypeQuals []@@ -109,20 +122,20 @@ isIntegralType :: Type -> Bool isIntegralType (DirectType (TyIntegral _) _ _) = True isIntegralType (DirectType (TyEnum _) _ _) = True-isIntegralType _ = False+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+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 (PtrType _ _ _) = True isPointerType (ArrayType _ _ _ _) = True-isPointerType _ = False+isPointerType _ = False -- | Check whether a type is a scalar type. Scalar types include -- arithmetic types and pointer types.@@ -134,8 +147,7 @@ -- 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"+ case ty of TypeDefType (TypeDefRef _ actual_ty _) _ _ -> isFunctionType actual_ty FunctionType _ _ -> True _ -> False @@ -145,8 +157,7 @@ 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)+typeQuals (TypeDefType (TypeDefRef _ t _) q _) = mergeTypeQuals q (typeQuals t) -- |Update type qualifiers -- For function types, it is an error to change any type qualifiers@@ -165,8 +176,7 @@ 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)+typeAttrs (TypeDefType (TypeDefRef _ t _) _ a) = mergeAttributes a (typeAttrs t) -- |Update type attributes typeAttrsUpd :: (Attributes -> Attributes) -> Type -> Type@@ -181,13 +191,13 @@ -- to call this function with a type that is not in one of those two -- categories. baseType :: Type -> Type-baseType (PtrType t _ _) = t+baseType (PtrType t _ _) = t baseType (ArrayType t _ _ _) = t-baseType _ = error "base of non-pointer type"+baseType _ = error "base of non-pointer type" -- | resolve typedefs, if possible derefTypeDef :: Type -> Type-derefTypeDef (TypeDefType (TypeDefRef _ (Just t) _) q a) =+derefTypeDef (TypeDefType (TypeDefRef _ t _) q a) = (typeAttrsUpd (mergeAttributes a) . typeQualsUpd (mergeTypeQuals q)) (derefTypeDef t) derefTypeDef ty = ty@@ -205,20 +215,116 @@ FunctionType (FunType (deepDerefTypeDef rt) params varargs) attrs deepDerefTypeDef (FunctionType (FunTypeIncomplete rt) attrs) = FunctionType (FunTypeIncomplete (deepDerefTypeDef rt)) attrs-deepDerefTypeDef (TypeDefType (TypeDefRef _ (Just t) _) q a) =+deepDerefTypeDef (TypeDefType (TypeDefRef _ t _) q a) = (typeAttrsUpd (mergeAttributes a) . typeQualsUpd (mergeTypeQuals q)) (deepDerefTypeDef t) deepDerefTypeDef t = t +-- | True iff Type is a variable length array or a derived type thereof.+-- Variably modified types have function or block scope, so only some+-- constructions are possible.+isVariablyModifiedType :: Type -> Bool+isVariablyModifiedType t =+ case derefTypeDef t of+ TypeDefType {} -> error "impossible: derefTypeDef t returned a TypeDefType"+ DirectType {} -> False+ PtrType ptr_ty _ _ -> isVariablyModifiedType ptr_ty+ ArrayType _ sz _ _ -> isVariableArraySize sz+ FunctionType {} -> False+ where+ isVariableArraySize :: ArraySize -> Bool+ isVariableArraySize (UnknownArraySize isStarred) = isStarred+ isVariableArraySize (ArraySize isStatic e) = isStatic || isConstantSize e++ isConstantSize :: Expr -> Bool+ isConstantSize (CConst (CIntConst {})) = True+ isConstantSize _ = False++-- | Two types denote the same type if they are identical, ignoring type+-- definitions, and neither is a variably modified type.+sameType :: Type -> Type -> Bool+sameType t1 t2 =+ not (isVariablyModifiedType t1 || isVariablyModifiedType t2) && sameType'+ where+ sameType' =+ case (derefTypeDef t1, derefTypeDef t2) of+ (TypeDefType {}, _) -> error "impossible: derefTypeDef t1 returned a TypeDefType"+ (_, TypeDefType {}) -> error "impossible: derefTypeDef t2 returned a TypeDefType"+ (DirectType tn1 q1 _a1, DirectType tn2 q2 _a2) ->+ sameTypeName tn1 tn2 && sameQuals q1 q2 {- FIXME: same attributes? -}+ (PtrType pt1 q1 _a1, PtrType pt2 q2 _a2) ->+ sameType pt1 pt2 && sameQuals q1 q2+ (ArrayType at1 sz1 q1 _a1, ArrayType at2 sz2 q2 _a2) ->+ sameType at1 at2 && sameArraySize sz1 sz2 && sameQuals q1 q2+ (FunctionType ft1 _a1, FunctionType ft2 _a2) ->+ sameFunType ft1 ft2+ _ -> False++sameTypeName :: TypeName -> TypeName -> Bool+sameTypeName t1 t2 =+ case (t1, t2) of+ (TyVoid, TyVoid) -> True+ (TyIntegral i1, TyIntegral i2) -> i1 == i2+ (TyFloating f1, TyFloating f2) -> f1 == f2+ (TyComplex f1, TyComplex f2) -> f1 == f2+ (TyComp ctr1, TyComp ctr2) -> sameCompTypeRef ctr1 ctr2+ (TyEnum etr1, TyEnum etr2) -> sameEnumTypeRef etr1 etr2+ (TyBuiltin b1, TyBuiltin b2) -> sameBuiltinType b1 b2+ _ -> False++sameBuiltinType :: BuiltinType -> BuiltinType -> Bool+sameBuiltinType TyVaList TyVaList = True+sameBuiltinType TyAny TyAny = False {- what does TyAny mean? -}+sameBuiltinType _ _ = False++sameCompTypeRef :: CompTypeRef -> CompTypeRef -> Bool+sameCompTypeRef (CompTypeRef sue1 kind1 _) (CompTypeRef sue2 kind2 _) =+ sue1 == sue2 && kind1 == kind2++sameEnumTypeRef :: EnumTypeRef -> EnumTypeRef -> Bool+sameEnumTypeRef (EnumTypeRef sue1 _) (EnumTypeRef sue2 _) = sue1 == sue2++sameFunType :: FunType -> FunType -> Bool+sameFunType (FunType rt1 params1 isVar1) (FunType rt2 params2 isVar2) =+ sameType rt1 rt2 && sameParamDecls params1 params2 && isVar1 == isVar2+ where+ sameParamDecls :: [ParamDecl] -> [ParamDecl] -> Bool+ sameParamDecls param_list1 param_list2 =+ length param_list1 == length param_list2+ && and (zipWith sameParamDecl param_list1 param_list2)+ -- ignores param identifiers, just compares types+ sameParamDecl :: ParamDecl -> ParamDecl -> Bool+ sameParamDecl p1 p2 = sameType (declType p1) (declType p2)+sameFunType (FunTypeIncomplete rt1) (FunTypeIncomplete rt2) =+ sameType rt1 rt2+sameFunType _ _ = False++-- | Returns 'True' iff both array sizes denote the same size. Assumes that+-- neither array type was a variably modified type.+sameArraySize :: ArraySize -> ArraySize -> Bool+sameArraySize (UnknownArraySize isStar1) (UnknownArraySize isStar2) = isStar1 == isStar2+sameArraySize (ArraySize s1 e1) (ArraySize s2 e2) = s1 == s2 && sizeEqual e1 e2+ where+ -- FIXME: Do something better, and combine with sizeEqual in Language.C.Analysis.TypeCheck+ sizeEqual :: Expr -> Expr -> Bool+ sizeEqual (CConst (CIntConst i1 _)) (CConst (CIntConst i2 _)) = i1 == i2+ sizeEqual oe1 oe2 = nodeInfo oe1 == nodeInfo oe2+sameArraySize _ _ = False++sameQuals :: TypeQuals -> TypeQuals -> Bool+sameQuals (TypeQuals {constant = c1, volatile = v1, restrict = r1})+ (TypeQuals {constant = c2, volatile = v2, restrict = r2}) =+ c1 == c2 && v1 == v2 && r1 == r2+ canonicalType :: Type -> Type canonicalType t = case deepDerefTypeDef t of FunctionType ft attrs -> simplePtr (FunctionType ft attrs)- t' -> t'+ 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+testFlags flags fi = all (`testFlag` fi) flags -- XXX: deal with FlagImag. No representation for it in Complex. -- XXX: deal with invalid combinations of flags?
src/Language/C/Data.hs view
@@ -14,12 +14,13 @@ -- * Input stream module Language.C.Data.InputStream, -- * Identifiers- SUERef(..), isAnonymousRef,+ SUERef(..), isAnonymousRef, sueRefToString, Ident,mkIdent, identToString, internalIdent, isInternalIdent, builtinIdent, -- * Unqiue names Name(..),newNameSupply, -- * Source code positions- Position(..),Pos(..),+ Position(..),posFile,posParent,+ Pos(..), initPos, nopos,builtinPos,internalPos, isSourcePos,isBuiltinPos,isInternalPos, -- * Syntax tree nodes
src/Language/C/Data/Error.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Data.Error@@ -28,8 +28,8 @@ internalErr, ) where-import Data.Typeable-import Data.Generics++import Data.Typeable (Typeable, cast) import Language.C.Data.Node import Language.C.Data.Position @@ -50,7 +50,7 @@ isHardError = ( > LevelWarn) . errorLevel -- | information attached to every error in Language.C-data ErrorInfo = ErrorInfo ErrorLevel Position [String] deriving Typeable+data ErrorInfo = ErrorInfo ErrorLevel Position [String] -- to facilitate newtype deriving instance Show ErrorInfo where show = showErrorInfo "error"@@ -64,8 +64,8 @@ -- | `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@@ -73,7 +73,7 @@ -- | wrap error in 'CError' toError :: e -> CError -- | try to cast a generic 'CError' to the specific error type- fromError :: CError -> (Maybe e)+ fromError :: CError -> Maybe e -- | modify the error level changeErrorLevel :: e -> ErrorLevel -> e @@ -106,7 +106,7 @@ 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+data UnsupportedFeature = UnsupportedFeature String Position instance Error UnsupportedFeature where errorInfo (UnsupportedFeature msg pos) = ErrorInfo LevelError pos (lines msg) instance Show UnsupportedFeature where show = showError "Unsupported Feature"@@ -119,7 +119,7 @@ -- | 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+newtype UserError = UserError ErrorInfo instance Error UserError where errorInfo (UserError info) = info instance Show UserError where show = showError "User Error"@@ -148,7 +148,7 @@ 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) ++ ": " +++ 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."
src/Language/C/Data/Ident.hs view
@@ -17,7 +17,8 @@ module Language.C.Data.Ident ( Ident(..), SUERef(..), isAnonymousRef,- mkIdent, builtinIdent, internalIdent, internalIdentAt, isInternalIdent, identToString, dumpIdent)+ mkIdent, builtinIdent, internalIdent, internalIdentAt, isInternalIdent,+ identToString, sueRefToString, dumpIdent) where -- TODO (comment from manuel):@@ -26,16 +27,20 @@ import Data.Char import Language.C.Data.Position import Language.C.Data.Node-import Language.C.Data.Name (Name,nameId)-import Data.Generics+import Language.C.Data.Name (Name)+import Data.Data (Data)+import GHC.Generics (Generic)+import Control.DeepSeq (NFData) -- | 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+ deriving (Data, Ord, Eq, Show, Generic) --, Read +instance NFData SUERef+ -- | Return true if the struct\/union\/enum reference is anonymous. isAnonymousRef :: SUERef -> Bool isAnonymousRef (AnonymousRef _) = True@@ -45,8 +50,10 @@ 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+ deriving (Data,Show, Generic) -- Read +instance NFData Ident+ -- 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@@ -122,6 +129,11 @@ -- | string of an identifier identToString :: Ident -> String identToString (Ident s _ _) = s++-- | string of a SUE ref (empty if anonymous)+sueRefToString :: SUERef -> String+sueRefToString (AnonymousRef _) = ""+sueRefToString (NamedRef ident) = identToString ident -- | dump the identifier string and its positions for debugging purposes dumpIdent :: Ident -> String
src/Language/C/Data/InputStream.hs view
@@ -71,15 +71,12 @@ 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+takeChars !n bstr = BSC.unpack $ BSC.take n bstr readInputStream = BSW.readFile inputStreamToString = BSC.unpack inputStreamFromString = BSC.pack countLines = length . BSC.lines- #else
src/Language/C/Data/Name.hs view
@@ -12,13 +12,16 @@ module Language.C.Data.Name ( Name(..),newNameSupply, namesStartingFrom ) where+import Data.Data (Data) import Data.Ix-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.Generics+import GHC.Generics (Generic)+import Control.DeepSeq (NFData) -- | Name is a unique identifier-newtype Name = Name { nameId :: Int } deriving (Show, Read, Eq, Ord, Ix, Data, Typeable)+newtype Name = Name { nameId :: Int }+ deriving (Show, Read, Eq, Ord, Ix, Data, Generic)++instance NFData Name instance Enum Name where toEnum = Name
src/Language/C/Data/Node.hs view
@@ -21,13 +21,17 @@ ) where import Language.C.Data.Position import Language.C.Data.Name (Name)-import Data.Generics+import Data.Data (Data)+import GHC.Generics (Generic)+import Control.DeepSeq (NFData) -- | 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)+ deriving (Data,Eq,Ord, Generic) +instance NFData NodeInfo+ instance Show NodeInfo where showsPrec d (OnlyPos p l) = (showString "(OnlyPos ") . (showsPrec d p) . (showString " ") . (showsPrec d l) . (showString ")")@@ -35,16 +39,16 @@ (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!"+--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 Ord NodeInfo where+-- (NodeInfo _ _ id1) <= (NodeInfo _ _ id2) = id1 <= id2+-- _ <= _ =+-- error "Attributes: Attempt to compare `OnlyPos' attributes!" instance Pos NodeInfo where posOf (OnlyPos pos _) = pos@@ -56,8 +60,8 @@ 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)+ computeLength pos (lastPos,lastTokLen) | lastTokLen < 0 = Nothing+ | otherwise = Just (posOffset lastPos + lastTokLen - posOffset pos) -- | get the position and length of the last token getLastTokenPos :: NodeInfo -> PosLength
src/Language/C/Data/Position.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Data.Position@@ -18,43 +18,62 @@ Position(), position, PosLength,- posFile,posRow,posColumn,posOffset,+ posFile,posRow,posColumn,posOffset,posParent, initPos, isSourcePos, nopos, isNoPos, builtinPos, isBuiltinPos, internalPos, isInternalPos,- incPos, retPos, adjustPos,+ incPos, retPos, incOffset, Pos(..), ) where-import Data.Generics+import Data.Data (Data)+import GHC.Generics (Generic)+import Control.DeepSeq (NFData) +-- | file position information+data FilePosition = FilePosition { posSrcFile :: String, -- ^ source file+ posParentFile :: (Maybe Position) -- ^ including file, if any+ }+ deriving (Eq, Ord, Data, Generic)++instance NFData FilePosition+ -- | 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.+ , posFileInfo :: FilePosition -- ^ position in source file, including files } | NoPosition | BuiltinPosition | InternalPosition- deriving (Eq, Ord, Typeable, Data)+ deriving (Eq, Ord, Data, Generic) +instance NFData Position++posFile :: Position -> String+posFile = posSrcFile . posFileInfo++posParent :: Position -> (Maybe Position)+posParent = posParentFile . posFileInfo+ -- | 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 = "<no file>"- show BuiltinPosition = "<builtin>"- show InternalPosition = "<internal>"--{-# DEPRECATED posColumn "column number information is inaccurate in presence of macros - do not rely on it." #-}+ showsPrec _ (Position _ row _ (FilePosition fname mparent)) =+ showString "(" . showsPrec 0 fname . showString ": line " . showsPrec 0 row .+ maybe id (\p -> showString ", in file included from " . showsPrec 0 p) mparent .+ showString ")"+ showsPrec _ NoPosition = showString "<no file>"+ showsPrec _ BuiltinPosition = showString "<builtin>"+ showsPrec _ InternalPosition = showString "<internal>" -- | @position absoluteOffset fileName lineNumber columnNumber@ initializes a @Position@ using the given arguments-position :: Int -> String -> Int -> Int -> Position-position = Position+position :: Int -> String -> Int -> Int -> Maybe Position -> Position+position offset fname row col mparent = Position offset row col (FilePosition fname mparent) -- | class of type which aggregate a source code location class Pos a where@@ -62,7 +81,7 @@ -- | 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+initPos file = Position 0 1 1 (FilePosition file Nothing) -- | returns @True@ if the given position refers to an actual source file isSourcePos :: Position -> Bool@@ -100,25 +119,17 @@ {-# INLINE incPos #-} -- | advance column incPos :: Position -> Int -> Position-incPos (Position offs fname row col) n = Position (offs + n) fname row (col + n)+incPos (Position offs row col fpos) n = Position (offs + n) row (col + n) fpos 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 (Position offs row _ fpos) = Position (offs+1) (row + 1) 1 fpos 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+incOffset (Position o r c f) n = Position (o + n) r c f+incOffset pos _ = pos
src/Language/C/Data/RList.hs view
@@ -30,7 +30,7 @@ snoc :: Reversed [a] -> a -> Reversed [a] snoc (Reversed xs) x = Reversed (x : xs)-infixr 5 `snoc`+infixl 5 `snoc` rappend :: Reversed [a] -> [a] -> Reversed [a] rappend (Reversed xs) ys = Reversed (List.reverse ys ++ xs)
src/Language/C/Parser/Builtin.hs view
@@ -18,4 +18,6 @@ -- predefined type names -- builtinTypeNames :: [Ident]-builtinTypeNames = [builtinIdent "__builtin_va_list"]+builtinTypeNames = [+ builtinIdent "__builtin_va_list"+ ]
src/Language/C/Parser/Lexer.x view
@@ -51,6 +51,7 @@ module Language.C.Parser.Lexer (lexC, parseError) where import Data.Char (chr, isDigit)+import Data.List (uncons) import Data.Word (Word8) import Control.Monad (liftM, when) @@ -119,10 +120,13 @@ @hexmant = @hexdigits?\.@hexdigits|@hexdigits\. @binexp = [pP][\+\-]?@digits -@floatsuffix = [fFlL]+-- Suffixes `qQwW` are GNU floating type extensions: <https://gcc.gnu.org/onlinedocs/gcc/Floating-Types.html>+@iec60559suffix = (16|32|64|128)[x]?+@floatsuffix = [fFlLqQwW]@iec60559suffix? @floatgnusuffix = @floatsuffix@gnusuffix?|@gnusuffix@floatsuffix? -+-- clang version literals with a major.minor.rev+@clangversion = @intpart\.@intpart\.@intpart tokens :- @@ -135,12 +139,16 @@ -- $white+ ; --- #line directive (K&R A12.6)+-- #line directive (C11 6.10.4, GCC Line Control) ----- * 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+-- * standard form: int => change line number+-- * standard form: int string => change source file and line number+-- * preprocessor (gcc/clang): int string int => change source file and line number,+-- push or pop item from stack ---\#$space*@int$space*(\"($infname|@charesc)*\"$space*)?(@int$space*)*\r?$eol+-- * see https://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html+--+\#$space*@digits$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)@@ -178,11 +186,14 @@ -- 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) }+\'($inchar|@charesc)\' { token CTokCLit (cChar . fst . unescapeChar . drop 1) }+L\'($inchar|@charesc)\' { token CTokCLit (cChar_w . fst . unescapeChar . drop 2) }+\'($inchar|@charesc){2,}\' { token CTokCLit (flip cChars False . unescapeMultiChars . drop 1) }+L\'($inchar|@charesc){2,}\' { token CTokCLit (flip cChars True . unescapeMultiChars . drop 2) } +-- Clang version literals+@clangversion { token (\pos -> CTokClangC pos . ClangCVersionTok) readClangCVersion }+ -- float constants (follows K&R A2.5.3. C99 6.4.4.2) -- -- * NOTE: Hexadecimal floating constants without binary exponents are forbidden.@@ -193,8 +204,8 @@ -- 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) }+\"($instr|@charesc)*\" { token CTokSLit (cString . unescapeString . init . drop 1) }+L\"($instr|@charesc)*\" { token CTokSLit (cString_w . unescapeString . init . drop 2) } L?\'@ucn\' { token_fail "Universal character names are unsupported" } L?\'\\[^0-7'\"\?\\abfnrtvuUx]\' { token_fail "Invalid escape sequence" }@@ -257,7 +268,9 @@ case r of (c:_) | isDigit c -> readCInteger OctalRepr r _ -> readCInteger DecRepr s+readCOctal _ = error "ReadOctal: string does not start with `0'" + -- 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@@ -265,21 +278,49 @@ -- 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)+-- using the script GenerateKeywords.hs (in /scripts) {--alignof @__, asm @__, auto-break, bool _Bool,-case, char, const @__, continue, complex _Complex __complex__+alignas _Alignas,+alignof _Alignof __alignof alignof __alignof__,+asm @__,+atomic _Atomic,+auto, break, bool _Bool bool,+case, char, const @__, continue,+complex _Complex __complex__ default, do, double, else, enum, extern,-float, for, goto,-if, inline @__, int, long,+float, for,+generic _Generic,+goto,+if, inline @__, int,+int128 __int128 __int128_t,+long,+noreturn _Noreturn,+nullable _Nullable __nullable,+nonnull _Nonnull __nonnull, register, restrict @__, return-short, signed @__, sizeof, static, struct, switch,-typedef, typeof @__, thread __thread,-union, unsigned, void, volatile @__,+short, signed @__, sizeof, static,+staticAssert _Static_assert,+struct, switch,+typedef, typeof @__,+thread __thread _Thread_local+(CTokUInt128) __uint128 __uint128_t,+union,+unsigned,+void,+volatile @__, while, label __label__+BFloat16 __bf16+(CTokFloatN 16 False) __fp16+(CTokFloatN 16 False) _Float16+(CTokFloatN 16 True) _Float16x+(CTokFloatN 32 False) _Float32+(CTokFloatN 32 True) _Float32x+(CTokFloatN 64 False) _Float64+(CTokFloatN 64 True) _Float64x+(CTokFloatN 128 False) _Float128 __float128+(CTokFloatN 128 True) _Float128x (CTokGnuC GnuCAttrTok) __attribute __attribute__ (CTokGnuC GnuCExtTok) __extension__ (CTokGnuC GnuCComplexReal) __real __real__@@ -287,10 +328,32 @@ (CTokGnuC GnuCVaArg) __builtin_va_arg (CTokGnuC GnuCOffsetof) __builtin_offsetof (CTokGnuC GnuCTyCompat) __builtin_types_compatible_p+(CTokGnuC GnuBitCast) __builtin_bit_cast+(flip CTokClangC ClangBuiltinConvertVector) __builtin_convertvector -}--- 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++-- Tokens: _Alignas _Alignof __alignof alignof __alignof__ __asm asm __asm__ _Atomic auto break _Bool bool case char __const const __const__ continue _Complex __complex__ default do double else enum extern float for _Generic goto if __inline inline __inline__ int __int128 __int128_t long _Noreturn _Nullable __nullable _Nonnull __nonnull register __restrict restrict __restrict__ return short __signed signed __signed__ sizeof static _Static_assert struct switch typedef __typeof typeof __typeof__ __thread _Thread_local __uint128 __uint128_t union unsigned void __volatile volatile __volatile__ while __label__ __bf16 __fp16 _Float16 _Float16x _Float32 _Float32x _Float64 _Float64x _Float128 __float128 _Float128x __attribute __attribute__ __extension__ __real __real__ __imag __imag__ __builtin_va_arg __builtin_offsetof __builtin_types_compatible_p __builtin_bit_cast __builtin_convertvector+idkwtok ('_' : 'A' : 'l' : 'i' : 'g' : 'n' : 'a' : 's' : []) = tok 8 CTokAlignas+idkwtok ('_' : 'A' : 'l' : 'i' : 'g' : 'n' : 'o' : 'f' : []) = tok 8 CTokAlignof+idkwtok ('_' : 'A' : 't' : 'o' : 'm' : 'i' : 'c' : []) = tok 7 CTokAtomic idkwtok ('_' : 'B' : 'o' : 'o' : 'l' : []) = tok 5 CTokBool idkwtok ('_' : 'C' : 'o' : 'm' : 'p' : 'l' : 'e' : 'x' : []) = tok 8 CTokComplex+#ifdef IEC_60559_TYPES_EXT+idkwtok ('_' : 'F' : 'l' : 'o' : 'a' : 't' : '1' : '2' : '8' : []) = tok 9 (CTokFloatN 128 False)+idkwtok ('_' : 'F' : 'l' : 'o' : 'a' : 't' : '1' : '2' : '8' : 'x' : []) = tok 10 (CTokFloatN 128 True)+idkwtok ('_' : 'F' : 'l' : 'o' : 'a' : 't' : '1' : '6' : []) = tok 8 (CTokFloatN 16 False)+idkwtok ('_' : 'F' : 'l' : 'o' : 'a' : 't' : '1' : '6' : 'x' : []) = tok 9 (CTokFloatN 16 True)+idkwtok ('_' : 'F' : 'l' : 'o' : 'a' : 't' : '3' : '2' : []) = tok 8 (CTokFloatN 32 False)+idkwtok ('_' : 'F' : 'l' : 'o' : 'a' : 't' : '3' : '2' : 'x' : []) = tok 9 (CTokFloatN 32 True)+idkwtok ('_' : 'F' : 'l' : 'o' : 'a' : 't' : '6' : '4' : []) = tok 8 (CTokFloatN 64 False)+idkwtok ('_' : 'F' : 'l' : 'o' : 'a' : 't' : '6' : '4' : 'x' : []) = tok 9 (CTokFloatN 64 True)+#endif+idkwtok ('_' : 'G' : 'e' : 'n' : 'e' : 'r' : 'i' : 'c' : []) = tok 8 CTokGeneric+idkwtok ('_' : 'N' : 'o' : 'n' : 'n' : 'u' : 'l' : 'l' : []) = tok 8 CTokNonnull+idkwtok ('_' : 'N' : 'o' : 'r' : 'e' : 't' : 'u' : 'r' : 'n' : []) = tok 9 CTokNoreturn+idkwtok ('_' : 'N' : 'u' : 'l' : 'l' : 'a' : 'b' : 'l' : 'e' : []) = tok 9 CTokNullable+idkwtok ('_' : 'S' : 't' : 'a' : 't' : 'i' : 'c' : '_' : 'a' : 's' : 's' : 'e' : 'r' : 't' : []) = tok 14 CTokStaticAssert+idkwtok ('_' : 'T' : 'h' : 'r' : 'e' : 'a' : 'd' : '_' : 'l' : 'o' : 'c' : 'a' : 'l' : []) = tok 13 CTokThread 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@@ -300,7 +363,11 @@ 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' : 'f' : '1' : '6' : []) = tok 6 CTokBFloat16+idkwtok ('b' : 'o' : 'o' : 'l' : []) = tok 4 CTokBool idkwtok ('b' : 'r' : 'e' : 'a' : 'k' : []) = tok 5 CTokBreak+idkwtok ('_' : '_' : 'b' : 'u' : 'i' : 'l' : 't' : 'i' : 'n' : '_' : 'b' : 'i' : 't' : '_' : 'c' : 'a' : 's' : 't' : []) = tok 18 (flip CTokClangC ClangCBitCast)+idkwtok ('_' : '_' : 'b' : 'u' : 'i' : 'l' : 't' : 'i' : 'n' : '_' : 'c' : 'o' : 'n' : 'v' : 'e' : 'r' : 't' : 'v' : 'e' : 'c' : 't' : 'o' : 'r' : []) = tok 23 (flip CTokClangC ClangBuiltinConvertVector) 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)@@ -319,7 +386,9 @@ 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' : 'l' : 'o' : 'a' : 't' : '1' : '2' : '8' : []) = tok 10 (CTokFloatN 128 False) idkwtok ('f' : 'o' : 'r' : []) = tok 3 CTokFor+idkwtok ('_' : '_' : 'f' : 'p' : '1' : '6' : []) = tok 6 (CTokFloatN 16 False) idkwtok ('g' : 'o' : 't' : 'o' : []) = tok 4 CTokGoto idkwtok ('i' : 'f' : []) = tok 2 CTokIf idkwtok ('_' : '_' : 'i' : 'm' : 'a' : 'g' : []) = tok 6 (CTokGnuC GnuCComplexImag)@@ -328,8 +397,12 @@ 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 ('_' : '_' : 'i' : 'n' : 't' : '1' : '2' : '8' : []) = tok 8 CTokInt128+idkwtok ('_' : '_' : 'i' : 'n' : 't' : '1' : '2' : '8' : '_' : 't' : []) = tok 10 CTokInt128 idkwtok ('_' : '_' : 'l' : 'a' : 'b' : 'e' : 'l' : '_' : '_' : []) = tok 9 CTokLabel idkwtok ('l' : 'o' : 'n' : 'g' : []) = tok 4 CTokLong+idkwtok ('_' : '_' : 'n' : 'o' : 'n' : 'n' : 'u' : 'l' : 'l' : []) = tok 9 CTokNonnull+idkwtok ('_' : '_' : 'n' : 'u' : 'l' : 'l' : 'a' : 'b' : 'l' : 'e' : []) = tok 10 CTokNullable 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@@ -350,6 +423,8 @@ 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' : 'i' : 'n' : 't' : '1' : '2' : '8' : []) = tok 9 (CTokUInt128)+idkwtok ('_' : '_' : 'u' : 'i' : 'n' : 't' : '1' : '2' : '8' : '_' : 't' : []) = tok 11 (CTokUInt128) 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@@ -358,6 +433,13 @@ idkwtok ('_' : '_' : 'v' : 'o' : 'l' : 'a' : 't' : 'i' : 'l' : 'e' : '_' : '_' : []) = tok 12 CTokVolatile idkwtok ('w' : 'h' : 'i' : 'l' : 'e' : []) = tok 5 CTokWhile +-- For OpenCL tokens+idkwtok ('_' : '_' : 'k' : 'e' : 'r' : 'n' : 'e' : 'l' : []) = tok 8 CTokClKernel+idkwtok ('_' : '_' : 'r' : 'e' : 'a' : 'd' : '_' : 'o' : 'n' : 'l' : 'y' : []) = tok 11 CTokClRdOnly+idkwtok ('_' : '_' : 'w' : 'r' : 'i' : 't' : 'e' : '_' : 'o' : 'n' : 'l' : 'y' : []) = tok 12 CTokClWrOnly+idkwtok ('_' : '_' : 'g' : 'l' : 'o' : 'b' : 'a' : 'l' : []) = tok 8 CTokClGlobal+idkwtok ('_' : '_' : 'l' : 'o' : 'c' : 'a' : 'l' : []) = tok 7 CTokClLocal+ idkwtok cs = \pos -> do name <- getNewName let len = case length cs of l -> l@@ -371,8 +453,8 @@ ignoreAttribute = skipTokens (0::Int) where skipTokens :: Int -> P () skipTokens n = do- tok <- lexToken' False- case tok of+ ntok <- lexToken' False+ case ntok of CTokRParen _ | n == 1 -> return () | otherwise -> skipTokens (n-1) CTokLParen _ -> skipTokens (n+1)@@ -383,19 +465,38 @@ adjustLineDirective :: Int -> String -> Position -> Position adjustLineDirective pragmaLen str pos =- offs' `seq` fname' `seq` row' `seq` (position offs' fname' row' 1)+ offs' `seq` fname' `seq` row' `seq` parent' `seq` (position offs' fname' row' 1 parent') where+ -- offset changes by length of #line pragma offs' = (posOffset pos) + pragmaLen str' = dropWhite . drop 1 $ str (rowStr, str'') = span isDigit str'+ -- row changes to the first number in the line pragma row' = read rowStr str''' = dropWhite str''- fnameStr = takeWhile (/= '"') . drop 1 $ str'''+ (fnameStr,str'''') = span (/= '"') . 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+ no_fn = null str''' || (fmap fst (uncons str''') /= Just '"') || (fmap fst (uncons str'''') /= Just '"')+ -- filename changes to new filename, if specified+ fname' | no_fn = fname+ -- try and get more sharing of file name strings+ | fnameStr == fname = fname+ | otherwise = fnameStr+ -- analye flags+ min_flag = find_min_flag (5 :: Int) (drop 1 str'''')+ find_min_flag cur_min = select_min . span isDigit . dropWhile (not . isDigit)+ where+ select_min (numStr, fstr') | null numStr = cur_min+ | otherwise = find_min_flag (read numStr `min` cur_min) fstr'+ parent = posParent pos+ parent' = case min_flag of+ 1 -> Just pos -- push+ 2 -> case parent >>= posParent of+ Nothing -> Nothing -- pop/underflow+ Just gp -> gp `seq` Just gp -- pop+ 3 -> parent -- unchanged stack, system header info+ 4 -> parent -- unchanged stack, extern C info+ _ -> Nothing -- dropWhite = dropWhile (\c -> c == ' ' || c == '\t') @@ -408,7 +509,7 @@ {-# INLINE token_ #-} -- token that ignores the string token_ :: Int -> (PosLength -> CToken) -> Position -> Int -> InputStream -> P CToken-token_ len tok pos _ _ = return (tok (pos,len))+token_ len mkTok pos _ _ = return (mkTok (pos,len)) {-# INLINE token_fail #-} -- error token@@ -421,15 +522,15 @@ -- 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))+token mkTok fromStr pos len str = return (mkTok (pos,len) (fromStr $ 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+token_plus mkTok fromStr pos len str =+ case fromStr (takeChars len str) of Left err -> failP pos [ "Lexical error ! ", err ]+ Right ok -> return $! mkTok (pos,len) ok -- ----------------------------------------------------------------------------- -- The input type@@ -463,17 +564,17 @@ lexicalError :: P a lexicalError = do pos <- getPos- (c,cs) <- liftM takeChar getInput+ (c,_) <- 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)+ lastTok <- getLastToken+ failP (posOf lastTok) ["Syntax error !",- "The symbol `" ++ show tok ++ "' does not fit here."]+ "The symbol `" ++ show lastTok ++ "' does not fit here."] -- there is a problem with ignored tokens here (that aren't skipped) -- consider@@ -498,20 +599,20 @@ AlexEOF -> do handleEofToken return CTokEof- AlexError inp' -> lexicalError- AlexSkip (pos', inp') len -> do+ 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+ nextTok <- action pos len inp+ when modifyCache $ setLastToken nextTok+ return nextTok lexC :: (CToken -> P a) -> P a lexC cont = do- tok <- lexToken- cont tok+ nextTok <- lexToken+ cont nextTok }
src/Language/C/Parser/Parser.y view
@@ -29,6 +29,8 @@ -- <http://www.sivity.net/projects/language.c/wiki/Cee> ------------------------------------------------------------------ {+{-# LANGUAGE LambdaCase #-}+ module Language.C.Parser.Parser ( -- * Parse a C translation unit parseC,@@ -94,6 +96,7 @@ -- --- TODO ---------------------------------------------------------------------- --+-- !* We ignore C11 _Atomic type annotations -- !* 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)@@ -102,16 +105,18 @@ -- !* see `We're being far to liberal here' (... struct definition within structs) -- * Documentation isn't complete and consistent yet. -import Prelude hiding (reverse)+import Prelude import qualified Data.List as List import Control.Monad (mplus)+import Data.Maybe (listToMaybe, mapMaybe) 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.Tokens (CToken(..), GnuCTok(..), ClangCTok (..), 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.RList (Reversed(..))+import qualified Language.C.Data.RList as RList import Language.C.Data.InputStream import Language.C.Data.Ident import Language.C.Data.Name@@ -182,6 +187,8 @@ '}' { CTokRBrace _ } "..." { CTokEllipsis _ } alignof { CTokAlignof _ }+alignas { CTokAlignas _ }+"_Atomic" { CTokAtomic _ } asm { CTokAsm _ } auto { CTokAuto _ } break { CTokBreak _ }@@ -198,13 +205,30 @@ enum { CTokEnum _ } extern { CTokExtern _ } float { CTokFloat _ }+"__bf16" { CTokBFloat16 _ }+"__fp16" { CTokFloatN 16 False _ }+"_Float16" { CTokFloatN 16 False _ }+"_Float16x" { CTokFloatN 16 True _ }+"_Float32" { CTokFloatN 32 False _ }+"_Float32x" { CTokFloatN 32 True _ }+"_Float64" { CTokFloatN 64 False _ }+"_Float64x" { CTokFloatN 64 True _ }+"_Float128" { CTokFloatN 128 False _ }+"_Float128x" { CTokFloatN 128 True _ }+"__float128" { CTokFloatN 128 False _ } for { CTokFor _ }+"_Generic" { CTokGeneric _ } goto { CTokGoto _ } if { CTokIf _ } inline { CTokInline _ } int { CTokInt _ }+"__int128" { CTokInt128 _ }+"__int128_t" { CTokInt128 _ } long { CTokLong _ } "__label__" { CTokLabel _ }+"_Noreturn" { CTokNoreturn _ }+"_Nullable" { CTokNullable _ }+"_Nonnull" { CTokNonnull _ } register { CTokRegister _ } restrict { CTokRestrict _ } return { CTokReturn _ }@@ -212,12 +236,15 @@ signed { CTokSigned _ } sizeof { CTokSizeof _ } static { CTokStatic _ }+"_Static_assert"{ CTokStaticAssert _ } struct { CTokStruct _ } switch { CTokSwitch _ } typedef { CTokTypedef _ } typeof { CTokTypeof _ } "__thread" { CTokThread _ } union { CTokUnion _ }+"__uint128" { CTokUInt128 _ }+"__uint128_t" { CTokUInt128 _ } unsigned { CTokUnsigned _ } void { CTokVoid _ } volatile { CTokVolatile _ }@@ -236,6 +263,14 @@ "__builtin_va_arg" { CTokGnuC GnuCVaArg _ } "__builtin_offsetof" { CTokGnuC GnuCOffsetof _ } "__builtin_types_compatible_p" { CTokGnuC GnuCTyCompat _ }+"__builtin_convertvector" { CTokClangC _ ClangBuiltinConvertVector }+clangcversion { CTokClangC _ (ClangCVersionTok $$) } -- Clang version literal+"__builtin_bit_cast" { CTokClangC _ ClangCBitCast }+"__kernel" { CTokClKernel _ } -- OpenCL kernel function+"__read_only" { CTokClRdOnly _ } -- OpenCL read only qualifier+"__write_only" { CTokClWrOnly _ } -- OpenCL write only qualifier+"__global" { CTokClGlobal _ } -- OpenCL global variable+"__local" { CTokClLocal _ } -- OpenCL local variable %% @@ -244,7 +279,7 @@ -- we have to take special care of empty translation units translation_unit :: { CTranslUnit } translation_unit- : ext_decl_list {% let decls = reverse $1 in+ : ext_decl_list {% let decls = RList.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 }@@ -255,24 +290,23 @@ -- * GNU extensions: -- allow empty translation_unit -- allow redundant ';'--- ext_decl_list :: { Reversed [CExtDecl] } ext_decl_list- : {- empty -} { empty }+ : {- empty -} { RList.empty } | ext_decl_list ';' { $1 }- | ext_decl_list external_declaration { $1 `snoc` $2 }+ | ext_decl_list external_declaration { $1 `RList.snoc` $2 } -- parse external C declaration (C99 6.9) -- -- * GNU extensions:--- allow extension keyword before external declaration+-- allow extension keyword before external declaration (TODO: discarded) -- asm definitions external_declaration :: { CExtDecl } external_declaration- : function_definition { CFDefExt $1 }+ : function_definition { CFDefExt $1 } | declaration { CDeclExt $1 }- | "__extension__" external_declaration { $2 }+ | "__extension__" external_declaration { $2 } | asm '(' string_literal ')' ';' {% withNodeInfo $1 $ CAsmExt $3 } @@ -295,10 +329,10 @@ function_definition :: { CFunDef } function_definition : function_declarator compound_statement- {% leaveScope >> (withNodeInfo $1 $ CFunDef [] $1 [] $2) }+ {% leaveScope >> (withNodeInfo $1 $ CFunDef [] $1 [] $2) } - | attrs function_declarator compound_statement- {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftCAttrs $1) $2 [] $3) }+ | 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) }@@ -307,36 +341,36 @@ {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) } | declaration_qualifier_list function_declarator compound_statement- {% leaveScope >> (withNodeInfo $1 $ CFunDef (reverse $1) $2 [] $3) }+ {% leaveScope >> (withNodeInfo $1 $ CFunDef (RList.reverse $1) $2 [] $3) } - | type_qualifier_list function_declarator compound_statement+ | type_qualifier_list function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 [] $3) } - | type_qualifier_list attrs function_declarator compound_statement+ | 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 }+ {% withNodeInfo $1 $ CFunDef [] $1 (RList.reverse $2) $3 } | attrs function_declarator_old declaration_list compound_statement- {% withNodeInfo $2 $ CFunDef (liftCAttrs $1) $2 (reverse $3) $4 }+ {% withNodeInfo $2 $ CFunDef (liftCAttrs $1) $2 (RList.reverse $3) $4 } | declaration_specifier function_declarator_old declaration_list compound_statement- {% withNodeInfo $1 $ CFunDef $1 $2 (reverse $3) $4 }+ {% withNodeInfo $1 $ CFunDef $1 $2 (RList.reverse $3) $4 } | type_specifier function_declarator_old declaration_list compound_statement- {% withNodeInfo $1 $ CFunDef $1 $2 (reverse $3) $4 }+ {% withNodeInfo $1 $ CFunDef $1 $2 (RList.reverse $3) $4 } | declaration_qualifier_list function_declarator_old declaration_list compound_statement- {% withNodeInfo $1 $ CFunDef (reverse $1) $2 (reverse $3) $4 }+ {% withNodeInfo $1 $ CFunDef (RList.reverse $1) $2 (RList.reverse $3) $4 } | type_qualifier_list function_declarator_old declaration_list compound_statement- {% withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 (reverse $3) $4 }+ {% withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 (RList.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 }+ {% withNodeInfo $1 $ CFunDef (liftTypeQuals $1 ++ liftCAttrs $2) $3 (RList.reverse $4) $5 } -- Read declarator and put function function_declarator :: { CDeclr }@@ -381,10 +415,10 @@ compound_statement :: { CStat } compound_statement : '{' enter_scope block_item_list leave_scope '}'- {% withNodeInfo $1 $ CCompound [] (reverse $3) }+ {% withNodeInfo $1 $ CCompound [] (RList.reverse $3) } | '{' enter_scope label_declarations block_item_list leave_scope '}'- {% withNodeInfo $1 $ CCompound (reverse $3) (reverse $4) }+ {% withNodeInfo $1 $ CCompound (RList.reverse $3) (RList.reverse $4) } -- No syntax for these, just side effecting semantic actions.@@ -397,8 +431,8 @@ block_item_list :: { Reversed [CBlockItem] } block_item_list- : {- empty -} { empty }- | block_item_list block_item { $1 `snoc` $2 }+ : {- empty -} { RList.empty }+ | block_item_list block_item { $1 `RList.snoc` $2 } block_item :: { CBlockItem } block_item@@ -420,7 +454,7 @@ {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) } | declaration_qualifier_list function_declarator compound_statement- {% leaveScope >> (withNodeInfo $1 $ CFunDef (reverse $1) $2 [] $3) }+ {% leaveScope >> (withNodeInfo $1 $ CFunDef (RList.reverse $1) $2 [] $3) } | type_qualifier_list function_declarator compound_statement {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 [] $3) }@@ -431,8 +465,8 @@ label_declarations :: { Reversed [Ident] } label_declarations- : "__label__" identifier_list ';' { $2 } --TODO- | label_declarations "__label__" identifier_list ';' { $1 `rappendr` $3 }+ : "__label__" identifier_list ';' { $2 }+ | label_declarations "__label__" identifier_list ';' { $1 `RList.rappendr` $3 } -- parse C expression statement (C99 6.8.3)@@ -453,7 +487,7 @@ | if '(' expression ')' statement else statement {% withNodeInfo $1 $ CIf $3 $5 (Just $7) } - | switch '(' expression ')' statement + | switch '(' expression ')' statement {% withNodeInfo $1 $ CSwitch $3 $5 } @@ -505,7 +539,7 @@ {% 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) }+ {% withNodeInfo $1 $ CAsmStmt $2 $4 $6 $8 $10 } maybe_type_qualifier :: { Maybe CTypeQual }@@ -516,12 +550,12 @@ asm_operands :: { [CAsmOperand] } asm_operands : {- empty -} { [] }- | nonnull_asm_operands { reverse $1 }+ | nonnull_asm_operands { RList.reverse $1 } nonnull_asm_operands :: { Reversed [CAsmOperand] } nonnull_asm_operands- : asm_operand { singleton $1 }- | nonnull_asm_operands ',' asm_operand { $1 `snoc` $3 }+ : asm_operand { RList.singleton $1 }+ | nonnull_asm_operands ',' asm_operand { $1 `RList.snoc` $3 } asm_operand :: { CAsmOperand } asm_operand@@ -529,12 +563,16 @@ | '[' 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 :: { [CStrLit] } asm_clobbers- : string_literal { singleton $1 }- | asm_clobbers ',' string_literal { $1 `snoc` $3 }+ : {- empty -} { [] }+ | nonnull_asm_clobbers { RList.reverse $1 } +nonnull_asm_clobbers :: { Reversed [CStrLit] }+nonnull_asm_clobbers+ : string_literal { RList.singleton $1 }+ | nonnull_asm_clobbers ',' string_literal { $1 `RList.snoc` $3 }+ {- --------------------------------------------------------------------------------------------------------------- ---------------------------------------------------------------------------------------------------------------@@ -543,18 +581,20 @@ --------------------------------------------------------------------------------------------------------------- Declarations are the most complicated part of the grammar, and shall be summarized here.-To allow a lightweight notation, we will use the modifier <permute> to indicate that the order of the immidieate right-hand-sides doesn't matter.+To allow a lightweight notation, we will use the modifier <permute> to indicate that the order of the immidieate right-hand sides doesn't matter. - <permute> 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+storage_class :- typedef | extern | static | auto | register | _Thread_local | __kernel | __global | __local+function_specifier :- inline | _Noreturn+alignment_specifier :- _Alignas (type_name) | _Alignas (constant_expr)++type_qualifier :- const | volatile | restrict | _Atomic | _Nullable | _Nonnull | __read_only | __write_only type_qualifier_list :- type_qualifier+ -declaration_qualifier :- storage_class | type_qualifier+declaration_qualifier :- storage_class | type_qualifier | function_specifier | alginment_specifier declaration_qualifier_list :- <permute> type_qualifier* storage_class+ qualifiers :- declaration_qualifier_list | type_qualifier_list@@ -593,7 +633,7 @@ -- Declaration ----------------------------------------------------------------------------------------------------------------declaration = sue_declaration | declaration_list+declaration = sue_declaration | declaration_list | _Static_assert(..) --------------------------------------------------------------------------------------------------------------- ---------------------------------------------------------------------------------------------------------------@@ -640,26 +680,30 @@ --- parse C declaration (C99 6.7)+-- parse C declaration (C11 6.7)+--+-- * new form in C11+-- _Static_assert(expr,string_literal) declaration :: { CDecl } declaration : sue_declaration_specifier ';'- {% withNodeInfo $1 $ CDecl (reverse $1) [] }+ {% withNodeInfo $1 $ CDecl (RList.reverse $1) [] } | sue_type_specifier ';'- {% withNodeInfo $1 $ CDecl (reverse $1) [] }+ {% withNodeInfo $1 $ CDecl (RList.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)) }-+ | "_Static_assert" '(' constant_expression ',' string_literal ')' ';'+ {% withNodeInfo $1 $ CStaticAssert $3 $5 } declaration_list :: { Reversed [CDecl] } declaration_list- : {- empty -} { empty }- | declaration_list declaration { $1 `snoc` $2 }+ : {- empty -} { RList.empty }+ | declaration_list declaration { $1 `RList.snoc` $2 } -- * SUMMARY: default_declaring_list :- qualifier* identifier_declarator asm_attrs initializer?@@ -673,7 +717,7 @@ default_declaring_list :: { CDecl } default_declaring_list : declaration_qualifier_list identifier_declarator asm_attrs_opt {-{}-} initializer_opt- {% let declspecs = reverse $1 in+ {% let declspecs = RList.reverse $1 in do{ declr <- withAsmNameAttrs $3 $2 ; doDeclIdent declspecs declr ; withNodeInfo $1 $@@ -749,48 +793,59 @@ -- 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+ : basic_declaration_specifier { RList.reverse $1 } -- Arithmetic or void+ | sue_declaration_specifier { RList.reverse $1 } -- Struct/Union/Enum+ | typedef_declaration_specifier { RList.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.+-- A mixture of type qualifiers (const, volatile, restrict, _Atomic, _Nonnull, _Nullable, __read_only, __write_only),+-- function specifiers (inline, _Noreturn),+-- alignment specifiers (_Alignas) and+-- storage class specifiers (extern, static, auto, register, _Thread_local, __kernel, __global, __local),+-- in any order, but containing at least one storage class specifier. ----- declaration_qualifier_list :- <permute> type_qualifier* storage_class++-- declaration_qualifier_list :- <permute> type_qualifier* alignment_specifier* function_specifier* storage_class+ -- -- GNU extensions -- * arbitrary interleaved __attribute__ annotations -- declaration_qualifier_list :: { Reversed [CDeclSpec] } declaration_qualifier_list- : storage_class- { singleton (CStorageSpec $1) }+ : declaration_qualifier_without_types+ { RList.singleton $1 } - | attrs storage_class- { reverseList (liftCAttrs $1) `snoc` (CStorageSpec $2) }+ | attrs declaration_qualifier_without_types+ { reverseList (liftCAttrs $1) `RList.snoc` $2 } - | type_qualifier_list storage_class- { rmap CTypeQual $1 `snoc` CStorageSpec $2 }+ | type_qualifier_list declaration_qualifier_without_types+ { RList.rmap CTypeQual $1 `RList.snoc` $2 } - | type_qualifier_list attrs storage_class- { (rmap CTypeQual $1 `rappend` liftCAttrs $2) `snoc` CStorageSpec $3 }+ | type_qualifier_list attrs declaration_qualifier_without_types+ { (RList.rmap CTypeQual $1 `RList.rappend` liftCAttrs $2) `RList.snoc` $3 } | declaration_qualifier_list declaration_qualifier- { $1 `snoc` $2 }+ { $1 `RList.snoc` $2 } | declaration_qualifier_list attr { addTrailingAttrs $1 $2 } ----- declaration_qualifier :- storage_class | type_qualifier+-- declaration_qualifier :- storage_class | type_qualifier | function_specifier | alignment_specifier -- declaration_qualifier :: { CDeclSpec } declaration_qualifier- : storage_class { CStorageSpec $1 }- | type_qualifier { CTypeQual $1 } -- const or volatile+ : storage_class { CStorageSpec $1 }+ | type_qualifier { CTypeQual $1 }+ | function_specifier { CFunSpec $1 }+ | alignment_specifier { CAlignSpec $1 } +declaration_qualifier_without_types :: { CDeclSpec }+ : storage_class { CStorageSpec $1 }+ | function_specifier { CFunSpec $1 }+ | alignment_specifier { CAlignSpec $1 }++ -- parse C storage class specifier (C99 6.7.1) -- -- * GNU extensions: '__thread' thread local storage@@ -803,8 +858,22 @@ | auto {% withNodeInfo $1 $ CAuto } | register {% withNodeInfo $1 $ CRegister } | "__thread" {% withNodeInfo $1 $ CThread }+ | "__kernel" {% withNodeInfo $1 $ CClKernel }+ | "__global" {% withNodeInfo $1 $ CClGlobal }+ | "__local" {% withNodeInfo $1 $ CClLocal } +-- parse C function specifier (C11 6.7.4)+function_specifier :: { CFunSpec }+function_specifier+ : inline {% withNodeInfo $1 $ CInlineQual }+ | "_Noreturn" {% withNodeInfo $1 $ CNoreturnQual } +-- parse C alignment specifier (C11 6.7.5)+alignment_specifier :: { CAlignSpec }+alignment_specifier+ : alignas '(' type_name ')' {% withNodeInfo $1 $ CAlignAsType $3 }+ | alignas '(' constant_expression ')' {% withNodeInfo $1 $ CAlignAsExpr $3 }+ -- parse C type specifier (C99 6.7.2) -- -- This recignises a whole list of type specifiers rather than just one@@ -812,11 +881,14 @@ -- -- type_specifier :- <permute> type_qualifier* (basic_type_name+ | elaborated_type_name | g) --+-- Type specifier _Atomic(type) is not yet supported because of conflicts with type qualifier _Atomic 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_specifier { RList.reverse $1 } -- Arithmetic or void+ | sue_type_specifier { RList.reverse $1 } -- Struct/Union/Enum+ | typedef_type_specifier { RList.reverse $1 } -- Typedef+-- | "_Atomic" '(' type_name ')' -- _Atomic(type)+-- {% withNodeInfo $1 $ \at -> [CTypeSpec (CAtomicType $3 at)] } basic_type_name :: { CTypeSpec } basic_type_name@@ -831,8 +903,24 @@ | unsigned {% withNodeInfo $1 $ CUnsigType } | "_Bool" {% withNodeInfo $1 $ CBoolType } | "_Complex" {% withNodeInfo $1 $ CComplexType }+ | "__int128" {% withNodeInfo $1 $ CInt128Type }+ | "__int128_t" {% withNodeInfo $1 $ CInt128Type }+ | "__uint128" {% withNodeInfo $1 $ CUInt128Type }+ | "__uint128_t" {% withNodeInfo $1 $ CUInt128Type }+ | "__bf16" {% withNodeInfo $1 $ CBFloat16Type }+ | "__fp16" {% withNodeInfo $1 $ (CFloatNType 16 False) }+ | "_Float16" {% withNodeInfo $1 $ (CFloatNType 16 False) }+ | "_Float16x" {% withNodeInfo $1 $ (CFloatNType 16 True) }+ | "_Float32" {% withNodeInfo $1 $ (CFloatNType 32 False) }+ | "_Float32x" {% withNodeInfo $1 $ (CFloatNType 32 True) }+ | "_Float64" {% withNodeInfo $1 $ (CFloatNType 64 False) }+ | "_Float64x" {% withNodeInfo $1 $ (CFloatNType 64 True) }+ | "_Float128" {% withNodeInfo $1 $ (CFloatNType 128 False) }+ | "_Float128x" {% withNodeInfo $1 $ (CFloatNType 128 True) }+ | "__float128" {% withNodeInfo $1 $ (CFloatNType 128 False) } + -- 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.@@ -845,16 +933,16 @@ basic_declaration_specifier :: { Reversed [CDeclSpec] } basic_declaration_specifier : declaration_qualifier_list basic_type_name- { $1 `snoc` CTypeSpec $2 }+ { $1 `RList.snoc` CTypeSpec $2 } | basic_type_specifier storage_class- { $1 `snoc` CStorageSpec $2 }+ { $1 `RList.snoc` CStorageSpec $2 } | basic_declaration_specifier declaration_qualifier- { $1 `snoc` $2 }+ { $1 `RList.snoc` $2 } | basic_declaration_specifier basic_type_name- { $1 `snoc` CTypeSpec $2 }+ { $1 `RList.snoc` CTypeSpec $2 } | basic_declaration_specifier attr { addTrailingAttrs $1 $2 }@@ -872,22 +960,22 @@ basic_type_specifier -- Arithmetic or void : basic_type_name- { singleton (CTypeSpec $1) }+ { RList.singleton (CTypeSpec $1) } | attrs basic_type_name- { (reverseList $ liftCAttrs $1) `snoc` (CTypeSpec $2) }+ { (reverseList $ liftCAttrs $1) `RList.snoc` (CTypeSpec $2) } | type_qualifier_list basic_type_name- { rmap CTypeQual $1 `snoc` CTypeSpec $2 }+ { RList.rmap CTypeQual $1 `RList.snoc` CTypeSpec $2 } | type_qualifier_list attrs basic_type_name- { rmap CTypeQual $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec $3 }+ { RList.rmap CTypeQual $1 `RList.rappend` (liftCAttrs $2) `RList.snoc` CTypeSpec $3 } | basic_type_specifier type_qualifier- { $1 `snoc` CTypeQual $2 }+ { $1 `RList.snoc` CTypeQual $2 } | basic_type_specifier basic_type_name- { $1 `snoc` CTypeSpec $2 }+ { $1 `RList.snoc` CTypeSpec $2 } | basic_type_specifier attr { addTrailingAttrs $1 $2 }@@ -902,14 +990,14 @@ sue_declaration_specifier :: { Reversed [CDeclSpec] } sue_declaration_specifier : declaration_qualifier_list elaborated_type_name- { $1 `snoc` CTypeSpec $2 }+ { $1 `RList.snoc` CTypeSpec $2 } | sue_type_specifier storage_class- { $1 `snoc` CStorageSpec $2 }+ { $1 `RList.snoc` CStorageSpec $2 } | sue_declaration_specifier declaration_qualifier- { $1 `snoc` $2 }- + { $1 `RList.snoc` $2 }+ | sue_declaration_specifier attr { addTrailingAttrs $1 $2 } @@ -926,20 +1014,20 @@ sue_type_specifier -- struct/union/enum : elaborated_type_name- { singleton (CTypeSpec $1) }+ { RList.singleton (CTypeSpec $1) } | attrs elaborated_type_name- { (reverseList $ liftCAttrs $1) `snoc` (CTypeSpec $2) }+ { (reverseList $ liftCAttrs $1) `RList.snoc` (CTypeSpec $2) } | type_qualifier_list elaborated_type_name- { rmap CTypeQual $1 `snoc` CTypeSpec $2 }+ { RList.rmap CTypeQual $1 `RList.snoc` CTypeSpec $2 } | type_qualifier_list attrs elaborated_type_name- { rmap CTypeQual $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec $3 }+ { RList.rmap CTypeQual $1 `RList.rappend` (liftCAttrs $2) `RList.snoc` CTypeSpec $3 } | sue_type_specifier type_qualifier- { $1 `snoc` CTypeQual $2 }- + { $1 `RList.snoc` CTypeQual $2 }+ | sue_type_specifier attr { addTrailingAttrs $1 $2 } @@ -955,19 +1043,19 @@ typedef_declaration_specifier :: { Reversed [CDeclSpec] } typedef_declaration_specifier : typedef_type_specifier storage_class- { $1 `snoc` CStorageSpec $2 }- + { $1 `RList.snoc` CStorageSpec $2 }+ | declaration_qualifier_list tyident- {% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (CTypeDef $2 at) }+ {% withNodeInfo $2 $ \at -> $1 `RList.snoc` CTypeSpec (CTypeDef $2 at) } | declaration_qualifier_list typeof '(' expression ')'- {% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (CTypeOfExpr $4 at) }+ {% withNodeInfo $2 $ \at -> $1 `RList.snoc` CTypeSpec (CTypeOfExpr $4 at) } | declaration_qualifier_list typeof '(' type_name ')'- {% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (CTypeOfType $4 at) }+ {% withNodeInfo $2 $ \at -> $1 `RList.snoc` CTypeSpec (CTypeOfType $4 at) } | typedef_declaration_specifier declaration_qualifier- { $1 `snoc` $2 }+ { $1 `RList.snoc` $2 } | typedef_declaration_specifier attr { addTrailingAttrs $1 $2 }@@ -981,44 +1069,44 @@ typedef_type_specifier :: { Reversed [CDeclSpec] } typedef_type_specifier : tyident- {% withNodeInfo $1 $ \at -> singleton (CTypeSpec (CTypeDef $1 at)) }+ {% withNodeInfo $1 $ \at -> RList.singleton (CTypeSpec (CTypeDef $1 at)) } | typeof '(' expression ')'- {% withNodeInfo $1 $ \at -> singleton (CTypeSpec (CTypeOfExpr $3 at)) }+ {% withNodeInfo $1 $ \at -> RList.singleton (CTypeSpec (CTypeOfExpr $3 at)) } | typeof '(' type_name ')'- {% withNodeInfo $1 $ \at -> singleton (CTypeSpec (CTypeOfType $3 at)) }+ {% withNodeInfo $1 $ \at -> RList.singleton (CTypeSpec (CTypeOfType $3 at)) } | type_qualifier_list tyident- {% withNodeInfo $2 $ \at -> rmap CTypeQual $1 `snoc` CTypeSpec (CTypeDef $2 at) }+ {% withNodeInfo $2 $ \at -> RList.rmap CTypeQual $1 `RList.snoc` CTypeSpec (CTypeDef $2 at) } | type_qualifier_list typeof '(' expression ')'- {% withNodeInfo $2 $ \at -> rmap CTypeQual $1 `snoc` CTypeSpec (CTypeOfExpr $4 at) }+ {% withNodeInfo $2 $ \at -> RList.rmap CTypeQual $1 `RList.snoc` CTypeSpec (CTypeOfExpr $4 at) } | type_qualifier_list typeof '(' type_name ')'- {% withNodeInfo $2 $ \at -> rmap CTypeQual $1 `snoc` CTypeSpec (CTypeOfType $4 at) }+ {% withNodeInfo $2 $ \at -> RList.rmap CTypeQual $1 `RList.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)) }+ {% withNodeInfo $2 $ \at -> reverseList (liftCAttrs $1) `RList.snoc` (CTypeSpec (CTypeDef $2 at)) } | attrs typeof '(' expression ')'- {% withNodeInfo $1 $ \at -> reverseList (liftCAttrs $1) `snoc` (CTypeSpec (CTypeOfExpr $4 at)) }+ {% withNodeInfo $1 $ \at -> reverseList (liftCAttrs $1) `RList.snoc` (CTypeSpec (CTypeOfExpr $4 at)) } | attrs typeof '(' type_name ')'- {% withNodeInfo $2 $ \at -> reverseList (liftCAttrs $1) `snoc` (CTypeSpec (CTypeOfType $4 at)) }+ {% withNodeInfo $2 $ \at -> reverseList (liftCAttrs $1) `RList.snoc` (CTypeSpec (CTypeOfType $4 at)) } | type_qualifier_list attrs tyident- {% withNodeInfo $3 $ \at -> rmap CTypeQual $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec (CTypeDef $3 at) }+ {% withNodeInfo $3 $ \at -> RList.rmap CTypeQual $1 `RList.rappend` (liftCAttrs $2) `RList.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) }+ {% withNodeInfo $3 $ \at -> RList.rmap CTypeQual $1 `RList.rappend` (liftCAttrs $2) `RList.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) }+ {% withNodeInfo $3 $ \at -> RList.rmap CTypeQual $1 `RList.rappend` (liftCAttrs $2) `RList.snoc` CTypeSpec (CTypeOfType $5 at) } | typedef_type_specifier type_qualifier- { $1 `snoc` CTypeQual $2 }+ { $1 `RList.snoc` CTypeQual $2 } | typedef_type_specifier attr { addTrailingAttrs $1 $2 }@@ -1043,11 +1131,9 @@ 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 }-+ {% withNodeInfo $1 $ CStruct (unL $1) (Just $3) (Just$ RList.reverse $5) $2 } | struct_or_union attrs_opt '{' struct_declaration_list '}'- {% withNodeInfo $1 $ CStruct (unL $1) Nothing (Just$ reverse $4) $2 }-+ {% withNodeInfo $1 $ CStruct (unL $1) Nothing (Just$ RList.reverse $4) $2 } | struct_or_union attrs_opt identifier {% withNodeInfo $1 $ CStruct (unL $1) (Just $3) Nothing $2 } @@ -1060,9 +1146,10 @@ struct_declaration_list :: { Reversed [CDecl] } struct_declaration_list- : {- empty -} { empty }+ : {- empty -} { RList.empty } | struct_declaration_list ';' { $1 }- | struct_declaration_list struct_declaration { $1 `snoc` $2 }+ | struct_declaration_list struct_declaration { $1 `RList.snoc` maybe $2 (addAlign $2) (containsAlign $1) }+ | struct_declaration_list alignment_specifier struct_declaration { $1 `RList.snoc` ( addAlign $3 $2 )} -- parse C structure declaration (C99 6.7.2.1)@@ -1154,50 +1241,56 @@ enum_specifier :: { CEnum } enum_specifier : enum attrs_opt '{' enumerator_list '}'- {% withNodeInfo $1 $ CEnum Nothing (Just$ reverse $4) $2 }+ {% withNodeInfo $1 $ CEnum Nothing (Just$ RList.reverse $4) $2 } | enum attrs_opt '{' enumerator_list ',' '}'- {% withNodeInfo $1 $ CEnum Nothing (Just$ reverse $4) $2 }+ {% withNodeInfo $1 $ CEnum Nothing (Just$ RList.reverse $4) $2 } | enum attrs_opt identifier '{' enumerator_list '}'- {% withNodeInfo $1 $ CEnum (Just $3) (Just$ reverse $5) $2 }+ {% withNodeInfo $1 $ CEnum (Just $3) (Just$ RList.reverse $5) $2 } | enum attrs_opt identifier '{' enumerator_list ',' '}'- {% withNodeInfo $1 $ CEnum (Just $3) (Just$ reverse $5) $2 }+ {% withNodeInfo $1 $ CEnum (Just $3) (Just$ RList.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 { RList.singleton $1 }+ | enumerator_list ',' enumerator { $1 `RList.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) }+ : identifier { ($1, Nothing) }+ | identifier attrs { ($1, Nothing) }+ | identifier attrs '=' constant_expression { ($1, Just $4) }+ | identifier '=' constant_expression { ($1, Just $3) } --- parse C type qualifier (C99 6.7.3)+-- parse C type qualifier (C11 6.7.3) --+-- concerning atomic, note: If the _Atomic keyword is immediately followed by a left+-- parenthesis, it should be interpreted as a type specifier (with a type name), not as a type qualifier type_qualifier :: { CTypeQual } type_qualifier : const {% withNodeInfo $1 $ CConstQual } | volatile {% withNodeInfo $1 $ CVolatQual } | restrict {% withNodeInfo $1 $ CRestrQual }- | inline {% withNodeInfo $1 $ CInlineQual }+ | "_Nullable" {% withNodeInfo $1 $ CNullableQual }+ | "_Nonnull" {% withNodeInfo $1 $ CNonnullQual }+ | "_Atomic" {% withNodeInfo $1 $ CAtomicQual }+ | "__read_only" {% withNodeInfo $1 $ CClRdOnlyQual }+ | "__write_only" {% withNodeInfo $1 $ CClWrOnlyQual } --- a list containing at least one type_qualifier (const, volatile, restrict, inline)+-- a list containing at least one type_qualifier (const, volatile, restrict, inline, _Noreturn, __read_only, __write_only) -- 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} + : attrs_opt type_qualifier { reverseList (map CAttrQual $1) `RList.snoc` $2 }+ | type_qualifier_list type_qualifier { $1 `RList.snoc` $2 }+ | type_qualifier_list attrs type_qualifier { ($1 `RList.rappend` map CAttrQual $2) `RList.snoc` $3} -- parse C declarator (C99 6.7.5) --@@ -1261,10 +1354,10 @@ {% withAttribute $1 $2 $ ptrDeclr $3 [] } | '*' type_qualifier_list parameter_typedef_declarator- {% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) }+ {% withNodeInfo $1 $ ptrDeclr $3 (RList.reverse $2) } | '*' type_qualifier_list attrs parameter_typedef_declarator- {% withAttribute $1 $3 $ ptrDeclr $4 (reverse $2) }+ {% withAttribute $1 $3 $ ptrDeclr $4 (RList.reverse $2) } -- clean_postfix_typedef_declarator :- ( attrs? clean_typedef_declarator ) declarator_postfix? --@@ -1289,17 +1382,17 @@ {% withNodeInfo $1 $ ptrDeclr $3 [] } | '*' type_qualifier_list '(' simple_paren_typedef_declarator ')'- {% withNodeInfo $1 $ ptrDeclr $4 (reverse $2) }+ {% withNodeInfo $1 $ ptrDeclr $4 (RList.reverse $2) } | '*' type_qualifier_list attrs '(' simple_paren_typedef_declarator ')'- {% withAttribute $1 $3 $ ptrDeclr $5 (reverse $2) }+ {% withAttribute $1 $3 $ ptrDeclr $5 (RList.reverse $2) } | '*' paren_typedef_declarator {% withNodeInfo $1 $ ptrDeclr $2 [] } | '*' type_qualifier_list paren_typedef_declarator- {% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) }+ {% withNodeInfo $1 $ ptrDeclr $3 (RList.reverse $2) } | '*' type_qualifier_list attrs paren_typedef_declarator- {% withAttribute $1 $3 $ ptrDeclr $4 (reverse $2) }+ {% withAttribute $1 $3 $ ptrDeclr $4 (RList.reverse $2) } -- redundant paren to left of tname paren_postfix_typedef_declarator :: { CDeclrR }@@ -1349,10 +1442,10 @@ {% withAttribute $1 $2 $ ptrDeclr $3 [] } | '*' type_qualifier_list identifier_declarator- {% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) }+ {% withNodeInfo $1 $ ptrDeclr $3 (RList.reverse $2) } | '*' type_qualifier_list attrs identifier_declarator- {% withAttribute $1 $3 $ ptrDeclr $4 (reverse $2) }+ {% withAttribute $1 $3 $ ptrDeclr $4 (RList.reverse $2) } postfix_identifier_declarator :: { CDeclrR } postfix_identifier_declarator@@ -1398,12 +1491,12 @@ {% withNodeInfo $1 $ ptrDeclr $2 [] } -- FIXME: no attr possible here ??? | '*' type_qualifier_list old_function_declarator- {% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) }+ {% withNodeInfo $1 $ ptrDeclr $3 (RList.reverse $2) } postfix_old_function_declarator :: { CDeclrR } postfix_old_function_declarator : paren_identifier_declarator '(' identifier_list ')'- {% withNodeInfo $1 $ funDeclr $1 (Left $ reverse $3) [] }+ {% withNodeInfo $1 $ funDeclr $1 (Left $ RList.reverse $3) [] } | '(' old_function_declarator ')' { $2 }@@ -1417,13 +1510,13 @@ parameter_type_list :: { ([CDecl], Bool) } parameter_type_list : {- empty -} { ([], False)}- | parameter_list { (reverse $1, False) }- | parameter_list ',' "..." { (reverse $1, True) }+ | parameter_list { (RList.reverse $1, False) }+ | parameter_list ',' "..." { (RList.reverse $1, True) } parameter_list :: { Reversed [CDecl] } parameter_list- : parameter_declaration { singleton $1 }- | parameter_list ',' parameter_declaration { $1 `snoc` $3 }+ : parameter_declaration { RList.singleton $1 }+ | parameter_list ',' parameter_declaration { $1 `RList.snoc` $3 } parameter_declaration :: { CDecl } parameter_declaration@@ -1440,13 +1533,13 @@ {% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] } | declaration_qualifier_list- {% withNodeInfo $1 $ CDecl (reverse $1) [] }+ {% withNodeInfo $1 $ CDecl (RList.reverse $1) [] } | declaration_qualifier_list abstract_declarator- {% withNodeInfo $1 $ CDecl (reverse $1) [(Just (reverseDeclr $2), Nothing, Nothing)] }+ {% withNodeInfo $1 $ CDecl (RList.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)] }+ {% withNodeInfo $1 $ CDecl (RList.reverse $1) [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] } | type_specifier {% withNodeInfo $1 $ CDecl $1 [] }@@ -1474,8 +1567,8 @@ identifier_list :: { Reversed [Ident] } identifier_list- : ident { singleton $1 }- | identifier_list ',' ident { $1 `snoc` $3 }+ : ident { RList.singleton $1 }+ | identifier_list ',' ident { $1 `RList.snoc` $3 } -- parse C type name (C99 6.7.6)@@ -1544,19 +1637,19 @@ {% 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 }+ {% withNodeInfo $1 $ \at declr -> arrDeclr declr (RList.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 }+ {% withAttributePF $1 $3 $ \at declr -> arrDeclr declr (RList.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 }+ {% withAttributePF $1 $4 $ \at declr -> arrDeclr declr (RList.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 }+ {% withAttributePF $1 ($3 ++ $5) $ \at declr -> arrDeclr declr (RList.reverse $2) False True (Just $6) at } | '[' '*' attrs_opt ']' {% withAttributePF $1 $3 $ \at declr -> arrDeclr declr [] True False Nothing at }@@ -1564,9 +1657,9 @@ {% 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 }+ {% withAttributePF $1 $4 $ \at declr -> arrDeclr declr (RList.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 }+ {% withAttributePF $1 ($3 ++ $5) $ \at declr -> arrDeclr declr (RList.reverse $2) True False Nothing at } unary_abstract_declarator :: { CDeclrR } unary_abstract_declarator@@ -1574,13 +1667,13 @@ {% withNodeInfo $1 $ ptrDeclr emptyDeclr [] } | '*' type_qualifier_list attrs_opt- {% withAttribute $1 $3 $ ptrDeclr emptyDeclr (reverse $2) }+ {% withAttribute $1 $3 $ ptrDeclr emptyDeclr (RList.reverse $2) } | '*' abstract_declarator {% withNodeInfo $1 $ ptrDeclr $2 [] } | '*' type_qualifier_list abstract_declarator- {% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) }+ {% withNodeInfo $1 $ ptrDeclr $3 (RList.reverse $2) } | '*' attrs {% withAttribute $1 $2 $ ptrDeclr emptyDeclr [] }@@ -1608,8 +1701,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_list '}' {% withNodeInfo $1 $ CInitList (RList.reverse $2) }+ | '{' initializer_list ',' '}' {% withNodeInfo $1 $ CInitList (RList.reverse $2) } initializer_opt :: { Maybe CInit }@@ -1620,11 +1713,11 @@ 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) }+ : {- empty -} { RList.empty }+ | initializer { RList.singleton ([],$1) }+ | designation initializer { RList.singleton ($1,$2) }+ | initializer_list ',' initializer { $1 `RList.snoc` ([],$3) }+ | initializer_list ',' designation initializer { $1 `RList.snoc` ($3,$4) } -- designation@@ -1635,15 +1728,15 @@ -- designation :: { [CDesignator] } designation- : designator_list '=' { reverse $1 }+ : designator_list '=' { RList.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 { RList.singleton $1 }+ | designator_list designator { $1 `RList.snoc` $2 } designator :: { CDesignator }@@ -1659,10 +1752,11 @@ {% withNodeInfo $1 $ CRangeDesig $2 $4 } --- parse C primary expression (C99 6.5.1)+-- parse C primary expression (C11 6.5.1) -- -- We cannot use a typedef name as a variable --+-- * C11: generic selection -- * GNU extensions: -- allow a compound statement as an expression -- __builtin_va_arg@@ -1670,11 +1764,12 @@ -- __builtin_types_compatible_p primary_expression :: { CExpr } primary_expression- : ident {% withNodeInfo $1 $ CVar $1 }+ : ident {% withNodeInfo $1 $ CVar $1 } | constant { CConst $1 }- | string_literal { CConst (liftStrLit $1) }- | '(' expression ')' { $2 }-+ | string_literal { CConst (liftStrLit $1) }+ | '(' expression ')' { $2 }+ | "_Generic" '(' assignment_expression ',' generic_assoc_list ')'+ {% withNodeInfo $1 $ CGenericSelection $3 (RList.reverse $5) } -- GNU extensions | '(' compound_statement ')' {% withNodeInfo $1 $ CStatExpr $2 }@@ -1683,17 +1778,33 @@ {% withNodeInfo $1 $ CBuiltinExpr . CBuiltinVaArg $3 $5 } | "__builtin_offsetof" '(' type_name ',' offsetof_member_designator ')'- {% withNodeInfo $1 $ CBuiltinExpr . CBuiltinOffsetOf $3 (reverse $5) }+ {% withNodeInfo $1 $ CBuiltinExpr . CBuiltinOffsetOf $3 (RList.reverse $5) } | "__builtin_types_compatible_p" '(' type_name ',' type_name ')' {% withNodeInfo $1 $ CBuiltinExpr . CBuiltinTypesCompatible $3 $5 } + | "__builtin_convertvector" '(' assignment_expression ',' type_name ')'+ {% withNodeInfo $1 $ CBuiltinExpr . CBuiltinConvertVector $3 $5 } + | "__builtin_bit_cast" '(' type_name ',' assignment_expression ')'+ {% withNodeInfo $1 $ CBuiltinExpr . CBuiltinBitCast $3 $5 }++-- Generic Selection association list (C11 6.5.1.1)+--+-- TODO: introduce AST type for generic association+generic_assoc_list :: { Reversed [(Maybe CDecl, CExpr)] }+ : generic_assoc_list ',' generic_assoc { $1 `RList.snoc` $3 }+ | generic_assoc { RList.singleton $1 }+generic_assoc :: { (Maybe CDecl, CExpr) }+generic_assoc+ : type_name ':' assignment_expression { (Just $1, $3) }+ | default ':' assignment_expression { (Nothing, $3) }+ 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 }+ : identifier {% withNodeInfo $1 $ RList.singleton . CMemberDesig $1 }+ | offsetof_member_designator '.' identifier {% withNodeInfo $3 $ ($1 `RList.snoc`) . CMemberDesig $3 }+ | offsetof_member_designator '[' expression ']' {% withNodeInfo $3 $ ($1 `RList.snoc`) . CArrDesig $3 } -- parse C postfix expression (C99 6.5.2)@@ -1710,7 +1821,7 @@ {% withNodeInfo $1 $ CCall $1 [] } | postfix_expression '(' argument_expression_list ')'- {% withNodeInfo $1 $ CCall $1 (reverse $3) }+ {% withNodeInfo $1 $ CCall $1 (RList.reverse $3) } | postfix_expression '.' identifier {% withNodeInfo $1 $ CMember $1 $3 False }@@ -1725,16 +1836,16 @@ {% withNodeInfo $1 $ CUnary CPostDecOp $1 } | '(' type_name ')' '{' initializer_list '}'- {% withNodeInfo $1 $ CCompoundLit $2 (reverse $5) }+ {% withNodeInfo $1 $ CCompoundLit $2 (RList.reverse $5) } | '(' type_name ')' '{' initializer_list ',' '}'- {% withNodeInfo $1 $ CCompoundLit $2 (reverse $5) }+ {% withNodeInfo $1 $ CCompoundLit $2 (RList.reverse $5) } argument_expression_list :: { Reversed [CExpr] } argument_expression_list- : assignment_expression { singleton $1 }- | argument_expression_list ',' assignment_expression { $1 `snoc` $3 }+ : assignment_expression { RList.singleton $1 }+ | argument_expression_list ',' assignment_expression { $1 `RList.snoc` $3 } -- parse C unary expression (C99 6.5.3)@@ -1967,12 +2078,12 @@ { $1 } | assignment_expression ',' comma_expression- {% let es = reverse $3 in withNodeInfo es $ CComma ($1:es) }+ {% let es = RList.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 }+ : assignment_expression { RList.singleton $1 }+ | comma_expression ',' assignment_expression { $1 `RList.snoc` $3 } -- The following was used for clarity@@ -2002,7 +2113,7 @@ 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 }+ | cfloat {% withNodeInfo $1 $ case $1 of CTokFLit _ f -> CFloatConst f } string_literal :: { CStrLit }@@ -2011,14 +2122,16 @@ {% 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)) }+ {% withNodeInfo $1 $ case $1 of CTokSLit _ s -> CStrLit (concatCStrings (s : RList.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 }+ : cstr { case $1 of CTokSLit _ s -> RList.singleton s }+ | string_literal_list cstr { case $2 of CTokSLit _ s -> $1 `RList.snoc` s } +clang_version_literal :: { ClangCVersion }+ : clangcversion { $1 } identifier :: { Ident } identifier@@ -2040,11 +2153,11 @@ attr :: { [CAttr] } attr- : "__attribute__" '(' '(' attribute_list ')' ')' { reverse $4 }+ : "__attribute__" '(' '(' attribute_list ')' ')' { RList.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 { case $1 of Nothing -> RList.empty; Just attr -> RList.singleton attr }+ | attribute_list ',' attribute { (maybe id (flip RList.snoc) $3) $1 } attribute :: { Maybe CAttr }@@ -2052,7 +2165,7 @@ : {- 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 '(' attribute_params ')' {% withNodeInfo $1 $ Just . CAttr $1 (RList.reverse $3) } | ident '(' ')' {% withNodeInfo $1 $ Just . CAttr $1 [] } -- OS X 10.9 (Mavericks) makes use of more liberal attribute syntax@@ -2061,13 +2174,31 @@ attribute_params :: { Reversed [CExpr] } attribute_params- : constant_expression { singleton $1 }+ : constant_expression { RList.singleton $1 }+ | unary_expression assignment_operator clang_version_literal { Reversed [] } | unary_expression assignment_operator unary_expression { Reversed [] }- | attribute_params ',' constant_expression { $1 `snoc` $3 }+ | attribute_params ',' constant_expression { $1 `RList.snoc` $3 } | attribute_params ',' unary_expression assignment_operator unary_expression { $1 }+ | attribute_params ',' unary_expression assignment_operator clang_version_literal { $1 } { +containsAlign :: Reversed [CDecl] -> Maybe CAlignSpec+containsAlign (Reversed input) = listToMaybe $ mapMaybe checkDecl input+ where+ checkDecl :: CDecl -> Maybe CAlignSpec+ checkDecl = \case+ CDecl list _ _ -> listToMaybe $ mapMaybe isAlignSpec list+ _ -> Nothing++ isAlignSpec :: CDeclSpec -> Maybe CAlignSpec+ isAlignSpec = \case+ CAlignSpec x -> Just x+ _ -> Nothing++addAlign :: CDecl -> CAlignmentSpecifier NodeInfo -> CDecl+addAlign (CDecl list list2 a) align = CDecl (CAlignSpec align : list) list2 a+ -- sometimes it is neccessary to reverse an unreversed list reverseList :: [a] -> Reversed [a] reverseList = Reversed . List.reverse@@ -2106,7 +2237,7 @@ 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+ = CDeclr ide (RList.reverse reversedDDs) asmname cattrs at instance CNode (CDeclrR) where nodeInfo (CDeclrR _ _ _ _ n) = n instance Pos (CDeclrR) where@@ -2169,7 +2300,7 @@ appendDeclrAttrs :: [CAttr] -> CDeclrR -> CDeclrR appendDeclrAttrs newAttrs (CDeclrR ident (Reversed []) asmname cattrs at)- = CDeclrR ident empty asmname (cattrs ++ newAttrs) at+ = CDeclrR ident RList.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@@ -2178,20 +2309,20 @@ ptrDeclr :: CDeclrR -> [CTypeQual] -> NodeInfo -> CDeclrR ptrDeclr (CDeclrR ident derivedDeclrs asmname cattrs dat) tyquals at- = CDeclrR ident (derivedDeclrs `snoc` CPtrDeclr tyquals at) asmname cattrs dat+ = CDeclrR ident (derivedDeclrs `RList.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+ = CDeclrR ident (derivedDeclrs `RList.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 )+ = arr_sz `seq` ( CDeclrR ident (derivedDeclrs `RList.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+liftTypeQuals = map CTypeQual . RList.reverse -- lift CAttrs to DeclSpecs --@@ -2202,12 +2333,12 @@ -- 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+ case RList.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 `RList.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)+ -> (specs_init `RList.snoc` CTypeSpec (CEnumType (CEnum name (Just def) (def_attrs ++ new_attrs) e_node) node))+ _ -> declspecs `RList.rappend` (liftCAttrs new_attrs) -- convenient instance, the position of a list of things is the position of -- the first thing in the list@@ -2219,9 +2350,9 @@ posOf (Reversed x) = posOf x emptyDeclr :: CDeclrR-emptyDeclr = CDeclrR Nothing empty Nothing [] undefNode+emptyDeclr = CDeclrR Nothing RList.empty Nothing [] undefNode mkVarDeclr :: Ident -> NodeInfo -> CDeclrR-mkVarDeclr ident = CDeclrR (Just ident) empty Nothing []+mkVarDeclr ident = CDeclrR (Just ident) RList.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,
src/Language/C/Parser/ParserMonad.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wwarn=incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Syntax.ParserMonad@@ -46,8 +48,10 @@ import Language.C.Data.Ident (Ident) import Language.C.Parser.Tokens (CToken(CTokEof)) +import Prelude hiding (Applicative(..), MonadFail(..)) import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap)+import Control.Monad.Fail (MonadFail (..)) import Data.Set (Set) import qualified Data.Set as Set (fromList, insert, member, delete) @@ -76,14 +80,19 @@ fmap = liftM instance Applicative P where- pure = return+ pure = returnP (<*>) = ap instance Monad P where- return = returnP (>>=) = thenP+#if !MIN_VERSION_base(4,13,0) fail m = getPos >>= \pos -> failP pos [m]+#endif +#if MIN_VERSION_base(4,9,0)+instance MonadFail P where+ fail m = getPos >>= \pos -> failP pos [m]+#endif -- | execute the given parser on the supplied input stream. -- returns 'ParseError' if the parser failed, and a pair of
src/Language/C/Parser/Tokens.hs view
@@ -11,11 +11,11 @@ -- C Tokens for the C lexer. -- ------------------------------------------------------------------------------module Language.C.Parser.Tokens (CToken(..), posLenOfTok, GnuCTok(..)) where+module Language.C.Parser.Tokens (CToken(..), posLenOfTok, GnuCTok(..), ClangCTok(..)) 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)+import Language.C.Syntax.Constants (CChar, CInteger, CFloat, CString, ClangCVersion) -- token definition -- ----------------@@ -71,9 +71,11 @@ | CTokAlignof !PosLength -- `alignof' -- (or `__alignof', -- `__alignof__')+ | CTokAlignas !PosLength -- `_Alignas' | CTokAsm !PosLength -- `asm' -- (or `__asm', -- `__asm__')+ | CTokAtomic !PosLength -- `_Atomic' | CTokAuto !PosLength -- `auto' | CTokBreak !PosLength -- `break' | CTokBool !PosLength -- `_Bool'@@ -90,15 +92,25 @@ | CTokEnum !PosLength -- `enum' | CTokExtern !PosLength -- `extern' | CTokFloat !PosLength -- `float'+ | CTokBFloat16 !PosLength -- `__bf16'+ | CTokFloatN !Int !Bool !PosLength -- (or `__float128',+ -- `__fp16',+ -- `_Float{16,32,64,128}{,x}`) | CTokFor !PosLength -- `for'+ | CTokGeneric !PosLength -- `_Generic' | CTokGoto !PosLength -- `goto' | CTokIf !PosLength -- `if' | CTokInline !PosLength -- `inline' -- (or `__inline', -- `__inline__') | CTokInt !PosLength -- `int'+ | CTokInt128 !PosLength -- `__int128`+ -- (or `__int128_t`) | CTokLong !PosLength -- `long'- | CTokLabel !PosLength -- `__label__'+ | CTokLabel !PosLength -- `__label__+ | CTokNoreturn !PosLength -- `_Noreturn'+ | CTokNullable !PosLength -- `_Nullable'+ | CTokNonnull !PosLength -- `_Nonnull' | CTokRegister !PosLength -- `register' | CTokRestrict !PosLength -- `restrict' -- (or `__restrict',@@ -110,11 +122,14 @@ -- `__signed__') | CTokSizeof !PosLength -- `sizeof' | CTokStatic !PosLength -- `static'+ | CTokStaticAssert !PosLength -- `_Static_assert' | CTokStruct !PosLength -- `struct' | CTokSwitch !PosLength -- `switch' | CTokTypedef !PosLength -- `typedef' | CTokTypeof !PosLength -- `typeof' | CTokThread !PosLength -- `__thread'+ | CTokUInt128 !PosLength -- `__uint128`+ -- (or `__uint128_t`) | CTokUnion !PosLength -- `union' | CTokUnsigned !PosLength -- `unsigned' | CTokVoid !PosLength -- `void'@@ -131,6 +146,12 @@ -- not generated here, but in `CParser.parseCHeader' | CTokTyIdent !PosLength !Ident -- `typedef-name' identifier | CTokGnuC !GnuCTok !PosLength -- special GNU C tokens+ | CTokClangC !PosLength !ClangCTok -- special Clang C tokens+ | CTokClKernel !PosLength -- OpenCL `__kernel'+ | CTokClRdOnly !PosLength -- OpenCL `__read_only'+ | CTokClWrOnly !PosLength -- OpenCL `__write_only'+ | CTokClGlobal !PosLength -- OpenCL `__Global'+ | CTokClLocal !PosLength -- OpenCL `__Local' | CTokEof -- end of file -- special tokens used in GNU C extensions to ANSI C@@ -143,6 +164,10 @@ | GnuCComplexReal -- `__real__' | GnuCComplexImag -- `__imag__' +data ClangCTok = ClangCVersionTok !ClangCVersion -- version constant from 'availability' attribute+ | ClangBuiltinConvertVector+ | ClangCBitCast -- `__builtin_bit_cast`+ instance Pos CToken where posOf = fst . posLenOfTok @@ -195,7 +220,9 @@ posLenOfTok (CTokRBrace pos ) = pos posLenOfTok (CTokEllipsis pos ) = pos posLenOfTok (CTokAlignof pos ) = pos+posLenOfTok (CTokAlignas pos ) = pos posLenOfTok (CTokAsm pos ) = pos+posLenOfTok (CTokAtomic pos ) = pos posLenOfTok (CTokAuto pos ) = pos posLenOfTok (CTokBreak pos ) = pos posLenOfTok (CTokBool pos ) = pos@@ -211,13 +238,20 @@ posLenOfTok (CTokEnum pos ) = pos posLenOfTok (CTokExtern pos ) = pos posLenOfTok (CTokFloat pos ) = pos+posLenOfTok (CTokBFloat16 pos ) = pos+posLenOfTok (CTokFloatN _ _ pos) = pos posLenOfTok (CTokFor pos ) = pos+posLenOfTok (CTokGeneric pos ) = pos posLenOfTok (CTokGoto pos ) = pos posLenOfTok (CTokInt pos ) = pos+posLenOfTok (CTokInt128 pos ) = pos posLenOfTok (CTokInline pos ) = pos posLenOfTok (CTokIf pos ) = pos posLenOfTok (CTokLong pos ) = pos posLenOfTok (CTokLabel pos ) = pos+posLenOfTok (CTokNoreturn pos ) = pos+posLenOfTok (CTokNullable pos ) = pos+posLenOfTok (CTokNonnull pos ) = pos posLenOfTok (CTokRegister pos ) = pos posLenOfTok (CTokRestrict pos ) = pos posLenOfTok (CTokReturn pos ) = pos@@ -225,11 +259,13 @@ posLenOfTok (CTokSigned pos ) = pos posLenOfTok (CTokSizeof pos ) = pos posLenOfTok (CTokStatic pos ) = pos+posLenOfTok (CTokStaticAssert pos) = pos posLenOfTok (CTokStruct pos ) = pos posLenOfTok (CTokSwitch pos ) = pos posLenOfTok (CTokTypedef pos ) = pos posLenOfTok (CTokTypeof pos ) = pos posLenOfTok (CTokThread pos ) = pos+posLenOfTok (CTokUInt128 pos ) = pos posLenOfTok (CTokUnion pos ) = pos posLenOfTok (CTokUnsigned pos ) = pos posLenOfTok (CTokVoid pos ) = pos@@ -242,6 +278,12 @@ posLenOfTok (CTokIdent pos _) = pos posLenOfTok (CTokTyIdent pos _) = pos posLenOfTok (CTokGnuC _ pos ) = pos+posLenOfTok (CTokClangC pos _) = pos+posLenOfTok (CTokClKernel pos ) = pos+posLenOfTok (CTokClRdOnly pos ) = pos+posLenOfTok (CTokClWrOnly pos ) = pos+posLenOfTok (CTokClGlobal pos ) = pos+posLenOfTok (CTokClLocal pos ) = pos posLenOfTok CTokEof = error "tokenPos: Eof" instance Show CToken where@@ -292,7 +334,9 @@ showsPrec _ (CTokRBrace _ ) = showString "}" showsPrec _ (CTokEllipsis _ ) = showString "..." showsPrec _ (CTokAlignof _ ) = showString "alignof"+ showsPrec _ (CTokAlignas _ ) = showString "_Alignas" showsPrec _ (CTokAsm _ ) = showString "asm"+ showsPrec _ (CTokAtomic _ ) = showString "_Atomic" showsPrec _ (CTokAuto _ ) = showString "auto" showsPrec _ (CTokBool _) = showString "_Bool" showsPrec _ (CTokBreak _ ) = showString "break"@@ -308,13 +352,21 @@ showsPrec _ (CTokEnum _ ) = showString "enum" showsPrec _ (CTokExtern _ ) = showString "extern" showsPrec _ (CTokFloat _ ) = showString "float"+ showsPrec _ (CTokBFloat16 _ ) = showString "__bf16"+ showsPrec _ (CTokFloatN n x _) = showString "_Float" . shows n .+ showString (if x then "x" else "") showsPrec _ (CTokFor _ ) = showString "for"+ showsPrec _ (CTokGeneric _ ) = showString "_Generic" showsPrec _ (CTokGoto _ ) = showString "goto" showsPrec _ (CTokIf _ ) = showString "if" showsPrec _ (CTokInline _ ) = showString "inline" showsPrec _ (CTokInt _ ) = showString "int"+ showsPrec _ (CTokInt128 _ ) = showString "__int128" showsPrec _ (CTokLong _ ) = showString "long" showsPrec _ (CTokLabel _ ) = showString "__label__"+ showsPrec _ (CTokNoreturn _ ) = showString "_Noreturn"+ showsPrec _ (CTokNullable _ ) = showString "_Nullable"+ showsPrec _ (CTokNonnull _ ) = showString "_Nonnull" showsPrec _ (CTokRegister _ ) = showString "register" showsPrec _ (CTokRestrict _ ) = showString "restrict" showsPrec _ (CTokReturn _ ) = showString "return"@@ -322,11 +374,13 @@ showsPrec _ (CTokSigned _ ) = showString "signed" showsPrec _ (CTokSizeof _ ) = showString "sizeof" showsPrec _ (CTokStatic _ ) = showString "static"+ showsPrec _ (CTokStaticAssert _ ) = showString "_Static_assert" showsPrec _ (CTokStruct _ ) = showString "struct" showsPrec _ (CTokSwitch _ ) = showString "switch" showsPrec _ (CTokTypedef _ ) = showString "typedef" showsPrec _ (CTokTypeof _ ) = showString "typeof"- showsPrec _ (CTokThread _ ) = showString "__thread"+ showsPrec _ (CTokThread _ ) = showString "_Thread_local"+ showsPrec _ (CTokUInt128 _ ) = showString "__uint128" showsPrec _ (CTokUnion _ ) = showString "union" showsPrec _ (CTokUnsigned _ ) = showString "unsigned" showsPrec _ (CTokVoid _ ) = showString "void"@@ -345,4 +399,12 @@ showsPrec _ (CTokGnuC GnuCVaArg _) = showString "__builtin_va_arg" showsPrec _ (CTokGnuC GnuCOffsetof _) = showString "__builtin_offsetof" showsPrec _ (CTokGnuC GnuCTyCompat _) = showString "__builtin_types_compatible_p"+ showsPrec _ (CTokClangC _ (ClangCVersionTok v)) = shows v+ showsPrec _ (CTokClangC _ ClangBuiltinConvertVector) = showString "__builtin_convertvector"+ showsPrec _ (CTokClangC _ ClangCBitCast) = showString "__builtin_bit_cast"+ showsPrec _ (CTokClKernel _ ) = showString "__kernel"+ showsPrec _ (CTokClRdOnly _ ) = showString "__read_only"+ showsPrec _ (CTokClWrOnly _ ) = showString "__write_only"+ showsPrec _ (CTokClGlobal _ ) = showString "__global"+ showsPrec _ (CTokClLocal _ ) = showString "__Local" showsPrec _ CTokEof = error "show CToken : CTokEof"
src/Language/C/Pretty.hs view
@@ -18,10 +18,11 @@ -- * Testing prettyUsingInclude ) where-import Data.List (partition,nub,isSuffixOf)+import Data.List (isSuffixOf) import qualified Data.Set as Set import Text.PrettyPrint.HughesPJ import Debug.Trace {- for warnings -}+import Prelude hiding ((<>)) import Language.C.Data import Language.C.Syntax@@ -79,9 +80,9 @@ prettyUsingInclude (CTranslUnit edecls _) = includeWarning headerFiles $$- (vcat $ map (either includeHeader pretty) mappedDecls)+ vcat (map (either includeHeader pretty) mappedDecls) where- (headerFiles,mappedDecls) = foldr addDecl (Set.empty,[]) $ map tagIncludedDecls edecls+ (headerFiles,mappedDecls) = foldr (addDecl . tagIncludedDecls) (Set.empty,[]) edecls tagIncludedDecls edecl | maybe False isHeaderFile (fileOfNode edecl) = Left ((posFile . posOf) edecl) | otherwise = Right edecl addDecl decl@(Left headerRef) (headerSet, ds)@@ -104,7 +105,7 @@ 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;+ $+$ (ii . vcat . map ((<> semi) . pretty)) decls -- register long b; $$ prettyPrec (-1) stat -- { ... -- } @@ -203,29 +204,42 @@ 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+ if any isAttrAfterSUE (zip specs (drop 1 specs))+ then trace+ ("Warning: AST Invariant violated: __attribute__ specifier following struct/union/enum:" +++ show (map pretty specs))+ specs+ else specs isAttrAfterSUE (CTypeSpec ty,CTypeQual (CAttrQual _)) = isSUEDef ty isAttrAfterSUE _ = False getAttrs Nothing = [] getAttrs (Just (CDeclr _ _ _ cattrs _)) = cattrs+ pretty (CStaticAssert expr str _) =+ text "_Static_assert" <> parens (hsep (punctuate comma [pretty expr, pretty str])) instance Pretty CDeclSpec where pretty (CStorageSpec sp) = pretty sp pretty (CTypeSpec sp) = pretty sp pretty (CTypeQual qu) = pretty qu+ pretty (CFunSpec fs) = pretty fs+ pretty (CAlignSpec sa) = pretty sa +instance Pretty CAlignSpec where+ pretty (CAlignAsType decl _) =+ text "_Alignas" <> parens (pretty decl)+ pretty (CAlignAsExpr expr _) =+ text "_Alignas" <> parens (pretty expr)+ 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"+ pretty (CThread _) = text "_Thread_local"+ pretty (CClKernel _) = text "__kernel"+ pretty (CClGlobal _) = text "__global"+ pretty (CClLocal _) = text "__local" instance Pretty CTypeSpec where pretty (CVoidType _) = text "void"@@ -234,33 +248,48 @@ pretty (CIntType _) = text "int" pretty (CLongType _) = text "long" pretty (CFloatType _) = text "float"+ pretty (CBFloat16Type _) = text "__bf16"+ pretty (CFloatNType n x _) = text "_Float" <> text (show n) <>+ (if x then text "x" else empty) pretty (CDoubleType _) = text "double" pretty (CSignedType _) = text "signed" pretty (CUnsigType _) = text "unsigned" pretty (CBoolType _) = text "_Bool" pretty (CComplexType _) = text "_Complex"+ pretty (CInt128Type _) = text "__int128"+ pretty (CUInt128Type _) = text "__uint128" pretty (CSUType union _) = pretty union pretty (CEnumType enum _) = pretty enum pretty (CTypeDef ident _) = identP ident pretty (CTypeOfExpr expr _) =- text "typeof" <> text "(" <> pretty expr <> text ")"+ text "typeof" <> parens (pretty expr) pretty (CTypeOfType decl _) =- text "typeof" <> text "(" <> pretty decl <> text ")"+ text "typeof" <> parens (pretty decl)+ pretty (CAtomicType decl _) =+ text "_Atomic" <> parens (pretty decl) instance Pretty CTypeQual where pretty (CConstQual _) = text "const" pretty (CVolatQual _) = text "volatile" pretty (CRestrQual _) = text "__restrict"- pretty (CInlineQual _) = text "inline"+ pretty (CAtomicQual _) = text "_Atomic" pretty (CAttrQual a) = attrlistP [a]+ pretty (CNullableQual _) = text "_Nullable"+ pretty (CNonnullQual _) = text "_Nonnull"+ pretty (CClRdOnlyQual _) = text "__read_only"+ pretty (CClWrOnlyQual _) = text "__write_only" +instance Pretty CFunSpec where+ pretty (CInlineQual _) = text "inline"+ pretty (CNoreturnQual _) = text "_Noreturn"+ 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)),+ ii $ sep (map ((<> semi) . pretty) decls), text "}"] instance Pretty CStructTag where@@ -415,29 +444,39 @@ 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+ p (mems, initializer) = hcat (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 (CGenericSelection expr assoc_list _) =+ text "_Generic" <> (parens.hsep.punctuate comma) (pretty expr : map pAssoc assoc_list)+ where+ pAssoc (mty, expr1) = maybe (text "default") pretty mty <> text ":" <+> pretty expr1 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)+ 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) )+ 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)+ 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)+ parens (pretty ty1 <> comma <+> pretty ty2)+ pretty (CBuiltinConvertVector expr ty _) =+ text "__builtin_convertvector" <+>+ parens (pretty expr <> comma <+> pretty ty)+ pretty (CBuiltinBitCast ty expr _) =+ text "__builtin_bit_cast" <+>+ parens (pretty ty <> comma <+> pretty expr) instance Pretty CAssignOp where pretty op = text $ case op of
src/Language/C/Syntax/AST.hs view
@@ -33,8 +33,9 @@ CStructTag(..), CStructureUnion(..), CEnumeration(..), -- * Declaration attributes CDeclSpec, partitionDeclSpecs,- CStorageSpec, CTypeSpec, isSUEDef, CTypeQual, CAttr,- CDeclarationSpecifier(..), CStorageSpecifier(..), CTypeSpecifier(..),+ CStorageSpec, CTypeSpec, isSUEDef, CTypeQual, CFunSpec, CAlignSpec, CAttr,+ CFunctionSpecifier(..), CDeclarationSpecifier(..), CStorageSpecifier(..), CTypeSpecifier(..),+ CAlignmentSpecifier(..), CTypeQualifier(..), CAttribute(..), -- * Declarators CDeclr,CDerivedDeclr,CArrSize,@@ -56,13 +57,14 @@ -- * 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+import Data.Data (Data)+import GHC.Generics (Generic, Generic1)+import Control.DeepSeq (NFData) -- | Complete C tranlsation unit (C99 6.9, K&R A10) --@@ -71,8 +73,10 @@ type CTranslUnit = CTranslationUnit NodeInfo data CTranslationUnit a = CTranslUnit [CExternalDeclaration a] a- deriving (Show, Data, Typeable {-! ,CNode ,Functor, Annotated !-})+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor, Annotated !-}) +instance NFData a => NFData (CTranslationUnit a)+ -- | External C declaration (C99 6.9, K&R A10) -- -- Either a toplevel declaration, function definition or external assembler.@@ -81,8 +85,10 @@ = CDeclExt (CDeclaration a) | CFDefExt (CFunctionDef a) | CAsmExt (CStringLiteral a) a- deriving (Show, Data,Typeable {-! ,CNode ,Functor, Annotated !-})+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor, Annotated !-}) +instance NFData a => NFData (CExternalDeclaration a)+ -- | C function definition (C99 6.9.1, K&R A10.1) -- -- A function definition is of the form @CFunDef specifiers declarator decllist? stmt@.@@ -104,8 +110,9 @@ [CDeclaration a] -- optional declaration list (CStatement a) -- compound statement a- deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CFunctionDef a) -- | C declarations (K&R A8, C99 6.7), including structure declarations, parameter -- declarations and type names.@@ -156,14 +163,22 @@ [(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 !-})+ a -- annotation+ | CStaticAssert+ (CExpression a) -- assert expression+ (CStringLiteral a) -- assert text+ a -- annotation+ deriving (Show, Data, Generic {-! ,CNode ,Annotated !-}) +instance NFData a => NFData (CDeclaration a)+ -- 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)+ fmap f (CStaticAssert expression strlit annot) =+ CStaticAssert (fmap f expression) (fmap f strlit) (f annot) -- | C declarator (K&R A8.5, C99 6.7.5) and abstract declarator (K&R A8.8, C99 6.7.6) --@@ -212,9 +227,11 @@ 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 !-})+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CDeclarator a) + -- | Derived declarators, see 'CDeclr' -- -- Indirections are qualified using type-qualifiers and generic attributes, and additionally@@ -233,8 +250,10 @@ -- ^ 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 !-})+ deriving (Show, Data, Generic {-! ,CNode , Annotated !-}) +instance NFData a => NFData (CDerivedDeclarator a)+ -- Derived instance relies on fmap2 instance Functor CDerivedDeclarator where fmap _f (CPtrDeclr a1 a2) = CPtrDeclr (fmap (fmap _f) a1) (_f a2)@@ -250,8 +269,9 @@ data CArraySize a = CNoArrSize Bool -- ^ @CUnknownSize isCompleteType@ | CArrSize Bool (CExpression a) -- ^ @CArrSize isStatic expr@- deriving (Show, Data,Typeable {-! , Functor !-})+ deriving (Show, Data, Generic, Generic1 {-! , Functor !-}) +instance NFData a => NFData (CArraySize a) -- | C statement (K&R A9, C99 6.8) --@@ -297,8 +317,10 @@ | CReturn (Maybe (CExpression a)) a -- | assembly statement | CAsm (CAssemblyStatement a) a- deriving (Show, Data,Typeable {-! , CNode , Annotated !-})+ deriving (Show, Data, Generic {-! , CNode , Annotated !-}) +instance NFData a => NFData (CStatement a)+ -- Derived instance relies on fmap2 :( instance Functor CStatement where fmap _f (CLabel a1 a2 a3 a4)@@ -346,8 +368,10 @@ [CAssemblyOperand a] -- input operands [CStringLiteral a] -- Clobbers a- deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CAssemblyStatement a)+ -- | Assembler operand -- -- @CAsmOperand argName? constraintExpr arg@ specifies an operand for an assembler@@ -359,8 +383,10 @@ (CStringLiteral a) -- constraint expr (CExpression a) -- argument a- deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CAssemblyOperand a)+ -- | C99 Block items -- -- Things that may appear in compound statements: either statements, declarations@@ -370,8 +396,10 @@ = 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 !-})+ deriving (Show, Data, Generic, Generic1 {-! , CNode , Functor, Annotated !-}) +instance NFData a => NFData (CCompoundBlockItem a)+ -- | C declaration specifiers and qualifiers -- -- Declaration specifiers include at most one storage-class specifier (C99 6.7.1),@@ -381,23 +409,27 @@ = 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 !-})+ | CFunSpec (CFunctionSpecifier a) -- ^ function specifier+ | CAlignSpec (CAlignmentSpecifier a) -- ^ alignment specifier+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor, Annotated !-}) +instance NFData a => NFData (CDeclarationSpecifier a) -- | 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)+ , [CTypeQualifier a], [CTypeSpecifier a]+ , [CFunctionSpecifier a], [CAlignmentSpecifier a])+partitionDeclSpecs = foldr deals ([],[],[],[],[],[]) where+ deals (CStorageSpec sp) (sts,ats,tqs,tss,fss,ass) = (sp:sts,ats,tqs,tss,fss,ass)+ deals (CTypeQual (CAttrQual attr)) (sts,ats,tqs,tss,fss,ass) = (sts,attr:ats,tqs,tss,fss,ass)+ deals (CTypeQual tq) (sts,ats,tqs,tss,fss,ass) = (sts,ats,tq:tqs,tss,fss,ass)+ deals (CTypeSpec ts) (sts,ats,tqs,tss,fss,ass) = (sts,ats,tqs,ts:tss,fss,ass)+ deals (CFunSpec fs) (sts,ats,tqs,tss,fss,ass) = (sts,ats,tqs,tss,fs:fss,ass)+ deals (CAlignSpec as) (sts,ats,tqs,tss,fss,ass) = (sts,ats,tqs,tss,fss,as:ass) -- | C storage class specifier (and typedefs) (K&R A8.1, C99 6.7.1) type CStorageSpec = CStorageSpecifier NodeInfo@@ -407,9 +439,13 @@ | CStatic a -- ^ static | CExtern a -- ^ extern | CTypedef a -- ^ typedef- | CThread a -- ^ GNUC thread local storage- deriving (Show, Eq,Ord,Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+ | CThread a -- ^ C11/GNUC thread local storage+ | CClKernel a -- ^ OpenCL kernel function+ | CClGlobal a -- ^ OpenCL __global variable+ | CClLocal a -- ^ OpenCL __local variable+ deriving (Show, Eq,Ord,Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CStorageSpecifier a) -- | C type specifier (K&R A8.2, C99 6.7.2) --@@ -430,13 +466,19 @@ | CUnsigType a | CBoolType a | CComplexType a+ | CInt128Type a+ | CUInt128Type a+ | CBFloat16Type a+ | CFloatNType Int Bool a -- ^ IEC 60227: width (32,64,128), extended flag | 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 !-})+ | CAtomicType (CDeclaration a) a -- ^ @_Atomic(type)@+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CTypeSpecifier a) -- | returns @True@ if the given typespec is a struct, union or enum /definition/ isSUEDef :: CTypeSpecifier a -> Bool@@ -444,20 +486,47 @@ 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.+-- | C type qualifiers (K&R A8.2, C99 6.7.3) and attributes. ----- @const@, @volatile@ and @restrict@ type qualifiers and @inline@ function specifier.--- Additionally, @__attribute__@ annotations for declarations and declarators.+-- @const@, @volatile@ and @restrict@ type qualifiers+-- Additionally, @__attribute__@ annotations for declarations and declarators, and+-- function specifiers type CTypeQual = CTypeQualifier NodeInfo data CTypeQualifier a = CConstQual a | CVolatQual a | CRestrQual a- | CInlineQual a+ | CAtomicQual a | CAttrQual (CAttribute a)- deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+ | CNullableQual a+ | CNonnullQual a+ | CClRdOnlyQual a+ | CClWrOnlyQual a+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CTypeQualifier a) +-- | C function specifiers (C99 6.7.4)+--+-- function specifiers @inline@ and @_Noreturn@+type CFunSpec = CFunctionSpecifier NodeInfo+data CFunctionSpecifier a+ = CInlineQual a+ | CNoreturnQual a+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-})++instance NFData a => NFData (CFunctionSpecifier a)++-- | C alignment specifiers (C99 6.7.5)+--+type CAlignSpec = CAlignmentSpecifier NodeInfo+data CAlignmentSpecifier a+ = CAlignAsType (CDeclaration a) a -- ^ @_Alignas(type)@+ | CAlignAsExpr (CExpression a) a -- ^ @_Alignas(expr)@+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-})++instance NFData a => NFData (CAlignmentSpecifier a)+ -- | 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@).@@ -476,14 +545,16 @@ (Maybe [CDeclaration a]) -- member declarations [CAttribute a] -- __attribute__s a- deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CStructureUnion a) -- | A tag to determine wheter we refer to a @struct@ or @union@, see 'CStructUnion'. data CStructTag = CStructTag | CUnionTag- deriving (Show, Eq,Data,Typeable)+ deriving (Show, Eq,Data, Generic) +instance NFData CStructTag -- | C enumeration specifier (K&R A8.4, C99 6.7.2.2) --@@ -505,9 +576,9 @@ Maybe (CExpression a))]) -- explicit variant value [CAttribute a] -- __attribute__s a- deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})-+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CEnumeration a) -- | C initialization (K&R A8.7, C99 6.7.8) --@@ -520,8 +591,10 @@ = CInitExpr (CExpression a) a -- | initialization list (see 'CInitList') | CInitList (CInitializerList a) a- deriving (Show, Data,Typeable {-! ,CNode , Annotated !-})+ deriving (Show, Data, Generic {-! ,CNode , Annotated !-}) +instance NFData a => NFData (CInitializer a)+ -- deriving Functor does not work (type synonym) instance Functor CInitializer where fmap _f (CInitExpr a1 a2) = CInitExpr (fmap _f a1) (_f a2)@@ -570,8 +643,9 @@ | CMemberDesig Ident a -- | array range designator @CRangeDesig from to _@ (GNU C) | CRangeDesig (CExpression a) (CExpression a) a- deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+ deriving (Show, Data, Generic {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CPartDesignator a) -- | @__attribute__@ annotations --@@ -579,8 +653,9 @@ -- 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 !-})+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CAttribute a) -- | C expression (K&R A7) --@@ -639,11 +714,14 @@ | CCompoundLit (CDeclaration a) (CInitializerList a) -- type name & initialiser list a -- ^ C99 compound literal+ | CGenericSelection (CExpression a) [(Maybe (CDeclaration a), CExpression a)] a -- ^ C11 generic selection | 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 (Data,Show, Generic {-! ,CNode , Annotated !-}) +instance NFData a => NFData (CExpression a)+ -- deriving Functor does not work (type synonyms) instance Functor CExpression where fmap _f (CComma a1 a2) = CComma (fmap (fmap _f) a1) (_f a2)@@ -673,7 +751,10 @@ 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)-+ fmap _f (CGenericSelection expr list annot) =+ CGenericSelection (fmap _f expr) (map fmap_helper list) (_f annot)+ where+ fmap_helper (ma1, a2) = (fmap (fmap _f) ma1, fmap _f a2) -- | GNU Builtins, which cannot be typed in C99 type CBuiltin = CBuiltinThing NodeInfo@@ -681,8 +762,11 @@ = 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 !-})+ | CBuiltinConvertVector (CExpression a) (CDeclaration a) a -- ^ @(expr, type)@+ | CBuiltinBitCast (CDeclaration a) (CExpression a) a -- ^ @(type, expr)@+ deriving (Show, Data, Generic {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CBuiltinThing a) -- | C constant (K&R A2.5 & A7.2) type CConst = CConstant NodeInfo@@ -691,14 +775,16 @@ | CCharConst CChar a | CFloatConst CFloat a | CStrConst CString a- deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CConstant a) -- | Attributed string literals type CStrLit = CStringLiteral NodeInfo data CStringLiteral a = CStrLit CString a- deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+ deriving (Show, Data, Generic, Generic1 {-! ,CNode ,Functor ,Annotated !-}) +instance NFData a => NFData (CStringLiteral a) cstringOfLit :: CStringLiteral a -> CString cstringOfLit (CStrLit cstr _) = cstr@@ -725,39 +811,31 @@ -- Instances generated using derive-2.* -- GENERATED START --instance (CNode t1) => CNode (CTranslationUnit t1) where+instance CNode t1 => CNode (CTranslationUnit t1) where nodeInfo (CTranslUnit _ n) = nodeInfo n--instance (CNode t1) => Pos (CTranslationUnit t1) where+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+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+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@@ -766,68 +844,57 @@ 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+instance CNode t1 => CNode (CFunctionDef t1) where nodeInfo (CFunDef _ _ _ _ n) = nodeInfo n--instance (CNode t1) => Pos (CFunctionDef t1) where+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+instance CNode t1 => CNode (CDeclaration t1) where nodeInfo (CDecl _ _ n) = nodeInfo n--instance (CNode t1) => Pos (CDeclaration t1) where+ nodeInfo (CStaticAssert _ _ n) = nodeInfo n+instance CNode t1 => Pos (CDeclaration t1) where posOf x = posOf (nodeInfo x) - instance Annotated CDeclaration where annotation (CDecl _ _ n) = n+ annotation (CStaticAssert _ _ n) = n amap f (CDecl a_1 a_2 a_3) = CDecl a_1 a_2 (f a_3)-+ amap f (CStaticAssert a_1 a_2 a_3) = CStaticAssert a_1 a_2 (f a_3) -instance (CNode t1) => CNode (CDeclarator t1) where+instance CNode t1 => CNode (CDeclarator t1) where nodeInfo (CDeclr _ _ _ _ n) = nodeInfo n--instance (CNode t1) => Pos (CDeclarator t1) where+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+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+instance CNode t1 => Pos (CDerivedDeclarator t1) where posOf x = posOf (nodeInfo x) - instance Annotated CDerivedDeclarator where annotation (CPtrDeclr _ n) = n annotation (CArrDeclr _ _ n) = n@@ -836,13 +903,11 @@ 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+instance CNode t1 => CNode (CStatement t1) where nodeInfo (CLabel _ _ _ n) = nodeInfo n nodeInfo (CCase _ _ n) = nodeInfo n nodeInfo (CCases _ _ _ n) = nodeInfo n@@ -859,11 +924,9 @@ nodeInfo (CBreak d) = nodeInfo d nodeInfo (CReturn _ n) = nodeInfo n nodeInfo (CAsm _ n) = nodeInfo n--instance (CNode t1) => Pos (CStatement t1) where+instance CNode t1 => Pos (CStatement t1) where posOf x = posOf (nodeInfo x) - instance Annotated CStatement where annotation (CLabel _ _ _ n) = n annotation (CCase _ _ n) = n@@ -898,14 +961,11 @@ 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+instance CNode t1 => CNode (CAssemblyStatement t1) where nodeInfo (CAsmStmt _ _ _ _ _ n) = nodeInfo n--instance (CNode t1) => Pos (CAssemblyStatement t1) where+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)@@ -913,46 +973,37 @@ (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+instance CNode t1 => CNode (CAssemblyOperand t1) where nodeInfo (CAsmOperand _ _ _ n) = nodeInfo n--instance (CNode t1) => Pos (CAssemblyOperand t1) where+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+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+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@@ -961,43 +1012,47 @@ amap f (CBlockDecl n) = CBlockDecl (amap f n) amap f (CNestedFunDef n) = CNestedFunDef (amap f n) --instance (CNode t1) => CNode (CDeclarationSpecifier t1) where+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+ nodeInfo (CFunSpec d) = nodeInfo d+ nodeInfo (CAlignSpec 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)-+ fmap _f (CFunSpec a1) = CFunSpec (fmap _f a1)+ fmap _f (CAlignSpec a1) = CAlignSpec (fmap _f a1) instance Annotated CDeclarationSpecifier where annotation (CStorageSpec n) = annotation n annotation (CTypeSpec n) = annotation n annotation (CTypeQual n) = annotation n+ annotation (CFunSpec n) = annotation n+ annotation (CAlignSpec 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)-+ amap f (CFunSpec n) = CFunSpec (amap f n)+ amap f (CAlignSpec n) = CAlignSpec (amap f n) -instance (CNode t1) => CNode (CStorageSpecifier t1) where+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+ nodeInfo (CClKernel d) = nodeInfo d+ nodeInfo (CClGlobal d) = nodeInfo d+ nodeInfo (CClLocal 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)@@ -1005,7 +1060,9 @@ fmap _f (CExtern a1) = CExtern (_f a1) fmap _f (CTypedef a1) = CTypedef (_f a1) fmap _f (CThread a1) = CThread (_f a1)-+ fmap _f (CClKernel a1) = CClKernel (_f a1)+ fmap _f (CClGlobal a1) = CClGlobal (_f a1)+ fmap _f (CClLocal a1) = CClLocal (_f a1) instance Annotated CStorageSpecifier where annotation (CAuto n) = n@@ -1014,36 +1071,44 @@ annotation (CExtern n) = n annotation (CTypedef n) = n annotation (CThread n) = n+ annotation (CClKernel n) = n+ annotation (CClGlobal n) = n+ annotation (CClLocal 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)-+ amap f (CClKernel a_1) = CClKernel (f a_1)+ amap f (CClGlobal a_1) = CClGlobal (f a_1)+ amap f (CClLocal a_1) = CClLocal (f a_1) -instance (CNode t1) => CNode (CTypeSpecifier t1) where+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 (CBFloat16Type d) = nodeInfo d nodeInfo (CFloatType d) = nodeInfo d+ nodeInfo (CFloatNType _ _ 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 (CInt128Type d) = nodeInfo d+ nodeInfo (CUInt128Type 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+ nodeInfo (CAtomicType _ 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)@@ -1051,17 +1116,21 @@ fmap _f (CIntType a1) = CIntType (_f a1) fmap _f (CLongType a1) = CLongType (_f a1) fmap _f (CFloatType a1) = CFloatType (_f a1)+ fmap _f (CBFloat16Type a1) = CBFloat16Type (_f a1)+ fmap _f (CFloatNType n x a1) = CFloatNType n x (_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 (CInt128Type a1) = CInt128Type (_f a1)+ fmap _f (CUInt128Type a1) = CUInt128Type (_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)-+ fmap _f (CAtomicType a1 a2) = CAtomicType (fmap _f a1) (_f a2) instance Annotated CTypeSpecifier where annotation (CVoidType n) = n@@ -1070,135 +1139,175 @@ annotation (CIntType n) = n annotation (CLongType n) = n annotation (CFloatType n) = n+ annotation (CBFloat16Type n) = n+ annotation (CFloatNType _ _ n) = n annotation (CDoubleType n) = n annotation (CSignedType n) = n annotation (CUnsigType n) = n annotation (CBoolType n) = n annotation (CComplexType n) = n+ annotation (CInt128Type n) = n+ annotation (CUInt128Type n) = n annotation (CSUType _ n) = n annotation (CEnumType _ n) = n annotation (CTypeDef _ n) = n annotation (CTypeOfExpr _ n) = n annotation (CTypeOfType _ n) = n+ annotation (CAtomicType _ 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 (CBFloat16Type a_1) = CBFloat16Type (f a_1)+ amap f (CFloatNType n x a_1) = CFloatNType n x (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 (CInt128Type a_1) = CInt128Type (f a_1)+ amap f (CUInt128Type a_1) = CUInt128Type (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)-+ amap f (CAtomicType a_1 a_2) = CAtomicType a_1 (f a_2) -instance (CNode t1) => CNode (CTypeQualifier t1) where+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 (CAtomicQual d) = nodeInfo d nodeInfo (CAttrQual d) = nodeInfo d+ nodeInfo (CNullableQual d) = nodeInfo d+ nodeInfo (CNonnullQual d) = nodeInfo d+ nodeInfo (CClRdOnlyQual d) = nodeInfo d+ nodeInfo (CClWrOnlyQual d) = nodeInfo d -instance (CNode t1) => Pos (CTypeQualifier t1) where+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 (CAtomicQual a1) = CAtomicQual (_f a1) fmap _f (CAttrQual a1) = CAttrQual (fmap _f a1)-+ fmap _f (CNullableQual a1) = CNullableQual (_f a1)+ fmap _f (CNonnullQual a1) = CNonnullQual (_f a1)+ fmap _f (CClRdOnlyQual a1) = CClRdOnlyQual (_f a1)+ fmap _f (CClWrOnlyQual a1) = CClWrOnlyQual (_f a1) instance Annotated CTypeQualifier where annotation (CConstQual n) = n annotation (CVolatQual n) = n annotation (CRestrQual n) = n- annotation (CInlineQual n) = n+ annotation (CAtomicQual n) = n annotation (CAttrQual n) = annotation n+ annotation (CNullableQual n) = n+ annotation (CNonnullQual n) = n+ annotation (CClRdOnlyQual n) = n+ annotation (CClWrOnlyQual n) = 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 (CAtomicQual a_1) = CAtomicQual (f a_1) amap f (CAttrQual n) = CAttrQual (amap f n)+ amap f (CNullableQual a_1) = CNullableQual (f a_1)+ amap f (CNonnullQual a_1) = CNonnullQual (f a_1)+ amap f (CClRdOnlyQual a_1) = CClRdOnlyQual (f a_1)+ amap f (CClWrOnlyQual a_1) = CClWrOnlyQual (f a_1) +instance CNode t1 => CNode (CFunctionSpecifier t1) where+ nodeInfo (CInlineQual d) = nodeInfo d+ nodeInfo (CNoreturnQual d) = nodeInfo d+instance CNode t1 => Pos (CFunctionSpecifier t1) where+ posOf x = posOf (nodeInfo x) -instance (CNode t1) => CNode (CStructureUnion t1) where- nodeInfo (CStruct _ _ _ _ n) = nodeInfo n+instance Functor CFunctionSpecifier where+ fmap _f (CInlineQual a1) = CInlineQual (_f a1)+ fmap _f (CNoreturnQual a1) = CNoreturnQual (_f a1) -instance (CNode t1) => Pos (CStructureUnion t1) where+instance Annotated CFunctionSpecifier where+ annotation (CInlineQual n) = n+ annotation (CNoreturnQual n) = n+ amap f (CInlineQual a_1) = CInlineQual (f a_1)+ amap f (CNoreturnQual a_1) = CNoreturnQual (f a_1)++instance CNode t1 => CNode (CAlignmentSpecifier t1) where+ nodeInfo (CAlignAsType _ n) = nodeInfo n+ nodeInfo (CAlignAsExpr _ n) = nodeInfo n+instance CNode t1 => Pos (CAlignmentSpecifier t1) where posOf x = posOf (nodeInfo x) +instance Functor CAlignmentSpecifier where+ fmap _f (CAlignAsType a1 a2) = CAlignAsType (fmap _f a1) (_f a2)+ fmap _f (CAlignAsExpr a1 a2) = CAlignAsExpr (fmap _f a1) (_f a2) +instance Annotated CAlignmentSpecifier where+ annotation (CAlignAsType _ n) = n+ annotation (CAlignAsExpr _ n) = n+ amap f (CAlignAsType a_1 a_2) = CAlignAsType a_1 (f a_2)+ amap f (CAlignAsExpr a_1 a_2) = CAlignAsExpr a_1 (f a_2)++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+instance CNode t1 => CNode (CEnumeration t1) where nodeInfo (CEnum _ _ _ n) = nodeInfo n--instance (CNode t1) => Pos (CEnumeration t1) where+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+instance CNode t1 => CNode (CInitializer t1) where nodeInfo (CInitExpr _ n) = nodeInfo n nodeInfo (CInitList _ n) = nodeInfo n--instance (CNode t1) => Pos (CInitializer t1) where+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+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+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@@ -1207,24 +1316,19 @@ 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+instance CNode t1 => CNode (CAttribute t1) where nodeInfo (CAttr _ _ n) = nodeInfo n--instance (CNode t1) => Pos (CAttribute t1) where+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+instance CNode t1 => CNode (CExpression t1) where nodeInfo (CComma _ n) = nodeInfo n nodeInfo (CAssign _ _ _ n) = nodeInfo n nodeInfo (CCond _ _ _ n) = nodeInfo n@@ -1243,14 +1347,13 @@ nodeInfo (CVar _ n) = nodeInfo n nodeInfo (CConst d) = nodeInfo d nodeInfo (CCompoundLit _ _ n) = nodeInfo n+ nodeInfo (CGenericSelection _ _ 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+instance CNode t1 => Pos (CExpression t1) where posOf x = posOf (nodeInfo x) - instance Annotated CExpression where annotation (CComma _ n) = n annotation (CAssign _ _ _ n) = n@@ -1270,6 +1373,7 @@ annotation (CVar _ n) = n annotation (CConst n) = annotation n annotation (CCompoundLit _ _ n) = n+ annotation (CGenericSelection _ _ n) = n annotation (CStatExpr _ n) = n annotation (CLabAddrExpr _ n) = n annotation (CBuiltinExpr n) = annotation n@@ -1291,20 +1395,21 @@ 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 (CGenericSelection a_1 a_2 a_3)+ = CGenericSelection 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+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+ nodeInfo (CBuiltinConvertVector _ _ n) = nodeInfo n+ nodeInfo (CBuiltinBitCast _ _ 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)@@ -1312,36 +1417,41 @@ = 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)-+ fmap _f (CBuiltinConvertVector a1 a2 a3)+ = CBuiltinConvertVector (fmap _f a1) (fmap _f a2) (_f a3)+ fmap _f (CBuiltinBitCast a1 a2 a3)+ = CBuiltinBitCast (fmap _f a1) (fmap _f a2) (_f a3) instance Annotated CBuiltinThing where annotation (CBuiltinVaArg _ _ n) = n annotation (CBuiltinOffsetOf _ _ n) = n annotation (CBuiltinTypesCompatible _ _ n) = n+ annotation (CBuiltinConvertVector _ _ n) = n+ annotation (CBuiltinBitCast _ _ 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)-+ amap f (CBuiltinConvertVector a_1 a_2 a_3) =+ CBuiltinConvertVector a_1 a_2 (f a_3)+ amap f (CBuiltinBitCast a_1 a_2 a_3) =+ CBuiltinBitCast a_1 a_2 (f a_3) -instance (CNode t1) => CNode (CConstant t1) where+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+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@@ -1352,17 +1462,13 @@ 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+instance CNode t1 => CNode (CStringLiteral t1) where nodeInfo (CStrLit _ n) = nodeInfo n--instance (CNode t1) => Pos (CStringLiteral t1) where+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
src/Language/C/Syntax/Constants.hs view
@@ -23,14 +23,16 @@ cFloat, CFloat(..), readCFloat, -- * C string literals cString, cString_w, CString(..), getCString, showStringLit, concatCStrings,+ -- * Clang C version literals+ ClangCVersion(..), readClangCVersion, ) 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+import Data.Data (Data)+import GHC.Generics (Generic, Generic1)+import Control.DeepSeq (NFData) -- | C char constants (abstract) data CChar = CChar@@ -39,12 +41,14 @@ | CChars [Char] -- multi-character character constant !Bool -- wide flag- deriving (Eq,Ord,Data,Typeable)+ deriving (Eq,Ord,Data,Generic) instance Show CChar where showsPrec _ (CChar c wideflag) = _showWideFlag wideflag . showCharConst c- showsPrec _ (CChars cs wideflag) = _showWideFlag wideflag . (sQuote $ concatMap escapeCChar cs)+ showsPrec _ (CChars cs wideflag) = _showWideFlag wideflag . sQuote (concatMap escapeCChar cs) +instance NFData CChar+ -- | @showCharConst c@ prepends _a_ String representing the C char constant corresponding to @c@. -- If necessary uses octal or hexadecimal escape sequences. showCharConst :: Char -> ShowS@@ -54,7 +58,7 @@ _showWideFlag flag = if flag then showString "L" else id -- | get the haskell representation of a char constant-getCChar :: CChar -> [Char]+getCChar :: CChar -> String getCChar (CChar c _) = [c] getCChar (CChars cs _) = cs @@ -79,19 +83,24 @@ cChar_w c = CChar c True -- | create a multi-character character constant-cChars :: [Char] -> Bool -> CChar+cChars :: String -> Bool -> CChar cChars = CChars -- | datatype for memorizing the representation of an integer-data CIntRepr = DecRepr | HexRepr | OctalRepr deriving (Eq,Ord,Enum,Bounded,Data,Typeable)+data CIntRepr = DecRepr | HexRepr | OctalRepr+ deriving (Eq,Ord,Enum,Bounded,Data,Generic) +instance NFData CIntRepr+ -- | datatype representing type flags for integers-data CIntFlag = FlagUnsigned | FlagLong | FlagLongLong | FlagImag deriving (Eq,Ord,Enum,Bounded,Data,Typeable)+data CIntFlag = FlagUnsigned | FlagLong | FlagLongLong | FlagImag+ deriving (Eq,Ord,Enum,Bounded,Data,Generic) instance Show CIntFlag where show FlagUnsigned = "u" show FlagLong = "L" show FlagLongLong = "LL" show FlagImag = "i"+instance NFData CIntFlag {-# SPECIALIZE setFlag :: CIntFlag -> Flags CIntFlag -> Flags CIntFlag #-} {-# SPECIALIZE clearFlag :: CIntFlag -> Flags CIntFlag -> Flags CIntFlag #-}@@ -101,13 +110,14 @@ !Integer !CIntRepr !(Flags CIntFlag) -- integer flags- deriving (Eq,Ord,Data,Typeable)+ deriving (Eq,Ord,Data,Generic) instance Show CInteger where- showsPrec _ (CInteger i repr flags) = showInt i . showString (concatMap showIFlag [FlagUnsigned .. ]) where+ showsPrec _ (CInteger ig repr flags) = showInt ig . 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+ showInt num = case repr of DecRepr -> shows num+ OctalRepr -> showString "0" . showOct num+ HexRepr -> showString "0x" . showHex num+instance NFData CInteger -- To be used in the lexer -- Note that the flag lexer won't scale@@ -142,9 +152,10 @@ -- | Floats (represented as strings) data CFloat = CFloat !String- deriving (Eq,Ord,Data,Typeable)+ deriving (Eq,Ord,Data,Generic) instance Show CFloat where showsPrec _ (CFloat internal) = showString internal+instance NFData CFloat cFloat :: Float -> CFloat cFloat = CFloat . show@@ -153,13 +164,25 @@ readCFloat :: String -> CFloat readCFloat = CFloat +-- | Clang dotted version literal+-- <https://clang.llvm.org/docs/AttributeReference.html#availability>+data ClangCVersion = ClangCVersion+ !String+ deriving (Eq,Ord,Data)+instance Show ClangCVersion where+ showsPrec _ (ClangCVersion internal) = showString internal++readClangCVersion :: String -> ClangCVersion+readClangCVersion = ClangCVersion+ -- | C String literals data CString = CString- [Char] -- characters+ String -- characters Bool -- wide flag- deriving (Eq,Ord,Data,Typeable)+ deriving (Eq,Ord,Data, Generic) instance Show CString where showsPrec _ (CString str wideflag) = _showWideFlag wideflag . showStringLit str+instance NFData CString -- construction cString :: String -> CString@@ -223,7 +246,6 @@ escapeChar '\\' = "\\\\" escapeChar '\a' = "\\a" escapeChar '\b' = "\\b"-escapeChar '\ESC' = "\\e"; escapeChar '\f' = "\\f" escapeChar '\n' = "\\n" escapeChar '\r' = "\\r"@@ -274,7 +296,8 @@ head' _ (x:_) = x -- TODO: Move to separate file ?-newtype Flags f = Flags Integer deriving (Eq,Ord,Data,Typeable)+newtype Flags f = Flags Integer deriving (Eq,Ord,Data,Generic,Generic1)+instance NFData (Flags f) noFlags :: Flags f noFlags = Flags 0 setFlag :: (Enum f) => f -> Flags f -> Flags f
src/Language/C/Syntax/Ops.hs view
@@ -25,7 +25,9 @@ isEffectfulOp ) where-import Data.Generics+import Data.Data (Data)+import GHC.Generics (Generic)+import Control.DeepSeq (NFData) -- | C assignment operators (K&R A7.17) data CAssignOp = CAssignOp | CMulAssOp@@ -38,8 +40,10 @@ | CAndAssOp | CXorAssOp | COrAssOp- deriving (Eq,Ord,Show,Data,Typeable)+ deriving (Eq,Ord,Show,Data,Generic) +instance NFData CAssignOp+ assignBinop :: CAssignOp -> CBinaryOp assignBinop CAssignOp = error "direct assignment has no binary operator" assignBinop CMulAssOp = CMulOp@@ -73,8 +77,10 @@ | COrOp -- ^ inclusive bitwise or | CLndOp -- ^ logical and | CLorOp -- ^ logical or- deriving (Eq,Ord,Show,Data,Typeable)+ deriving (Eq,Ord,Show,Data,Generic) +instance NFData CBinaryOp+ isCmpOp :: CBinaryOp -> Bool isCmpOp op = op `elem` [ CLeqOp, CGeqOp, CLeOp, CGrOp, CEqOp, CNeqOp ] @@ -99,7 +105,9 @@ | CMinOp -- ^ prefix minus | CCompOp -- ^ one's complement | CNegOp -- ^ logical negation- deriving (Eq,Ord,Show,Data,Typeable)+ deriving (Eq,Ord,Show,Data,Generic)++instance NFData CUnaryOp isEffectfulOp :: CUnaryOp -> Bool isEffectfulOp op = op `elem` [ CPreIncOp, CPreDecOp, CPostIncOp, CPostDecOp ]
src/Language/C/Syntax/Utils.hs view
@@ -47,7 +47,7 @@ mapSubStmts stop f (CIf e sthen selse ni) = f (CIf e (mapSubStmts stop f sthen)- (maybe Nothing (Just . mapSubStmts stop f) selse)+ (fmap (mapSubStmts stop f) selse) ni) mapSubStmts stop f (CSwitch e s ni) = f (CSwitch e (mapSubStmts stop f s) ni)
src/Language/C/System/GCC.hs view
@@ -64,6 +64,11 @@ case unparsed_args of ("-E":rest) -> mungeArgs parsed rest + (flag:flagArg:rest) | flag == "-MF"+ || flag == "-MT"+ || flag == "-MQ"+ -> mungeArgs (cpp_args,(extra,other `snoc` flag `snoc` flagArg)) rest+ (flag:rest) | flag == "-c" || flag == "-S" || "-M" `isPrefixOf` flag@@ -75,7 +80,7 @@ (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")+ (cfile:rest) | any (`isSuffixOf` cfile) (words ".c .hc .h") -> if isJust inp then Left "two input files given" else mungeArgs ((Just cfile,out,cpp_opts),unparsed) rest@@ -89,13 +94,13 @@ | "-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)+ getDefine opt = let (key,val) = break (== '=') opt in Define key (drop 1 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+buildCppArgs (CppArgs options extra_args _tmpdir input_file output_file_opt) = (concatMap tOption options) ++ outputFileOpt ++ ["-E", input_file]
src/Language/C/System/Preprocess.hs view
@@ -12,7 +12,7 @@ module Language.C.System.Preprocess ( Preprocessor(..), CppOption(..),- CppArgs(..),rawCppArgs,addCppOption,addExtraOption,+ CppArgs(..),rawCppArgs,addCppOption,addExtraOption,cppFile, runPreprocessor, isPreprocessed, )@@ -21,7 +21,6 @@ import System.Exit import System.Directory import System.FilePath-import System.Environment import System.IO import Control.Exception import Control.Monad@@ -58,6 +57,7 @@ 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 =@@ -66,16 +66,16 @@ -- | add a typed option to the given preprocessor arguments addCppOption :: CppArgs -> CppOption -> CppArgs addCppOption cpp_args opt =- cpp_args { cppOptions = opt : (cppOptions cpp_args) }+ 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) }+ 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+runPreprocessor cpp cpp_args = bracket getActualOutFile -- remove outfile if it was temporary
+ test/harness/run-harness.hs view
@@ -0,0 +1,70 @@+module Main where++import Data.List (intercalate)+import System.Exit (ExitCode(..), exitFailure, exitSuccess, exitWith)+import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, setCurrentDirectory,+ getDirectoryContents)+import System.FilePath ((</>))+import System.Process (readProcessWithExitCode, callProcess)+import System.IO (hPutStrLn, hPrint, stderr)+import Control.Monad (filterM, liftM, when)++testDirs :: [String]+testDirs = ["test/harness","harness","."]++getActualTestDirectory :: [String] -> IO FilePath+getActualTestDirectory test_dirs = do+ validDirs <- filterM (doesFileExist . (</> "run-harness.hs")) test_dirs+ case validDirs of+ [] -> ioError (userError ("run-harness.hs not found in " ++ intercalate " or " test_dirs))+ (d:_) -> return d++subdirectoriesOf :: FilePath -> IO [FilePath]+subdirectoriesOf fp = do+ entries <- getDirectoryContents fp+ filterM (doesDirectoryExist . (fp </>)) (filter (not . isSpecialDir) entries)+ where+ isSpecialDir "." = True+ isSpecialDir ".." = True+ isSpecialDir _ = False++-- from Control.Monad.Extra+findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)+findM _ [] = return Nothing+findM p (x:xs) = do guard <- p x ; if guard then (return $ Just x) else (findM p xs)++main :: IO ExitCode+main = do+ actual_test_dir <- getActualTestDirectory testDirs+ has_makefile <- doesFileExist (actual_test_dir </> "Makefile")+ when (not has_makefile) $ do+ hPutStrLn stderr "No Makefile found (out of source tree)"+ hPutStrLn stderr "Skipping harness test"+ exitWith ExitSuccess+ tests <- subdirectoriesOf actual_test_dir+ cdir <- getCurrentDirectory+ hPutStrLn stderr ("Changing to test directory " ++ actual_test_dir ++ " and compiling")+ -- build test executables+ setCurrentDirectory (cdir</>actual_test_dir)+ callProcess "make" ["prepare"]+ -- run harness tests+ hasFailure <- findM (liftM (/= ExitSuccess) . runTest . (cdir</>) . (actual_test_dir</>)) tests+ setCurrentDirectory cdir+ case hasFailure of+ Nothing -> exitSuccess+ Just _failed -> exitFailure+ where+ runTest :: FilePath -> IO ExitCode+ runTest dir = do+ setCurrentDirectory dir+ (exitCode, _outp, _errp) <- readProcessWithExitCode "make" [] ""+ hPutStrLn stderr ("cd " ++ dir ++ " && make: " ++ show exitCode)+ when (exitCode /= ExitSuccess) $ do+ hPutStrLn stderr "=== Standard Output ==="+ hPutStrLn stderr _outp+ hPutStrLn stderr "=== Error Output ==="+ hPutStrLn stderr _errp+ hPutStrLn stderr "=== End of Output ==="+ return exitCode++