diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -7,6 +7,7 @@ Iavor Diatchki Kevin Charter +Aleksey Kliger This project originated from the C parser component of c2hs, for many additional contributors see AUTHORS.c2hs. diff --git a/ChangeLog b/ChangeLog deleted file mode 100644 --- a/ChangeLog +++ /dev/null @@ -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 - * 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 - diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 : 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 + * 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 + diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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="" -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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`. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/env runhaskell - -import Distribution.Simple - -main = defaultMain diff --git a/language-c.cabal b/language-c.cabal --- a/language-c.cabal +++ b/language-c.cabal @@ -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 diff --git a/src/Language/C.hs b/src/Language/C.hs --- a/src/Language/C.hs +++ b/src/Language/C.hs @@ -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 } diff --git a/src/Language/C/Analysis.hs b/src/Language/C/Analysis.hs --- a/src/Language/C/Analysis.hs +++ b/src/Language/C/Analysis.hs @@ -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 diff --git a/src/Language/C/Analysis/AstAnalysis.hs b/src/Language/C/Analysis/AstAnalysis.hs --- a/src/Language/C/Analysis/AstAnalysis.hs +++ b/src/Language/C/Analysis/AstAnalysis.hs @@ -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) diff --git a/src/Language/C/Analysis/Builtins.hs b/src/Language/C/Analysis/Builtins.hs --- a/src/Language/C/Analysis/Builtins.hs +++ b/src/Language/C/Analysis/Builtins.hs @@ -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] diff --git a/src/Language/C/Analysis/ConstEval.hs b/src/Language/C/Analysis/ConstEval.hs --- a/src/Language/C/Analysis/ConstEval.hs +++ b/src/Language/C/Analysis/ConstEval.hs @@ -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 diff --git a/src/Language/C/Analysis/Debug.hs b/src/Language/C/Analysis/Debug.hs --- a/src/Language/C/Analysis/Debug.hs +++ b/src/Language/C/Analysis/Debug.hs @@ -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 diff --git a/src/Language/C/Analysis/DeclAnalysis.hs b/src/Language/C/Analysis/DeclAnalysis.hs --- a/src/Language/C/Analysis/DeclAnalysis.hs +++ b/src/Language/C/Analysis/DeclAnalysis.hs @@ -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" diff --git a/src/Language/C/Analysis/DefTable.hs b/src/Language/C/Analysis/DefTable.hs --- a/src/Language/C/Analysis/DefTable.hs +++ b/src/Language/C/Analysis/DefTable.hs @@ -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 diff --git a/src/Language/C/Analysis/Export.hs b/src/Language/C/Analysis/Export.hs --- a/src/Language/C/Analysis/Export.hs +++ b/src/Language/C/Analysis/Export.hs @@ -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 diff --git a/src/Language/C/Analysis/MachineDescs.hs b/src/Language/C/Analysis/MachineDescs.hs new file mode 100644 --- /dev/null +++ b/src/Language/C/Analysis/MachineDescs.hs @@ -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 { .. } diff --git a/src/Language/C/Analysis/NameSpaceMap.hs b/src/Language/C/Analysis/NameSpaceMap.hs --- a/src/Language/C/Analysis/NameSpaceMap.hs +++ b/src/Language/C/Analysis/NameSpaceMap.hs @@ -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 diff --git a/src/Language/C/Analysis/SemError.hs b/src/Language/C/Analysis/SemError.hs --- a/src/Language/C/Analysis/SemError.hs +++ b/src/Language/C/Analysis/SemError.hs @@ -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 -- ~~~~~~~~~~~ diff --git a/src/Language/C/Analysis/SemRep.hs b/src/Language/C/Analysis/SemRep.hs --- a/src/Language/C/Analysis/SemRep.hs +++ b/src/Language/C/Analysis/SemRep.hs @@ -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 diff --git a/src/Language/C/Analysis/TravMonad.hs b/src/Language/C/Analysis/TravMonad.hs --- a/src/Language/C/Analysis/TravMonad.hs +++ b/src/Language/C/Analysis/TravMonad.hs @@ -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 diff --git a/src/Language/C/Analysis/TypeCheck.hs b/src/Language/C/Analysis/TypeCheck.hs --- a/src/Language/C/Analysis/TypeCheck.hs +++ b/src/Language/C/Analysis/TypeCheck.hs @@ -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@ diff --git a/src/Language/C/Analysis/TypeConversions.hs b/src/Language/C/Analysis/TypeConversions.hs --- a/src/Language/C/Analysis/TypeConversions.hs +++ b/src/Language/C/Analysis/TypeConversions.hs @@ -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 diff --git a/src/Language/C/Analysis/TypeUtils.hs b/src/Language/C/Analysis/TypeUtils.hs --- a/src/Language/C/Analysis/TypeUtils.hs +++ b/src/Language/C/Analysis/TypeUtils.hs @@ -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? diff --git a/src/Language/C/Data.hs b/src/Language/C/Data.hs --- a/src/Language/C/Data.hs +++ b/src/Language/C/Data.hs @@ -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 diff --git a/src/Language/C/Data/Error.hs b/src/Language/C/Data/Error.hs --- a/src/Language/C/Data/Error.hs +++ b/src/Language/C/Data/Error.hs @@ -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." diff --git a/src/Language/C/Data/Ident.hs b/src/Language/C/Data/Ident.hs --- a/src/Language/C/Data/Ident.hs +++ b/src/Language/C/Data/Ident.hs @@ -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 diff --git a/src/Language/C/Data/InputStream.hs b/src/Language/C/Data/InputStream.hs --- a/src/Language/C/Data/InputStream.hs +++ b/src/Language/C/Data/InputStream.hs @@ -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 diff --git a/src/Language/C/Data/Name.hs b/src/Language/C/Data/Name.hs --- a/src/Language/C/Data/Name.hs +++ b/src/Language/C/Data/Name.hs @@ -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 diff --git a/src/Language/C/Data/Node.hs b/src/Language/C/Data/Node.hs --- a/src/Language/C/Data/Node.hs +++ b/src/Language/C/Data/Node.hs @@ -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 diff --git a/src/Language/C/Data/Position.hs b/src/Language/C/Data/Position.hs --- a/src/Language/C/Data/Position.hs +++ b/src/Language/C/Data/Position.hs @@ -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 = "" - show BuiltinPosition = "" - show InternalPosition = "" - -{-# 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 "" + showsPrec _ BuiltinPosition = showString "" + showsPrec _ InternalPosition = showString "" -- | @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 diff --git a/src/Language/C/Data/RList.hs b/src/Language/C/Data/RList.hs --- a/src/Language/C/Data/RList.hs +++ b/src/Language/C/Data/RList.hs @@ -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) diff --git a/src/Language/C/Parser/Builtin.hs b/src/Language/C/Parser/Builtin.hs --- a/src/Language/C/Parser/Builtin.hs +++ b/src/Language/C/Parser/Builtin.hs @@ -18,4 +18,6 @@ -- predefined type names -- builtinTypeNames :: [Ident] -builtinTypeNames = [builtinIdent "__builtin_va_list"] +builtinTypeNames = [ + builtinIdent "__builtin_va_list" + ] diff --git a/src/Language/C/Parser/Lexer.x b/src/Language/C/Parser/Lexer.x --- a/src/Language/C/Parser/Lexer.x +++ b/src/Language/C/Parser/Lexer.x @@ -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: +@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 } diff --git a/src/Language/C/Parser/Parser.y b/src/Language/C/Parser/Parser.y --- a/src/Language/C/Parser/Parser.y +++ b/src/Language/C/Parser/Parser.y @@ -29,6 +29,8 @@ -- ------------------------------------------------------------------ { +{-# 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 to indicate that the order of the immidieate right-hand -sides doesn't matter. +To allow a lightweight notation, we will use the modifier to indicate that the order of the immidieate right-hand sides doesn't matter. - a* b+ c === any sequence of a's, b's and c's, which contains exactly 1 'c' and at least one 'b' -- storage class and type qualifier --------------------------------------------------------------------------------------------------------------- attr :- __attribute__((..)) -storage_class :- typedef | extern | static | auto | register | __thread -type_qualifier :- const | volatile | restrict | inline +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 :- 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 :- type_qualifier* storage_class+ +-- declaration_qualifier_list :- 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 :- 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, diff --git a/src/Language/C/Parser/ParserMonad.hs b/src/Language/C/Parser/ParserMonad.hs --- a/src/Language/C/Parser/ParserMonad.hs +++ b/src/Language/C/Parser/ParserMonad.hs @@ -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 diff --git a/src/Language/C/Parser/Tokens.hs b/src/Language/C/Parser/Tokens.hs --- a/src/Language/C/Parser/Tokens.hs +++ b/src/Language/C/Parser/Tokens.hs @@ -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" diff --git a/src/Language/C/Pretty.hs b/src/Language/C/Pretty.hs --- a/src/Language/C/Pretty.hs +++ b/src/Language/C/Pretty.hs @@ -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 diff --git a/src/Language/C/Syntax/AST.hs b/src/Language/C/Syntax/AST.hs --- a/src/Language/C/Syntax/AST.hs +++ b/src/Language/C/Syntax/AST.hs @@ -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 diff --git a/src/Language/C/Syntax/Constants.hs b/src/Language/C/Syntax/Constants.hs --- a/src/Language/C/Syntax/Constants.hs +++ b/src/Language/C/Syntax/Constants.hs @@ -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 +-- +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 diff --git a/src/Language/C/Syntax/Ops.hs b/src/Language/C/Syntax/Ops.hs --- a/src/Language/C/Syntax/Ops.hs +++ b/src/Language/C/Syntax/Ops.hs @@ -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 ] diff --git a/src/Language/C/Syntax/Utils.hs b/src/Language/C/Syntax/Utils.hs --- a/src/Language/C/Syntax/Utils.hs +++ b/src/Language/C/Syntax/Utils.hs @@ -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) diff --git a/src/Language/C/System/GCC.hs b/src/Language/C/System/GCC.hs --- a/src/Language/C/System/GCC.hs +++ b/src/Language/C/System/GCC.hs @@ -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] diff --git a/src/Language/C/System/Preprocess.hs b/src/Language/C/System/Preprocess.hs --- a/src/Language/C/System/Preprocess.hs +++ b/src/Language/C/System/Preprocess.hs @@ -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 diff --git a/test/harness/run-harness.hs b/test/harness/run-harness.hs new file mode 100644 --- /dev/null +++ b/test/harness/run-harness.hs @@ -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 (cdiractual_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 + +