packages feed

language-objc (empty) → 0.4.2.0

raw patch · 48 files changed

+13595/−0 lines, 48 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, containers, directory, filepath, newtype, pretty, process, syb

Files

+ AUTHORS view
@@ -0,0 +1,23 @@+John W. Lato            <jwlato@gmail.com>++This project originated from language-c, and would not exist without+the many authors and contributors to that library.++Benedikt Huber          <benedikt.huber@gmail.com>+Manuel M T Chakravarty  <chak@cse.unsw.edu.au>+Duncan Coutts           <duncan@haskell.org>+Bertram Felgenhauer     <int-e@gmx.de>++with code contributions and patches from++Iavor Diatchki          <iavor.diatchki@gmail.com>+Kevin Charter           <kcharter@gmail.com>++This project originated from the C parser component of c2hs,+for many additional contributors see AUTHORS.c2hs.++Special thanks for their great support, comments and suggestions to:++Duncan Coutts           <duncan@haskell.org>+Iavor Diatchki          <iavor.diatchki@gmail.com>+Don Steward             <dons@galois.com>
+ AUTHORS.c2hs view
@@ -0,0 +1,25 @@+Manuel M T Chakravarty	<chak@cse.unsw.edu.au>+Duncan Coutts		<duncan@haskell.org>++with contributions from (alphabetical order)++Bertram Felgenhauer	<int-e@gmx.de>+Ian Lynagh		<igloo@earth.li>+André Pang		<ozone@algorithm.com.au>+Jens-Ulrik Petersen	<petersen@haskell.org>+Armin Sander		<armin@mindwalker.org>+Sean Seefried		<sseefried@cse.unsw.edu.au>+Udo Stenzel		<u.stenzel@web.de>+Axel Simon              <A.Simon@ukc.ac.uk>+Michael Weber		<michaelw@debian.org>++Thanks for comments and suggestions to ++Roman Leshchinskiy	<rl@cs.tu-berlin.de>+Jan Kort		<kort@science.uva.nl>+Seth Kurtzberg		<seth@cql.com>+Simon Marlow		<simonmar@microsoft.com>+Matthias Neubauer	<neubauer@informatik.uni-freiburg.de>+Sven Panne		<sven.panne@aedion.de>+Simon L. Peyton Jones	<simonpj@microsoft.com>+Volker Wysk		<post@volker-wysk.de>
+ ChangeLog view
@@ -0,0 +1,4 @@++Version 0.4.2.0+  * initial release of language-objc+  * This project originated as a fork of language-c-0.4.2
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012      John W. Lato+              1999-2008 Manuel M T Chakravarty +                        Duncan Coutts+                        Benedikt Huber+Portions Copyright (c)  1989,  1990  James  A.  Roskind+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ README view
@@ -0,0 +1,39 @@+= 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 configure FLAGS+runhaskell Setup build+runhaskell Setup install++Provide the set of flags passing+ --flags="<flags-seperated-by-space>"+to configure.++== Compatibility ==++Tested with ghc-6.12 (Ubuntu), ghc-7.0 (OSX 10.5, Linux) and ghc-7.2 (Linux).+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.
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++import Distribution.Simple++main = defaultMain
+ language-objc.cabal view
@@ -0,0 +1,111 @@+Name:           language-objc+Version:        0.4.2.0+Cabal-Version:  >= 1.6+Build-Type:     Simple+License:        BSD3+License-File:   LICENSE+Copyright:      LICENSE+Author:         AUTHORS+Maintainer:     jwlato@gmail.com+Stability:      experimental+Homepage:       http://www.tiresiaspress.us/haskell/language-objc++Synopsis:       Analysis and generation of Objcective C code+Description:    Language-ObjC is a haskell library for the analysis and+                generation of Objective C code.+                It features a complete, well tested parser and pretty printer.+Category:       Language++Extra-Source-Files: AUTHORS AUTHORS.c2hs ChangeLog README+                    src/Language/ObjC/Parser/Lexer.x+                    src/Language/ObjC/Parser/Parser.y++Source-Repository head+  type:     git+  location: http://github.com/JohnLato/language-objc.git++Flag useByteStrings+    Description: Use ByteString as InputStream datatype+    Default: True+Flag separateSYB+  description: Data.Generics available in separate package.++Library+    Extensions: CPP, DeriveDataTypeable, PatternGuards, BangPatterns, ExistentialQuantification, GeneralizedNewtypeDeriving, ScopedTypeVariables++    Build-Depends: base       >= 3 && < 5,+                   filepath   == 1.3.*,+                   process    == 1.1.*,+                   directory  == 1.1.*,+                   array      == 0.4.*,+                   containers >= 0.4     && < 0.6,+                   newtype    == 0.2.*,+                   pretty     == 1.1.*++    If flag(separateSYB)+      Build-Depends:+            base >=4 && <5,+            syb  == 0.3.*+    Else+      Build-Depends:+            base <4++    if flag(useByteStrings)+        Build-Depends: bytestring >= 0.9.0+    else+        cpp-options: -DNO_BYTESTRING+    Build-Tools:    happy, alex++    Hs-Source-Dirs: src+    Exposed-Modules:+                      -- top-level+                      Language.ObjC+                      -- data+                      Language.ObjC.Data+                      Language.ObjC.Data.Position+                      Language.ObjC.Data.Ident+                      Language.ObjC.Data.Error+                      Language.ObjC.Data.Name+                      Language.ObjC.Data.Node+                      Language.ObjC.Data.InputStream+                      -- syntax+                      Language.ObjC.Syntax+                      Language.ObjC.Syntax.AST+                      Language.ObjC.Syntax.Builders+                      Language.ObjC.Syntax.Constants+                      Language.ObjC.Syntax.Ops+                      Language.ObjC.Syntax.Utils+                      -- parser+                      Language.ObjC.Parser+                      -- pretty printer+                      Language.ObjC.Pretty+                      -- system+                      Language.ObjC.System+                      Language.ObjC.System.Preprocess+                      Language.ObjC.System.GCC+                      -- analysis [experimental]+                      Language.ObjC.Analysis+                      Language.ObjC.Analysis.ConstEval+                      Language.ObjC.Analysis.Builtins+                      Language.ObjC.Analysis.SemError+                      Language.ObjC.Analysis.SemRep+                      Language.ObjC.Analysis.DefTable+                      Language.ObjC.Analysis.TravMonad+                      Language.ObjC.Analysis.AstAnalysis+                      Language.ObjC.Analysis.DeclAnalysis+                      Language.ObjC.Analysis.Debug+                      Language.ObjC.Analysis.TypeCheck+                      Language.ObjC.Analysis.TypeConversions+                      Language.ObjC.Analysis.TypeUtils+                      Language.ObjC.Analysis.NameSpaceMap+                      -- semrep -> code [alpha]+                      Language.ObjC.Analysis.Export+    Other-Modules:+                      Language.ObjC.Data.RList+                      -- parser implementation+                      Language.ObjC.Parser.Builtin+                      Language.ObjC.Parser.Lexer+                      Language.ObjC.Parser.ParserMonad+                      Language.ObjC.Parser.Tokens+                      Language.ObjC.Parser.Parser+
+ src/Language/ObjC.hs view
@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC+-- Copyright   :  2012 John W. Lato+--                (c) 2008 Benedikt Huber+--                [1995..2007]+--                   Manuel M. T. Chakravarty+--                   Duncan Coutts+--                   Betram Felgenhauer+-- License     : BSD-style+-- Maintainer  : jwlato@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Library for analysing and generating Objective-C code.+--+-- See <http://www.sivity.net/projects/language.c>+-----------------------------------------------------------------------------+module Language.ObjC (+    parseCFile, parseCFilePre, -- maybe change ?+    module Language.ObjC.Data,+    module Language.ObjC.Syntax,+    module Language.ObjC.Pretty,+    module Language.ObjC.Parser,+)+where+import Language.ObjC.Data+import Language.ObjC.Syntax+import Language.ObjC.Pretty+import Language.ObjC.Parser+import Language.ObjC.System.Preprocess++-- | preprocess (if necessary) and parse a C source file+--+--   > Synopsis: parseCFile preprocesssor tmp-dir? cpp-opts file+--   > Example:  parseCFile (newGCC "gcc") Nothing ["-I/usr/include/gtk-2.0"] my-gtk-exts.c+parseCFile :: (Preprocessor cpp) => cpp -> (Maybe FilePath) -> [String] -> FilePath -> IO (Either ParseError CTranslUnit)+parseCFile cpp tmp_dir_opt args input_file = do+    input_stream <- if not (isPreprocessed input_file)+                        then  let cpp_args = (rawCppArgs args input_file) { cppTmpDir = tmp_dir_opt }+                              in  runPreprocessor cpp cpp_args >>= handleCppError+                        else  readInputStream input_file+    return$ parseC input_stream (initPos input_file)+    where+    handleCppError (Left exitCode) = fail $ "Preprocessor failed with " ++ show exitCode+    handleCppError (Right ok)      = return ok++-- | parse an already preprocessed C file+--+--   > Synopsis: parseCFilePre file.i+parseCFilePre :: FilePath -> IO (Either ParseError CTranslUnit)+parseCFilePre file = do+    input_stream <- readInputStream file+    return $ parseC input_stream (initPos file)
+ src/Language/ObjC/Analysis.hs view
@@ -0,0 +1,69 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Analysis+-- Copyright   :  (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  alpha+-- Portability :  ghc+--+-- Analysis of the AST.+--+-- Currently, we provide a monad for analysis and analyze declarations and types.+-- Especially note that there is no direct support for analyzing function bodies and+-- constant expressions.+--+-- /NOTE/ This is an experimental interface, and therefore the API will change in the+-- future.+--+-- DONE:+--+--  * Name analysis framework+--+--  * File-scope analysis+--+--  * Declaration analysis+--+-- TODO:+--+--  * Type checking expressions+--+--  * Constant expression evaluation (CEE)+--+--  * Typed representation of attributes (depends on CEE)+--+--  * Normalized representation of initializers+--+--  * Support for analyzing function bodies (depends on CEE)+--+--  * Normalizing expressions and statements+--+--  * Formal rules how to link back to the AST using NodeInfo fields+--+--  * Typed assembler representation++-----------------------------------------------------------------------------+module Language.ObjC.Analysis (+    -- * Semantic representation+    module Language.ObjC.Analysis.SemRep,+    -- * Error datatypes for the analysis+    module Language.ObjC.Analysis.SemError,+    -- * Traversal monad+    module Language.ObjC.Analysis.TravMonad,+    -- * Top level analysis+    module Language.ObjC.Analysis.AstAnalysis,+    -- * Analyzing declarations+    module Language.ObjC.Analysis.DeclAnalysis,+    -- * Debug print+    module Language.ObjC.Analysis.Debug,+)+where+import Language.ObjC.Analysis.SemError+import Language.ObjC.Analysis.SemRep++import Language.ObjC.Analysis.TravMonad++import Language.ObjC.Analysis.AstAnalysis+import Language.ObjC.Analysis.DeclAnalysis++import Language.ObjC.Analysis.Debug
+ src/Language/ObjC/Analysis/AstAnalysis.hs view
@@ -0,0 +1,742 @@+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Parser.Translation+-- Copyright   :  (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  alpha+-- Portability :  ghc+--+-- Analyse the parse tree+--+-- Traverses the AST, analyses declarations and invokes handlers.+-----------------------------------------------------------------------------+module Language.ObjC.Analysis.AstAnalysis (+    -- * Top-level analysis+    analyseAST,+    analyseExt,analyseFunDef,analyseDecl,+    -- * Building blocks for additional analyses+    analyseFunctionBody,+    defineParams,+    -- * Type checking+    tExpr, ExprSide(..),+    tStmt, StmtCtx(..),+    tDesignator,+    defaultMD+)+where+import Language.ObjC.Analysis.SemError+import Language.ObjC.Analysis.SemRep+import Language.ObjC.Analysis.TravMonad+import Language.ObjC.Analysis.ConstEval+import Language.ObjC.Analysis.Debug+import Language.ObjC.Analysis.DefTable (DefTable, globalDefs, defineScopedIdent,+                                     defineLabel, inFileScope, lookupTag,+                                     lookupLabel, insertType, lookupType)+import Language.ObjC.Analysis.DeclAnalysis+import Language.ObjC.Analysis.TypeUtils+import Language.ObjC.Analysis.TypeCheck++import Language.ObjC.Data+import Language.ObjC.Pretty+import Language.ObjC.Syntax.AST+import Language.ObjC.Syntax.Constants+import Language.ObjC.Syntax.Ops+import Language.ObjC.Syntax.Utils+import Text.PrettyPrint.HughesPJ+++import Control.Monad+import Prelude hiding (reverse)+import qualified Data.Map as Map+import Data.Maybe++-- * analysis++-- | Analyse the given AST+--+-- @analyseAST ast@ results in global declaration dictionaries.+-- If you want to perform specific actions on declarations or definitions, you may provide+-- callbacks in the @MonadTrav@ @m@.+--+-- Returns the set of global declarations and definitions which where successfully translated.+-- It is the users responsibility to check whether any hard errors occurred (@runTrav@ does this for you).+analyseAST :: (MonadTrav m) => CTranslUnit -> m GlobalDecls+analyseAST (CTranslUnit decls _file_node) = do+    -- analyse all declarations, but recover from errors+    mapRecoverM_ analyseExt decls+    -- check we are in global scope afterwards+    getDefTable >>= \dt -> when (not (inFileScope dt)) $+        error "Internal Error: Not in filescope after analysis"+    -- get the global definition table (XXX: remove ?)+    liftM globalDefs getDefTable+    where+    mapRecoverM_ f = mapM_ (handleTravError . f)++-- | Analyse an top-level declaration+analyseExt :: (MonadTrav m) => CExtDecl -> m ()+analyseExt (CAsmExt asm _)+    = handleAsmBlock asm+analyseExt (CFDefExt fundef)+    = analyseFunDef fundef+analyseExt (CDeclExt decl)+    = analyseDecl False decl++-- | Analyse a function definition+analyseFunDef :: (MonadTrav m) => CFunDef -> m ()+analyseFunDef (CFunDef declspecs declr oldstyle_decls stmt node_info) = do+    -- analyse the declarator+    var_decl_info <- analyseVarDecl' True declspecs declr oldstyle_decls Nothing+    let (VarDeclInfo name is_inline storage_spec attrs ty declr_node) = var_decl_info+    when (isNoName name) $ astError node_info "NoName in analyseFunDef"+    let ident = identOfVarName name+    -- improve incomplete type+    ty' <- improveFunDefType ty+    -- compute storage+    fun_storage <- computeFunDefStorage ident storage_spec+    let var_decl = VarDecl name (DeclAttrs is_inline fun_storage attrs) ty'+    -- callback for declaration+    handleVarDecl False (Decl var_decl node_info)+    -- process body+    stmt' <- analyseFunctionBody node_info var_decl stmt+    -- callback for definition+    handleFunDef ident (FunDef var_decl stmt' node_info)+    where+    improveFunDefType (FunctionType (FunTypeIncomplete return_ty) attrs) =+      return $ FunctionType (FunType return_ty [] False) attrs+    improveFunDefType ty = return $ ty++-- | Analyse a declaration other than a function definition+analyseDecl :: (MonadTrav m) => Bool -> CDecl -> m ()+analyseDecl is_local decl@(CDecl declspecs declrs node)+    | null declrs =+        case typedef_spec of Just _  -> astError node "bad typedef declaration: missing declarator"+                             Nothing -> analyseTypeDecl decl >> return ()+    | (Just declspecs') <- typedef_spec = mapM_ (uncurry (analyseTyDef declspecs')) declr_list+    | otherwise   = do let (storage_specs, attrs, typequals, typespecs, inline) =+                             partitionDeclSpecs declspecs+                       canonTySpecs <- canonicalTypeSpec typespecs+                       let specs =+                             (storage_specs, attrs, typequals, canonTySpecs, inline)+                       mapM_ (uncurry (analyseVarDeclr specs)) declr_list+    where+    declr_list = zip (True : repeat False) declrs+    typedef_spec = hasTypeDef declspecs++    analyseTyDef declspecs' handle_sue_def declr =+        case declr of+            (Just tydeclr, Nothing , Nothing) -> analyseTypeDef handle_sue_def declspecs' tydeclr node+            _ -> astError node "bad typdef declaration: bitfieldsize or initializer present"++    analyseVarDeclr specs handle_sue_def (Just declr, init_opt, Nothing) = do+        -- analyse the declarator+        let (storage_specs, attrs, typequals, canonTySpecs, inline) = specs+        vardeclInfo@(VarDeclInfo _ _ _ _ typ _) <-+          analyseVarDecl handle_sue_def storage_specs attrs typequals canonTySpecs inline+                         declr [] Nothing+        -- declare / define the object+        if (isFunctionType typ)+            then extFunProto vardeclInfo+            else (if is_local then localVarDecl else extVarDecl)+                 -- XXX: if Initializer becomes different from CInit, this+                 -- will have to change.+                 vardeclInfo init_opt+        init_opt' <- mapMaybeM init_opt (tInit typ)+        return ()+    analyseVarDeclr _ _ (Nothing,_,_)         = astError node "abstract declarator in object declaration"+    analyseVarDeclr _ _ (_,_,Just bitfieldSz) = astError node "bitfield size in object declaration"++-- | Analyse a typedef+analyseTypeDef :: (MonadTrav m) => Bool -> [CDeclSpec] -> CDeclr -> NodeInfo -> m ()+analyseTypeDef handle_sue_def declspecs declr node_info = do+    -- analyse the declarator+    (VarDeclInfo name is_inline storage_spec attrs ty declr_node) <- analyseVarDecl' handle_sue_def declspecs declr [] Nothing+    checkValidTypeDef is_inline storage_spec attrs+    when (isNoName name) $ astError node_info "NoName in analyseTypeDef"+    let ident = identOfVarName name+    handleTypeDef (TypeDef ident ty attrs node_info)+    where+    checkValidTypeDef True _ _ = astError node_info "inline specifier for typeDef"+    checkValidTypeDef _ NoStorageSpec _ = return ()+    checkValidTypeDef _ bad_storage _ = astError node_info $ "storage specified for typeDef: " ++ show bad_storage++-- | compute storage of a function definition+--+-- a function definition has static storage with internal linkage if specified `static`,+-- the previously declared linkage if any if 'extern' or no specifier are present. (See C99 6.2.2, clause 5)+--+-- This function won't raise an Trav error if the declaration is incompatible with the existing one,+-- this case is handled in 'handleFunDef'.+computeFunDefStorage :: (MonadTrav m) => Ident -> StorageSpec -> m Storage+computeFunDefStorage _ (StaticSpec b)  = return$ FunLinkage InternalLinkage+computeFunDefStorage ident other_spec  = do+  obj_opt <- lookupObject ident+  let defaultSpec = FunLinkage ExternalLinkage+  case other_spec of+    NoStorageSpec  -> return$ maybe defaultSpec declStorage obj_opt+    (ExternSpec False) -> return$ maybe defaultSpec declStorage obj_opt+    bad_spec -> throwTravError $ badSpecifierError (nodeInfo ident)+                  $ "unexpected function storage specifier (only static or extern is allowed)" ++ show bad_spec++-- (private) Get parameters of a function type+getParams :: Type -> Maybe [ParamDecl]+getParams (FunctionType (FunType _ params _) _) = Just params+getParams _ = Nothing++-- | handle a function prototype+extFunProto :: (MonadTrav m) => VarDeclInfo -> m ()+extFunProto (VarDeclInfo var_name is_inline storage_spec attrs ty node_info) =+    do  when (isNoName var_name) $ astError node_info "NoName in extFunProto"+        old_fun <- lookupObject (identOfVarName var_name)+        checkValidSpecs+        let decl = VarDecl var_name (DeclAttrs is_inline (funDeclLinkage old_fun) attrs) ty+        handleVarDecl False (Decl decl node_info)+        -- XXX: structs should be handled in 'function prototype scope' too+        enterPrototypeScope+        maybe (return ()) (mapM_ handleParamDecl) (getParams ty)+        leavePrototypeScope+    where+    funDeclLinkage old_fun =+        case storage_spec of+            NoStorageSpec    -> FunLinkage ExternalLinkage -- prototype declaration / external linkage+            StaticSpec False -> FunLinkage InternalLinkage -- prototype declaration / internal linkage+            ExternSpec False -> case old_fun of+                                    Nothing -> FunLinkage ExternalLinkage+                                    Just f  -> declStorage f+            _ -> error $ "funDeclLinkage: " ++ show storage_spec+    checkValidSpecs+        | hasThreadLocalSpec storage_spec = astError node_info "thread local storage specified for function"+        | RegSpec <- storage_spec         = astError node_info "invalid `register' storage specified for function"+        | otherwise                       = return ()++-- | handle a object declaration \/ definition+--+-- We have to check the storage specifiers here, as they determine wheter we're dealing with decalartions+-- or definitions+-- see [http://www.sivity.net/projects/language.c/wiki/ExternalDefinitions]+extVarDecl :: (MonadTrav m) => VarDeclInfo -> (Maybe Initializer) -> m ()+extVarDecl (VarDeclInfo var_name is_inline storage_spec attrs typ node_info) init_opt =+    do when (isNoName var_name) $ astError node_info "NoName in extVarDecl"+       (storage,is_def) <- globalStorage storage_spec+       let vardecl = VarDecl var_name (DeclAttrs is_inline storage attrs) typ+       if is_def+           then handleObjectDef False ident $ ObjDef vardecl init_opt node_info+           else handleVarDecl False $ Decl vardecl node_info+    where+       ident = identOfVarName var_name+       globalStorage _ | is_inline = astError node_info "invalid `inline' specifier external variable"+       globalStorage RegSpec       =+         do when (isJust init_opt) $ astError node_info "initializer given for global register variable"+            case var_name of+              NoName -> astError node_info "global register variable has no name"+              VarName _ Nothing -> astError node_info "no register specified for global register variable"+              _ -> return ()+            dt <- getDefTable+            when (hasFunDef dt) $ astError node_info "global register variable appears after a function definition"+            return (Static InternalLinkage False, False)+       -- tentative if there is no initializer, external+       globalStorage NoStorageSpec = return $ (Static ExternalLinkage False, True)+       -- tentative if there is no initializer, internal+       globalStorage (StaticSpec thread_local) = return $ (Static InternalLinkage thread_local, True)+       globalStorage (ExternSpec thread_local) =+           case init_opt of+               -- declaration with either external or old storage+               Nothing -> do old_decl <- lookupObject ident+                             return $ (maybe (Static ExternalLinkage thread_local) declStorage old_decl,False)+               -- warning, external definition+               Just _  -> do warn $ badSpecifierError node_info "Both initializer and `extern` specifier given - treating as definition"+                             return $ (Static ExternalLinkage thread_local, True)+       hasFunDef dt = any (isFuncDef . snd) (Map.toList $ gObjs $ globalDefs dt)+       isFuncDef (FunctionDef fd) = not $ isInline $ declAttrs fd+       isFuncDef _ = False+       isInline (DeclAttrs inl _ _) = inl++-- | handle a function-scope object declaration \/ definition+-- see [http://www.sivity.net/projects/language.c/wiki/LocalDefinitions]+localVarDecl :: (MonadTrav m) => VarDeclInfo -> (Maybe Initializer) -> m ()+localVarDecl (VarDeclInfo var_name is_inline storage_spec attrs typ node_info) init_opt =+    do when (isNoName var_name) $ astError node_info "NoName in localVarDecl"+       (storage,is_def) <- localStorage storage_spec+       let vardecl = VarDecl var_name (DeclAttrs is_inline storage attrs) typ+       if is_def+           then handleObjectDef True ident (ObjDef vardecl init_opt node_info)+           else handleVarDecl True (Decl vardecl node_info)+    where+    ident = identOfVarName var_name+    localStorage _+      | is_inline = astError node_info "invalid `inline' specifier for local variable"+    localStorage NoStorageSpec = return $ (Auto False,True)+    localStorage RegSpec = return $ (Auto True,True)+    -- static no linkage+    localStorage (StaticSpec thread_local) =+      return $ (Static NoLinkage thread_local,True)+    localStorage (ExternSpec thread_local)+      | isJust init_opt = astError node_info "extern keyword and initializer for local"+      | otherwise =+          do old_decl <- lookupObject ident+             return (maybe (Static ExternalLinkage thread_local) declStorage old_decl,False)+    localStorage s = astError node_info "bad storage specifier for local"++defineParams :: MonadTrav m => NodeInfo -> VarDecl -> m ()+defineParams ni decl =+  case (getParams $ declType decl) of+    Nothing -> astError ni+               "expecting complete function type in function definition"+    Just params -> mapM_ handleParamDecl params++analyseFunctionBody :: (MonadTrav m) => NodeInfo -> VarDecl -> CStat -> m Stmt+analyseFunctionBody node_info decl s@(CCompound localLabels items _) =+  do enterFunctionScope+     mapM_ (withDefTable . defineLabel) (localLabels ++ getLabels s)+     defineParams node_info decl+     -- record parameters+     mapM_ (tBlockItem [FunCtx decl]) items+     leaveFunctionScope+     return s -- XXX: bogus++analyseFunctionBody _ _ s = astError (nodeInfo s) "Function body is no compound statement"++data StmtCtx = FunCtx VarDecl+             | LoopCtx+             | SwitchCtx++-- | Given a context, determine the type declaration for the enclosing+--   function, if possible, given a context.+enclosingFunctionType :: [StmtCtx] -> Maybe Type+enclosingFunctionType [] = Nothing+enclosingFunctionType (FunCtx vd : _) = Just $ declType vd+enclosingFunctionType (_ : cs) = enclosingFunctionType cs++inLoop :: [StmtCtx] -> Bool+inLoop c = any isLoop c+  where isLoop LoopCtx = True+        isLoop _ = False++inSwitch :: [StmtCtx] -> Bool+inSwitch c = any isSwitch c+  where isSwitch SwitchCtx = True+        isSwitch _ = False++data ExprSide = LValue | RValue+                deriving (Eq, Show)++-- | Typecheck a statement, given a statement context. The type of a+--   statement is usually @void@, but expression statements and blocks+--   can sometimes have other types.+tStmt :: MonadTrav m => [StmtCtx] -> CStat -> m Type+tStmt c (CLabel _ s _ _)         = tStmt c s+tStmt c (CExpr e _)              =+  maybe (return voidType) (tExpr c RValue) e+tStmt c (CCompound ls body _)    =+  do enterBlockScope+     mapM_ (withDefTable . defineLabel) ls+     t <- foldM (const $ tBlockItem c) voidType body+     leaveBlockScope+     return t+tStmt c (CIf e sthen selse _)    =+  checkGuard c e >> tStmt c sthen+                 >> maybe (return ()) (\s -> tStmt c s >> return ()) selse+                 >> return voidType+tStmt c (CSwitch e s ni)         =+  tExpr c RValue e >>= checkIntegral' ni >>+  tStmt (SwitchCtx : c) s+tStmt c (CWhile e s _ _)         =+  checkGuard c e >> tStmt (LoopCtx : c) s+tStmt _ (CGoto l ni)             =+  do dt <- getDefTable+     case lookupLabel l dt of+       Just _ -> return voidType+       Nothing -> typeError ni $ "undefined label in goto: " ++ identToString l+tStmt c (CCont ni)               =+  do unless (inLoop c) $ astError ni "continue statement outside of loop"+     return voidType+tStmt c (CBreak ni)              =+  do unless (inLoop c || inSwitch c) $+            astError ni "break statement outside of loop or switch statement"+     return voidType+tStmt c (CReturn (Just e) ni)    =+  do t <- tExpr c RValue e+     rt <- case enclosingFunctionType c of+             Just (FunctionType (FunType rt _ _) _) -> return rt+             Just (FunctionType (FunTypeIncomplete rt) _) -> return rt+             Just ft -> astError ni $ "bad function type: " ++ pType ft+             Nothing -> astError ni "return statement outside function"+     case (rt, t) of+       -- apparently it's ok to return void from a void function?+       (DirectType TyVoid _ _, DirectType TyVoid _ _) -> return ()+       _ -> assignCompatible' ni CAssignOp rt t+     return voidType+tStmt _ (CReturn Nothing _)      = return voidType+-- XXX: anything to do for assembly?+tStmt _ (CAsm _ _)               = return voidType+tStmt c (CCase e s ni)           =+  do unless (inSwitch c) $+            astError ni "case statement outside of switch statement"+     tExpr c RValue e >>= checkIntegral' ni+     tStmt c s+tStmt c (CCases e1 e2 s ni)      =+  do unless (inSwitch c) $+            astError ni "case statement outside of switch statement"+     tExpr c RValue e1 >>= checkIntegral' ni+     tExpr c RValue e2 >>= checkIntegral' ni+     tStmt c s+tStmt c (CDefault s ni)          =+  do unless (inSwitch c) $+            astError ni "default statement outside of switch statement"+     tStmt c s+tStmt c (CFor i g inc s _)       =+  do enterBlockScope+     either (maybe (return ()) checkExpr) (analyseDecl True) i+     maybe (return ()) (checkGuard c) g+     maybe (return ()) checkExpr inc+     tStmt (LoopCtx : c) s+     leaveBlockScope+     return voidType+  where checkExpr e = tExpr c RValue e >> return ()+tStmt c (CGotoPtr e ni)          =+  do t <- tExpr c RValue e+     case t of+       (PtrType _ _ _) -> return voidType+       _               -> typeError ni "can't goto non-pointer"++-- | Typecheck a block item. When statement expressions are blocks,+--   they have the type of their last expression statement, so this+--   needs to return a type.+tBlockItem :: MonadTrav m => [StmtCtx] -> CBlockItem -> m Type+tBlockItem c (CBlockStmt s) = tStmt c s+tBlockItem _ (CBlockDecl d) = analyseDecl True d >> return voidType+-- TODO: fixup analyseFunDef to handle nested functions+tBlockItem _ (CNestedFunDef fd) = analyseFunDef fd >> return voidType++checkGuard :: MonadTrav m => [StmtCtx] -> CExpr -> m ()+checkGuard c e = tExpr c RValue e >>= checkScalar' (nodeInfo e)++-- XXX: this is bogus, correct only for IA32. We should eventually+-- have a collection of these and allow people to choose one.+defaultMD :: MachineDesc+defaultMD =+  MachineDesc+  { iSize = \it ->+            case it of+              TyBool   -> 1+              TyChar   -> 1+              TySChar  -> 1+              TyUChar  -> 1+              TyShort  -> 2+              TyUShort -> 2+              TyInt    -> 4+              TyUInt   -> 4+              TyLong   -> 4+              TyULong  -> 4+              TyLLong  -> 8+              TyULLong -> 8+  , fSize = \ft ->+            case ft of+              TyFloat   -> 4+              TyDouble  -> 8+              TyLDouble -> 16+  , builtinSize = \bt ->+                  case bt of+                    TyVaList -> 4+                    TyAny    -> 4+  , ptrSize = 4+  , voidSize = 1+  , iAlign = \it ->+             case it of+               TyBool   -> 1+               TyChar   -> 1+               TySChar  -> 1+               TyUChar  -> 1+               TyShort  -> 2+               TyUShort -> 2+               TyInt    -> 4+               TyUInt   -> 4+               TyLong   -> 4+               TyULong  -> 4+               TyLLong  -> 8+               TyULLong -> 8+  , fAlign = \ft ->+             case ft of+               TyFloat   -> 4+               TyDouble  -> 8+               TyLDouble -> 16+  , builtinAlign = \bt ->+                   case bt of+                     TyVaList -> 4+                     TyAny    -> 4+  , ptrAlign = 4+  , voidAlign = 1+  }++tExpr :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type+tExpr c side e =+  case nameOfNode (nodeInfo e) of+    Just n ->+      do dt <- getDefTable+         case lookupType dt n of+           Just t -> return t+           Nothing ->+             do t <- tExpr' c side e+                withDefTable (\dt -> (t, insertType dt n t))+    Nothing -> tExpr' c side e++-- | Typecheck an expression, with information about whether it+--   appears as an lvalue or an rvalue.+tExpr' :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type+tExpr' c side (CBinary op le re ni)    =+  do when (side == LValue) $ typeError ni "binary operator as lvalue"+     lt <- tExpr c RValue le+     rt <- tExpr c RValue re+     binopType' ni op lt rt+tExpr' c side (CUnary CAdrOp e ni)     =+  do when (side == LValue) $+          typeError ni "address-of operator as lvalue"+     case e of+       CCompoundLit _ _ _ -> simplePtr `liftM` tExpr c RValue e+       CVar i _ -> lookupObject i >>=+                   typeErrorOnLeft ni . maybe (notFound i) varAddrType+       _        -> simplePtr `liftM` tExpr c LValue e+tExpr' c _ (CUnary CIndOp e ni)     =+  tExpr c RValue e >>= (typeErrorOnLeft ni . derefType)+tExpr' c _ (CUnary CCompOp e ni)    =+  do t <- tExpr c RValue e+     checkIntegral' ni t+     return t+tExpr' c side (CUnary CNegOp e ni)      =+  do when (side == LValue) $+          typeError ni "logical negation used as lvalue"+     tExpr c RValue e >>= checkScalar' ni+     return boolType+tExpr' c side (CUnary op e _)          =+  tExpr c (if isEffectfulOp op then LValue else side) e+tExpr' c _ (CIndex b i ni)             =+  do bt <- tExpr c RValue b+     it <- tExpr c RValue i+     addrTy <- binopType' ni CAddOp bt it+     typeErrorOnLeft ni $ derefType addrTy+tExpr' c side (CCond e1 me2 e3 ni)     =+  do t1 <- tExpr c RValue e1+     checkScalar' (nodeInfo e1) t1+     t3 <- tExpr c side e3+     case me2 of+       Just e2 ->+         do t2 <- tExpr c side e2+            conditionalType' ni t2 t3+       Nothing -> conditionalType' ni t1 t3+tExpr' c _side (CMember e m deref ni)   =+  do t <- tExpr c RValue e+     bt <- if deref then typeErrorOnLeft ni (derefType t) else return t+     fieldType ni m bt+tExpr' c side (CComma es _)            =+  mapM (tExpr c side) es >>= return . last+tExpr' c side (CCast d e ni)           =+  do dt <- analyseTypeDecl d+     et <- tExpr c side e+     typeErrorOnLeft ni $ castCompatible dt et+     return dt+tExpr' c side (CSizeofExpr e ni)       =+  do when (side == LValue) $ typeError ni "sizeof as lvalue"+     void $ tExpr c RValue e+     return size_tType+tExpr' c side (CAlignofExpr e ni)      =+  do when (side == LValue) $ typeError ni "alignof as lvalue"+     void $ tExpr c RValue e+     return size_tType+tExpr' c side (CComplexReal e ni)      = complexBaseType ni c side e+tExpr' c side (CComplexImag e ni)      = complexBaseType ni c side e+tExpr' _ side (CLabAddrExpr _ ni)      =+  do when (side == LValue) $ typeError ni "label address as lvalue"+     return $ PtrType voidType noTypeQuals []+tExpr' _ side (CCompoundLit d initList ni) =+  do when (side == LValue) $ typeError ni "compound literal as lvalue"+     lt <- analyseTypeDecl d+     tInitList ni (canonicalType lt) initList+     return lt+tExpr' _ RValue (CAlignofType _ _)     = return size_tType+tExpr' _ RValue (CSizeofType _ _)      = return size_tType+tExpr' _ LValue (CAlignofType _ ni)    =+  typeError ni "alignoftype as lvalue"+tExpr' _ LValue (CSizeofType _ ni)     =+  typeError ni "sizeoftype as lvalue"+tExpr' _ _    (CVar i ni)              =+  lookupObject i >>=+  maybe (typeErrorOnLeft ni $ notFound i) (return . declType)+tExpr' _ _ (CConst c)                  = constType c+tExpr' _ _ (CBuiltinExpr b)            = builtinType b+tExpr' c side (CCall (CVar i _) args ni)+  | identToString i == "__builtin_choose_expr" =+    case args of+      [g, e1, e2] ->+        -- XXX: the MachineDesc parameter below should be configurable+        do b <- constEval defaultMD Map.empty g+           case boolValue b of+             Just True -> tExpr c side e1+             Just False -> tExpr c side e2+             Nothing ->+               astError ni "non-constant argument to __builtin_choose_expr"+      _ -> astError ni "wrong number of arguments to __builtin_choose_expr"+tExpr' c _ (CCall fe args ni)          =+  do let defType = FunctionType+                   (FunTypeIncomplete+                    (DirectType (TyIntegral TyInt) noTypeQuals noAttributes))+                   noAttributes+         fallback i = do warn $ invalidAST ni $+                                "unknown function: " ++ identToString i+                         return defType+     t <- case fe of+            CVar i _ -> lookupObject i >>=+                        maybe (fallback i) (const $ tExpr c RValue fe)+            _ -> tExpr c RValue fe+     atys <- mapM (tExpr c RValue) args+     -- XXX: we don't actually want to return the canonical return type here+     case canonicalType t of+       PtrType (FunctionType (FunType rt pdecls varargs) _) _ _ ->+         do let ptys = map declType pdecls+            mapM_ checkArg $ zip3 ptys atys args+            unless varargs $ when (length atys /= length ptys) $+                   typeError ni "incorrect number of arguments"+            return $ canonicalType rt+       PtrType (FunctionType (FunTypeIncomplete rt) _) _ _ ->+         do -- warn $ invalidAST ni "incomplete function type"+            return $ canonicalType rt+       _  -> typeError ni $ "attempt to call non-function of type " ++ pType t+  where checkArg (pty, aty, arg) =+          do attrs <- deepTypeAttrs pty+             case isTransparentUnion attrs of+               True ->+                 case canonicalType pty of+                   DirectType (TyComp ctr) _ _ ->+                     do td <- lookupSUE (nodeInfo arg) (sueRef ctr)+                        ms <- tagMembers (nodeInfo arg) td+                        {-+                        when (null $ rights $ matches ms) $+                             astError (nodeInfo arg) $+                             "argument matches none of the elements " +++                             "of transparent union"+                        -}+                        return ()+                     where matches =+                             map (\d -> assignCompatible+                                        CAssignOp+                                        (snd d)+                                        aty+                                 )+                   _ -> astError (nodeInfo arg)+                        "non-composite has __transparent_union__ attribute"+               False -> assignCompatible' (nodeInfo arg) CAssignOp pty aty+        isTransparentUnion =+          any (\(Attr n _ _) -> identToString n == "__transparent_union__")+tExpr' c _ (CAssign op le re ni)       =+  do lt <- tExpr c LValue le+     rt <- tExpr c RValue re+     when (constant $ typeQuals lt) $+          typeError ni $ "assignment to lvalue with `constant' qualifier: "+                         ++ (render . pretty) le+     case (canonicalType lt, re) of+       (lt', CConst (CIntConst i _))+         | isPointerType lt' && getCInteger i == 0 -> return ()+       (_, _) -> assignCompatible' ni op lt rt+     return lt+tExpr' c _ (CStatExpr s _)             =+  do enterBlockScope+     mapM_ (withDefTable . defineLabel) (getLabels s)+     t <- tStmt c s+     leaveBlockScope+     return t+tExpr' _ _ (CBlockExpr _ _ ni) =+  typeError ni $ "tExpr': don't know how to type block expressions"+tExpr' _ _ (ObjCMessageExpr _ ni) =+  typeError ni $ "tExpr': don't know how to type message expressions"+tExpr' _ _ (ObjCSelectorExpr _ ni) =+  typeError ni $ "tExpr': don't know how to type selector expressions"+tExpr' _ _ (ObjCProtoExpr _ ni) =+  typeError ni $ "tExpr': don't know how to type protocol expressions"++tInitList :: MonadTrav m => NodeInfo -> Type -> CInitList -> m ()+tInitList _ (ArrayType (DirectType (TyIntegral TyChar) _ _) _ _ _)+             [([], CInitExpr e@(CConst (CStrConst _ _)) _)] =+  tExpr [] RValue e >> return ()+tInitList ni t@(ArrayType _ _ _ _) initList =+  do let default_ds =+           repeat (CArrDesig (CConst (CIntConst (cInteger 0) ni)) ni)+     checkInits t default_ds initList+tInitList ni t@(DirectType (TyComp ctr) _ _) initList =+  do td <- lookupSUE ni (sueRef ctr)+     ms <- tagMembers ni td+     let default_ds = map (\m -> CMemberDesig (fst m) ni) ms+     checkInits t default_ds initList+tInitList _ (PtrType (DirectType TyVoid _ _) _ _ ) _ =+          return () -- XXX: more checking+tInitList _ t [([], i)] = tInit t i >> return ()+tInitList ni t _ = typeError ni $ "initializer list for type: " ++ pType t++checkInits :: MonadTrav m => Type -> [CDesignator] -> CInitList -> m ()+checkInits _ _ [] = return ()+checkInits t dds ((ds, i) : is) =+  do (dds', ds') <- case (dds, ds) of+                      ([], []) ->+                        typeError (nodeInfo i) "excess elements in initializer"+                      (dd' : rest, []) -> return (rest, [dd'])+                      (_, d : _) -> return (advanceDesigList dds d, ds)+     t' <- tDesignator t ds'+     void $ tInit t' i+     checkInits t dds' is++advanceDesigList :: [CDesignator] -> CDesignator -> [CDesignator]+advanceDesigList ds d = drop 1 $ dropWhile (not . matchDesignator d) ds++matchDesignator :: CDesignator -> CDesignator -> Bool+matchDesignator (CMemberDesig m1 _) (CMemberDesig m2 _) = m1 == m2+matchDesignator _ _ = True -- XXX: for now, array ranges aren't checked++tDesignator :: MonadTrav m => Type -> [CDesignator] -> m Type+-- XXX: check that initializers are within array size+tDesignator (ArrayType bt _ _ _) (CArrDesig e ni : ds) =+  do tExpr [] RValue e >>= checkIntegral' ni+     tDesignator bt ds+tDesignator (ArrayType bt _ _ _) (CRangeDesig e1 e2 ni : ds) =+  do tExpr [] RValue e1 >>= checkIntegral' ni+     tExpr [] RValue e2 >>= checkIntegral' ni+     tDesignator bt ds+tDesignator (ArrayType _ _ _ _) (d : _) =+  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 (DirectType (TyComp _) _ _) (d : _) =+  typeError (nodeInfo d) "array designator in compound initializer"+tDesignator t [] = return t++tInit :: MonadTrav m => Type -> CInit -> m Initializer+tInit t i@(CInitExpr e ni) =+  do it <- tExpr [] RValue e+     assignCompatible' ni CAssignOp t it+     return i+tInit t i@(CInitList initList ni) =+  tInitList ni (canonicalType t) initList >> return i++complexBaseType :: MonadTrav m => NodeInfo -> [StmtCtx] -> ExprSide -> CExpr -> m Type+complexBaseType ni c side e =+  do t <- tExpr c side e+     case canonicalType t of+       DirectType (TyComplex ft) quals attrs ->+         return $ DirectType (TyFloating ft) quals attrs+       _ -> typeError ni $ "expected complex type, got: " ++ pType t+++-- | Return the type of a builtin.+builtinType :: MonadTrav m => CBuiltin -> m Type+builtinType (CBuiltinVaArg _ d _)           = analyseTypeDecl d+builtinType (CBuiltinOffsetOf _ _ _)        = return size_tType+builtinType (CBuiltinTypesCompatible _ _ _) = return boolType++-- return @Just declspecs@ without @CTypedef@ if the declaration specifier contain @typedef@+hasTypeDef :: [CDeclSpec] -> Maybe [CDeclSpec]+hasTypeDef declspecs =+    case foldr hasTypeDefSpec (False,[]) declspecs of+        (True,specs') -> Just specs'+        (False,_)     -> Nothing+    where+    hasTypeDefSpec (CStorageSpec (CTypedef _n)) (_,specs) = (True, specs)+    hasTypeDefSpec spec (b,specs) = (b,spec:specs)
+ src/Language/ObjC/Analysis/AstAnalysis.hs-boot view
@@ -0,0 +1,13 @@+module Language.ObjC.Analysis.AstAnalysis where++import Language.ObjC.Analysis.SemRep+import Language.ObjC.Analysis.TravMonad+import Language.ObjC.Syntax.AST++data StmtCtx = FunCtx VarDecl+             | LoopCtx+             | SwitchCtx++data ExprSide = LValue | RValue++tExpr :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type
+ src/Language/ObjC/Analysis/Builtins.hs view
@@ -0,0 +1,217 @@+module Language.ObjC.Analysis.Builtins (builtins) where++import Language.ObjC.Data.Ident+import Language.ObjC.Data.Node+import Language.ObjC.Analysis.DefTable+import Language.ObjC.Analysis.SemRep+import Language.ObjC.Analysis.TypeUtils++builtins :: DefTable+builtins = foldr doIdent (foldr doTypeDef emptyDefTable typedefs) idents+  where doTypeDef d = snd . defineTypeDef (identOfTypeDef d) d+        doIdent   d = snd . defineGlobalIdent (declIdent d) d+        dName     s = VarName (builtinIdent s) Nothing+        param ty    = ParamDecl (VarDecl+                                 NoName+                                 (DeclAttrs False (Auto False) [])+                                 ty) undefNode+        fnAttrs     = DeclAttrs False (FunLinkage ExternalLinkage) []+        varAttrs    = DeclAttrs False (Static InternalLinkage False) []+        fnType r as = FunctionType (FunType r (map param as) False) noAttributes+        fnType' r as = FunctionType (FunType r (map param as) True) noAttributes+        func n r as = Declaration+                      (Decl+                       (VarDecl (dName n) fnAttrs (fnType r as))+                       undefNode)+        func' n r as = Declaration+                       (Decl+                        (VarDecl (dName n) fnAttrs (fnType' r as))+                        undefNode)+        var n t     = Declaration+                      (Decl (VarDecl (dName n) varAttrs t) undefNode)+        typedef n t = TypeDef (builtinIdent n) t [] undefNode+        typedefs    = [ typedef "__builtin_va_list"+                                valistType+                      ]+        idents      = [ func "__builtin_expect"+                             (integral TyLong)+                             [integral TyLong, integral TyLong]+                      , func "__builtin_fabs"+                             (floating TyDouble)+                             [floating TyDouble]+                      , func "__builtin_fabsf"+                             (floating TyFloat)+                             [floating TyFloat]+                      , func "__builtin_fabsl"+                             (floating TyLDouble)+                             [floating TyLDouble]+                      , func "__builtin_inf" (floating TyDouble) []+                      , func "__builtin_inff" (floating TyFloat) []+                      , func "__builtin_infl" (floating TyLDouble) []+                      , func "__builtin_huge_val" (floating TyDouble) []+                      , func "__builtin_huge_valf" (floating TyFloat) []+                      , func "__builtin_huge_vall" (floating TyLDouble) []+                      , func "__builtin_copysign"+                             (floating TyDouble)+                             [ floating TyDouble, floating TyDouble ]+                      , func "__builtin_va_start"+                             voidType+                             [ valistType , voidPtr ]+                      , func "__builtin_va_end"+                             voidType+                             [valistType]+                      , func "__builtin_va_copy"+                             voidType+                             [ valistType, valistType ]+                      , func "__builtin_va_arg_pack" (integral TyInt) []+                      , func "__builtin_va_arg_pack_len" (integral TyInt) []+                      , func "__builtin_alloca"+                             voidPtr+                             [ size_tType ]+                      , func "__builtin_memcpy"+                             voidPtr+                             [ voidPtr+                             , constVoidPtr+                             , size_tType+                             ]+                      , func "__builtin_strspn"+                             size_tType+                             [ constCharPtr, constCharPtr ]+                      , func "__builtin_strcspn"+                             size_tType+                             [ constCharPtr, constCharPtr ]+                      , func "__builtin_strchr"+                             charPtr+                             [ constCharPtr, integral TyInt]+                      , func "__builtin_strncpy"+                             charPtr+                             [ constCharPtr -- XXX: restrict+                             , constCharPtr -- XXX: restrict+                             , size_tType+                             ]+                      , func "__builtin_strncat"+                             charPtr+                             [ constCharPtr -- XXX: restrict+                             , constCharPtr -- XXX: restrict+                             , size_tType+                             ]+                      , func "__builtin_strcmp"+                             (integral TyInt)+                             [ constCharPtr, constCharPtr ]+                      , func "__builtin_strpbrk"+                             charPtr+                             [ constCharPtr, constCharPtr ]+                      , func "__builtin_bzero"+                             voidType+                             [ voidPtr, size_tType ]+                      , func "__builtin_clz"+                             (integral TyInt)+                             [ integral TyUInt ]+                      , func "__builtin_constant_p"+                             (integral TyInt)+                             [DirectType (TyBuiltin TyAny) noTypeQuals noAttributes]+                      -- XXX: I don't know if the following has the+                      -- correct type. It doesn't seem to be+                      -- documented.+                      , func "__builtin_extract_return_addr"+                             voidPtr+                             [ voidPtr ]+                      , func "__builtin_return_address"+                             voidPtr+                             [ integral TyUInt ]+                      , func "__builtin_frame_address"+                             voidPtr+                             [ integral TyUInt ]+                      , func "__builtin_expect"+                             (integral TyLong)+                             [ integral TyLong, integral TyLong ]+                      , func "__builtin_prefetch"+                             voidType+                             [ constVoidPtr ]+                      , var "__func__"+                            stringType+                      , var "__PRETTY_FUNCTION__"+                            stringType+                      , var "__FUNCTION__"+                            stringType+                      -- Builtin GCC error checking functions+                      , func "__builtin_object_size"+                             size_tType+                             [ voidPtr, integral TyInt ]+                      , func "__builtin___memcpy_chk"+                             voidPtr+                             [ voidPtr, constVoidPtr, size_tType, size_tType ]+                      , func "__builtin___mempcpy_chk"+                             voidPtr+                             [ voidPtr, constVoidPtr, size_tType, size_tType ]+                      , func "__builtin___memmove_chk"+                             voidPtr+                             [ voidPtr, constVoidPtr, size_tType, size_tType ]+                      , func "__builtin___memset_chk"+                             voidPtr+                             [ voidPtr, integral TyInt, size_tType, size_tType ]+                      , func "__builtin___strcpy_chk"+                             charPtr+                             [ constCharPtr -- XXX: restrict+                             , constCharPtr -- XXX: restrict+                             , size_tType+                             ]+                      , func "__builtin___stpcpy_chk"+                             charPtr+                             [ constCharPtr -- XXX: restrict+                             , constCharPtr -- XXX: restrict+                             , size_tType+                             ]+                      , func "__builtin___strncpy_chk"+                             charPtr+                             [ constCharPtr -- XXX: restrict+                             , constCharPtr -- XXX: restrict+                             , size_tType+                             , size_tType+                             ]+                      , func "__builtin___strcat_chk"+                             charPtr+                             [ constCharPtr -- XXX: restrict+                             , constCharPtr -- XXX: restrict+                             , size_tType+                             ]+                      , func "__builtin___strncat_chk"+                             charPtr+                             [ constCharPtr -- XXX: restrict+                             , constCharPtr -- XXX: restrict+                             , size_tType+                             , size_tType+                             ]+                      , func' "__builtin___sprintf_chk"+                             (integral TyInt)+                             [ charPtr+                             , integral TyInt+                             , size_tType+                             , constCharPtr+                             ]+                      , func' "__builtin___snprintf_chk"+                             (integral TyInt)+                             [ charPtr+                             , size_tType+                             , integral TyInt+                             , size_tType+                             , constCharPtr+                             ]+                      , func "__builtin___vsprintf_chk"+                             (integral TyInt)+                             [ charPtr+                             , integral TyInt+                             , size_tType+                             , constCharPtr+                             , valistType+                             ]+                      , func "__builtin___vsnprintf_chk"+                             (integral TyInt)+                             [ charPtr+                             , size_tType+                             , integral TyInt+                             , size_tType+                             , constCharPtr+                             , valistType+                             ]+                      ]
+ src/Language/ObjC/Analysis/ConstEval.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE RelaxedPolyRec #-}+module Language.ObjC.Analysis.ConstEval where++import Control.Monad+import Data.Bits+import Data.Maybe+import qualified Data.Map as Map+import Language.ObjC.Syntax.AST+import Language.ObjC.Syntax.Constants+import {-# SOURCE #-} Language.ObjC.Analysis.AstAnalysis (tExpr, ExprSide(..))+import Language.ObjC.Analysis.Debug+import Language.ObjC.Analysis.DeclAnalysis+import Language.ObjC.Analysis.DefTable+import Language.ObjC.Data+import Language.ObjC.Pretty+import Language.ObjC.Analysis.SemRep+import Language.ObjC.Analysis.TravMonad+import Language.ObjC.Analysis.TypeUtils+import Text.PrettyPrint.HughesPJ++data MachineDesc =+  MachineDesc+  { iSize        :: IntType -> Integer+  , fSize        :: FloatType -> Integer+  , builtinSize  :: BuiltinType -> Integer+  , ptrSize      :: Integer+  , voidSize     :: Integer+  , iAlign       :: IntType -> Integer+  , fAlign       :: FloatType -> Integer+  , builtinAlign :: BuiltinType -> Integer+  , ptrAlign     :: Integer+  , voidAlign    :: Integer+  }++intExpr :: (Pos n, MonadName m) => n -> Integer -> m CExpr+intExpr n i =+  genName >>= \name ->+    return $ CConst $ CIntConst (cInteger i) (mkNodeInfo (posOf n) name)++sizeofType :: (MonadTrav m, CNode n) => MachineDesc -> n -> Type -> m Integer+sizeofType md _ (DirectType TyVoid _ _) = return $ voidSize md+sizeofType md _ (DirectType (TyIntegral it) _ _) = return $ iSize md it+sizeofType md _ (DirectType (TyFloating ft) _ _) = return $ fSize md ft+sizeofType md _ (DirectType (TyComplex ft) _ _) = return $ 2 * fSize md ft+sizeofType md _ (DirectType (TyComp ctr) _ _) = compSize md ctr+sizeofType md _ (DirectType (TyEnum _) _ _) = return $ iSize md TyInt+sizeofType md _ (DirectType (TyBuiltin b) _ _) = return $ builtinSize md b+sizeofType md _ (PtrType _ _ _)  = return $ ptrSize md+sizeofType md n (ArrayType bt (UnknownArraySize _) _ _) = return $ ptrSize md+sizeofType md n (ArrayType bt (ArraySize _ sz) _ _) =+  do sz' <- constEval md Map.empty sz+     case sz' of+       CConst (CIntConst i _) ->+         do s <- sizeofType md n bt+            return $ getCInteger i * s+       _ -> return $ ptrSize md+            {-+            astError (nodeInfo sz) $+            "array size is not a constant: " ++ (render . pretty) sz+            -}+sizeofType md n (TypeDefType (TypeDefRef _ (Just t) _) _ _) = sizeofType md n t+sizeofType md _ (FunctionType _ _) = return $ ptrSize md+sizeofType _ n t = astError (nodeInfo n) $+                 "can't find size of type: " ++ (render . pretty) t++alignofType :: (MonadTrav m, CNode n) => MachineDesc -> n -> Type -> m Integer+alignofType md _ (DirectType TyVoid _ _) = return $ voidAlign md+alignofType md _ (DirectType (TyIntegral it) _ _) = return $ iAlign md it+alignofType md _ (DirectType (TyFloating ft) _ _) = return $ fAlign md ft+alignofType md _ (DirectType (TyComplex ft) _ _) = return $ fAlign md ft+alignofType md _ (DirectType (TyEnum _) _ _) = return $ iAlign md TyInt+alignofType md _ (DirectType (TyBuiltin b) _ _) = return $ builtinAlign md b+alignofType md _ (PtrType _ _ _)  = return $ ptrAlign md+alignofType md n (ArrayType bt (UnknownArraySize _) _ _) = return $ ptrAlign md+alignofType md n (ArrayType bt (ArraySize _ sz) _ _) = alignofType md n bt+alignofType md n (TypeDefType (TypeDefRef _ (Just t) _) _ _) = alignofType md n t+alignofType _ n t = astError (nodeInfo n) $+                 "can't find alignment of type: " ++ (render . pretty) t++compSize :: MonadTrav m => MachineDesc -> CompTypeRef -> m Integer+compSize md ctr =+  do dt <- getDefTable+     case lookupTag (sueRef ctr) dt of+       Just (Left _)   -> astError (nodeInfo ctr)+                          "composite declared but not defined"+       Just (Right (CompDef (CompType _ tag ms _ ni))) ->+         do let ts = map declType ms+            sizes <- mapM (sizeofType md ni) ts+            -- XXX: handle padding+            case tag of+              StructTag -> return $ sum sizes+              UnionTag  -> return $ maximum sizes+       Just (Right (EnumDef _)) -> return $ iSize md TyInt+       Nothing         -> astError (nodeInfo ctr) "unknown composite"+++{- Expression evaluation -}++-- Use the withWordBytes function to wrap the results around to the+-- correct word size+intOp :: CBinaryOp -> Integer -> Integer -> Integer+intOp CAddOp i1 i2 = i1 + i2+intOp CSubOp i1 i2 = i1 - i2+intOp CMulOp i1 i2 = i1 * i2+intOp CDivOp i1 i2 = i1 `div` i2+intOp CRmdOp i1 i2 = i1 `mod` i2+intOp CShlOp i1 i2 = i1 `shiftL` fromInteger i2+intOp CShrOp i1 i2 = i1 `shiftR` fromInteger i2+intOp CLeOp  i1 i2 = toInteger $ fromEnum $ i1 < i2+intOp CGrOp  i1 i2 = toInteger $ fromEnum $ i1 > i2+intOp CLeqOp i1 i2 = toInteger $ fromEnum $ i1 <= i2+intOp CGeqOp i1 i2 = toInteger $ fromEnum $ i1 >= i2+intOp CEqOp  i1 i2 = toInteger $ fromEnum $ i1 == i2+intOp CNeqOp i1 i2 = toInteger $ fromEnum $ i1 /= i2+intOp CAndOp i1 i2 = i1 .&. i2+intOp CXorOp i1 i2 = i1 `xor` i2+intOp COrOp  i1 i2 = i1 .|. i2+intOp CLndOp i1 i2 = toInteger $ fromEnum $ (i1 /= 0) && (i2 /= 0)+intOp CLorOp i1 i2 = toInteger $ fromEnum $ (i1 /= 0) || (i2 /= 0)++-- Use the withWordBytes function to wrap the results around to the+-- correct word size+intUnOp :: CUnaryOp -> Integer -> Maybe Integer+intUnOp CPlusOp i = Just i+intUnOp CMinOp  i = Just $ -i+intUnOp CCompOp i = Just $ complement i+intUnOp CNegOp  i = Just $ toInteger $ fromEnum $ i == 0+intUnOp _       _ = Nothing++withWordBytes :: Int -> Integer -> Integer+withWordBytes bytes n = n `rem` (1 `shiftL` (bytes `shiftL` 3))++boolValue :: CExpr -> Maybe Bool+boolValue (CConst (CIntConst i _))  = Just $ getCInteger i /= 0+boolValue (CConst (CCharConst c _)) = Just $ getCCharAsInt c /= 0+boolValue (CConst (CStrConst _ _))  = Just True+boolValue _                         = Nothing++intValue :: CExpr -> Maybe Integer+intValue (CConst (CIntConst i _))  = Just $ getCInteger i+intValue (CConst (CCharConst c _)) = Just $ getCCharAsInt c+intValue _                         = Nothing++constEval :: (MonadTrav m) =>+             MachineDesc -> Map.Map Ident CExpr -> CExpr -> m CExpr+constEval md env (CCond e1 me2 e3 ni) =+  do e1'  <- constEval md env e1+     me2' <- maybe (return Nothing) (\e -> Just `liftM` constEval md env e) me2+     e3'  <- constEval md env e3+     case boolValue e1' of+       Just True  -> return $ fromMaybe e1' me2'+       Just False -> return e3'+       Nothing    -> return $ CCond e1' me2' e3' ni+constEval md env e@(CBinary op e1 e2 ni) =+  do e1' <- constEval md env e1+     e2' <- constEval md env e2+     t <- tExpr [] RValue e+     bytes <- fromIntegral `liftM` sizeofType md e t+     case (intValue e1', intValue e2') of+       (Just i1, Just i2) -> intExpr ni (withWordBytes bytes (intOp op i1 i2))+       (_, _)             -> return $ CBinary op e1' e2' ni+constEval md env (CUnary op e ni) =+  do e' <- constEval md env e+     t <- tExpr [] RValue e+     bytes <- fromIntegral `liftM` sizeofType md e t+     case intValue e' of+       Just i  -> case intUnOp op i of+                    Just i' -> intExpr ni (withWordBytes bytes i')+                    Nothing -> astError ni+                               "invalid unary operator applied to constant"+       Nothing -> return $ CUnary op e' ni+constEval md env (CCast d e ni) =+  do e' <- constEval md env e+     t <- analyseTypeDecl d+     bytes <- fromIntegral `liftM` sizeofType md d t+     case intValue e' of+       Just i -> intExpr ni (withWordBytes bytes i)+       Nothing -> return $ CCast d e' ni+constEval md _ (CSizeofExpr e ni) =+  do t <- tExpr [] RValue e+     sz <- sizeofType md e t+     intExpr ni sz+constEval md _ (CSizeofType d ni) =+  do t <- analyseTypeDecl d+     sz <- sizeofType md d t+     intExpr ni sz+constEval md _ (CAlignofExpr e ni) =+  do t <- tExpr [] RValue e+     sz <- alignofType md e t+     intExpr ni sz+constEval md _ (CAlignofType d ni) =+  do t <- analyseTypeDecl d+     sz <- alignofType md d t+     intExpr ni sz+constEval md env e@(CVar i _) | Map.member i env =+  return $ fromMaybe e $ Map.lookup i env+constEval md env e@(CVar i _) =+  do t <- tExpr [] RValue e+     case derefTypeDef t of+       DirectType (TyEnum etr) _ _ ->+         do dt <- getDefTable+            case lookupTag (sueRef etr) dt of+              Just (Right (EnumDef (EnumType _ es _ _))) ->+                do env' <- foldM enumConst env es+                   return $ fromMaybe e $ Map.lookup i env'+              _ -> return e+       _ -> return e+  where enumConst env' (Enumerator n e' _ _) =+          do c <- constEval md env' e'+             return $ Map.insert n c env'+constEval _ _ e = return e
+ src/Language/ObjC/Analysis/Debug.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# OPTIONS -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Analysis.Debug+-- Copyright   :  (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  prototype+-- Portability :  ghc+--+-- Pretty printing the semantic analysis representation.+-- This is currently only intended for debugging purposes.+-----------------------------------------------------------------------------+module Language.ObjC.Analysis.Debug (+globalDeclStats,+prettyAssocs, prettyAssocsWith,+-- and many pretty instances+)+where+import Language.ObjC.Analysis.SemRep+import Language.ObjC.Analysis.Export+import Language.ObjC.Analysis.DefTable+import Language.ObjC.Analysis.NameSpaceMap++import Language.ObjC.Data+import Language.ObjC.Pretty++import Text.PrettyPrint.HughesPJ+import Data.Map (Map) ; import qualified Data.Map as Map++prettyAssocs :: (Pretty k, Pretty v) => String -> [(k,v)] -> Doc+prettyAssocs label = prettyAssocsWith label pretty pretty+prettyAssocsWith :: String -> (k -> Doc) -> (v -> Doc) -> [(k,v)] -> Doc+prettyAssocsWith label prettyKey prettyVal theMap =+    text label $$ (nest 8) (vcat $ map prettyEntry theMap)+    where+    prettyEntry (k,v) = prettyKey k <+> text " ~> " <+> prettyVal v++instance Pretty DefTable where+    pretty dt = text "DefTable" $$ (nest 4 $ vcat defMaps)+        where+        defMaps = [ prettyNSMap "idents" identDecls+                  , prettyNSMap "tags" tagDecls+                  , prettyNSMap "labels" labelDefs+                  , prettyNSMap "members" memberDecls+                  ]+        prettyNSMap label f = prettyAssocs label . nsMapToList $ f dt++instance Pretty GlobalDecls where+    pretty gd = text "Global Declarations" $$ (nest 4 $ vcat declMaps)+        where+        declMaps = [ prettyMap "enumerators" theEnums, prettyMap "declarations" theDecls,+                     prettyMap "objects" theObjs,  prettyMap "functions" theFuns,+                     prettyMap "tags"    $ gTags gd,  prettyMap "typeDefs"  $ gTypeDefs gd ]+        prettyMap :: (Pretty t, Pretty k) => String -> Map k t -> Doc+        prettyMap label = prettyAssocs label . Map.assocs+        (theDecls, (theEnums, theObjs, theFuns)) = splitIdentDecls False (gObjs gd)++globalDeclStats :: (FilePath -> Bool) -> GlobalDecls -> [(String,Int)]+globalDeclStats file_filter gmap =+    [ ("Enumeration Constants",Map.size enumerators),+      ("Total Object/Function Declarations",Map.size all_decls),+      ("Object definitions", Map.size objDefs),+      ("Function Definitions", Map.size funDefs),+      ("Tag definitions", Map.size tagDefs),+      ("TypeDefs", Map.size typeDefs)+    ]+    where+    gmap' = filterGlobalDecls filterFile gmap+    (all_decls,(enumerators,objDefs,funDefs)) = splitIdentDecls True (gObjs gmap')+    (tagDefs,typeDefs) = (gTags gmap', gTypeDefs gmap')+    filterFile :: (CNode n) => n -> Bool+    filterFile = file_filter . posFile . posOfNode . nodeInfo++instance (Pretty a, Pretty b) => Pretty (Either a b) where+    pretty = either pretty pretty+instance Pretty TagFwdDecl where+    pretty (CompDecl ct) = pretty ct+    pretty (EnumDecl et) = pretty et+instance Pretty CompTyKind where+    pretty StructTag = text "struct"+    pretty UnionTag = text "union"+instance Pretty CompTypeRef where+    pretty (CompTypeRef sue kind _) = pretty kind <+> pretty sue+instance Pretty EnumTypeRef where+    pretty (EnumTypeRef sue _ ) = text "enum" <+> pretty sue+instance Pretty Ident where+    pretty = text . identToString+instance Pretty SUERef where+    pretty ref = text (show ref)+instance Pretty TagDef where+    pretty (CompDef compty) = pretty compty+    pretty (EnumDef enumty) = pretty enumty+instance Pretty IdentDecl where+    pretty (Declaration decl) = pretty decl+    pretty (ObjectDef odef) = pretty odef+    pretty (FunctionDef fdef) = pretty fdef+    pretty (EnumeratorDef enumerator) = pretty enumerator+instance Pretty Decl where+    pretty (Decl vardecl _) =+        text "declaration" <+>+        pretty vardecl+instance Pretty TypeDef where+    pretty (TypeDef ident ty attrs _) =+        text "typedef" <+> pretty ident <+> text "as"  <+>+        pretty attrs <+> pretty ty+instance Pretty ObjDef where+    pretty (ObjDef vardecl init_opt _) =+        text "object" <+>+        pretty vardecl <+> maybe empty (((text "=") <+>) . pretty) init_opt+instance Pretty FunDef where+    pretty (FunDef vardecl _stmt _) =+        text "function" <+>+        pretty vardecl+instance Pretty VarDecl where+    pretty (VarDecl name attrs ty) =+        ((hsep . punctuate (text " |")) [pretty name, pretty attrs, pretty ty])+instance Pretty ParamDecl where+    pretty (ParamDecl (VarDecl name declattrs ty) _) =+        pretty declattrs <+> pretty name <+> text "::" <+> pretty ty+    pretty (AbstractParamDecl (VarDecl name declattrs ty) _) =+        text "abstract" <+> pretty declattrs <+> pretty name <+>+             text "::" <+> pretty ty+instance Pretty DeclAttrs where+    pretty (DeclAttrs inline storage attrs) =+        (if inline then (text "inline") else empty) <+>+        (hsep $ [ pretty storage, pretty attrs])+instance Pretty Type where+  pretty ty = pretty (exportTypeDecl ty)+instance Pretty TypeQuals where+    pretty tyQuals = hsep $ map showAttr [ ("const",constant),("volatile",volatile),("restrict",restrict) ]+        where showAttr (str,select) | select tyQuals = text str+                                    | otherwise      = empty++instance Pretty CompType where+    pretty (CompType sue_ref tag members attrs _node) =+        (text.show) tag <+> pretty sue_ref <+>+        braces (terminateSemi members) <+>+        pretty attrs+instance Pretty MemberDecl where+    pretty (MemberDecl (VarDecl name declattrs ty) bitfield _) =+        pretty declattrs <+> pretty name <+> text "::" <+> pretty ty <+>+        (maybe empty (\bf -> text ":" <+> pretty bf) bitfield)+    pretty (AnonBitField ty bitfield_sz _) =+        pretty ty <+> text ":" <+> pretty bitfield_sz++instance Pretty EnumType where+    pretty (EnumType sue_ref enumerators attrs _) =+      text "enum" <+> pretty sue_ref <+> braces (terminateSemi_ $ map prettyEnr enumerators) <+> pretty attrs+      where+      prettyEnr (Enumerator ident expr _enumty _) = pretty ident <+> text " = " <+> pretty expr++instance Pretty Enumerator where+    pretty (Enumerator ident expr enumty _) = text "<" <> text "econst" <+> pretty (sueRef enumty) <> text ">" <+>+                                              pretty ident <+> text " = " <+> pretty expr++instance Pretty Storage where+    pretty NoStorage = empty+    pretty (Auto reg) = text$ if reg then "auto/register" else "auto"+    pretty (Static linkage thread_local) =+        (hcat . punctuate (text "/") $ [ text "static",pretty linkage ])+        <+> (if thread_local then text ", __thread" else empty)+    pretty (FunLinkage linkage) = text "function/" <> pretty linkage+instance Pretty Linkage where+    pretty InternalLinkage = text "internal"+    pretty ExternalLinkage = text "external"+    pretty NoLinkage       = text "local"+instance Pretty VarName where+    pretty NoName = text "<anonymous>"+    pretty (VarName ident asmname_opt) = pretty ident <+> (maybe empty pAsmName asmname_opt)+        where pAsmName asmname = text "" <+> parens (text "asmname" <+> pretty asmname)+instance Pretty Attributes where+    pretty = joinComma+instance Pretty Attr where+    pretty (Attr ident es _) = pretty ident <+> (if null es then empty else text "(...)")++joinComma :: (Pretty a) => [a] -> Doc+joinComma = hsep . punctuate comma . map pretty+terminateSemi :: (Pretty a) => [a] -> Doc+terminateSemi = terminateSemi_ . map pretty+terminateSemi_ :: [Doc] -> Doc+terminateSemi_ = hsep . map (<> semi)+
+ src/Language/ObjC/Analysis/DeclAnalysis.hs view
@@ -0,0 +1,583 @@+{-# LANGUAGE PatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Analysis.DeclAnalysis+-- Copyright   :  (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  alpha+-- Portability :  ghc+--+-- This module performs the analysis of declarations and the translation of+-- type specifications in the AST.+-----------------------------------------------------------------------------+module Language.ObjC.Analysis.DeclAnalysis (+  -- * Translating types+  analyseTypeDecl,+  tType,tDirectType,tNumType,tArraySize,tTypeQuals,+  mergeOldStyle,+  -- * Dissecting type specs+  canonicalTypeSpec, NumBaseType(..),SignSpec(..),SizeMod(..),NumTypeSpec(..),TypeSpecAnalysis(..),+  canonicalStorageSpec, StorageSpec(..),hasThreadLocalSpec, isTypeDef,+  -- * Helpers+  VarDeclInfo(..),+  tAttr,mkVarName,getOnlyDeclr,nameOfDecl,analyseVarDecl,analyseVarDecl'+)+where+import Language.ObjC.Data.Error+import Language.ObjC.Data.Node+import Language.ObjC.Data.Ident+import Language.ObjC.Pretty+import Language.ObjC.Syntax+import {-# SOURCE #-} Language.ObjC.Analysis.AstAnalysis (tExpr, ExprSide(..))+import Language.ObjC.Analysis.DefTable (TagFwdDecl(..), insertType)+import Language.ObjC.Analysis.Export+import Language.ObjC.Analysis.SemError+import Language.ObjC.Analysis.SemRep+import Language.ObjC.Analysis.TravMonad++import Data.Foldable as F (foldrM)+import Control.Monad (liftM,when,ap)+import Data.List (intersperse, mapAccumL)+import qualified Data.Map as Map+import Data.Monoid+import Text.PrettyPrint.HughesPJ+++-- * handling declarations++-- | analyse and translate a parameter declaration+-- Should be called in either prototype or block scope+tParamDecl :: (MonadTrav m) => CDecl -> m ParamDecl+tParamDecl (CDecl declspecs declrs node) =+  do declr <- getParamDeclr+     -- analyse the variable declaration+     (VarDeclInfo name is_inline storage_spec attrs ty declr_node) <- analyseVarDecl' True declspecs declr [] Nothing+     when (is_inline) $ throwTravError (badSpecifierError node "parameter declaration with inline specifier")+     -- compute storage of parameter (NoStorage, but might have a register specifier)+     storage <- throwOnLeft $ computeParamStorage node storage_spec+     let paramDecl = mkParamDecl name storage attrs ty declr_node+     -- XXX: we shouldn't modify the deftable here, just analyse and build representation+     return $ paramDecl+  where+  getParamDeclr =+      case declrs of+          [] -> return (emptyDeclr node)+          [(Just declr,Nothing,Nothing)] -> return declr+          _ -> astError node "bad parameter declaration: multiple decls / bitfield or initializer present"+  mkParamDecl name storage attrs ty declr_node =+    let vd = VarDecl name (DeclAttrs False storage attrs) ty in+    case name of+      NoName -> AbstractParamDecl vd declr_node+      _ -> ParamDecl vd declr_node++-- | a parameter declaration has no linkage and either auto or register storage+computeParamStorage :: NodeInfo -> StorageSpec -> Either BadSpecifierError Storage+computeParamStorage _ NoStorageSpec = Right (Auto False)+computeParamStorage _ RegSpec       = Right (Auto True)+computeParamStorage node spec       = Left . badSpecifierError node $ "Bad storage specified for parameter: " ++ show spec++-- | analyse and translate a member declaration+tMemberDecls :: (MonadTrav m) => CDecl -> m [MemberDecl]+-- Anonymous struct or union members+tMemberDecls (CDecl declspecs [] node) =+  do let (_storage_specs, _attrs, typequals, typespecs, is_inline) =+           partitionDeclSpecs declspecs+     when is_inline $ astError node "member declaration with inline specifier"+     canonTySpecs <- canonicalTypeSpec typespecs+     ty <- tType True node typequals canonTySpecs [] []+     case ty of+       DirectType (TyComp _) _ _ ->+         return $ [MemberDecl+                   -- XXX: are these DeclAttrs correct?+                   (VarDecl NoName (DeclAttrs False NoStorage []) ty)+                   Nothing node]+       _ -> astError node "anonymous member has a non-composite type"+-- Named members+tMemberDecls (CDecl declspecs declrs node) = mapM (uncurry tMemberDecl) (zip (True:repeat False) declrs)+    where+    tMemberDecl handle_sue_def (Just member_declr,Nothing,bit_field_size_opt) =+        -- TODO: use analyseVarDecl here, not analyseVarDecl'+        do var_decl <- analyseVarDecl' handle_sue_def declspecs member_declr [] Nothing+           let (VarDeclInfo name is_inline storage_spec attrs ty _declr_node) = var_decl+           --+           checkValidMemberSpec is_inline storage_spec+           return $ MemberDecl (VarDecl name (DeclAttrs False NoStorage attrs) ty) bit_field_size_opt node+    tMemberDecl handle_sue_def (Nothing,Nothing,Just bit_field_size) =+        do let (storage_specs, _attrs, typequals, typespecs, _is_inline) = partitionDeclSpecs declspecs+           storage_spec  <- canonicalStorageSpec storage_specs+           canonTySpecs  <- canonicalTypeSpec typespecs+           typ           <- tType handle_sue_def node typequals canonTySpecs [] []+           --+           return $ AnonBitField typ bit_field_size node+    tMemberDecl _ _ = astError node "Bad member declaration"+    checkValidMemberSpec is_inline storage_spec =+        do  when (is_inline)                     $ astError node "member declaration with inline specifier"+            when (storage_spec /= NoStorageSpec) $ astError node "storage specifier for member"+            return ()++data StorageSpec = NoStorageSpec | AutoSpec | RegSpec | ThreadSpec | StaticSpec Bool | ExternSpec Bool+                    deriving (Eq,Ord,Show,Read)++hasThreadLocalSpec :: StorageSpec -> Bool+hasThreadLocalSpec ThreadSpec = True+hasThreadLocalSpec (StaticSpec b) = b+hasThreadLocalSpec (ExternSpec b) = b+hasThreadLocalSpec _  = False++data VarDeclInfo = VarDeclInfo VarName Bool {- is-inline? -} StorageSpec Attributes Type NodeInfo++analyseVarDecl' :: (MonadTrav m) =>+                  Bool -> [CDeclSpec] ->+                  CDeclr -> [CDecl] -> (Maybe CInit) -> m VarDeclInfo+analyseVarDecl' handle_sue_def declspecs declr oldstyle init_opt =+  do let (storage_specs, attrs, type_quals, type_specs, inline) =+           partitionDeclSpecs declspecs+     canonTySpecs <- canonicalTypeSpec type_specs+     analyseVarDecl handle_sue_def storage_specs attrs type_quals canonTySpecs inline+                    declr oldstyle init_opt++-- | analyse declarators+analyseVarDecl+  :: (MonadTrav m)+  => Bool+  -> [CStorageSpec]+  -> [CAttr]+  -> [CTypeQual]+  -> TypeSpecAnalysis+  -> Bool+  -> CDeclr+  -> [CDecl]+  -> (Maybe CInit)   -- ^ currently unused+  -> m VarDeclInfo+analyseVarDecl handle_sue_def storage_specs decl_attrs typequals canonTySpecs inline+               (CDeclr name_opt derived_declrs asmname_opt declr_attrs node)+               oldstyle_params _init_opt+    = do -- analyse the storage specifiers+         storage_spec  <- canonicalStorageSpec storage_specs+         -- translate the type into semantic representation+         typ          <- tType handle_sue_def node typequals canonTySpecs derived_declrs oldstyle_params+         -- translate attributes+         attrs'       <- mapM tAttr (decl_attrs ++ declr_attrs)+         -- make name+         name         <- mkVarName node name_opt asmname_opt+         return $ VarDeclInfo name inline storage_spec attrs' typ node+    where+        isInlineSpec (CInlineQual _) = True+        isInlineSpec _ = False+++-- return @True@ if the declarations is a type def+isTypeDef :: [CDeclSpec] -> Bool+isTypeDef declspecs = not $ null [ n | (CStorageSpec (CTypedef n)) <- declspecs ]++-- * translation++-- | get the type of a /type declaration/+--+-- A type declaration @T@ may appear in thre forms:+--+--  * @typeof(T)@+--+--  * as abstract declarator in a function prototype, as in @f(int)@+--+--  * in a declaration without declarators, as in @struct x { int a } ;@+--+-- Currently, @analyseTypeDecl@ is exlusively used for analysing types for GNU's @typeof(T)@.+--+-- We move attributes to the type, as they have no meaning for the abstract declarator+analyseTypeDecl :: (MonadTrav m) => CDecl -> m Type+analyseTypeDecl (CDecl declspecs declrs node)+    | [] <- declrs = analyseTyDeclr (emptyDeclr node)+    | [(Just declr,Nothing,Nothing)] <- declrs = analyseTyDeclr declr+    | otherwise = astError node "Bad declarator for type declaration"+    where+    analyseTyDeclr (CDeclr Nothing derived_declrs Nothing attrs _declrnode)+        | (not (null storagespec) || inline) = astError node "storage specifier for type declaration"+        | otherwise                          =+          do canonTySpecs <- canonicalTypeSpec typespecs+             t <- tType True node (map CAttrQual (attrs++attrs_decl) ++ typequals)+                   canonTySpecs derived_declrs []+             case nameOfNode node of+               Just n -> withDefTable (\dt -> (t, insertType dt n t))+               Nothing -> return t+        where+        (storagespec, attrs_decl, typequals, typespecs, inline) = partitionDeclSpecs declspecs+    analyseTyDeclr _ = astError node "Non-abstract declarator in type declaration"+++-- | translate a type+tType :: (MonadTrav m) => Bool -> NodeInfo -> [CTypeQual] -> TypeSpecAnalysis -> [CDerivedDeclr] -> [CDecl] -> m Type+tType handle_sue_def top_node typequals canonTySpecs derived_declrs oldstyle_params+    = mergeOldStyle top_node oldstyle_params derived_declrs >>= buildType+    where+    buildType [] =+        tDirectType handle_sue_def top_node typequals canonTySpecs+    buildType (CPtrDeclr ptrquals node : dds) =+        buildType dds >>= buildPointerType ptrquals node+    buildType (CBlkDeclr blkquals node : dds) =+        buildType dds >>= buildBlockType blkquals node+    buildType (CArrDeclr arrquals size node : dds)+        = buildType dds >>= buildArrayType arrquals size node+    buildType (CFunDeclr (Right (params, isVariadic)) attrs node : dds)+        = buildType dds >>= (liftM  (uncurry FunctionType) . buildFunctionType params isVariadic attrs node)+    buildType (CFunDeclr (Left _) _ _ : _)+        -- /FIXME/: this is really an internal error, not an AST error.+        = astError top_node "old-style parameters remaining after mergeOldStyle"+    buildPointerType ptrquals _node inner_ty+        = liftM (\(quals,attrs) -> PtrType inner_ty quals attrs) (tTypeQuals ptrquals)+    buildBlockType blkquals _node inner_ty+        = liftM (\(quals,attrs) -> BlockType inner_ty quals attrs) (tTypeQuals blkquals)+    buildArrayType arr_quals size _node inner_ty+        = do (quals,attrs) <- tTypeQuals arr_quals+             arr_sz        <- tArraySize size+             return$ ArrayType inner_ty arr_sz quals attrs+    -- We build functions in function prototype scope.+    -- When analyzing the  the function body, we push parameters in function body scope.+    buildFunctionType params is_variadic attrs _node return_ty+        = do enterPrototypeScope+             params' <- mapM tParamDecl params+             leavePrototypeScope+             attrs'  <- mapM tAttr attrs+             return $ (\t -> (t,attrs')) $+                case (map declType params',is_variadic) of+                    ([],False) -> FunTypeIncomplete return_ty  -- may be improved later on+                    ([DirectType TyVoid _ _],False) -> FunType return_ty [] False+                    _ -> FunType return_ty params' is_variadic++-- | translate a type without (syntactic) indirections+-- Due to the GNU @typeof@ extension and typeDefs, this can be an arbitrary type+tDirectType :: (MonadTrav m) =>+               Bool -> NodeInfo -> [CTypeQual] -> TypeSpecAnalysis -> m Type+tDirectType handle_sue_def node ty_quals canonTySpec = do+    (quals,attrs) <- tTypeQuals ty_quals+    let baseType ty_name = DirectType ty_name quals attrs+    case canonTySpec of+        TSNone -> return$ baseType (TyIntegral TyInt)+        TSVoid -> return$ baseType TyVoid+        TSBool -> return$ baseType (TyIntegral TyBool)+        TSNum tsnum -> do+            numType <- tNumType tsnum+            return . baseType $+                case numType of+                    Left (floatType,iscomplex) | iscomplex -> TyComplex floatType+                                               | otherwise -> TyFloating floatType+                    Right intType  -> TyIntegral intType+        TSTypeDef tdr -> return$ TypeDefType tdr quals attrs+        TSNonBasic (CSUType su _tnode)      -> liftM (baseType . TyComp) $ tCompTypeDecl handle_sue_def su+        TSNonBasic (CEnumType enum _tnode)   -> liftM (baseType . TyEnum) $ tEnumTypeDecl handle_sue_def enum+        TSType t                             ->  mergeTypeAttributes node quals attrs t+        TSNonBasic _ -> astError node "Unexpected typespec"++-- | Merge type attributes+--+-- This handles for example the form+--+-- > /* tyqual attr typeof(type) */+-- > const typeof(char volatile) x;+mergeTypeAttributes :: (MonadCError m) => NodeInfo -> TypeQuals -> [Attr] -> Type -> m Type+mergeTypeAttributes node_info quals attrs typ =+    case typ of+        DirectType ty_name quals' attrs' -> merge quals' attrs' $ mkDirect ty_name+        PtrType   ty quals' attrs' -> merge quals' attrs' $ PtrType ty+        BlockType ty quals' attrs' -> merge quals' attrs' $ BlockType ty+        ArrayType ty array_sz quals' attrs' -> merge quals' attrs' $ ArrayType ty array_sz+        FunctionType (FunType return_ty params inline) attrs'+-- /FIXME/: This needs review, but checking (null attrs) seems strange here+--            | not (null attrs) -> astError node_info "type qualifiers for function type"+--           | otherwise        -> return$ FunctionType (FunType return_ty params inline (attrs' ++ attrs))+            -> return$ FunctionType (FunType return_ty params inline)  (attrs' ++ attrs)+        TypeDefType tdr quals' attrs'+            -> merge quals' attrs' $ TypeDefType tdr+    where+    mkDirect ty_name quals' attrs' = DirectType ty_name quals' attrs'+    merge quals' attrs' tyf = return $ tyf (mergeTypeQuals quals quals') (attrs' ++ attrs)++typeDefRef :: (MonadCError m, MonadSymtab m) => NodeInfo -> Ident -> m TypeDefRef+typeDefRef t_node name = lookupTypeDef name >>= \ty -> return (TypeDefRef name (Just ty) t_node)++-- extract a struct\/union+-- we emit @declStructUnion@ and @defStructUnion@ actions+--+-- TODO: should attributes be part of declarartions too ?+tCompTypeDecl :: (MonadTrav m) => Bool -> CStructUnion -> m CompTypeRef+tCompTypeDecl handle_def (CStruct tag ident_opt member_decls_opt attrs node_info) = do+    -- create reference+    sue_ref <- createSUERef node_info ident_opt+    let tag' = tTag tag+    attrs' <- mapM tAttr attrs+    -- record tag name+    let decl = CompTypeRef sue_ref tag' node_info+    handleTagDecl (CompDecl decl)+    -- when handle_def is true, enter the definition+    when (handle_def) $ do+        maybeM member_decls_opt $ \decls ->+                tCompType sue_ref tag' decls (attrs') node_info+            >>= (handleTagDef.CompDef)+    return decl++tTag :: CStructTag -> CompTyKind+tTag CStructTag = StructTag+tTag CUnionTag  = UnionTag++tCompType :: (MonadTrav m) => SUERef -> CompTyKind -> [CDecl] -> Attributes -> NodeInfo -> m CompType+tCompType tag sue_ref member_decls attrs node+    = return (CompType tag sue_ref) `ap`+        (concatMapM tMemberDecls member_decls) `ap`+        (return attrs) `ap`+        (return node)++-- | translate a enum type decl+--+--  > enum my_enum+--  > enum your_enum { x, y=3 }+--+tEnumTypeDecl :: (MonadTrav m) => Bool -> CEnum -> m EnumTypeRef+tEnumTypeDecl handle_def (CEnum ident_opt enumerators_opt attrs node_info)+    | (Nothing, Nothing) <- (ident_opt, enumerators_opt) = astError node_info "both definition and name of enum missing"+    | Just [] <- enumerators_opt                         = astError node_info "empty enumerator list"+    | otherwise+        = do sue_ref <- createSUERef node_info ident_opt+             attrs' <- mapM tAttr attrs+             let decl = EnumTypeRef sue_ref node_info+             when handle_def $ do+                 maybeM enumerators_opt $ \enumerators ->+                         tEnumType sue_ref enumerators attrs' node_info+                    >>=  (handleTagDef . EnumDef)+             return decl++-- | translate and analyse an enumeration type+tEnumType :: (MonadCError m, MonadSymtab m) =>+             SUERef -> [(Ident, Maybe CExpr)] -> Attributes -> NodeInfo -> m EnumType+tEnumType sue_ref enumerators attrs node = do+    mapM_ handleEnumeratorDef enumerators'+    return ty+    where+    ty = EnumType sue_ref enumerators' attrs node+    (_,enumerators') = mapAccumL nextEnumerator (Left 0) enumerators+    nextEnumerator memo (ident,e) =+      let (memo',expr) = nextEnrExpr memo e in+      (memo', Enumerator ident expr ty (nodeInfo ident))+    nextEnrExpr :: (Either Integer (Expr,Integer)) -> Maybe CExpr -> (Either Integer (Expr,Integer), CExpr)+    nextEnrExpr (Left i) Nothing = (Left (succ i), intExpr i)+    nextEnrExpr (Right (e,offs)) Nothing = (Right (e, succ offs), offsExpr e offs)+    nextEnrExpr _ (Just e) = (Right (e,1), e)+    intExpr i = CConst (CIntConst (cInteger i) undefNode)+    offsExpr e offs = CBinary CAddOp e (intExpr offs) undefNode++-- | Mapping from num type specs to C types (C99 6.7.2-2), ignoring the complex qualifier.+tNumType :: (MonadCError m) => NumTypeSpec -> m (Either (FloatType,Bool) IntType)+tNumType (NumTypeSpec basetype sgn sz iscomplex) =+    case (basetype,sgn,sz) of+        (BaseChar,_,NoSizeMod)      | Signed <- sgn   -> intType TySChar+                                      | Unsigned <- sgn -> intType TyUChar+                                      | otherwise       -> intType TyChar+        (intbase, _, NoSizeMod)  | optBase BaseInt intbase ->+            intType$ case sgn of+                            Unsigned -> TyUInt+                            _        -> TyInt+        (intbase, signed, sizemod)    | optBase BaseInt intbase, optSign Signed signed ->+            intType$ case sizemod of ShortMod    -> TyShort+                                     LongMod     -> TyLong+                                     LongLongMod -> TyLLong+                                     _ -> internalErr "numTypeMapping: unexpected pattern matching error"+        (intbase, Unsigned, sizemod) | optBase BaseInt intbase ->+            intType$ case sizemod of ShortMod    -> TyUShort+                                     LongMod     -> TyULong+                                     LongLongMod -> TyULLong+                                     _ -> internalErr "numTypeMapping: unexpected pattern matching error"+        (BaseFloat, NoSignSpec, NoSizeMod)  -> floatType TyFloat+        (BaseDouble, NoSignSpec, NoSizeMod) -> floatType TyDouble+        (BaseDouble, NoSignSpec, LongMod)   -> floatType TyLDouble+        -- TODO: error analysis+        (_,_,_)   -> error "Bad AST analysis"+    where+    optBase _ NoBaseType = True+    optBase expect baseTy = expect == baseTy+    optSign _ NoSignSpec = True+    optSign expect sign = expect == sign+    intType = return . Right+    floatType ft = return (Left (ft,iscomplex))++-- TODO: currently bogus+tArraySize :: (MonadTrav m) => CArrSize -> m ArraySize+tArraySize (CNoArrSize False) = return (UnknownArraySize False)+tArraySize (CNoArrSize True) = return (UnknownArraySize True)+tArraySize (CArrSize static szexpr) = liftM (ArraySize static) (return szexpr)++tTypeQuals :: (MonadTrav m) => [CTypeQual] -> m (TypeQuals,Attributes)+tTypeQuals = foldrM go (noTypeQuals,[]) where+    go (CConstQual _) (tq,attrs) = return$ (tq { constant = True },attrs)+    go (CVolatQual _) (tq,attrs) = return$ (tq { volatile = True },attrs)+    go (CRestrQual _) (tq,attrs) = return$ (tq { restrict = True },attrs)+    go (ObjCProtoQual proto) (tq,attrs) = let p1 = protocol tq in return$ (tq { protocol = mappend p1 $ protoFromAST proto },attrs)+    go (CAttrQual attr) (tq,attrs) = liftM (\attr' -> (tq,attr':attrs)) (tAttr attr)+    -- go (ObjCProtoQual proto) (tq,attrs,protos) = liftM (\attr' -> (tq,attr':attrs)) (tAttr attr)+    go (CInlineQual node) (_tq,_attrs) = astError node "unexpected inline qualifier"+++-- * analysis+++{-+To canoicalize type specifiers, we define a canonical form:+void | bool | (char|int|float|double) (signed|unsigned)? (long long?)? complex? | othertype+-}+data NumBaseType = NoBaseType | BaseChar | BaseInt | BaseFloat | BaseDouble deriving (Eq,Ord)+data SignSpec    = NoSignSpec | Signed | Unsigned deriving (Eq,Ord)+data SizeMod     = NoSizeMod | ShortMod | LongMod | LongLongMod deriving (Eq,Ord)+data NumTypeSpec = NumTypeSpec { base :: NumBaseType, signSpec :: SignSpec, sizeMod :: SizeMod, isComplex :: Bool  }+emptyNumTypeSpec :: NumTypeSpec+emptyNumTypeSpec = NumTypeSpec { base = NoBaseType, signSpec = NoSignSpec, sizeMod = NoSizeMod, isComplex = False }+data TypeSpecAnalysis =+  TSNone | TSVoid | TSBool | TSNum NumTypeSpec |+  TSTypeDef TypeDefRef | TSType Type | TSNonBasic CTypeSpec++canonicalTypeSpec :: (MonadTrav m) => [CTypeSpec] -> m TypeSpecAnalysis+canonicalTypeSpec = foldrM go TSNone where+    getNTS TSNone = Just emptyNumTypeSpec+    getNTS (TSNum nts) = Just nts+    getNTS _ = Nothing+    updLongMod NoSizeMod = Just LongMod+    updLongMod LongMod   = Just LongLongMod+    updLongMod _         = Nothing+    getTypeSpecs :: MonadTrav m => Type -> m [CTypeSpec]+    getTypeSpecs         =  return . getTS . partitionDeclSpecs . fst . exportType+    getTS (_, _, _, ts, _) = ts+    go :: (MonadTrav m) => CTypeSpec -> TypeSpecAnalysis -> m TypeSpecAnalysis+    go (CVoidType _)    TSNone = return$  TSVoid+    go (CBoolType _)    TSNone = return$  TSBool+    go (CCharType _)    tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa+                            = return$  TSNum$ nts { base = BaseChar }+    go (CIntType _)     tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa+                            = return$  TSNum$ nts { base = BaseInt }+    go (CFloatType _)   tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa+                            = return$  TSNum$ nts { base = BaseFloat }+    go (CDoubleType _)  tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa+                            = return$  TSNum$ nts { base = BaseDouble }+    go (CShortType _)   tsa | (Just nts@(NumTypeSpec { sizeMod = NoSizeMod })) <- getNTS tsa+                            = return$  TSNum$nts { sizeMod = ShortMod }+    go (CLongType _)    tsa | (Just nts@(NumTypeSpec { sizeMod = szMod })) <- getNTS tsa,+                              (Just szMod') <- updLongMod szMod+                            = return$  TSNum$ nts { sizeMod = szMod' }+    go (CSignedType _)  tsa | (Just nts@(NumTypeSpec { signSpec = NoSignSpec })) <- getNTS tsa+                            = return$  TSNum$ nts { signSpec = Signed }+    go (CUnsigType _)   tsa | (Just nts@(NumTypeSpec { signSpec = NoSignSpec })) <- getNTS tsa+                            = return$  TSNum$ nts { signSpec = Unsigned }+    go (CComplexType _) tsa | (Just nts@(NumTypeSpec { isComplex = False })) <- getNTS tsa+                            = return$  TSNum$ nts { isComplex = True }+    go (CTypeDef i ni) TSNone = liftM TSTypeDef $ typeDefRef ni i+    go (CTypeOfType d ni) TSNone = liftM TSType $ analyseTypeDecl d+    go (CTypeOfExpr e _) TSNone = liftM TSType $ tExpr [] RValue e+    go otherType  TSNone    = return$  TSNonBasic otherType+    go ty _ts = astError (nodeInfo ty) "Invalid type specifier"++-- compute storage given storage specifiers+canonicalStorageSpec :: (MonadCError m) =>[CStorageSpec] -> m StorageSpec+canonicalStorageSpec storagespecs = liftM elideAuto $ foldrM updStorage NoStorageSpec storagespecs where+        updStorage (CAuto _) NoStorageSpec     = return$ AutoSpec+        updStorage (CRegister _) NoStorageSpec = return$ RegSpec+        updStorage (CThread _) NoStorageSpec   = return$ ThreadSpec+        updStorage (CThread _) (StaticSpec _)  = return$ StaticSpec True+        updStorage (CThread _) (ExternSpec _)  = return$ ExternSpec True+        updStorage (CStatic _) NoStorageSpec   = return$ StaticSpec False+        updStorage (CExtern _) NoStorageSpec   = return$ ExternSpec False+        updStorage (CStatic _) ThreadSpec      = return$ StaticSpec True+        updStorage (CExtern _) ThreadSpec      = return$ ExternSpec True+        updStorage badSpec old+            = astError (nodeInfo badSpec) $ "Invalid storage specifier "++render (pretty badSpec)++" in combination with "++show old+        elideAuto AutoSpec = NoStorageSpec+        elideAuto spec = spec++-- | convert old style parameters+--+-- This requires matching parameter names and declarations, as in the following example:+--+-- > int f(d,c,a,b)+-- > char a,*b;+-- > int c;+-- > { }+--+-- is converted to+--+-- > int f(int d, int c, char a, char* b)+--+-- TODO: This could be moved to syntax, as it operates on the AST only+mergeOldStyle :: (MonadCError m) => NodeInfo -> [CDecl] -> [CDerivedDeclr] -> m [CDerivedDeclr]+mergeOldStyle _node [] declrs = return declrs+mergeOldStyle node oldstyle_params (CFunDeclr params attrs fdnode : dds) =+    case params of+        Left list -> do+            -- FIXME: This translation doesn't work in the following example+            -- [| int f(b,a) struct x { }; int b,a; { struct x local; return local.x } |]+            oldstyle_params' <- liftM concat $ mapM splitCDecl oldstyle_params+            param_map <- liftM Map.fromList $ mapM attachNameOfDecl oldstyle_params'+            (newstyle_params,param_map') <- foldrM insertParamDecl ([],param_map) list+            when (not $ Map.null param_map') $+                astError node $ "declarations for parameter(s) "++ showParamMap param_map' ++" but no such parameter"+            return $ (CFunDeclr (Right (newstyle_params, False)) attrs fdnode : dds)+        Right _newstyle -> astError node "oldstyle parameter list, but newstyle function declaration"+    where+        attachNameOfDecl decl = nameOfDecl decl >>= \n -> return (n,decl)+        insertParamDecl param_name (ps, param_map)+            = case Map.lookup param_name param_map of+                Just p -> return (p:ps, Map.delete param_name param_map)+                Nothing -> return (implicitIntParam param_name : ps, param_map)+        implicitIntParam param_name =+            let node = (nodeInfo param_name) in+            CDecl [CTypeSpec (CIntType node)] [(Just (CDeclr (Just param_name) [] Nothing [] node),Nothing,Nothing)] node+        showParamMap = concat . intersperse ", " . map identToString . Map.keys+mergeOldStyle node _ _ = astError node "oldstyle parameter list, but not function type"++-- | split a CDecl into declarators, hereby eliding SUE defs from the second declarator on.+--+--   There are several reasons why this isn;t the preferred way for handling multiple-declarator declarations,+--   but it can be convinient some times.+--+-- > splitCDecl [d| struct x { int z; } a,*b; |]+-- > [ [d| struct x { int z; } a, struct x *b |] ]+--+-- /TODO/: This could be moved to syntax, as it operates on the AST only+splitCDecl :: (MonadCError m) => CDecl -> m [CDecl]+splitCDecl decl@(CDecl declspecs declrs node) =+    case declrs of+        []      -> internalErr "splitCDecl applied to empty declaration"+        [declr] -> return [decl]+        (d1:ds) ->+            let declspecs' = map elideSUEDef declspecs in+            return$ (CDecl declspecs [d1] node) : [ CDecl declspecs' [declr] node | declr <- ds ]+    where+    elideSUEDef declspec@(CTypeSpec tyspec) =+        case tyspec of+            (CEnumType (CEnum name def attrs enum_node) node) ->+                CTypeSpec (CEnumType (CEnum name Nothing [] enum_node) node)+            (CSUType (CStruct tag name def attrs su_node) node) ->+                CTypeSpec (CSUType (CStruct tag name Nothing [] su_node) node)+            _ -> declspec+    elideSUEDef declspec = declspec+++-- | translate @__attribute__@ annotations+-- TODO: This is a unwrap and wrap stub+tAttr :: (MonadCError m, MonadSymtab m) => CAttr -> m Attr+tAttr (CAttr name cexpr node) = return$ Attr name cexpr node+++-- | construct a name for a variable+-- TODO: more or less bogus+mkVarName :: (MonadCError m, MonadSymtab m) =>+             NodeInfo -> Maybe Ident -> Maybe AsmName -> m VarName+mkVarName  node Nothing _ = return NoName+mkVarName  node (Just n) asm = return $ VarName n asm++-- helpers+nameOfDecl :: (MonadCError m) => CDecl -> m Ident+nameOfDecl d = getOnlyDeclr d >>= \declr ->+    case declr of+        (CDeclr (Just name) _ _ _ _) -> return name+        (CDeclr Nothing _ _ _ node) -> internalErr "nameOfDecl: abstract declarator"+emptyDeclr :: NodeInfo -> CDeclr+emptyDeclr node = CDeclr Nothing [] Nothing [] node+getOnlyDeclr :: (MonadCError m) => CDecl -> m CDeclr+getOnlyDeclr (CDecl _ [(Just declr,_,_)] _) = return declr+getOnlyDeclr (CDecl _ _ node) = internalErr "getOnlyDeclr: declaration doesn't have a unique declarator"
+ src/Language/ObjC/Analysis/DefTable.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE PatternGuards, DeriveDataTypeable  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Analysis.DefTable+-- Copyright   :  (c) 2008 Benedikt Huber+--                  based on code from c2hs+--                (c) [1999..2001] Manuel M. T. Chakravarty+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  alpha+-- Portability :  ghc+--+-- This module manages symbols in local and global scopes.+--+-- There are four different kind of identifiers: ordinary identifiers (henceforth+-- simply called `identifier'), tag names (names of struct\/union\/enum types),+-- labels and structure members.+-----------------------------------------------------------------------------+module Language.ObjC.Analysis.DefTable (+    IdentEntry, identOfTyDecl,+    TagEntry, TagFwdDecl(..),+    DefTable(..),+    emptyDefTable,+    globalDefs,+    inFileScope,+    enterFunctionScope,leaveFunctionScope,enterBlockScope,leaveBlockScope,+    enterMemberDecl,leaveMemberDecl,+    DeclarationStatus(..),declStatusDescr,+    defineTypeDef, defineGlobalIdent, defineScopedIdent, defineScopedIdentWhen,+    declareTag,defineTag,defineLabel,lookupIdent,+    lookupTag,lookupLabel,lookupIdentInner,lookupTagInner,+    insertType, lookupType,+    mergeDefTable+)+where+import Language.ObjC.Data+import Language.ObjC.Analysis.NameSpaceMap+import Language.ObjC.Analysis.SemRep++import qualified Data.Map as Map+import Data.IntMap (IntMap, union)+import qualified Data.IntMap as IntMap+import Data.Generics++{- Name spaces, scopes and contexts [Scopes]++ In C, there are 4 categories of identifiers:++  * labels+  * tag names (@(struct|union|enum) tag-name@), where /all/ tag names live in one namespace+  * members of structures and unions+  * ordinary identifiers, denoting objects, functions, typeDefs and enumeration constants++ There are 4 kind of scopes:++  * file scope: outside of parameter lists and blocks+  * function prototype scope+  * function scope: labels are visible within the entire function, and declared implicitely+  * block scope++ While function scope is irrelevant for variable declarations, they might also appear in member declarations.+ Therefore, there are also 4 kinds of contexts where a variable might be declared:++  * File Scope Context: external declaration \/ definition+  * Block Scope Context: either external or local definition+  * Function prototype scope context+  * Member Declaration context++ See+   <http://www.embedded.com/design/206901036>+   C99 6+-}++-- | All ordinary identifiers map to 'IdenTyDecl': either a typedef or a object\/function\/enumerator+type IdentEntry = Either TypeDef IdentDecl++identOfTyDecl :: IdentEntry -> Ident+identOfTyDecl = either identOfTypeDef declIdent++data TagFwdDecl = CompDecl CompTypeRef+                | EnumDecl EnumTypeRef+instance HasSUERef TagFwdDecl where+  sueRef (CompDecl ctr) = sueRef ctr+  sueRef (EnumDecl etr) = sueRef etr+instance CNode TagFwdDecl where+  nodeInfo (CompDecl ctr) = nodeInfo ctr+  nodeInfo (EnumDecl etr) = nodeInfo etr++-- | Tag names map to forward declarations or definitions of struct\/union\/enum types+type TagEntry = Either TagFwdDecl TagDef++-- | Table holding current definitions+data DefTable = DefTable+    {+        identDecls   :: NameSpaceMap Ident IdentEntry,     -- ^ declared `ordinary identifiers'+        tagDecls   :: NameSpaceMap SUERef TagEntry,        -- ^ declared struct/union/enum  tags+        labelDefs  :: NameSpaceMap Ident Ident,            -- ^ defined labels+        memberDecls :: NameSpaceMap Ident MemberDecl,      -- ^ member declarations (only local)+        refTable   :: IntMap Name,                         -- ^ link names with definitions+        typeTable  :: IntMap Type+    }++-- | empty definition table, with all name space maps in global scope+emptyDefTable :: DefTable+emptyDefTable = DefTable nameSpaceMap nameSpaceMap nameSpaceMap nameSpaceMap IntMap.empty IntMap.empty++-- | get the globally defined entries of a definition table+globalDefs :: DefTable -> GlobalDecls+globalDefs deftbl = Map.foldWithKey insertDecl (GlobalDecls e gtags e) (globalNames $ identDecls deftbl)+    where+    e = Map.empty+    (_fwd_decls,gtags) = Map.mapEither id $ globalNames (tagDecls deftbl)+    insertDecl ident (Left tydef) ds = ds { gTypeDefs = Map.insert ident tydef (gTypeDefs ds)}+    insertDecl ident (Right obj) ds = ds { gObjs = Map.insert ident obj (gObjs ds) }++inFileScope :: DefTable -> Bool+inFileScope dt = not (hasLocalNames (identDecls dt) || hasLocalNames (labelDefs dt))++leaveScope_ :: (Ord k) => NameSpaceMap k a -> NameSpaceMap k a+leaveScope_ = fst . leaveScope++enterLocalScope :: DefTable -> DefTable+enterLocalScope deftbl = deftbl {+        identDecls = enterNewScope (identDecls deftbl),+        tagDecls = enterNewScope (tagDecls deftbl)+    }+leaveLocalScope :: DefTable -> DefTable+leaveLocalScope deftbl = deftbl {+                        identDecls = leaveScope_ (identDecls deftbl),+                        tagDecls = leaveScope_ (tagDecls deftbl)+                       }++-- | Enter function scope (AND the corresponding block scope)+enterFunctionScope :: DefTable -> DefTable+enterFunctionScope deftbl = enterLocalScope  $ deftbl { labelDefs = enterNewScope (labelDefs deftbl) }++-- | Leave function scope, and return the associated DefTable.+--   Error if not in function scope.+leaveFunctionScope :: DefTable -> DefTable+leaveFunctionScope deftbl = leaveLocalScope $ deftbl { labelDefs = leaveScope_ (labelDefs deftbl) }++-- | Enter new block scope+enterBlockScope :: DefTable -> DefTable+enterBlockScope deftbl = enterLocalScope $ deftbl { labelDefs = enterNewScope (labelDefs deftbl) }++-- | Leave innermost block scope+leaveBlockScope :: DefTable -> DefTable+leaveBlockScope deftbl = leaveLocalScope $ deftbl { labelDefs = leaveScope_ (labelDefs deftbl) }++-- | Enter new member declaration scope+enterMemberDecl :: DefTable -> DefTable+enterMemberDecl deftbl = deftbl { memberDecls = enterNewScope (memberDecls deftbl) }++-- | Leave innermost member declaration scope+leaveMemberDecl :: DefTable -> ([MemberDecl], DefTable)+leaveMemberDecl deftbl =+    let (decls',members) = leaveScope (memberDecls deftbl)+    in (,) (map snd members)+           (deftbl { memberDecls = decls' })++-- * declarations++-- | Status of a declaration+data DeclarationStatus t =+      NewDecl         -- ^ new entry+    | Redeclared t    -- ^ old def was overwritten+    | KeepDef t       -- ^ new def was discarded+    | Shadowed t      -- ^ new def shadows one in outer scope+    | KindMismatch t  -- ^ kind mismatch+    deriving (Data,Typeable)+declStatusDescr :: DeclarationStatus t -> String+declStatusDescr NewDecl = "new"+declStatusDescr (Redeclared _) = "redeclared"+declStatusDescr (KeepDef _) = "keep old"+declStatusDescr (Shadowed _) = "shadowed"+declStatusDescr (KindMismatch _) = "kind mismatch"++compatIdentEntry :: IdentEntry -> IdentEntry -> Bool+compatIdentEntry (Left _tydef) = either (const True) (const False)+compatIdentEntry (Right def) = either (const False) $+  \other_def -> case (def,other_def) of+                  (EnumeratorDef _, EnumeratorDef _) -> True+                  (EnumeratorDef _, _) -> True+                  (_, EnumeratorDef _) -> True+                  (_,_) -> True++data TagEntryKind = CompKind CompTyKind | EnumKind+                    deriving (Eq,Ord)+instance Show TagEntryKind where+  show (CompKind ctk) = show ctk+  show EnumKind = "enum"++-- | @sameTagKind ty1 ty2@ returns @True@ if @ty1,ty2@ are the same kind of tag (struct,union or enum)+tagKind :: TagEntry -> TagEntryKind+tagKind (Left (CompDecl cd)) = CompKind (compTag cd)+tagKind (Left (EnumDecl _)) = EnumKind+tagKind (Right (CompDef cd)) = CompKind (compTag cd)+tagKind (Right (EnumDef _)) =  EnumKind++compatTagEntry :: TagEntry -> TagEntry -> Bool+compatTagEntry  te1 te2 = tagKind te1 == tagKind te2++defRedeclStatus :: (t -> t -> Bool) -> t -> Maybe t -> DeclarationStatus t+defRedeclStatus sameKind def oldDecl =+    case oldDecl of+        Just def' | def `sameKind` def' -> Redeclared def'+                  | otherwise           -> KindMismatch def'+        Nothing                         -> NewDecl++defRedeclStatusLocal :: (Ord k) =>+                        (t -> t -> Bool) -> k -> t -> Maybe t -> NameSpaceMap k t -> DeclarationStatus t+defRedeclStatusLocal sameKind ident def oldDecl nsm =+    case defRedeclStatus sameKind def oldDecl of+        NewDecl -> case lookupName nsm ident of+                     Just shadowed -> Shadowed shadowed+                     Nothing       -> NewDecl+        redecl  -> redecl++defineTypeDef :: Ident -> TypeDef -> DefTable -> (DeclarationStatus IdentEntry, DefTable)+defineTypeDef ident tydef deftbl =+  (defRedeclStatus compatIdentEntry (Left tydef) oldDecl, deftbl { identDecls = decls' })+  where+  (decls', oldDecl) = defLocal (identDecls deftbl) ident (Left tydef)++-- | declare\/define a global object\/function\/typeDef+--+--  returns @Redeclared def@ if there is already an object\/function\/typeDef+--  in global scope, or @DifferentKindRedec def@ if the old declaration is of a different kind.+defineGlobalIdent :: Ident -> IdentDecl -> DefTable -> (DeclarationStatus IdentEntry, DefTable)+defineGlobalIdent ident def deftbl =+    (defRedeclStatus compatIdentEntry (Right def) oldDecl, deftbl { identDecls = decls' })+    where+    (decls',oldDecl) = defGlobal (identDecls deftbl) ident (Right def)+-- | declare\/define a object\/function\/typeDef with lexical scope+--+--  returns @Redeclared def@ or @DifferentKindRedec def@  if there is already an object\/function\/typeDef+--  in the same scope.+defineScopedIdent :: Ident -> IdentDecl -> DefTable -> (DeclarationStatus IdentEntry, DefTable)+defineScopedIdent = defineScopedIdentWhen (const True)++-- | declare\/define a object\/function\/typeDef with lexical scope, if the given predicate holds on the old+--   entry.+--+--  returns @Keep old_def@ if the old definition shouldn't be overwritten, and otherwise @Redeclared def@ or+--  @DifferentKindRedecl def@  if there is already an object\/function\/typeDef in the same scope.+defineScopedIdentWhen :: (IdentDecl -> Bool) -> Ident -> IdentDecl -> DefTable ->+                           (DeclarationStatus IdentEntry, DefTable)+defineScopedIdentWhen override_def ident def deftbl+    = (redecl_status, deftbl { identDecls = decls' })+    where+    new_def = Right def+    old_decls = identDecls deftbl+    old_decl_opt = lookupInnermostScope old_decls ident+    (decls',redecl_status)  | (Just old_decl) <- old_decl_opt, not (old_decl `compatIdentEntry` new_def)+                              = (new_decls, KindMismatch old_decl)+                            | maybe True doOverride old_decl_opt+                              = (new_decls, redeclStatus' old_decl_opt)+                            | otherwise+                              = (old_decls, maybe NewDecl KeepDef old_decl_opt)+    new_decls = fst (defLocal old_decls ident new_def)+    doOverride (Left _) = False+    doOverride (Right old_def) = (override_def old_def)+    redeclStatus' overriden_decl = defRedeclStatusLocal compatIdentEntry ident new_def overriden_decl old_decls++-- | declare a tag (fwd decl in case the struct name isn't defined yet)+declareTag :: SUERef -> TagFwdDecl -> DefTable -> (DeclarationStatus TagEntry, DefTable)+declareTag sueref decl deftbl =+  case lookupTag sueref deftbl of+    Nothing -> (NewDecl, deftbl { tagDecls = fst $ defLocal (tagDecls deftbl) sueref (Left decl) })+    Just old_def | tagKind old_def == tagKind (Left decl) ->  (KeepDef old_def, deftbl)+                 | otherwise -> (KindMismatch old_def, deftbl)++-- | define a tag+defineTag :: SUERef -> TagDef -> DefTable -> (DeclarationStatus TagEntry, DefTable)+defineTag sueref def deftbl =+    (redeclStatus, deftbl { tagDecls = decls'})+    where+    (decls',olddecl) = defLocal (tagDecls deftbl) sueref (Right def)+    redeclStatus =+      case olddecl of+        Just fwd_decl@(Left _)+          | tagKind fwd_decl == tagKind (Right def) -> NewDecl -- should be NewDef+          | otherwise -> KindMismatch fwd_decl+        _ -> defRedeclStatusLocal compatTagEntry sueref (Right def) olddecl (tagDecls deftbl)++-- | define a label+-- Return the old label if it is already defined in this function's scope+defineLabel :: Ident -> DefTable -> (DeclarationStatus Ident, DefTable)+defineLabel ident deftbl =+    let (labels',old_label) = defLocal (labelDefs deftbl) ident ident+    in  (maybe NewDecl Redeclared old_label, deftbl { labelDefs = labels' })++-- | lookup identifier (object, function, typeDef, enumerator)+lookupIdent :: Ident -> DefTable -> Maybe IdentEntry+lookupIdent ident deftbl = lookupName (identDecls deftbl) ident++-- | lookup tag+lookupTag :: SUERef -> DefTable -> Maybe TagEntry+lookupTag sue_ref deftbl = lookupName (tagDecls deftbl) sue_ref++-- | lookup label+lookupLabel :: Ident -> DefTable -> Maybe Ident+lookupLabel ident deftbl = lookupName (labelDefs deftbl) ident++-- | lookup an object in the innermost scope+lookupIdentInner :: Ident -> DefTable -> Maybe IdentEntry+lookupIdentInner ident deftbl = lookupInnermostScope (identDecls deftbl) ident++-- | lookup an identifier in the innermost scope+lookupTagInner :: SUERef -> DefTable -> Maybe TagEntry+lookupTagInner sue_ref deftbl = lookupInnermostScope (tagDecls deftbl) sue_ref++-- | Record the type of a node.+insertType :: DefTable -> Name -> Type -> DefTable+insertType dt n t = dt { typeTable = IntMap.insert (nameId n) t (typeTable dt) }++-- | Lookup the type of a node.+lookupType :: DefTable -> Name -> Maybe Type+lookupType dt n = IntMap.lookup (nameId n) (typeTable dt)++-- | Merge two DefTables. If both tables contain an entry for a given+--   key, they must agree on its value.+mergeDefTable :: DefTable -> DefTable -> DefTable+mergeDefTable (DefTable i1 t1 l1 m1 r1 tt1) (DefTable i2 t2 l2 m2 r2 tt2) =+  DefTable+  (mergeNameSpace i1 i2)+  (mergeNameSpace t1 t2)+  (mergeNameSpace l1 l2)+  (mergeNameSpace m1 m2)+  (union r1 r2)+  (union tt1 tt2)+
+ src/Language/ObjC/Analysis/Export.hs view
@@ -0,0 +1,223 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Analysis.Export+-- Copyright   :  (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  prototype+-- Portability :  ghc+--+-- /WARNING/ : This is just an implementation sketch and not very well tested.+--+-- Export 'SemRep' entities to 'AST' nodes.+-----------------------------------------------------------------------------+module Language.ObjC.Analysis.Export (+exportDeclr,+exportType, exportTypeDecl, exportTypeSpec,+exportTypeDef,+exportCompType, exportCompTypeDecl, exportCompTypeRef,+exportEnumType, exportEnumTypeDecl, exportEnumTypeRef,+)+where+import Language.ObjC.Data.Ident+import Language.ObjC.Data.Node+import Language.ObjC.Syntax.AST+import Language.ObjC.Analysis.SemRep+import Data.Maybe++-- |Export Declarator+--+--  Synopsis: @exportDeclr other_specs type attributes variable-name@+exportDeclr :: [CDeclSpec] -> Type -> Attributes -> VarName -> ([CDeclSpec],CDeclr)+exportDeclr other_specs ty attrs name =+    (other_specs ++ specs, CDeclr ident derived asmname (exportAttrs attrs) ni)+    where+    (specs,derived) = exportType ty+    (ident,asmname) = case name of (VarName vident asmname_opt) -> (Just vident, asmname_opt)+                                   _ -> (Nothing,Nothing)++exportTypeDecl :: Type -> CDecl+exportTypeDecl ty =+  CDecl declspecs declrs ni+  where+  (declspecs,derived) = exportType ty+  declrs | null derived = []+         | otherwise = [(Just $ CDeclr Nothing derived Nothing [] ni,Nothing,Nothing)]++exportTypeDef :: TypeDef -> CDecl+exportTypeDef (TypeDef ident ty attrs node_info) =+  CDecl (CStorageSpec (CTypedef ni) : declspecs) [declr] node_info+  where+  (declspecs,derived) = exportType ty+  declr = (Just $ CDeclr (Just ident) derived Nothing (exportAttrs attrs) ni, Nothing, Nothing)++-- |Export a type to syntax+exportType :: Type -> ([CDeclSpec],[CDerivedDeclr])+exportType ty = exportTy [] ty+  where+    exportTy dd (PtrType ity tyquals attrs) =+        let ptr_declr = CPtrDeclr (exportTypeQualsAttrs tyquals attrs) ni+        in  exportTy (ptr_declr : dd) ity+    exportTy dd (BlockType ity tyquals attrs) =+        let blk_declr = CBlkDeclr (exportTypeQualsAttrs tyquals attrs) ni+        in  exportTy (blk_declr : dd) ity+    exportTy dd (ArrayType ity array_sz tyquals attrs) =+        let arr_declr = CArrDeclr (exportTypeQualsAttrs tyquals attrs) (exportArraySize array_sz) ni+        in  exportTy (arr_declr : dd) ity+    exportTy dd (FunctionType (FunType ity params variadic) attrs) =+        let fun_declr = CFunDeclr (Right (map exportParamDecl params,variadic)) (exportAttrs attrs) ni+        in  exportTy (fun_declr : dd) ity+    exportTy dd (FunctionType (FunTypeIncomplete ity) attrs) =+        let fun_declr = CFunDeclr (Right ([],False)) (exportAttrs attrs) ni+        in  exportTy (fun_declr : dd) ity+    exportTy dd (TypeDefType (TypeDefRef ty_ident _ node) quals attrs) =+        let declspecs =    [CTypeSpec (CTypeDef ty_ident node)]+                        ++ map CTypeQual (exportTypeQualsAttrs quals attrs)+        in (declspecs, reverse dd)+    exportTy dd (DirectType ity quals attrs) =+        let declspecs =    map CTypeQual (exportTypeQualsAttrs quals attrs)+                        ++ map CTypeSpec (exportTypeSpec ity)+        in (declspecs, reverse dd)++exportTypeQuals :: TypeQuals -> [CTypeQual]+exportTypeQuals quals = mapMaybe select [(constant,CConstQual ni),(volatile,CVolatQual ni),(restrict,CRestrQual ni)]+    where+    select (predicate,tyqual) | predicate quals = Just tyqual+                              | otherwise       = Nothing++exportTypeQualsAttrs :: TypeQuals -> Attributes -> [CTypeQual]+exportTypeQualsAttrs tyqs attrs = (exportTypeQuals tyqs ++ map CAttrQual (exportAttrs attrs))++exportArraySize :: ArraySize -> CArrSize+exportArraySize (ArraySize static e) = CArrSize static e+exportArraySize (UnknownArraySize complete) = CNoArrSize complete++exportTypeSpec :: TypeName -> [CTypeSpec]+exportTypeSpec tyname =+    case tyname of+        TyVoid -> [CVoidType ni]+        TyIntegral ity -> exportIntType ity+        TyFloating fty -> exportFloatType fty+        TyComplex fty -> exportComplexType fty+        TyComp comp -> exportCompTypeDecl comp+        TyEnum enum -> exportEnumTypeDecl enum+        TyBuiltin TyVaList -> [CTypeDef (internalIdent "va_list") ni]+        TyBuiltin TyAny -> [CTypeDef (internalIdent "__ty_any") ni]++exportIntType :: IntType -> [CTypeSpec]+exportIntType ty =+    case ty of+      TyBool    -> [CBoolType ni]+      TyChar    -> [CCharType ni]+      TySChar   -> [CSignedType ni,CCharType ni]+      TyUChar   -> [CUnsigType ni,CCharType ni]+      TyShort   -> [CShortType ni]+      TyUShort  -> [CUnsigType ni, CShortType ni]+      TyInt     -> [CIntType ni]+      TyUInt    -> [CUnsigType ni, CIntType ni]+      TyLong    -> [CLongType ni]+      TyULong   -> [CUnsigType ni,CLongType ni]+      TyLLong   -> [CLongType ni, CLongType ni]+      TyULLong  -> [CUnsigType ni, CLongType ni, CLongType ni]++exportFloatType :: FloatType -> [CTypeSpec]+exportFloatType ty =+    case ty of+      TyFloat   -> [CFloatType ni]+      TyDouble  -> [CDoubleType ni]+      TyLDouble -> [CLongType ni, CDoubleType ni]++exportComplexType :: FloatType -> [CTypeSpec]+exportComplexType ty = (CComplexType ni) : exportFloatType ty++exportCompTypeDecl :: CompTypeRef -> [CTypeSpec]+exportCompTypeDecl ty = [CSUType (exportComp ty) ni]+    where+    exportComp (CompTypeRef sue_ref comp_tag _n) =+        CStruct (if comp_tag == StructTag then CStructTag else CUnionTag)+                (exportSUERef sue_ref) Nothing [] ni++exportEnumTypeDecl :: EnumTypeRef -> [CTypeSpec]+exportEnumTypeDecl ty = [CEnumType (exportEnum ty) ni]+    where+    exportEnum (EnumTypeRef sue_ref _n) =+        CEnum (exportSUERef sue_ref) Nothing [] ni++exportCompType :: CompType -> [CTypeSpec]+exportCompType (CompType sue_ref comp_tag members attrs node_info) = [CSUType comp ni]+    where+    comp = CStruct (if comp_tag == StructTag then CStructTag else CUnionTag)+                   (exportSUERef sue_ref)+                   (Just (map exportMemberDecl members))+                   (exportAttrs attrs)+                   node_info+exportCompTypeRef :: CompType -> [CTypeSpec]+exportCompTypeRef (CompType sue_ref com_tag  _ _ node_info) = exportCompTypeDecl (CompTypeRef sue_ref com_tag node_info)++exportEnumType :: EnumType -> [CTypeSpec]+exportEnumType (EnumType sue_ref enumerators attrs node_info) = [CEnumType enum ni]+    where+    enum = CEnum (exportSUERef sue_ref)+                 (Just (map exportEnumerator enumerators))+                 (exportAttrs attrs)+                 node_info+    exportEnumerator (Enumerator ident val _ty _) = (ident,Just val)++exportEnumTypeRef :: EnumType -> [CTypeSpec]+exportEnumTypeRef (EnumType sue_ref _ _ node_info) = exportEnumTypeDecl (EnumTypeRef sue_ref node_info)++exportSUERef :: SUERef -> Maybe Ident+exportSUERef = Just . internalIdent . show -- relies on a the source program not having any $'s in it++exportMemberDecl :: MemberDecl -> CDecl+exportMemberDecl (AnonBitField ty expr node_info) =+    CDecl (map CTypeSpec $ exportTypeSpec $ fromDirectType ty) [(Nothing,Nothing,Just expr)] node_info+exportMemberDecl (MemberDecl vardecl bitfieldsz node_info) =+    let (specs,declarator) = exportVarDecl vardecl+    in  CDecl specs [(Just declarator, Nothing, bitfieldsz)] node_info+exportVarDecl :: VarDecl -> ([CDeclSpec],CDeclr)++-- NOTE: that there is an ambiguity between two possible places for __attributes__ s here+exportVarDecl (VarDecl name attrs ty) = exportDeclr (exportDeclAttrs attrs) ty [] name+exportParamDecl :: ParamDecl -> CDecl+exportParamDecl paramdecl =+    let (specs,declr) = exportVarDecl (getVarDecl paramdecl)+    in CDecl specs [(Just declr, Nothing , Nothing) ] (nodeInfo paramdecl)++exportDeclAttrs :: DeclAttrs -> [CDeclSpec]+exportDeclAttrs (DeclAttrs inline storage attrs) =+       (if inline then [CTypeQual (CInlineQual ni)] else [])+    ++ map (CStorageSpec) (exportStorage storage)+    ++ map (CTypeQual . CAttrQual) (exportAttrs attrs)++-- | express storage in terms of storage specifiers.+--+-- This isn't always possible and depends on the context the identifier is declared.+-- Most importantly, if there is a /conflicting/ declaration in scope, export is impossible.+-- Furthermore, automatic storage is impossible in file scope.+-- If the storage can actually be specified, the export is correct.+exportStorage :: Storage -> [CStorageSpec]+exportStorage NoStorage = []+exportStorage (Auto reg) = if reg then [CRegister ni] else []+exportStorage (Static InternalLinkage thread_local) = threadLocal thread_local [CStatic ni]+exportStorage (Static ExternalLinkage thread_local) = threadLocal thread_local [CExtern ni]+exportStorage (Static NoLinkage _) = error "impossible storage: static without linkage"+exportStorage (FunLinkage InternalLinkage) = [CStatic ni]+exportStorage (FunLinkage ExternalLinkage) = []+exportStorage (FunLinkage NoLinkage) = error "impossible storage: function without linkage"++threadLocal :: Bool -> [CStorageSpec] -> [CStorageSpec]+threadLocal False = id+threadLocal True = ((CThread ni) :)++exportAttrs :: [Attr] -> [CAttr]+exportAttrs = map exportAttr where+    exportAttr (Attr ident es n) = CAttr ident es n++fromDirectType :: Type -> TypeName+fromDirectType (DirectType ty _ _) = ty+fromDirectType (TypeDefType (TypeDefRef _ ref _) _ _) = maybe (error "undefined typeDef") fromDirectType ref+fromDirectType _ = error "fromDirectType"++ni :: NodeInfo+ni = undefNode
+ src/Language/ObjC/Analysis/NameSpaceMap.hs view
@@ -0,0 +1,158 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Analysis.NameSpaceMap+-- Copyright   :  (c) [1995..1999] Manuel M. T. Chakravarty+--                (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  alpha+-- Portability :  portable+--+-- This module manages name spaces.+--+--  * A name space map associates identifiers with their definition.+--+--  * Each name space map is organized in a hierarchical way using the notion of+--    scopes. A name space map, at any moment, always has a global scope and may+--    have several local scopes. Definitions in inner scopes hide definitions+--    of the same identifier in outer scopes.+--+module Language.ObjC.Analysis.NameSpaceMap (+    -- * name space maps+    NameSpaceMap, nameSpaceMap, nsMapToList,+    globalNames,localNames,hasLocalNames,+    -- * scope modification+    defGlobal,+    enterNewScope, leaveScope,+    defLocal,+    lookupName,lookupGlobal,lookupInnermostScope,+    mergeNameSpace+    )+where+import Prelude hiding (lookup)+import qualified Prelude+import qualified Data.Map as Map (empty, insert, lookup, toList, union)+import qualified Data.List as List (unionBy)+import Data.Map   (Map)++{-+C Namespaces and scopes:+++-}++-- DevDocs:+--+-- * the definitions in the global scope are stored in a finite map, because+--   they tend to be a lot.+--+-- * the definitions of the local scopes are stored in a single list, usually+--   they are not very many and the definitions entered last are the most+--   frequently accessed ones; the list structure naturally hides older+--   definitions, i.e., definitions from outer scopes; adding new definitions+--   is done in time proportinal to the current size of the scope; removing a+--   scope is done in constant time (and the definitions of a scope can be+--   returned as a result of leaving the scope); lookup is proportional to the+--   number of definitions in the local scopes and the logarithm of the number+--   of definitions in the global scope -- i.e., efficiency relies on a+--   relatively low number of local definitions together with frequent lookup+--   of the most recently defined local identifiers+--++-- | @NameSpaceMap a@ is a Map from identifiers to @a@, which manages+-- global and local name spaces.+data NameSpaceMap k v = NsMap (Map k v)  -- defs in global scope+                              [[(k, v)]] -- stack of local scopes+globalNames :: (Ord k) => NameSpaceMap k v -> Map k v+globalNames (NsMap g _) = g+hasLocalNames :: NameSpaceMap k v -> Bool+hasLocalNames (NsMap _ l) = not (null l)+localNames :: (Ord k) => NameSpaceMap k v -> [[(k,v)]]+localNames (NsMap _ l) = l++-- | create a name space+nameSpaceMap :: (Ord k) => NameSpaceMap k v+nameSpaceMap  = NsMap Map.empty []++++-- | Add global definition+--+-- @(ns',oldDef) = defGlobal ns ident def@+--   adds a global definition @ident := def@ to the namespace.+--   It returns the modified namespace @ns'@. If the identifier is+--   already declared in the global namespace, the definition is overwritten+--   and the old definition @oldDef@ is returned.+defGlobal :: (Ord k) => NameSpaceMap k a -> k -> a -> (NameSpaceMap k a, Maybe a)+defGlobal (NsMap gs lss) ident def+    = (NsMap (Map.insert ident def gs) lss, Map.lookup ident gs)++-- | Enter new local scope+--+-- @ns' = enterNewScope ns@ creates and enters a new local scope.+enterNewScope :: (Ord k) => NameSpaceMap k a -> NameSpaceMap k a+enterNewScope (NsMap gs lss)  = NsMap gs ([]:lss)++-- | Leave innermost local scope+--+-- @(ns',defs) = leaveScope ns@ pops leaves the innermost local scope.+--  and returns its definitions+leaveScope :: (Ord k) => NameSpaceMap k a -> (NameSpaceMap k a, [(k, a)])+leaveScope (NsMap _ [])         = error "NsMaps.leaveScope: No local scope!"+leaveScope (NsMap gs (ls:lss))  = (NsMap gs lss, ls)++-- | Add local definition+--+-- @(ns',oldDef) = defLocal ns ident def@ adds the local definition+--   @ident := def@ to the innermost local scope, if there is a local scope,+--     and to the global scope otherwise.+--   It returns the modified name space @ns'@ and the old  binding of+--   the identifier @oldDef@, which is overwritten.+defLocal :: (Ord k) => NameSpaceMap k a -> k -> a -> (NameSpaceMap k a, Maybe a)+defLocal ns@(NsMap _ []) ident def = defGlobal ns ident def+defLocal (NsMap    gs (ls:lss)) ident def =+  (NsMap gs (((ident, def):ls):lss),+   Prelude.lookup ident ls)++-- | Search for a definition+--+-- @def = find ns ident@ returns the definition in some scope (inner to outer),+-- if there is one.+lookupName :: (Ord k) => NameSpaceMap k a -> k -> Maybe a+lookupName ns@(NsMap _ localDefs) ident+    = case (lookupLocal localDefs) of+        Nothing  -> lookupGlobal ns ident+        Just def -> Just def+  where+    lookupLocal []       = Nothing+    lookupLocal (ls:lss) = case (Prelude.lookup ident ls) of+                        Nothing  -> lookupLocal lss+                        Just def -> Just def++lookupGlobal :: (Ord k) => NameSpaceMap k a -> k -> Maybe a+lookupGlobal (NsMap gs _) ident = Map.lookup ident gs++lookupInnermostScope :: (Ord k) => NameSpaceMap k a -> k -> Maybe a+lookupInnermostScope nsm@(NsMap _gs localDefs) ident  =+    case localDefs of+        (ls : _lss) -> Prelude.lookup ident ls+        [] -> lookupGlobal nsm ident++-- | flatten a namespace into a assoc list+--+--  @nameSpaceToList ns = (localDefInnermost ns ++ .. ++ localDefsOutermost ns) ++ globalDefs ns@+nsMapToList :: (Ord k) => NameSpaceMap k a -> [(k, a)]+nsMapToList (NsMap gs lss)  = concat lss ++ Map.toList gs++-- | Merge two namespaces. If they disagree on the types of any+--   variables, all bets are off.+mergeNameSpace :: (Ord k) =>+                  NameSpaceMap k a+               -> NameSpaceMap k a+               -> NameSpaceMap k a+mergeNameSpace (NsMap global1 local1) (NsMap global2 local2) =+  NsMap (Map.union global1 global2) (localUnion local1 local2)+  where localUnion (l1:ls1) (l2:ls2) =+          List.unionBy (\p1 p2 -> fst p1 == fst p2) l1 l2 : localUnion ls1 ls2+        localUnion [] ls2 = ls2+        localUnion ls1 [] = ls1
+ src/Language/ObjC/Analysis/SemError.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Analysis.SemError+-- Copyright   :  (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  alpha+-- Portability :  ghc+--+-- Errors in the semantic analysis+-----------------------------------------------------------------------------+module Language.ObjC.Analysis.SemError (+InvalidASTError(..), invalidAST,+BadSpecifierError(..), badSpecifierError,+TypeMismatch(..), typeMismatch,+RedefError(..), RedefInfo(..), RedefKind(..), redefinition,+)+where+import Data.Typeable++-- this means we cannot use SemError in SemRep, but use rich types here+import Language.ObjC.Analysis.SemRep++import Language.ObjC.Data.Error+import Language.ObjC.Data.Node++-- here are the errors available++-- | InvalidASTError is caused by the violation of an invariant in the AST+newtype InvalidASTError = InvalidAST ErrorInfo deriving (Typeable,Error)++-- | BadSpecifierError is caused by an invalid combination of specifiers+newtype BadSpecifierError = BadSpecifierError ErrorInfo deriving (Typeable,Error)++-- | RedefError is caused by an invalid redefinition of the same identifier or type+data RedefError = RedefError ErrorLevel RedefInfo deriving Typeable++data RedefInfo = RedefInfo String RedefKind NodeInfo NodeInfo+data RedefKind = DuplicateDef | DiffKindRedecl | ShadowedDef | DisagreeLinkage |+                 NoLinkageOld+data TypeMismatch = TypeMismatch String (NodeInfo,Type) (NodeInfo,Type) deriving Typeable++-- Invalid AST+-- ~~~~~~~~~~~++instance Show InvalidASTError  where show = showError "AST invariant violated"++invalidAST :: NodeInfo -> String -> InvalidASTError+invalidAST node_info msg = InvalidAST (mkErrorInfo LevelError msg node_info)++-- Bad specifier (e.g. static for a parameter, or extern when there is an initializer)+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++instance Show BadSpecifierError     where show = showError "Bad specifier"++badSpecifierError :: NodeInfo -> String -> BadSpecifierError+badSpecifierError node_info msg = BadSpecifierError (mkErrorInfo LevelError msg node_info)++-- Type mismatch+-- ~~~~~~~~~~~~~+typeMismatch :: String -> (NodeInfo, Type) -> (NodeInfo,Type) -> TypeMismatch+typeMismatch = TypeMismatch++instance Show TypeMismatch where+    show tm = showError "Type mismatch" (typeMismatchInfo tm)+instance Error TypeMismatch where+    errorInfo = typeMismatchInfo+typeMismatchInfo :: TypeMismatch -> ErrorInfo+typeMismatchInfo (TypeMismatch reason (node1,_ty2) _t2) =+    ErrorInfo LevelError (posOfNode node1) [reason]++-- Redefinitions+-- ~~~~~~~~~~~~~++instance Show RedefError  where+    show (RedefError lvl info) = showErrorInfo (redefErrLabel info) (redefErrorInfo lvl info)+instance Error RedefError where+    errorInfo (RedefError lvl info) = redefErrorInfo lvl info+    changeErrorLevel (RedefError _lvl info) lvl' = RedefError lvl' info++redefErrLabel :: RedefInfo -> String+redefErrLabel  (RedefInfo ident _ _ _) = ident ++ " redefined"++redefErrorInfo :: ErrorLevel -> RedefInfo -> ErrorInfo+redefErrorInfo lvl info@(RedefInfo _ _ node old_node) =+    ErrorInfo lvl (posOfNode node) ([redefErrReason info] ++ prevDeclMsg old_node)++redefErrReason :: RedefInfo -> String+redefErrReason (RedefInfo ident DuplicateDef _ _) = "duplicate definition of " ++ ident+redefErrReason (RedefInfo ident ShadowedDef _ _)   = "this declaration of " ++ ident ++ " shadows a previous one"+redefErrReason (RedefInfo ident DiffKindRedecl _ _) = ident ++ " previously declared as a different kind of symbol"+redefErrReason (RedefInfo ident DisagreeLinkage _ _) = ident ++ " previously declared with different linkage"+redefErrReason (RedefInfo ident NoLinkageOld _ _) = ident ++ " previously declared without linkage"++prevDeclMsg :: NodeInfo -> [String]+prevDeclMsg old_node = ["The previous declaration was here: ", show (posOfNode old_node)]++redefinition :: ErrorLevel -> String -> RedefKind -> NodeInfo -> NodeInfo -> RedefError+redefinition lvl ctx kind new old = RedefError lvl (RedefInfo ctx kind new old)+
+ src/Language/ObjC/Analysis/SemRep.hs view
@@ -0,0 +1,724 @@+{-# LANGUAGE DeriveDataTypeable  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Analysis.Syntax+-- Copyright   :  (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  alpha+-- Portability :  ghc+--+-- This module contains definitions for representing C translation units.+-- In contrast to 'Language.ObjC.Syntax.AST', the representation tries to express the semantics of+-- of a translation unit.+---------------------------------------------------------------------------------------------------+module Language.ObjC.Analysis.SemRep(+-- * Sums of tags and identifiers+TagDef(..),typeOfTagDef,+Declaration(..),declIdent,declName,declType,declAttrs,+IdentDecl(..),objKindDescr, splitIdentDecls,+-- * Global definitions+GlobalDecls(..),emptyGlobalDecls,filterGlobalDecls,mergeGlobalDecls,+-- * Events for visitors+DeclEvent(..),+-- * Declarations and definitions+Decl(..),+ObjDef(..),isTentative,+FunDef(..),+ParamDecl(..),MemberDecl(..),+TypeDef(..),identOfTypeDef,+VarDecl(..),+-- * Declaration attributes+DeclAttrs(..),isExtDecl,+Storage(..),declStorage,ThreadLocal,Register,+Linkage(..),hasLinkage,declLinkage,+-- * Types+Type(..),+FunType(..),+ArraySize(..),+TypeDefRef(..),+TypeName(..),BuiltinType(..),+IntType(..),FloatType(..),+HasSUERef(..),HasCompTyKind(..),+CompTypeRef(..),CompType(..),typeOfCompDef,CompTyKind(..),+EnumTypeRef(..),EnumType(..),typeOfEnumDef,+Enumerator(..),+TypeQuals(..),noTypeQuals, mergeTypeQuals,+ProtoQuals(..),noProtoQuals,mergeProtoQuals,protoFromAST,+-- * Variable names+VarName(..),identOfVarName,isNoName,AsmName,+-- * Attributes (STUB, not yet analyzed)+Attr(..),Attributes,noAttributes,mergeAttributes,+-- * Statements and Expressions (STUB, aliases to Syntax)+Stmt,Expr,Initializer,AsmBlock,+)+where+import Language.ObjC.Data+import Language.ObjC.Syntax++import Data.Map (Map)+import Data.Monoid+import qualified Data.Map as Map+import Data.Generics++-- | accessor class : struct\/union\/enum names+class HasSUERef a where+    sueRef  :: a -> SUERef++-- | accessor class : composite type tags (struct or union)+class HasCompTyKind a where+    compTag :: a -> CompTyKind++-- | Composite type definitions (tags)+data TagDef =  CompDef CompType	  --definition+     	       | EnumDef EnumType      -- enum definition+               deriving (Typeable, Data {-! ,CNode !-})++instance HasSUERef TagDef where+    sueRef (CompDef ct) = sueRef ct+    sueRef (EnumDef et) = sueRef et++-- | return the type corresponding to a tag definition+typeOfTagDef :: TagDef -> TypeName+typeOfTagDef (CompDef comptype) =  typeOfCompDef comptype+typeOfTagDef (EnumDef enumtype) =  typeOfEnumDef enumtype++-- | All datatypes aggregating a declaration are instances of @Declaration@+class Declaration n where+    -- | get the name, type and declaration attributes of a declaration or definition+    getVarDecl :: n -> VarDecl++-- | get the declaration corresponding to a definition+declOfDef :: (Declaration n, CNode n) => n -> Decl+declOfDef def = let vd = getVarDecl def in Decl vd (nodeInfo def)++-- | get the variable identifier of a declaration (only safe if the+--    the declaration is known to have a name)+declIdent :: (Declaration n) => n -> Ident+declIdent = identOfVarName . declName+-- | get the variable name of a @Declaration@+declName ::  (Declaration n) => n -> VarName+declName = (\(VarDecl n _ _) -> n) . getVarDecl+-- | get the type of a @Declaration@+declType ::  (Declaration n) => n -> Type+declType = (\(VarDecl _ _ ty) -> ty) . getVarDecl+-- | get the declaration attributes of a @Declaration@+declAttrs :: (Declaration n) => n -> DeclAttrs+declAttrs = (\(VarDecl _ specs _) -> specs) . getVarDecl++instance (Declaration a, Declaration b) => Declaration (Either a b) where+    getVarDecl = either getVarDecl getVarDecl++-- | identifiers, typedefs and enumeration constants (namespace sum)+data IdentDecl = Declaration Decl           -- ^ object or function declaration+	             | ObjectDef ObjDef           -- ^ object definition+	             | FunctionDef FunDef         -- ^ function definition+	             | EnumeratorDef Enumerator   -- ^ definition of an enumerator+               deriving (Typeable, Data {-! ,CNode !-})++instance Declaration IdentDecl where+  getVarDecl (Declaration decl) = getVarDecl decl+  getVarDecl (ObjectDef def) = getVarDecl def+  getVarDecl (FunctionDef def) = getVarDecl def+  getVarDecl (EnumeratorDef def) = getVarDecl def++-- | textual description of the kind of an object+objKindDescr :: IdentDecl -> String+objKindDescr  (Declaration _ ) = "declaration"+objKindDescr (ObjectDef _) = "object definition"+objKindDescr (FunctionDef _) = "function definition"+objKindDescr (EnumeratorDef _) = "enumerator definition"++-- | @splitIdentDecls includeAllDecls@ splits a map of object, function and enumerator declarations and definitions into one map+-- holding declarations, and three maps for object definitions, enumerator definitions and function definitions.+-- If @includeAllDecls@ is @True@ all declarations are present in the first map, otherwise only those where no corresponding definition+-- is available.+splitIdentDecls :: Bool -> Map Ident IdentDecl -> (Map Ident Decl,+                                                ( Map Ident Enumerator,+                                                  Map Ident ObjDef,+                                                  Map Ident FunDef ) )+splitIdentDecls include_all = Map.foldWithKey (if include_all then deal else deal') (Map.empty,(Map.empty,Map.empty,Map.empty))+  where+  deal ident entry (decls,defs) = (Map.insert ident (declOfDef entry) decls, addDef ident entry defs)+  deal' ident (Declaration d) (decls,defs) = (Map.insert ident d decls,defs)+  deal' ident def (decls,defs) = (decls, addDef ident def defs)+  addDef ident entry (es,os,fs) =+    case entry of+        Declaration _   -> (es,os,fs)+        EnumeratorDef e -> (Map.insert ident e es,os,fs)+        ObjectDef o     -> (es,Map.insert ident o os,fs)+        FunctionDef f   -> (es, os,Map.insert ident f fs)+++-- | global declaration\/definition table returned by the analysis+data GlobalDecls = GlobalDecls {+                     gObjs     :: Map Ident IdentDecl,+                     gTags     :: Map SUERef TagDef,+                     gTypeDefs :: Map Ident TypeDef+                   }++-- | empty global declaration table+emptyGlobalDecls :: GlobalDecls+emptyGlobalDecls = GlobalDecls Map.empty Map.empty Map.empty++-- | filter global declarations+filterGlobalDecls :: (DeclEvent -> Bool) -> GlobalDecls -> GlobalDecls+filterGlobalDecls decl_filter gmap = GlobalDecls+    {+        gObjs  = Map.filter (decl_filter . DeclEvent) (gObjs gmap),+        gTags  = Map.filter (decl_filter . TagEvent) (gTags gmap),+        gTypeDefs = Map.filter (decl_filter . TypeDefEvent) (gTypeDefs gmap)+    }+-- | merge global declarations+mergeGlobalDecls :: GlobalDecls -> GlobalDecls -> GlobalDecls+mergeGlobalDecls gmap1 gmap2 = GlobalDecls+    {+        gObjs  = Map.union (gObjs gmap1) (gObjs gmap2),+        gTags  = Map.union  (gTags gmap1) (gTags gmap2),+        gTypeDefs = Map.union (gTypeDefs gmap1) (gTypeDefs gmap2)+    }+++-- * Events++-- | Declaration events+--+-- Those events are reported to callbacks, which are executed during the traversal.+data DeclEvent =+       TagEvent  TagDef+       -- ^ file-scope struct\/union\/enum event+     | DeclEvent IdentDecl+       -- ^ file-scope declaration or definition+     | ParamEvent ParamDecl+       -- ^ parameter declaration+     | LocalEvent IdentDecl+       -- ^ local variable declaration or definition+     | TypeDefEvent TypeDef+       -- ^ a type definition+     | AsmEvent AsmBlock+       -- ^ assembler block+     deriving ({-! CNode !-})++-- * Declarations and definitions++-- | Declarations, which aren't definitions+data Decl = Decl VarDecl NodeInfo+            deriving (Typeable, Data {-! ,CNode !-})++instance Declaration Decl where+    getVarDecl   (Decl vd _) =  vd++-- | Object Definitions+--+-- An object definition is a declaration together with an initializer.+--+-- If the initializer is missing, it is a tentative definition, i.e. a+-- definition which might be overriden later on.+data ObjDef = ObjDef VarDecl (Maybe Initializer) NodeInfo+             deriving (Typeable, Data {-! ,CNode !-})+instance Declaration ObjDef where+    getVarDecl  (ObjDef vd _ _) =  vd++-- | Returns @True@ if the given object definition is tentative.+isTentative :: ObjDef -> Bool+isTentative (ObjDef decl init_opt _) | isExtDecl decl = maybe True (const False) init_opt+                                     | otherwise = False++-- | Function definitions+--+-- A function definition is a declaration together with a statement (the function body).+data FunDef = FunDef VarDecl Stmt NodeInfo+             deriving (Typeable, Data {-! ,CNode !-})+instance Declaration FunDef where+    getVarDecl (FunDef vd _ _) = vd+++-- | Parameter declaration+data ParamDecl = ParamDecl VarDecl NodeInfo+               | AbstractParamDecl VarDecl NodeInfo+    deriving (Typeable, Data {-! ,CNode !-} )++instance Declaration ParamDecl where+  getVarDecl (ParamDecl vd _) = vd+  getVarDecl (AbstractParamDecl vd _) = vd++-- | Struct\/Union member declaration+data MemberDecl = MemberDecl VarDecl (Maybe Expr) NodeInfo+                  -- ^ @MemberDecl vardecl bitfieldsize node@+                | AnonBitField Type Expr NodeInfo+                  -- ^ @AnonBitField typ size@+    deriving (Typeable, Data {-! ,CNode !-} )++instance Declaration MemberDecl where+  getVarDecl (MemberDecl vd _ _) = vd+  getVarDecl (AnonBitField ty _ _) = VarDecl NoName (DeclAttrs False NoStorage []) ty++-- | @typedef@ definitions.+--+-- The identifier is a new name for the given type.+data TypeDef = TypeDef Ident Type Attributes NodeInfo+               deriving (Typeable, Data {-! ,CNode !-} )++-- | return the idenitifier of a @typedef@+identOfTypeDef :: TypeDef -> Ident+identOfTypeDef (TypeDef ide _ _ _) = ide++-- | Generic variable declarations+data VarDecl = VarDecl VarName DeclAttrs Type+              deriving (Typeable, Data)++instance Declaration VarDecl where+  getVarDecl = id++-- @isExtDecl d@ returns true if the declaration has /linkage/+isExtDecl :: (Declaration n) => n -> Bool+isExtDecl = hasLinkage . declStorage++-- | Declaration attributes of the form @DeclAttrs isInlineFunction storage linkage attrs@+--+-- They specify the storage and linkage of a declared object.+data DeclAttrs = DeclAttrs Bool Storage Attributes+                 -- ^ @DeclAttrs inline storage attrs@+               deriving (Typeable, Data)++-- | get the 'Storage' of a declaration+declStorage :: (Declaration d) => d -> Storage+declStorage d = case declAttrs d of (DeclAttrs _ st _) -> st++-- In C we have+--  Identifiers can either have internal, external or no linkage+--  (same object everywhere, same object within the translation unit, unique).+--  * top-level identifiers+--      static : internal linkage (objects and function defs)+--      extern : linkage of prior declaration (if specified), external linkage otherwise+--      no-spec: external linkage+--  * storage duration+--      * static storage duration: objects with external or internal linkage, or local ones with the static keyword+--      * automatic storage duration: otherwise (register)+-- See http://publications.gbdirect.co.uk/c_book/chapter8/declarations_and_definitions.html, Table 8.1, 8.2++-- | Storage duration and linkage of a variable+data Storage  =  NoStorage                  -- ^ no storage+               | Auto Register              -- ^ automatic storage (optional: register)+               | Static Linkage ThreadLocal -- ^ static storage, linkage spec and thread local specifier (gnu c)+               | FunLinkage Linkage         -- ^ function, either internal or external linkage+               deriving (Typeable, Data, Show, Eq, Ord)++type ThreadLocal = Bool+type Register    = Bool++-- | Linkage: Either no linkage, internal to the translation unit or external+data Linkage = NoLinkage | InternalLinkage | ExternalLinkage+               deriving (Typeable, Data, Show, Eq, Ord)++-- | return @True@ if the object has linkage+hasLinkage :: Storage -> Bool+hasLinkage (Auto _) = False+hasLinkage (Static NoLinkage _) = False+hasLinkage _ = True++-- | Get the linkage of a definition+declLinkage :: (Declaration d) => d -> Linkage+declLinkage decl =+    case declStorage decl of+        NoStorage -> undefined+        Auto _ -> NoLinkage+        Static linkage _ -> linkage+        FunLinkage linkage -> linkage+++-- * types++-- | types of C objects+data Type =+       DirectType TypeName TypeQuals Attributes+     -- ^ a non-derived type+     | PtrType Type TypeQuals Attributes+     -- ^ pointer type+     | BlockType Type TypeQuals Attributes+     -- ^ block type+     | ArrayType Type ArraySize TypeQuals Attributes+     -- ^ array type+     | FunctionType FunType Attributes+     -- ^ function type+     | TypeDefType TypeDefRef TypeQuals Attributes+     -- ^ a defined type+     deriving (Typeable, Data)++-- | Function types are of the form @FunType return-type params isVariadic@.+--+-- If the parameter types aren't yet known, the function has type @FunTypeIncomplete type attrs@.+data FunType = FunType Type [ParamDecl] Bool+            |  FunTypeIncomplete Type+               deriving (Typeable, Data)++-- | An array type may either have unknown size or a specified array size, the latter either variable or constant.+-- Furthermore, when used as a function parameters, the size may be qualified as /static/.+-- In a function prototype, the size may be `Unspecified variable size' (@[*]@).+data ArraySize =  UnknownArraySize Bool+                -- ^ @UnknownArraySize is-starred@+                | ArraySize Bool Expr+                -- ^ @FixedSizeArray is-static size-expr@+               deriving (Typeable, Data)++-- | normalized type representation+data TypeName =+      TyVoid+    | TyIntegral IntType+    | TyFloating FloatType+    | TyComplex  FloatType+    | TyComp CompTypeRef+    | TyEnum EnumTypeRef+    | TyBuiltin BuiltinType+    deriving (Typeable, Data)++-- | Builtin type (va_list, anything)+data BuiltinType = TyVaList+                 | TyAny+                   deriving (Typeable, Data)++-- | typdef references+-- If the actual type is known, it is attached for convenience+data TypeDefRef = TypeDefRef Ident (Maybe Type) NodeInfo+               deriving (Typeable, Data {-! ,CNode !-})++-- | integral types (C99 6.7.2.2)+data IntType =+      TyBool+    | TyChar+    | TySChar+    | TyUChar+    | TyShort+    | TyUShort+    | TyInt+    | TyUInt+    | TyLong+    | TyULong+    | TyLLong+    | TyULLong+    deriving (Typeable, Data, Eq, Ord)++instance Show IntType where+    show TyBool = "_Bool"+    show TyChar = "char"+    show TySChar = "signed char"+    show TyUChar = "unsigned char"+    show TyShort = "short"+    show TyUShort = "unsigned short"+    show TyInt = "int"+    show TyUInt = "unsigned int"+    show TyLong = "long"+    show TyULong = "unsigned long"+    show TyLLong = "long long"+    show TyULLong = "unsigned long long"++-- | floating point type (C99 6.7.2.2)+data FloatType =+      TyFloat+    | TyDouble+    | TyLDouble+    deriving (Typeable, Data, Eq, Ord)++instance Show FloatType where+    show TyFloat = "float"+    show TyDouble = "double"+    show TyLDouble = "long double"++-- | composite type declarations+data CompTypeRef = CompTypeRef SUERef CompTyKind NodeInfo+                    deriving (Typeable, Data {-! ,CNode !-})++instance HasSUERef  CompTypeRef where sueRef  (CompTypeRef ref _ _) = ref+instance HasCompTyKind CompTypeRef where compTag (CompTypeRef _ tag _)  = tag++data EnumTypeRef = EnumTypeRef SUERef NodeInfo+    deriving (Typeable, Data {-! ,CNode !-})+instance HasSUERef  EnumTypeRef where sueRef  (EnumTypeRef ref _) = ref++-- | Composite type (struct or union).+data CompType =  CompType SUERef CompTyKind [MemberDecl] Attributes NodeInfo+                 deriving (Typeable, Data {-! ,CNode !-} )+instance HasSUERef  CompType where sueRef  (CompType ref _ _ _ _) = ref+instance HasCompTyKind CompType where compTag (CompType _ tag _ _ _) = tag++-- | return the type of a composite type definition+typeOfCompDef :: CompType -> TypeName+typeOfCompDef (CompType ref tag _ _ _) = TyComp (CompTypeRef ref tag undefNode)++-- | a tag to determine wheter we refer to a @struct@ or @union@, see 'CompType'.+data CompTyKind =  StructTag+                 | UnionTag+    deriving (Eq,Ord,Typeable,Data)++instance Show CompTyKind where+    show StructTag = "struct"+    show UnionTag  = "union"++-- | Representation of C enumeration types+data EnumType = EnumType SUERef [Enumerator] Attributes NodeInfo+                 -- ^ @EnumType name enumeration-constants attrs node@+                 deriving (Typeable, Data {-! ,CNode !-} )++instance HasSUERef EnumType where sueRef  (EnumType ref _ _ _) = ref++-- | return the type of an enum definition+typeOfEnumDef :: EnumType -> TypeName+typeOfEnumDef (EnumType ref _ _ _) = TyEnum (EnumTypeRef ref undefNode)++-- | An Enumerator consists of an identifier, a constant expressions and the link to its type+data Enumerator = Enumerator Ident Expr EnumType NodeInfo+                  deriving (Typeable, Data {-! ,CNode !-})+instance Declaration Enumerator where+  getVarDecl (Enumerator ide _ enumty _) =+    VarDecl+      (VarName ide Nothing)+      (DeclAttrs False NoStorage [])+      (DirectType (typeOfEnumDef enumty) noTypeQuals noAttributes)++-- | Type qualifiers: constant, volatile, proto, and restrict+data TypeQuals = TypeQuals { constant :: Bool, volatile :: Bool, restrict :: Bool, protocol :: ProtoQuals }+    deriving (Typeable, Data, Eq, Ord)++data ProtoQuals = ProtoQuals {+   inQ     :: Bool+  ,outQ    :: Bool+  ,inoutQ  :: Bool+  ,bycopyQ :: Bool+  ,onewayQ :: Bool+ } deriving (Typeable, Data, Eq, Ord)++-- | no type qualifiers+noTypeQuals :: TypeQuals+noTypeQuals = TypeQuals False False False noProtoQuals++noProtoQuals :: ProtoQuals+noProtoQuals = ProtoQuals False False False False False++-- | Convert protocol qualifier from AST representation+protoFromAST :: ObjCProtoQualifier a -> ProtoQuals+protoFromAST (ObjCInQual     _) = noProtoQuals{ inQ     = True }+protoFromAST (ObjCOutQual    _) = noProtoQuals{ outQ    = True }+protoFromAST (ObjCInOutQual  _) = noProtoQuals{ inoutQ  = True }+protoFromAST (ObjCBycopyQual _) = noProtoQuals{ bycopyQ = True }+protoFromAST (ObjCOnewayQual _) = noProtoQuals{ onewayQ = True }++-- | merge (/&&/) two type qualifier sets+mergeTypeQuals :: TypeQuals -> TypeQuals -> TypeQuals+mergeTypeQuals (TypeQuals c1 v1 r1 p1) (TypeQuals c2 v2 r2 p2) =+  TypeQuals (c1 && c2) (v1 && v2) (r1 && r2) (mergeProtoQuals p1 p2)++-- | merge (/&&/) two protocol qualifier sets+mergeProtoQuals :: ProtoQuals -> ProtoQuals -> ProtoQuals+mergeProtoQuals (ProtoQuals i1 o1 io1 b1 ow1) (ProtoQuals i2 o2 io2 b2 ow2) =+  ProtoQuals (i1 && i2) (o1 && o2) (io1 && io2) (b1 && b2) (ow1 && ow2)++instance Monoid TypeQuals where+  mempty = noTypeQuals+  mappend (TypeQuals c1 v1 r1 p1) (TypeQuals c2 v2 r2 p2) =+    TypeQuals (c1 || c2) (v1 || v2) (r1 || r2) (mappend p1 p2)++instance Monoid ProtoQuals where+  mempty  = noProtoQuals+  mappend (ProtoQuals i1 o1 io1 b1 ow1) (ProtoQuals i2 o2 io2 b2 ow2) =+    ProtoQuals (i1 || i2) (o1 || o2) (io1 || io2) (b1 || b2) (ow1 || ow2)++++-- * initializers++-- | 'Initializer' is currently an alias for 'CInit'.+--+-- We're planning a normalized representation, but this depends on the implementation of+-- constant expression evaluation+type Initializer = CInit++-- | Normalized C Initializers+-- * If the expression has scalar type, the initializer is an expression+-- * If the expression has struct type, the initializer is a map from designators to initializers+-- * If the expression has array type, the initializer is a list of values+-- Not implemented yet, as it depends on constant expression evaluation+++-- * names and attributes++-- | @VarName name assembler-name@ is a name of an declared object+data VarName =  VarName Ident (Maybe AsmName)+              | NoName+               deriving (Typeable, Data)+identOfVarName :: VarName -> Ident+identOfVarName NoName            = error "identOfVarName: NoName"+identOfVarName (VarName ident _) = ident++isNoName :: VarName -> Bool+isNoName NoName = True+isNoName _ = False++-- | Top level assembler block (alias for @CStrLit@)+type AsmBlock = CStrLit++-- | Assembler name (alias for @CStrLit@)+type AsmName = CStrLit++-- | @__attribute__@ annotations+--+-- Those are of the form @Attr attribute-name attribute-parameters@,+-- and serve as generic properties of some syntax tree elements.+--+-- Some examples:+--+-- * labels can be attributed with /unused/ to indicate that their not used+--+-- * struct definitions can be attributed with /packed/ to tell the compiler to use the most compact representation+--+-- * declarations can be attributed with /deprecated/+--+-- * function declarations can be attributes with /noreturn/ to tell the compiler that the function will never return,+--+-- * or with /const/ to indicate that it is a pure function+--+-- /TODO/: ultimatively, we want to parse attributes and represent them in a typed way+data Attr = Attr Ident [Expr] NodeInfo+            deriving (Typeable, Data {-! ,CNode !-})++type Attributes = [Attr]++-- |Empty attribute list+noAttributes :: Attributes+noAttributes = []++-- |Merge attribute lists+-- /TODO/: currently does not remove duplicates+mergeAttributes :: Attributes -> Attributes -> Attributes+mergeAttributes = (++)++-- * statements and expressions (Type aliases)++-- | 'Stmt' is an alias for 'CStat' (Syntax)+type Stmt = CStat+-- | 'Expr' is currently an alias for 'CExpr' (Syntax)+type Expr = CExpr+-- GENERATED START++ +instance CNode TagDef where+        nodeInfo (CompDef d) = nodeInfo d+        nodeInfo (EnumDef d) = nodeInfo d+ +instance Pos TagDef where+        posOf x = posOf (nodeInfo x)++ +instance CNode IdentDecl where+        nodeInfo (Declaration d) = nodeInfo d+        nodeInfo (ObjectDef d) = nodeInfo d+        nodeInfo (FunctionDef d) = nodeInfo d+        nodeInfo (EnumeratorDef d) = nodeInfo d+ +instance Pos IdentDecl where+        posOf x = posOf (nodeInfo x)++ +instance CNode DeclEvent where+        nodeInfo (TagEvent d) = nodeInfo d+        nodeInfo (DeclEvent d) = nodeInfo d+        nodeInfo (ParamEvent d) = nodeInfo d+        nodeInfo (LocalEvent d) = nodeInfo d+        nodeInfo (TypeDefEvent d) = nodeInfo d+        nodeInfo (AsmEvent d) = nodeInfo d+ +instance Pos DeclEvent where+        posOf x = posOf (nodeInfo x)++ +instance CNode Decl where+        nodeInfo (Decl _ n) = n+ +instance Pos Decl where+        posOf x = posOf (nodeInfo x)++ +instance CNode ObjDef where+        nodeInfo (ObjDef _ _ n) = n+ +instance Pos ObjDef where+        posOf x = posOf (nodeInfo x)++ +instance CNode FunDef where+        nodeInfo (FunDef _ _ n) = n+ +instance Pos FunDef where+        posOf x = posOf (nodeInfo x)++ +instance CNode ParamDecl where+        nodeInfo (ParamDecl _ n) = n+        nodeInfo (AbstractParamDecl _ n) = n+ +instance Pos ParamDecl where+        posOf x = posOf (nodeInfo x)++ +instance CNode MemberDecl where+        nodeInfo (MemberDecl _ _ n) = n+        nodeInfo (AnonBitField _ _ n) = n+ +instance Pos MemberDecl where+        posOf x = posOf (nodeInfo x)++ +instance CNode TypeDef where+        nodeInfo (TypeDef _ _ _ n) = n+ +instance Pos TypeDef where+        posOf x = posOf (nodeInfo x)++ +instance CNode TypeDefRef where+        nodeInfo (TypeDefRef _ _ n) = n+ +instance Pos TypeDefRef where+        posOf x = posOf (nodeInfo x)++ +instance CNode CompTypeRef where+        nodeInfo (CompTypeRef _ _ n) = n+ +instance Pos CompTypeRef where+        posOf x = posOf (nodeInfo x)++ +instance CNode EnumTypeRef where+        nodeInfo (EnumTypeRef _ n) = n+ +instance Pos EnumTypeRef where+        posOf x = posOf (nodeInfo x)++ +instance CNode CompType where+        nodeInfo (CompType _ _ _ _ n) = n+ +instance Pos CompType where+        posOf x = posOf (nodeInfo x)++ +instance CNode EnumType where+        nodeInfo (EnumType _ _ _ n) = n+ +instance Pos EnumType where+        posOf x = posOf (nodeInfo x)++ +instance CNode Enumerator where+        nodeInfo (Enumerator _ _ _ n) = n+ +instance Pos Enumerator where+        posOf x = posOf (nodeInfo x)++ +instance CNode Attr where+        nodeInfo (Attr _ _ n) = n+ +instance Pos Attr where+        posOf x = posOf (nodeInfo x)+-- GENERATED STOP
+ src/Language/ObjC/Analysis/TravMonad.hs view
@@ -0,0 +1,506 @@+{-# LANGUAGE MultiParamTypeClasses+            ,TypeSynonymInstances+            ,StandaloneDeriving+            ,FlexibleContexts+            ,DeriveFunctor+            ,FlexibleInstances+            ,PatternGuards+            ,RankNTypes+            ,ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Analysis.TravMonad+-- Copyright   :  (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  alpha+-- Portability :  ghc+--+-- Monad for Traversals of the C AST.+--+-- For the traversal, we maintain a symboltable and need MonadError and unique+-- name generation facilities.+-- Furthermore, the user may provide callbacks to handle declarations and definitions.+-----------------------------------------------------------------------------+module Language.ObjC.Analysis.TravMonad (+    -- * Name generation monad+    MonadName(..),+    -- * Symbol table monad+    MonadSymtab(..),+    -- * Specialized C error-handling monad+    MonadCError(..),+    -- * AST traversal monad+    MonadTrav(..),+    -- * Handling declarations+    handleTagDecl, handleTagDef, handleEnumeratorDef, handleTypeDef,+    handleObjectDef,handleFunDef,handleVarDecl,handleParamDecl,+    handleAsmBlock,+    -- * Symbol table scope modification+    enterPrototypeScope,leavePrototypeScope,+    enterFunctionScope,leaveFunctionScope,+    enterBlockScope,leaveBlockScope,+    -- * Symbol table lookup (delegate)+    lookupTypeDef, lookupObject,+    -- * Symbol table modification+    createSUERef,+    -- * Additional error handling facilities+    hadHardErrors,handleTravError,throwOnLeft,+    astError, warn,+    -- * Trav - default MonadTrav implementation+    Trav,+    runTrav,runTrav_,+    TravState,initTravState,withExtDeclHandler,modifyUserState,userState,+    getUserState,+    TravOptions(..),modifyOptions,+    travErrors,+    -- * Language options+    CLanguage(..),+    -- * Helpers+    mapMaybeM,maybeM,mapSndM,concatMapM,+)+where+import Language.ObjC.Data+import Language.ObjC.Data.RList as RList++import Language.ObjC.Analysis.Builtins+import Language.ObjC.Analysis.SemError+import Language.ObjC.Analysis.SemRep+import Language.ObjC.Analysis.DefTable hiding (enterBlockScope,leaveBlockScope,+                                            enterFunctionScope,leaveFunctionScope)+import qualified Language.ObjC.Analysis.DefTable as ST++import Data.IntMap (insert)+import Data.Maybe+import Control.Monad(liftM)+import Prelude hiding (lookup)++class (Monad m) => MonadName m where+    -- | unique name generation+    genName :: m Name++class (Monad m) => MonadSymtab m where+    -- symbol table handling+    -- | return the definition table+    getDefTable :: m DefTable+    -- | perform an action modifying the definition table+    withDefTable :: (DefTable -> (a, DefTable)) -> m a++class (Monad m) => MonadCError m where+    -- error handling facilities++    -- | throw an 'Error'+    throwTravError :: Error e => e -> m a+    -- | catch an 'Error' (we could implement dynamically-typed catch here)+    catchTravError :: m a -> (CError -> m a) -> m a+    -- | remember that an 'Error' occurred (without throwing it)+    recordError    :: Error e => e -> m ()+    -- | return the list of recorded errors+    getErrors      :: m [CError]++-- | Traversal monad+class (Functor m, MonadName m, MonadSymtab m, MonadCError m) => MonadTrav m where+    -- | handling declarations and definitions+    handleDecl :: DeclEvent -> m ()++-- * handling declarations++-- check wheter a redefinition is ok+checkRedef :: (MonadCError m, CNode t, CNode t1) => String -> t -> (DeclarationStatus t1) -> m ()+checkRedef subject new_decl redecl_status =+    case redecl_status of+        NewDecl -> return ()+        Redeclared old_def   -> throwTravError $+            redefinition LevelError subject DuplicateDef (nodeInfo new_decl) (nodeInfo old_def)+        KindMismatch old_def -> throwTravError $+            redefinition LevelError subject DiffKindRedecl (nodeInfo new_decl) (nodeInfo old_def)+        Shadowed _old_def     ->  return ()+            -- warn $+            -- redefinition LevelWarn subject ShadowedDef (nodeInfo new_decl) (nodeInfo old_def)+        KeepDef _old_def      -> return ()++-- | forward declaration of a tag. Only necessary for name analysis, but otherwise no semantic+-- consequences.+handleTagDecl :: (MonadCError m, MonadSymtab m) => TagFwdDecl -> m ()+handleTagDecl decl = do+    redecl <- withDefTable $ declareTag (sueRef decl) decl+    checkRedef (show $ sueRef decl) decl redecl++-- | define the given composite type or enumeration+-- If there is a declaration visible, overwrite it with the definition.+-- Otherwise, enter a new definition in the current namespace.+-- If there is already a definition present, yield an error (redeclaration).+handleTagDef :: (MonadTrav m) => TagDef -> m ()+handleTagDef def = do+    redecl <- withDefTable $ defineTag (sueRef def) def+    checkRedef (show $ sueRef def) def redecl+    handleDecl (TagEvent def)++handleEnumeratorDef :: (MonadCError m, MonadSymtab m) => Enumerator ->  m ()+handleEnumeratorDef enumerator = do+    let ident = declIdent enumerator+    redecl <- withDefTable $ defineScopedIdent ident (EnumeratorDef enumerator)+    checkRedef (show ident) ident redecl+    return ()++handleTypeDef :: (MonadTrav m) => TypeDef -> m ()+handleTypeDef typeDef@(TypeDef ident _ _ _) = do+    redecl <- withDefTable $ defineTypeDef ident typeDef+    checkRedef (show ident) typeDef redecl+    handleDecl (TypeDefEvent typeDef)+    return ()++handleAsmBlock :: (MonadTrav m) => AsmBlock -> m ()+handleAsmBlock asm = handleDecl (AsmEvent asm)++redefErr :: (MonadCError m, CNode old, CNode new) =>+            Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()+redefErr name lvl new old kind =+  throwTravError $ redefinition lvl (show name) kind (nodeInfo new) (nodeInfo old)++-- TODO: unused+checkIdentTyRedef :: (MonadCError m) => IdentEntry -> (DeclarationStatus IdentEntry) -> m ()+checkIdentTyRedef (Right decl) status = checkVarRedef decl status+checkIdentTyRedef (Left tydef) (KindMismatch old_def) =+  redefErr (identOfTypeDef tydef) LevelError tydef old_def DiffKindRedecl+checkIdentTyRedef (Left tydef) (Redeclared old_def) =+  redefErr (identOfTypeDef tydef) LevelError tydef old_def DuplicateDef+checkIdentTyRedef (Left _tydef) _ = return ()++-- Check whether it is ok to declare a variable already in scope+checkVarRedef :: (MonadCError m) => IdentDecl -> (DeclarationStatus IdentEntry) -> m ()+checkVarRedef odef redecl =+    case redecl of+        -- always an error+        KindMismatch old_def -> redefVarErr old_def DiffKindRedecl+        -- Declaration referencing definition:+        --   * new entry has to be a declaration+        --   * old entry and new entry have to have linkage and agree on linkage+        --   * types have to match+        KeepDef (Right old_def) | not (agreeOnLinkage odef old_def) -> linkageErr odef old_def+                                | otherwise -> throwOnLeft $ checkCompatibleTypes new_ty (declType old_def)+        -- redefinition:+        --   * old entry has to be a declaration or tentative definition+        --   * old entry and new entry have to have linkage and agree on linkage+        --   * types have to match+        Redeclared (Right old_def) | not (agreeOnLinkage odef old_def) -> linkageErr odef old_def+                                   | not(canBeOverwritten old_def) -> redefVarErr old_def DuplicateDef+                                   | otherwise -> throwOnLeft $ checkCompatibleTypes new_ty (declType old_def)+        -- NewDecl/Shadowed is ok+        _ -> return ()+    where+    redefVarErr old_def kind = redefErr (declIdent odef) LevelError odef old_def kind+    linkageErr def old_def =+        case (declLinkage def, declLinkage old_def) of+            (NoLinkage, _) -> redefErr (declIdent def) LevelError  def old_def NoLinkageOld+            _otherwise     -> redefErr (declIdent def) LevelError  def old_def DisagreeLinkage++    new_ty = declType odef+    canBeOverwritten (Declaration _) = True+    canBeOverwritten (ObjectDef od)  = isTentative od+    canBeOverwritten _               = False+    agreeOnLinkage def old_def+        | declStorage old_def == FunLinkage InternalLinkage = True+        | not (hasLinkage $ declStorage def) || not (hasLinkage $ declStorage old_def) = False+        | (declLinkage def) /= (declLinkage old_def) = False+        | otherwise = True++-- | handle variable declarations (external object declarations and function prototypes)+-- variable declarations are either function prototypes, or external declarations, and not very+-- interesting on their own. we only put them in the symbol table and call the handle.+-- declarations never override definitions+handleVarDecl :: (MonadTrav m) => Bool -> Decl -> m ()+handleVarDecl is_local decl = do+    def <- enterDecl decl (const False)+    handleDecl ((if is_local then LocalEvent else DeclEvent) def)++-- | handle parameter declaration. The interesting part is that parameters can be abstract+-- (if they are part of a type). If they have a name, we enter the name (usually in function prototype or function scope),+-- checking if there are duplicate definitions.+-- FIXME: I think it would be more transparent to handle parameter declarations in a special way+handleParamDecl :: (MonadTrav m) => ParamDecl -> m ()+handleParamDecl pd@(AbstractParamDecl _ _) = handleDecl (ParamEvent pd)+handleParamDecl pd@(ParamDecl vardecl node) = do+    let def = ObjectDef (ObjDef vardecl Nothing node)+    redecl <- withDefTable $ defineScopedIdent (declIdent def) def+    checkVarRedef def redecl+    handleDecl (ParamEvent pd)++-- shared impl+enterDecl :: (MonadCError m, MonadSymtab m) => Decl -> (IdentDecl -> Bool) -> m IdentDecl+enterDecl decl cond = do+    let def = Declaration decl+    redecl <- withDefTable $+              defineScopedIdentWhen cond (declIdent def) def+    checkVarRedef def redecl+    return def++-- | handle function definitions+handleFunDef :: (MonadTrav m) => Ident -> FunDef -> m ()+handleFunDef ident fun_def = do+    let def = FunctionDef fun_def+    redecl <- withDefTable $+              defineScopedIdentWhen isDeclaration ident def+    checkVarRedef def redecl+    handleDecl (DeclEvent def)++isDeclaration :: IdentDecl -> Bool+isDeclaration (Declaration _) = True+isDeclaration _ = False++checkCompatibleTypes :: Type -> Type -> Either TypeMismatch ()+checkCompatibleTypes _ _ = Right ()++-- | handle object defintions (maybe tentative)+handleObjectDef :: (MonadTrav m) => Bool -> Ident -> ObjDef -> m ()+handleObjectDef local ident obj_def = do+    let def = ObjectDef obj_def+    redecl <- withDefTable $+              defineScopedIdentWhen (\old -> shouldOverride def old) ident def+    checkVarRedef def redecl+    handleDecl ((if local then LocalEvent else DeclEvent) def)+    where+    isTentativeDef (ObjectDef object_def) = isTentative object_def+    isTentativeDef _ = False+    shouldOverride def old | isDeclaration old = True+                           | not (isTentativeDef def) = True+                           | isTentativeDef old = True+                           | otherwise = False++-- * scope manipulation+--+--  * file scope: outside of parameter lists and blocks (outermost)+--+--  * function prototype scope+--+--  * function scope: labels are visible within the entire function, and declared implicitely+--+--  * block scope+updDefTable :: (MonadSymtab m) => (DefTable -> DefTable) -> m ()+updDefTable f = withDefTable (\st -> ((),f st))++enterPrototypeScope :: (MonadSymtab m) => m ()+enterPrototypeScope = updDefTable (ST.enterBlockScope)++leavePrototypeScope :: (MonadSymtab m) => m ()+leavePrototypeScope = updDefTable (ST.leaveBlockScope)++enterFunctionScope :: (MonadSymtab m) => m ()+enterFunctionScope = updDefTable (ST.enterFunctionScope)++leaveFunctionScope :: (MonadSymtab m) => m ()+leaveFunctionScope = updDefTable (ST.leaveFunctionScope)++enterBlockScope :: (MonadSymtab m) => m ()+enterBlockScope = updDefTable (ST.enterBlockScope)++leaveBlockScope :: (MonadSymtab m) => m ()+leaveBlockScope = updDefTable (ST.leaveBlockScope)++-- * Lookup++-- | lookup a type definition+-- the 'wrong kind of object' is an internal error here,+-- because the parser should distinguish typeDefs and other+-- objects+lookupTypeDef :: (MonadCError m, MonadSymtab m) => Ident -> m Type+lookupTypeDef ident =+    getDefTable >>= \symt ->+    case lookupIdent ident symt of+        Nothing                             ->+          astError (nodeInfo ident) $ "unbound typeDef: " ++ identToString ident+        Just (Left (TypeDef def_ident ty _ _)) -> addRef ident def_ident >> return ty+        Just (Right d)                      -> astError (nodeInfo ident) (wrongKindErrMsg d)+    where+    wrongKindErrMsg d = "wrong kind of object: expected typedef but found "++ (objKindDescr d)+                        ++ " (for identifier `" ++ identToString ident ++ "')"+++-- | lookup an object, function or enumerator+lookupObject :: (MonadCError m, MonadSymtab m) => Ident -> m (Maybe IdentDecl)+lookupObject ident = do+    old_decl <- liftM (lookupIdent ident) getDefTable+    mapMaybeM old_decl $ \obj ->+        case obj of+        Right objdef -> addRef ident objdef >> return objdef+        Left _tydef  -> astError (nodeInfo ident) (mismatchErr "lookupObject" "an object" "a typeDef")++-- | add link between use and definition (private)+addRef :: (MonadCError m, MonadSymtab m, CNode u, CNode d) => u -> d -> m ()+addRef use def =+  case (nodeInfo use, nodeInfo def) of+    (NodeInfo _ _ useName, NodeInfo _ _ defName) ->+      withDefTable+      (\dt ->+         ((),+          dt { refTable = insert (nameId useName) defName (refTable dt) }+         )+      )+    (_, _) -> return () -- Don't have Names for both, so can't record.+++mismatchErr :: String -> String -> String -> String+mismatchErr ctx expect found = ctx ++ ": Expected " ++ expect ++ ", but found: " ++ found++-- * inserting declarations++-- | create a reference to a struct\/union\/enum+--+-- This currently depends on the fact the structs are tagged with unique names.+-- We could use the name generation of TravMonad as well, which might be the better+-- choice when dealing with autogenerated code.+createSUERef :: (MonadCError m, MonadSymtab m) => NodeInfo -> Maybe Ident -> m SUERef+createSUERef _node_info (Just ident) = return$ NamedRef ident+createSUERef node_info Nothing | (Just name) <- nameOfNode node_info = return $ AnonymousRef name+                               | otherwise = astError node_info "struct/union/enum definition without unique name"++-- * error handling facilities++handleTravError :: (MonadCError m) => m a -> m (Maybe a)+handleTravError a = liftM Just a `catchTravError` (\e -> recordError e >> return Nothing)++-- | check wheter non-recoverable errors occurred+hadHardErrors :: [CError] -> Bool+hadHardErrors = (not . null . filter isHardError)++-- | raise an error caused by a malformed AST+astError :: (MonadCError m) => NodeInfo -> String -> m a+astError node msg = throwTravError $ invalidAST node msg++-- | raise an error based on an Either argument+throwOnLeft :: (MonadCError m, Error e) => Either e a -> m a+throwOnLeft (Left err) = throwTravError err+throwOnLeft (Right v)  = return v++warn :: (Error e, MonadCError m) => e -> m ()+warn err = recordError (changeErrorLevel err LevelWarn)++-- * The Trav datatype++-- | simple traversal monad, providing user state and callbacks+newtype Trav s a = Trav { unTrav :: TravState s -> Either CError (a, TravState s) }+modify :: (TravState s -> TravState s) -> Trav s ()+modify f = Trav (\s -> Right ((),f s))+gets :: (TravState s -> a) -> Trav s a+gets f   = Trav (\s -> Right (f s, s))+get ::  Trav s (TravState s)+get      = Trav (\s -> Right (s,s))+put :: TravState s -> Trav s ()+put s    = Trav (\_ -> Right ((),s))++deriving instance Functor (Trav s)+++runTrav :: forall s a. s -> Trav s a -> Either [CError] (a, TravState s)+runTrav state traversal =+    case unTrav action (initTravState state) of+        Left trav_err                                 -> Left [trav_err]+        Right (v, ts) | hadHardErrors (travErrors ts) -> Left (travErrors ts)+                      | otherwise                     -> Right (v,ts)+    where+    action = do withDefTable (const ((), builtins))+                traversal++runTrav_ :: Trav () a -> Either [CError] (a,[CError])+runTrav_ t = fmap fst . runTrav () $+    do r <- t+       es <- getErrors+       return (r,es)++withExtDeclHandler :: Trav s a -> (DeclEvent -> Trav s ()) -> Trav s a+withExtDeclHandler action handler =+    do modify $ \st -> st { doHandleExtDecl = handler }+       action++instance Monad (Trav s) where+    return x  = Trav (\s -> Right (x,s))+    m >>= k   = Trav (\s -> case unTrav m s of+                              Right (x,s1) -> unTrav (k x) s1+                              Left e       -> Left e)++instance MonadName (Trav s) where+    -- unique name generation+    genName = generateName++instance MonadSymtab (Trav s) where+    -- symbol table handling+    getDefTable = gets symbolTable+    withDefTable f = do+        ts <- get+        let (r,symt') = f (symbolTable ts)+        put $ ts { symbolTable = symt' }+        return r++instance MonadCError (Trav s) where+    -- error handling facilities+    throwTravError e = Trav (\_ -> Left (toError e))+    catchTravError a handler = Trav (\s -> case unTrav a s of+                                             Left e  -> unTrav (handler e) s+                                             Right r -> Right r)+    recordError e = modify $ \st -> st { rerrors = (rerrors st) `snoc` toError e }+    getErrors = gets (RList.reverse . rerrors)++instance MonadTrav (Trav s) where+    -- handling declarations and definitions+    handleDecl d = ($ d) =<< gets doHandleExtDecl++-- | The variety of the C language to accept. Note: this is not yet enforced.+data CLanguage = C89 | C99 | GNU89 | GNU99++data TravOptions =+    TravOptions {+        language :: CLanguage+    }++data TravState s =+    TravState {+        symbolTable :: DefTable,+        rerrors :: RList CError,+        nameGenerator :: [Name],+        doHandleExtDecl :: (DeclEvent -> Trav s ()),+        userState :: s,+        options :: TravOptions+      }++travErrors :: TravState s -> [CError]+travErrors = RList.reverse . rerrors++initTravState :: s -> TravState s+initTravState userst =+    TravState {+        symbolTable = emptyDefTable,+        rerrors = RList.empty,+        nameGenerator = newNameSupply,+        doHandleExtDecl = const (return ()),+        userState = userst,+        options = TravOptions { language = C99 }+      }++-- * Trav specific operations+modifyUserState :: (s -> s) -> Trav s ()+modifyUserState f = modify $ \ts -> ts { userState = f (userState ts) }++getUserState :: Trav s s+getUserState = userState `liftM` get++modifyOptions :: (TravOptions -> TravOptions) -> Trav s ()+modifyOptions f = modify $ \ts -> ts { options = f (options ts) }++generateName :: Trav s Name+generateName =+    get >>= \ts ->+    do let (new_name : gen') = nameGenerator ts+       put $ ts { nameGenerator = gen'}+       return new_name++-- * helpers+mapMaybeM :: (Monad m) => (Maybe a) -> (a -> m b) -> m (Maybe b)+mapMaybeM m f = maybe (return Nothing) (liftM Just . f) m++maybeM :: (Monad m) => (Maybe a) -> (a -> m ()) -> m ()+maybeM m f = maybe (return ()) f m++mapSndM :: (Monad m) => (b -> m c) -> (a,b) -> m (a,c)+mapSndM f (a,b) = liftM ((,) a) (f b)++concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]+concatMapM f = liftM concat . mapM f
+ src/Language/ObjC/Analysis/TypeCheck.hs view
@@ -0,0 +1,453 @@+{-# LANGUAGE FlexibleInstances, CPP #-}+module Language.ObjC.Analysis.TypeCheck where++import Control.Monad+import Data.Either+import Data.Maybe+import Language.ObjC.Data.Ident+import Language.ObjC.Data.Node+import Language.ObjC.Data.Position+import Language.ObjC.Pretty+import Language.ObjC.Syntax.AST+import Language.ObjC.Syntax.Constants+import Language.ObjC.Syntax.Ops+import Language.ObjC.Analysis.Debug+import Language.ObjC.Analysis.DefTable+import Language.ObjC.Analysis.SemRep+import Language.ObjC.Analysis.TravMonad+import Language.ObjC.Analysis.TypeConversions+import Language.ObjC.Analysis.TypeUtils+import Text.PrettyPrint.HughesPJ++-- We used to re-implement and export the standard Either instance for+-- Monad, which is bad, because as of GHC 7 it is in Control.Monad.Instances+-- in base >4.2. For backwards compatibility with ghc-6.X, we use CPP here.+#if __GLASGOW_HASKELL__ < 700+instance Monad (Either String) where+    return        = Right+    Left  l >>= _ = Left l+    Right r >>= k = k r+    fail msg      = Left msg+#endif++pType :: Type -> String+pType = render . pretty++typeErrorOnLeft :: (MonadCError m) => NodeInfo -> Either String a -> m a+typeErrorOnLeft ni (Left err) = typeError ni err+typeErrorOnLeft _  (Right v)  = return v++-- XXX: this should use a custom error type, but typeMismatch isn't always right+typeError :: MonadCError m => NodeInfo -> String -> m a+typeError = astError++notFound :: Ident -> Either String a+notFound i = fail $ "not found: " ++ identToString i++checkScalar' :: MonadCError m => NodeInfo -> Type -> m ()+checkScalar' ni = typeErrorOnLeft ni . checkScalar++checkIntegral' :: MonadCError m => NodeInfo -> Type -> m ()+checkIntegral' ni = typeErrorOnLeft ni . checkIntegral++assignCompatible' :: MonadCError m =>+                     NodeInfo -> CAssignOp -> Type -> Type -> m ()+assignCompatible' ni op t1 t2 = typeErrorOnLeft ni (assignCompatible op t1 t2)++binopType' :: MonadCError m =>+              NodeInfo -> CBinaryOp -> Type -> Type -> m Type+binopType' ni op t1 t2 = typeErrorOnLeft ni (binopType op t1 t2)++conditionalType' :: MonadCError m => NodeInfo -> Type -> Type -> m Type+conditionalType' ni t1 t2 = typeErrorOnLeft ni $ conditionalType t1 t2++checkScalar :: Type -> Either String ()+checkScalar t =+  case canonicalType t of+    DirectType _ _ _  -> return ()+    PtrType _ _ _     -> return ()+    ArrayType _ _ _ _ -> return () -- because it's just a pointer+    t' -> fail $+          "expected scalar type, got: "+          ++ pType t ++ " (" ++ pType t' ++ ")"++checkIntegral :: Type -> Either String ()+checkIntegral t | isIntegralType (canonicalType t) = return ()+                | otherwise = fail $+                              "expected integral type, got: " +++                              pType t ++ " (" +++                              pType (canonicalType t) ++ ")"++-- | Determine the type of a constant.+constType :: (MonadCError m, MonadName m) => CConst -> m Type+constType (CIntConst (CInteger _ _ flags) _) =+  return $ DirectType (TyIntegral (getIntType flags)) noTypeQuals noAttributes+constType (CCharConst (CChar _ True) _) =+  return $ DirectType (TyIntegral TyInt) noTypeQuals noAttributes+constType (CCharConst (CChar _ False) _) =+  return $ DirectType (TyIntegral TyChar) noTypeQuals noAttributes+constType (CCharConst (CChars _ _) _)  =+  return $ DirectType (TyIntegral TyInt) noTypeQuals noAttributes -- XXX+constType (CFloatConst (CFloat fs) _) =+  return $ DirectType (TyFloating (getFloatType fs)) noTypeQuals noAttributes+-- XXX: should strings have any type qualifiers or attributes?+constType (CStrConst (CString chars wide) ni) =+  do n <- genName+     let charType | wide      = TyInt -- XXX: this isn't universal+                  | otherwise = TyChar+         ni' = mkNodeInfo (posOf ni) n+         arraySize = ArraySize+                     True -- XXX: is it static?+                     (CConst+                      (CIntConst+                       (cInteger (toInteger (length chars))) ni'))+     return $ ArrayType (DirectType (TyIntegral charType) noTypeQuals noAttributes)+                        arraySize noTypeQuals []++-- | Determine whether two types are compatible.+compatible :: Type -> Type -> Either String ()+compatible t1 t2 = compositeType t1 t2 >> return ()++-- | Determine the composite type of two compatible types.+compositeType :: Type -> Type -> Either String Type+compositeType t1 (DirectType (TyBuiltin TyAny) _ _) = return t1+compositeType (DirectType (TyBuiltin TyAny) _ _) t2 = return t2+compositeType t1@(DirectType tn1 q1 a1) t2@(DirectType tn2 q2 a2) =+  do tn <- case (tn1, tn2) of+             (TyVoid, TyVoid) -> return TyVoid+             (TyIntegral _, TyEnum _) -> return tn1+             (TyEnum _, TyIntegral _) -> return tn2+             (TyIntegral i1, TyIntegral i2) ->+               return $ TyIntegral (intConversion i1 i2)+             (TyFloating f1, TyFloating f2) ->+               return $ TyFloating (floatConversion f1 f2)+             (TyComplex f1, TyComplex f2) ->+               return $ TyComplex (floatConversion f1 f2)+             (TyComp c1, TyComp c2) ->+               do when (sueRef c1 /= sueRef c2) $+                       fail $ "incompatible composite types: "+                              ++ pType t1 ++ ", " ++ pType t2+                  return tn1+             (TyEnum e1, TyEnum e2) ->+               do when (sueRef e1 /= sueRef e2) $+                       fail $ "incompatible enumeration types: "+                              ++ pType t1 ++ ", " ++ pType t2+                  return $ TyEnum e1+             (TyBuiltin TyVaList, TyBuiltin TyVaList) ->+               return $ TyBuiltin TyVaList+             (TyBuiltin _, TyBuiltin _) ->+               fail $ "incompatible builtin types: "+                      ++ pType t1 ++ ", " ++ pType t2+             (_, _) -> fail $ "incompatible direct types: "+                       ++ pType t1 ++ ", " ++ pType t2+     return $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2)+compositeType (PtrType t1 q1 a1) (PtrType (DirectType TyVoid _ _) q2 _) =+  return $ PtrType t1 (mergeTypeQuals q1 q2) a1+compositeType (PtrType (DirectType TyVoid _ _) q1 _) (PtrType t2 q2 a2) =+  return $ PtrType t2 (mergeTypeQuals q1 q2) a2+compositeType (PtrType t1 q1 a1) t2 | isIntegralType t2 =+  return $ PtrType t1 (mergeTypeQuals q1 (typeQuals t2)) a1+compositeType t1 (PtrType t2 q2 a2) | isIntegralType t1 =+  return $ PtrType t2 (mergeTypeQuals (typeQuals t1) q2) a2+compositeType (ArrayType t1 sz1 q1 a1) t2 | isIntegralType t2 =+  return $ PtrType t1 q1 a1+compositeType t1 (ArrayType t2 sz2 q2 a2) | isIntegralType t1 =+  return $ PtrType t2 q2 a2+compositeType (ArrayType t1 s1 q1 a1) (ArrayType t2 s2 q2 a2) =+  do t <- compositeType t1 t2+     s <- compositeSize s1 s2+     let quals = mergeTypeQuals q1 q2+         attrs = mergeAttrs a1 a2+     return (ArrayType t s quals attrs)+compositeType t1 t2 | isPointerType t1 && isPointerType t2 =+  do t <- compositeType (baseType t1) (baseType t2)+     let quals = mergeTypeQuals (typeQuals t1) (typeQuals t2)+         attrs = mergeAttrs (typeAttrs t1) (typeAttrs t2)+     return (PtrType t quals attrs)+compositeType (TypeDefType tdr1 q1 a1) (TypeDefType tdr2 q2 a2) =+  case (tdr1, tdr2) of+    (TypeDefRef i1 Nothing _, TypeDefRef i2 _ _) -> doTypeDef i1 i2 tdr1+    (TypeDefRef i1 _ _, TypeDefRef i2 Nothing _) -> doTypeDef i1 i2 tdr2+    (TypeDefRef _ (Just t1) _, TypeDefRef _ (Just t2) _) ->+      compositeType t1 t2+  where doTypeDef i1 i2 tdr =+          do when (i1 /= i2) $ fail $ "incompatible typedef types: "+                               ++ identToString i1 ++ ", " ++ identToString i2+             return (TypeDefType tdr (mergeTypeQuals q1 q2) (mergeAttributes a1 a2))+compositeType (FunctionType ft1 attrs1) (FunctionType ft2 attrs2) =+  case (ft1, ft2) of+    (FunType rt1 args1 varargs1, FunType rt2 args2 varargs2) ->+      do {- when (length args1 /= length args2) $+              fail "different numbers of arguments in function types" -}+         args <- mapM (uncurry compositeParamDecl) (zip args1 args2)+         when (varargs1 /= varargs2) $+              fail "incompatible varargs declarations"+         doFunType rt1 rt2 args varargs1+    (FunType rt1 args1 varargs1, FunTypeIncomplete rt2) ->+      doFunType rt1 rt2 args1 varargs1+    (FunTypeIncomplete rt1, FunType rt2 args2 varargs2) ->+      doFunType rt1 rt2 args2 varargs2+    (FunTypeIncomplete rt1, FunTypeIncomplete rt2) ->+      do rt <- compositeType rt1 rt2+         return (FunctionType (FunTypeIncomplete rt) (mergeAttrs attrs1 attrs2))+  where doFunType rt1 rt2 args varargs =+          do rt <- compositeType rt1 rt2+             return (FunctionType+                     (FunType rt args varargs)+                     (mergeAttrs attrs1 attrs2))+compositeType t1 t2 = fail $ "incompatible types: "+                         ++ pType t1 ++ ", " ++ pType t2++-- XXX: this may not be correct+compositeSize :: ArraySize -> ArraySize -> Either String ArraySize+compositeSize (UnknownArraySize _) s2 = return s2+compositeSize s1 (UnknownArraySize _) = return s1+compositeSize (ArraySize s1 e1) (ArraySize s2 e2)+  | s1 == s2 && sizeEqual e1 e2 = return $ ArraySize s1 e1+  | otherwise = return $ ArraySize s1 e1+{-+    fail $ "incompatible array sizes: "+           ++ (render . pretty) e1 ++ ", " ++ (render . pretty) e2+-}++sizeEqual :: CExpr -> CExpr -> Bool+sizeEqual (CConst (CIntConst i1 _)) (CConst (CIntConst i2 _)) = i1 == i2+sizeEqual e1 e2 = nodeInfo e1 == nodeInfo e2++mergeAttrs :: Attributes -> Attributes -> Attributes+mergeAttrs = (++) -- XXX: ultimately this should be smarter++compositeParamDecl :: ParamDecl -> ParamDecl -> Either String ParamDecl+compositeParamDecl (ParamDecl vd1 ni1) (ParamDecl vd2 _) =+  compositeParamDecl' ParamDecl vd1 vd2 ni1+compositeParamDecl (AbstractParamDecl vd1 _) (ParamDecl vd2 ni2) =+  compositeParamDecl' ParamDecl vd1 vd2 ni2+compositeParamDecl (ParamDecl vd1 ni1) (AbstractParamDecl vd2 _) =+  compositeParamDecl' ParamDecl vd1 vd2 ni1+compositeParamDecl (AbstractParamDecl vd1 ni1) (AbstractParamDecl vd2 _) =+  compositeParamDecl' AbstractParamDecl vd1 vd2 ni1++compositeParamDecl' :: (VarDecl -> NodeInfo -> ParamDecl)+                    -> VarDecl+                    -> VarDecl+                    -> NodeInfo+                    -> Either String ParamDecl+compositeParamDecl' f (VarDecl n1 attrs1 t1) (VarDecl n2 attrs2 t2) dni =+  do vd <- compositeVarDecl (VarDecl n1 attrs1 t1') (VarDecl n2 attrs2 t2')+     return $ f vd dni+  where t1' = canonicalType t1+        t2' = canonicalType t2++compositeVarDecl :: VarDecl -> VarDecl -> Either String VarDecl+compositeVarDecl (VarDecl n1 attrs1 t1) (VarDecl _ attrs2 t2) =+  do t <- compositeType t1 t2+     return (VarDecl n1 (compositeDeclAttrs attrs1 attrs2) t)++-- XXX: bad treatement of inline and storage+compositeDeclAttrs :: DeclAttrs -> DeclAttrs -> DeclAttrs+compositeDeclAttrs (DeclAttrs inl stor attrs1) (DeclAttrs _ _ attrs2) =+  DeclAttrs inl stor (mergeAttrs attrs1 attrs2)++castCompatible :: Type -> Type -> Either String ()+castCompatible t1 t2 =+  case (canonicalType t1, canonicalType t2) of+    (DirectType TyVoid _ _, _) -> return ()+    (_, _) -> checkScalar t1 >> checkScalar t2++-- | Determine whether two types are compatible in an assignment expression.+assignCompatible :: CAssignOp -> Type -> Type -> Either String ()+assignCompatible CAssignOp t1 t2 =+  case (canonicalType t1, canonicalType t2) of+    (DirectType (TyBuiltin TyAny) _ _, _) -> return ()+    (_, DirectType (TyBuiltin TyAny) _ _) -> return ()+    -- XXX: check qualifiers+    (PtrType (DirectType TyVoid _ _) _ _, t2') | isPointerType t2' -> return ()+    -- XXX: check qualifiers+    (t1', PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> return ()+    (PtrType _ _ _, t2') | isIntegralType t2' -> return ()+    (t1', t2') | isPointerType t1' && isPointerType t2' ->+                 do compatible (baseType t1') (baseType t2')+                --unless (typeQuals t2 <= typeQuals t1) $+                --       fail $+                --       "incompatible qualifiers in pointer assignment: "+                --       ++ pType t1 ++ ", " ++ pType t2+    (DirectType (TyComp c1) _ _, DirectType (TyComp c2) _ _)+      | sueRef c1 == sueRef c2 -> return ()+      | otherwise -> fail $+                     "incompatible compound types in assignment: "+                     ++ pType t1 ++ ", " ++ pType t2+    (DirectType (TyBuiltin TyVaList) _ _, DirectType (TyBuiltin TyVaList) _ _) ->+      return ()+    (DirectType tn1 _ _, DirectType tn2 _ _)+      | isJust (arithmeticConversion tn1 tn2) -> return ()+      | otherwise -> fail $ "incompatible direct types in assignment: "+                     ++ pType t1 ++ ", " ++ pType t2+    (t1', t2') -> compatible t1' t2'+assignCompatible op t1 t2 = binopType (assignBinop op) t1 t2 >> return ()++-- | Determine the type of a binary operation.+binopType :: CBinaryOp -> Type -> Type -> Either String Type+binopType op t1 t2 =+  case (op, canonicalType t1, canonicalType t2) of+    (_, t1', t2')+      | isLogicOp op ->+        checkScalar t1' >> checkScalar t2' >> return boolType+      | isCmpOp op ->+        case (t1', t2') of+          (DirectType tn1 _ _, DirectType tn2 _ _) ->+                case arithmeticConversion tn1 tn2 of+                  Just _ -> return boolType+                  Nothing -> fail+                             "incompatible arithmetic types in comparison"+          (PtrType (DirectType TyVoid _ _) _ _, _)+            | isPointerType t2' -> return boolType+          (_, PtrType (DirectType TyVoid _ _) _ _)+            | isPointerType t1' -> return boolType+          (_, _)+            | isPointerType t1' && isIntegralType t2' -> return boolType+            | isIntegralType t1' && isPointerType t2' -> return boolType+            | isPointerType t1' && isPointerType t2' ->+              compatible t1' t2' >> return boolType+          (_, _) -> fail "incompatible types in comparison"+    (CSubOp, ArrayType t1' _ _ _, ArrayType t2' _ _ _) ->+      compatible t1' t2' >> return ptrDiffType+    (CSubOp, ArrayType t1' _ _ _, PtrType t2' _ _) ->+      compatible t1' t2' >> return ptrDiffType+    (CSubOp, PtrType t1' _ _, ArrayType t2' _ _ _) ->+      compatible t1' t2' >> return ptrDiffType+    (CSubOp, PtrType t1' _ _, PtrType t2' _ _) ->+      compatible t1' t2' >> return ptrDiffType+    (_, PtrType _ _ _, t2')+      | isPtrOp op && isIntegralType t2' -> return t1+      | otherwise -> fail $ "invalid pointer operation: " ++ render (pretty op)+    (CAddOp, t1', PtrType _ _ _) | isIntegralType t1' -> return t2+    (_, ArrayType _ _ _ _, t2')+      | isPtrOp op && isIntegralType t2' -> return t1+      | otherwise -> fail $ "invalid pointer operation: " ++ render (pretty op)+    (CAddOp, t1', ArrayType _ _ _ _) | isIntegralType t1' -> return t2+    (_, DirectType tn1 q1 a1, DirectType tn2 q2 a2) ->+        do when (isBitOp op) (checkIntegral t1 >> checkIntegral t2)+           case arithmeticConversion tn1 tn2 of+             Just tn -> return $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2)+             Nothing -> fail $ render $+                        text "invalid binary operation:" <+> pretty t1 <+> pretty op <+> pretty t2+    (_, _, _) -> fail $ render $+                 text "unhandled binary operation:" <+> pretty t1 <+> pretty op <+> pretty t2++-- | Determine the type of a conditional expression.+conditionalType :: Type -> Type -> Either String Type+conditionalType t1 t2 =+  case (canonicalType t1, canonicalType t2) of+    (PtrType (DirectType TyVoid _ _) _ _, t2') | isPointerType t2' -> return t2+    (t1', PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> return t1+    (ArrayType t1' _ q1 a1, ArrayType t2' _ q2 a2) ->+      do t <- compositeType t1' t2'+         return $ ArrayType t (UnknownArraySize False)+                  (mergeTypeQuals q1 q2) (mergeAttrs a1 a2)+    (t1'@(DirectType tn1 q1 a1), t2'@(DirectType tn2 q2 a2)) ->+      case arithmeticConversion tn1 tn2 of+        Just tn -> return $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2)+        Nothing -> compositeType t1' t2'+    (t1', t2') -> compositeType t1' t2'++derefType :: Type -> Either String Type+derefType (PtrType t _ _) = return t+derefType (ArrayType t _ _ _) = return t+derefType t =+  -- XXX: is it good to use canonicalType here?+  case canonicalType t of+    PtrType t' _ _ -> return t'+    ArrayType t' _ _ _ -> return t'+    _ -> fail $ "dereferencing non-pointer: " ++ pType t++varAddrType :: IdentDecl -> Either String Type+varAddrType d =+  do case declStorage d of+       Auto True -> fail "address of register variable"+       _         -> return ()+     case t of+       ArrayType _ _ q a -> return $ PtrType t q a+       _                 -> return $ simplePtr t+  where t = declType d++-- | Get the type of field @m@ of type @t@+fieldType :: (MonadCError m, MonadSymtab m) => NodeInfo -> Ident -> Type -> m Type+fieldType ni m t =+  case canonicalType t of+    DirectType (TyComp ctr) _ _ ->+      do td <- lookupSUE ni (sueRef ctr)+         ms <- tagMembers ni td+         case lookup m ms of+           Just ft -> return ft+           Nothing -> typeError ni $ "field not found: " ++ identToString m+    _t' -> astError ni $+          "field of non-composite type: " ++ identToString m+          ++ ", " ++ pType t++-- | Get all members of a struct, union, or enum, with their+--   types. Collapse fields of anonymous members.+tagMembers :: (MonadCError m, MonadSymtab m) =>+              NodeInfo -> TagDef -> m [(Ident, Type)]+tagMembers ni td =+  case td of+    CompDef (CompType _ _ ms _ _) -> getMembers ms+    EnumDef (EnumType _ es _ _) -> getMembers es+  where getMembers ds =+          do let ts = map declType ds+                 ns = map declName ds+             concat `liftM` mapM (expandAnonymous ni) (zip ns ts)++-- | Expand an anonymous composite type into a list of member names+--   and their associated types.+expandAnonymous :: (MonadCError m, MonadSymtab m) =>+                   NodeInfo -> (VarName, Type)+                -> m [(Ident, Type)]+expandAnonymous ni (NoName, DirectType (TyComp ctr) _ _) =+  lookupSUE ni (sueRef ctr) >>= tagMembers ni+expandAnonymous _ (NoName, _) = return []+expandAnonymous _ (VarName n _, t) = return [(n, t)]++lookupSUE :: (MonadCError m, MonadSymtab m) =>+             NodeInfo -> SUERef -> m TagDef+lookupSUE ni sue =+  do dt <- getDefTable+     case lookupTag sue dt of+       Just (Right td) -> return td+       _               ->+         typeError ni $ "unknown composite type: " ++ (render . pretty) sue++deepTypeAttrs :: (MonadCError m, MonadSymtab m) =>+                 Type -> m Attributes+deepTypeAttrs (DirectType (TyComp (CompTypeRef sue _ ni)) _ attrs) =+  (attrs ++) `liftM` sueAttrs ni sue+deepTypeAttrs (DirectType (TyEnum (EnumTypeRef sue ni)) _ attrs) =+  (attrs ++) `liftM` sueAttrs ni sue+deepTypeAttrs (DirectType _ _ attrs) = return attrs+deepTypeAttrs (PtrType   t _ attrs) = (attrs ++) `liftM` deepTypeAttrs t+deepTypeAttrs (BlockType t _ attrs) = (attrs ++) `liftM` deepTypeAttrs t+deepTypeAttrs (ArrayType t _ _ attrs) = (attrs ++) `liftM` deepTypeAttrs t+deepTypeAttrs (FunctionType (FunType t _ _) attrs) =+  (attrs ++) `liftM` deepTypeAttrs t+deepTypeAttrs (FunctionType (FunTypeIncomplete t)  attrs) =+  (attrs ++) `liftM` deepTypeAttrs t+deepTypeAttrs (TypeDefType (TypeDefRef i _ ni) _ attrs) =+  (attrs ++) `liftM` typeDefAttrs ni i++typeDefAttrs :: (MonadCError m, MonadSymtab m) =>+                NodeInfo -> Ident -> m Attributes+typeDefAttrs ni i =+  do dt <- getDefTable+     case lookupIdent i dt of+       Nothing -> astError ni $ "can't find typedef name: " ++ identToString i+       Just (Left (TypeDef _ t attrs _)) -> (attrs ++) `liftM` deepTypeAttrs t+       Just (Right _) -> astError ni $ "not a typedef name: " ++ identToString i++sueAttrs :: (MonadCError m, MonadSymtab m) =>+            NodeInfo -> SUERef -> m Attributes+sueAttrs ni sue =+  do dt <- getDefTable+     case lookupTag sue dt of+       Nothing -> astError ni $ "SUE not found: " ++ render (pretty sue)+       Just (Left _) -> return []+       Just (Right (CompDef (CompType _ _ _ attrs _))) -> return attrs+       Just (Right (EnumDef (EnumType _ _ attrs _))) -> return attrs
+ src/Language/ObjC/Analysis/TypeConversions.hs view
@@ -0,0 +1,39 @@+module Language.ObjC.Analysis.TypeConversions (+    arithmeticConversion,+    floatConversion,+    intConversion+) where++import Language.ObjC.Analysis.SemRep++-- | For an arithmetic operator, if the arguments are of the given+--   types, return the type of the full expression.+arithmeticConversion :: TypeName -> TypeName -> Maybe TypeName+-- XXX: I'm assuming that double `op` complex float = complex+-- double. The standard seems somewhat unclear on whether this is+-- really the case.+arithmeticConversion (TyComplex t1) (TyComplex t2) =+  Just $ TyComplex $ floatConversion t1 t2+arithmeticConversion (TyComplex t1) (TyFloating t2) =+  Just $ TyComplex $ floatConversion t1 t2+arithmeticConversion (TyFloating t1) (TyComplex t2) =+  Just $ TyComplex $ floatConversion t1 t2+arithmeticConversion t1@(TyComplex _) (TyIntegral _) = Just t1+arithmeticConversion (TyIntegral _) t2@(TyComplex _) = Just t2+arithmeticConversion (TyFloating t1) (TyFloating t2) =+  Just $ TyFloating $ floatConversion t1 t2+arithmeticConversion t1@(TyFloating _) (TyIntegral _) = Just t1+arithmeticConversion (TyIntegral _) t2@(TyFloating _) = Just t2+arithmeticConversion (TyIntegral t1) (TyIntegral t2) =+  Just $ TyIntegral $ intConversion t1 t2+arithmeticConversion (TyEnum _) (TyEnum _) = Just $ TyIntegral TyInt+arithmeticConversion (TyEnum _) t2 = Just $ t2+arithmeticConversion t1 (TyEnum _) = Just $ t1+arithmeticConversion _ _ = Nothing++floatConversion :: FloatType -> FloatType -> FloatType+floatConversion = max++intConversion :: IntType -> IntType -> IntType+intConversion t1 t2 = max TyInt (max t1 t2)+
+ src/Language/ObjC/Analysis/TypeUtils.hs view
@@ -0,0 +1,234 @@+module Language.ObjC.Analysis.TypeUtils (+    -- * Constructors+    integral,+    floating,+    simplePtr,+    size_tType,+    ptrDiffType,+    boolType,+    voidType,+    voidPtr,+    constVoidPtr,+    charPtr,+    constCharPtr,+    stringType,+    valistType,+    -- * Classifiers+    isIntegralType,+    isFloatingType,+    isPointerType,+    isScalarType,+    isFunctionType,+    -- Extractors+    typeQuals,+    typeQualsUpd,+    typeAttrs,+    typeAttrsUpd,+    baseType,+    derefTypeDef,+    deepDerefTypeDef,+    canonicalType,+    -- * Other utilities+    getIntType,+    getFloatType+) where++import Language.ObjC.Analysis.SemRep+import Language.ObjC.Syntax.Constants+++-- | Constructor for a simple integral type.+integral :: IntType -> Type+integral ty = DirectType (TyIntegral ty) noTypeQuals noAttributes++-- | Constructor for a simple floating-point type.+floating :: FloatType -> Type+floating ty = DirectType (TyFloating ty) noTypeQuals noAttributes++-- | A simple pointer with no qualifiers+simplePtr :: Type -> Type+simplePtr t = PtrType t noTypeQuals []++-- | A pointer with the @const@ qualifier.+constPtr :: Type -> Type+constPtr t = PtrType t (TypeQuals True False False noProtoQuals) []++-- | The type returned by sizeof (size_t). For now, this is just @int@.+size_tType :: Type+size_tType = integral TyInt++-- | The type of pointer differences (ptrdiff_t). For now, this is just @int@.+ptrDiffType :: Type+ptrDiffType = integral TyInt++-- | The type of comparisons\/guards. This is always just @int@.+boolType :: Type+boolType = integral TyInt++-- | Simple @void@ type.+voidType :: Type+voidType = DirectType TyVoid noTypeQuals noAttributes++-- | An unqualified @void@ pointer.+voidPtr :: Type+voidPtr = simplePtr voidType++-- | A @const@-qualified @void@ pointer.+constVoidPtr :: Type+constVoidPtr = constPtr voidType++-- | An unqualified @char@ pointer.+charPtr :: Type+charPtr = simplePtr (integral TyChar)++-- | A @const@-qualified @char@ pointer.+constCharPtr :: Type+constCharPtr = constPtr (integral TyChar)++-- | The type of a constant string.+stringType :: Type+stringType  = ArrayType+              (DirectType (TyIntegral TyChar) (TypeQuals True False False noProtoQuals) noAttributes)+              (UnknownArraySize False)+              noTypeQuals+              []++-- | The builtin type of variable-length argument lists.+valistType :: Type+valistType  = DirectType (TyBuiltin TyVaList) noTypeQuals noAttributes++-- | Check whether a type is an integral type. This includes @enum@+--   types. This function does not attempt to resolve @typedef@ types.+isIntegralType :: Type -> Bool+isIntegralType (DirectType (TyIntegral _) _ _) = True+isIntegralType (DirectType (TyEnum _) _ _)     = True+isIntegralType _                             = False++-- | Check whether a type is a floating-point numeric type. This+--   function does not attempt to resolve @typedef@ types.+isFloatingType :: Type -> Bool+isFloatingType (DirectType (TyFloating _) _ _) = True+isFloatingType _                             = False++-- | Check whether a type is an pointer type. This includes array+--   types. This function does not attempt to resolve @typedef@ types.+isPointerType :: Type -> Bool+isPointerType (PtrType _ _ _) = True+isPointerType (ArrayType _ _ _ _) = True+isPointerType _ = False++-- | Check whether a type is a scalar type. Scalar types include+--   arithmetic types and pointer types.+isScalarType :: Type -> Bool+isScalarType t = isIntegralType t || isPointerType t || isFloatingType t++-- | return @True@ if the given type is a function type+--+--   Result is undefined in the presence of undefined typeDefs+isFunctionType :: Type -> Bool+isFunctionType ty =+    case ty of  TypeDefType (TypeDefRef _ (Just actual_ty) _) _ _ -> isFunctionType actual_ty+                TypeDefType _ _ _ -> error "isFunctionType: unresolved typeDef"+                FunctionType _ _ -> True+                _ -> False++-- | Return the qualifiers of a type.+typeQuals :: Type -> TypeQuals+typeQuals (DirectType _ q _) = q+typeQuals (PtrType _ q _) = q+typeQuals (BlockType _ q _) = q+typeQuals (ArrayType _ _ q _) = q+typeQuals (FunctionType _ _) = noTypeQuals+typeQuals (TypeDefType (TypeDefRef _ Nothing _)  q _) = q+typeQuals (TypeDefType (TypeDefRef _ (Just t) _) q _) = mergeTypeQuals q (typeQuals t)++--  |Update type qualifiers+--   For function types, it is an error to change any type qualifiers+--   For typedef types, the result is stored in the typedef attribute field+typeQualsUpd :: (TypeQuals -> TypeQuals) -> Type -> Type+typeQualsUpd f ty =+    case ty of DirectType ty_name ty_quals ty_attrs -> DirectType ty_name (f ty_quals) ty_attrs+               PtrType ty_inner ty_quals ty_attrs         -> PtrType ty_inner (f ty_quals) ty_attrs+               BlockType ty_inner ty_quals ty_attrs       -> PtrType ty_inner (f ty_quals) ty_attrs+               ArrayType ty_inner sz ty_quals ty_attrs    -> ArrayType ty_inner sz (f ty_quals) ty_attrs+               FunctionType ty_inner ty_attrs             -> FunctionType ty_inner ty_attrs+               TypeDefType ty_ref ty_quals ty_attrs -> TypeDefType ty_ref (f ty_quals) ty_attrs++-- | Return the attributes of a type.+typeAttrs :: Type -> Attributes+typeAttrs (DirectType _ _ a) = a+typeAttrs (PtrType _ _ a) = a+typeAttrs (BlockType _ _ a) = a+typeAttrs (ArrayType _ _ _ a) = a+typeAttrs (FunctionType _ a) = a+typeAttrs (TypeDefType (TypeDefRef _ Nothing _) _ a) = a+typeAttrs (TypeDefType (TypeDefRef _ (Just t) _) _ a) = mergeAttributes a (typeAttrs t)++--  |Update type attributes+typeAttrsUpd :: (Attributes -> Attributes) -> Type -> Type+typeAttrsUpd f ty =+    case ty of DirectType ty_name ty_quals ty_attrs -> DirectType ty_name ty_quals (f ty_attrs)+               PtrType ty_inner ty_quals ty_attrs         -> PtrType ty_inner ty_quals (f ty_attrs)+               BlockType ty_inner ty_quals ty_attrs       -> BlockType ty_inner ty_quals (f ty_attrs)+               ArrayType ty_inner sz ty_quals ty_attrs    -> ArrayType ty_inner sz ty_quals (f ty_attrs)+               FunctionType ty_inner ty_attrs             -> FunctionType ty_inner (f ty_attrs)+               TypeDefType ty_ref ty_quals ty_attrs -> TypeDefType ty_ref ty_quals (f ty_attrs)++-- | Return the base type of a pointer or array type. It is an error+--   to call this function with a type that is not in one of those two+--   categories.+baseType :: Type -> Type+baseType (PtrType t _ _) = t+baseType (ArrayType t _ _ _) = t+baseType _ = error "base of non-pointer type"++-- | resolve typedefs, if possible+derefTypeDef :: Type -> Type+derefTypeDef (TypeDefType (TypeDefRef _ (Just t) _) q a) =+  (typeAttrsUpd (mergeAttributes a) . typeQualsUpd (mergeTypeQuals q))+  (derefTypeDef t)+derefTypeDef ty = ty++-- | Attempt to remove all references to @typedef@ types from a given type.+--   Note that this does not dereference the types of structure or union+--   fields, so there are still cases where further dereferencing is+--   needed.+deepDerefTypeDef :: Type -> Type+deepDerefTypeDef (PtrType t quals attrs) =+  PtrType (deepDerefTypeDef t) quals attrs+deepDerefTypeDef (ArrayType t size quals attrs) =+  ArrayType (deepDerefTypeDef t) size quals attrs+deepDerefTypeDef (FunctionType (FunType rt params varargs) attrs) =+  FunctionType (FunType (deepDerefTypeDef rt) params varargs) attrs+deepDerefTypeDef (FunctionType (FunTypeIncomplete rt) attrs) =+  FunctionType (FunTypeIncomplete (deepDerefTypeDef rt)) attrs+deepDerefTypeDef (TypeDefType (TypeDefRef _ (Just t) _) q a) =+  (typeAttrsUpd (mergeAttributes a) . typeQualsUpd (mergeTypeQuals q))+  (deepDerefTypeDef t)+deepDerefTypeDef t = t++canonicalType :: Type -> Type+canonicalType t =+  case deepDerefTypeDef t of+    FunctionType ft attrs -> simplePtr (FunctionType ft attrs)+    t' -> t'++-- XXX: move to be with other flag functions+testFlags :: Enum f => [f] -> Flags f -> Bool+testFlags flags fi = and $ map ((flip testFlag) fi) flags++-- XXX: deal with FlagImag. No representation for it in Complex.+-- XXX: deal with invalid combinations of flags?+getIntType :: Flags CIntFlag -> IntType+getIntType flags | testFlags [FlagLongLong, FlagUnsigned] flags = TyULLong+                 | testFlag  FlagLongLong flags                 = TyLLong+                 | testFlags [FlagLong, FlagUnsigned] flags     = TyULong+                 | testFlag  FlagLong flags                     = TyLong+                 | testFlag  FlagUnsigned flags                 = TyUInt+                 | otherwise                                    = TyInt++getFloatType :: String -> FloatType+getFloatType fs | last fs `elem` ['f', 'F'] = TyFloat+                | last fs `elem` ['l', 'L'] = TyLDouble+                | otherwise                 = TyDouble+
+ src/Language/ObjC/Data.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Data+-- Copyright   :  (c) 2008 Benedikt Huber+--                (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  : jwlato@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Common data types for Language.ObjC: Identifiers, unique names, source code locations,+-- ast node attributes and extensible errors.+-----------------------------------------------------------------------------+module Language.ObjC.Data (+     -- * Input stream+     module Language.ObjC.Data.InputStream,+     -- * Identifiers+     SUERef(..), isAnonymousRef,+     Ident,mkIdent, identToString, internalIdent, isInternalIdent, builtinIdent,+     -- * Unqiue names+     Name(..),newNameSupply,+     -- * Source code positions+     Position(..),Pos(..),+     initPos, nopos,builtinPos,internalPos,+     posFile, posRow, posColumn,+     isSourcePos,isBuiltinPos,isInternalPos,+     -- * Syntax tree nodes+     NodeInfo(..),CNode(..),+     fileOfNode,posOfNode,nameOfNode,+     undefNode,mkNodeInfoOnlyPos,mkNodeInfo,+     internalNode, -- DEPRECATED+     -- * Extensible errors+     module Language.ObjC.Data.Error+)+where+import Language.ObjC.Data.InputStream+import Language.ObjC.Data.Ident+import Language.ObjC.Data.Name+import Language.ObjC.Data.Position+import Language.ObjC.Data.Error+import Language.ObjC.Data.Node
+ src/Language/ObjC/Data/Error.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Data.Error+-- Copyright   :  (c) 2008 Benedikt Huber, Manuel M. T. Chakravarty+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  experimental+-- Portability :  ghc+--+-- Base type for errors occurring in parsing, analysing and pretty-printing.+-- With ideas from Simon Marlow's+-- "An extensible dynamically-typed hierarchy of execeptions [2006]"+-----------------------------------------------------------------------------+module Language.ObjC.Data.Error (+    -- * Severity Level+    ErrorLevel(..), isHardError,+    -- * Error class+    Error(..), errorPos, errorLevel, errorMsgs,+    -- * Error 'supertype'+    CError(..),+    -- * Infos attached to errors+    ErrorInfo(..),showError,showErrorInfo,mkErrorInfo,+    -- * Default error types+    UnsupportedFeature, unsupportedFeature, unsupportedFeature_,+    UserError, userErr,+    -- * Raising internal errors+    internalErr,+)+where+import Data.Typeable+import Language.ObjC.Data.Node+import Language.ObjC.Data.Position++-- | Error levels (severity)+data ErrorLevel = LevelWarn+                | LevelError+                | LevelFatal+              deriving (Eq, Ord)++instance Show ErrorLevel where+    show LevelWarn  = "WARNING"+    show LevelError = "ERROR"+    show LevelFatal = "FATAL ERROR"++-- | return @True@ when the given error makes it impossible to continue+--   analysis or compilation.+isHardError :: (Error ex) => ex -> Bool+isHardError = ( > LevelWarn) . errorLevel++-- | information attached to every error in Language.ObjC+data ErrorInfo = ErrorInfo ErrorLevel Position [String] deriving Typeable++-- to facilitate newtype deriving+instance Show ErrorInfo where show = showErrorInfo "error"+instance Error ErrorInfo where+    errorInfo = id+    changeErrorLevel (ErrorInfo _ pos msgs) lvl' = ErrorInfo lvl' pos msgs++mkErrorInfo :: ErrorLevel -> String -> NodeInfo -> ErrorInfo+mkErrorInfo lvl msg node = ErrorInfo lvl (posOfNode node) (lines msg)++-- | `supertype' of all errors+data CError+    = forall err. (Error err) => CError err+    deriving Typeable++-- | errors in Language.ObjC are instance of 'Error'+class (Typeable e, Show e) => Error e where+    -- | obtain source location etc. of an error+    errorInfo        :: e -> ErrorInfo+    -- | wrap error in 'CError'+    toError          :: e -> CError+    -- | try to cast a generic 'CError' to the specific error type+    fromError     :: CError -> (Maybe e)+    -- | modify the error level+    changeErrorLevel :: e -> ErrorLevel -> e++    -- default implementation+    fromError (CError e) = cast e+    toError = CError+    changeErrorLevel e lvl =+        if errorLevel e == lvl+            then e+            else error $ "changeErrorLevel: not possible for " ++ show e++instance Show CError where+    show (CError e) = show e+instance Error CError where+    errorInfo (CError err) = errorInfo err+    toError = id+    fromError = Just+    changeErrorLevel (CError e) = CError . changeErrorLevel e++-- | position of an @Error@+errorPos   :: (Error e) => e -> Position+errorPos = ( \(ErrorInfo _ pos _) -> pos ) . errorInfo++-- | severity level of an @Error@+errorLevel :: (Error e) => e -> ErrorLevel+errorLevel = ( \(ErrorInfo lvl _ _) -> lvl ) . errorInfo++-- | message lines of an @Error@+errorMsgs   :: (Error e) => e -> [String]+errorMsgs = ( \(ErrorInfo _ _ msgs) -> msgs ) . errorInfo++-- | error raised if a operation requires an unsupported or not yet implemented feature.+data UnsupportedFeature = UnsupportedFeature String Position deriving Typeable+instance Error UnsupportedFeature where+    errorInfo (UnsupportedFeature msg pos) = ErrorInfo LevelError pos (lines msg)+instance Show UnsupportedFeature where show = showError "Unsupported Feature"++unsupportedFeature :: (Pos a) => String -> a -> UnsupportedFeature+unsupportedFeature msg a = UnsupportedFeature msg (posOf a)++unsupportedFeature_ :: String -> UnsupportedFeature+unsupportedFeature_ msg = UnsupportedFeature msg internalPos++-- | unspecified error raised by the user (in case the user does not want to define+--   her own error types).+newtype UserError     = UserError ErrorInfo deriving Typeable+instance Error UserError where+    errorInfo (UserError info) = info+instance Show UserError where show = showError "User Error"++userErr :: String -> UserError+userErr msg = UserError (ErrorInfo LevelError internalPos (lines msg))++-- other errors to be defined elsewhere++showError :: (Error e) => String -> e -> String+showError short_msg = showErrorInfo short_msg . errorInfo++-- | converts an error into a string using a fixed format+--+-- * either the lines of the long error message or the short message has to be non-empty+--+-- * the format is+--+-- >    <fname>:<row>: (column <col>) [<err lvl>]+-- >      >>> <line_1>+-- >      <line_2>+-- >        ...+-- >      <line_n>+showErrorInfo :: String -> ErrorInfo -> String+showErrorInfo short_msg (ErrorInfo level pos msgs) =+    header ++ showMsgLines (if null short_msg then msgs else short_msg:msgs)+    where+    header = (posFile pos) ++ ":" ++ show (posRow pos) ++ ": " +++             "(column " ++ show (posColumn pos) ++ ") " +++             "[" ++ show level ++ "]"+    showMsgLines []     = internalErr "No short message or error message provided."+    showMsgLines (x:xs) = indent ++ ">>> " ++ x ++ "\n" ++ unlines (map (indent++) xs)+++-- internal errors+internalErrPrefix :: String+internalErrPrefix = unlines [ "Language.ObjC : Internal Error" ,+                              "This is propably a bug, and should be reported at "+++                              "http://www.sivity.net/projects/language.c/newticket"]++-- | raise a fatal internal error; message may have multiple lines+internalErr     :: String -> a+internalErr msg  = error (internalErrPrefix ++ "\n"+                       ++ indentLines msg+                       ++ "\n")+indent :: String+indent = "  "+indentLines :: String -> String+indentLines = unlines . map (indent++) . lines
+ src/Language/ObjC/Data/Ident.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Data.Ident+-- Copyright   :  (c) [1995..1999] Manuel M. T. Chakravarty+--                (c) 2008 Benedikt Huber+--                (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  experimental+-- Portability :  ghc+--+-- This module provides the notion of identifiers in C, speed up using hashing.+-- Identifiers are associated optionally associated with a 'NodeInfo', i.e. with+-- a unique 'Name' and a source location ('Position'). The ordering relation on+-- identifiers is based on the hash and does not follow the lexical order.+-----------------------------------------------------------------------------+module Language.ObjC.Data.Ident (+    Ident(..),+    SUERef(..), isAnonymousRef,+    mkIdent, builtinIdent, internalIdent, internalIdentAt, isInternalIdent, identToString, dumpIdent)+where++-- TODO (comment from manuel):+--  * Hashing is not 8bit clean.++import Data.Char+import Language.ObjC.Data.Position+import Language.ObjC.Data.Node+import Language.ObjC.Data.Name   (Name,nameId)+import Data.Generics++-- | References uniquely determining a struct, union or enum type.+-- Those are either identified by an string identifier, or by a unique+-- name (anonymous types).+data SUERef =  AnonymousRef Name+             | NamedRef Ident+    deriving (Typeable, Data, Ord, Eq)+instance Show SUERef where+    show (AnonymousRef name) = "$" ++ show (nameId name)+    show (NamedRef ident) = identToString ident++-- | Return true if the struct\/union\/enum reference is anonymous.+isAnonymousRef :: SUERef -> Bool+isAnonymousRef (AnonymousRef _) = True+isAnonymousRef _ = False++-- | C identifiers+data Ident = Ident String       -- lexeme+                   {-# UNPACK #-}   !Int     -- hash to speed up equality check+                   NodeInfo                   -- attributes of this ident. incl. position+             deriving (Data,Typeable)++-- the definition of the equality allows identifiers to be equal that are+-- defined at different source text positions, and aims at speeding up the+-- equality test, by comparing the lexemes only if the two numbers are equal+--+instance Eq Ident where+  (Ident s h _) == (Ident s' h' _) = (h == h') && (s == s')++-- this does *not* follow the alphanumerical ordering of the lexemes+--+instance Ord Ident where+  compare (Ident s h _) (Ident s' h' _) = compare (h, s) (h', s')++-- for displaying identifiers+instance Show Ident where+  showsPrec _ ide = showString ("\"" ++ identToString ide ++ "\"")++-- identifiers are attributed+instance CNode Ident where+  nodeInfo (Ident _ _ at) = at+instance Pos Ident where+  posOf = posOfNode . nodeInfo+-- to speed up the equality test we compute some hash-like value for each+-- identifiers lexeme and store it in the identifiers representation++-- hash function from the dragon book pp437; assumes 7 bit characters and needs+-- the (nearly) full range of values guaranteed for `Int' by the Haskell+-- language definition; can handle 8 bit characters provided we have 29 bit+-- for the `Int's without sign+--+quad                 :: String -> Int+quad (c1:c2:c3:c4:s)  = ((ord c4 * bits21+                          + ord c3 * bits14+                          + ord c2 * bits7+                          + ord c1)+                         `mod` bits28)+                        + (quad s `mod` bits28)+quad (c1:c2:c3:[]  )  = ord c3 * bits14 + ord c2 * bits7 + ord c1+quad (c1:c2:[]     )  = ord c2 * bits7 + ord c1+quad (c1:[]        )  = ord c1+quad ([]           )  = 0++bits7 :: Int+bits7  = 2^(7::Int)+bits14 :: Int+bits14 = 2^(14::Int)+bits21 :: Int+bits21 = 2^(21::Int)+bits28 :: Int+bits28 = 2^(28::Int)++-- | build an identifier from a string.+--+-- * only minimal error checking, e.g., the characters of the identifier are+--   not checked for being alphanumerical only; the correct lexis of the+--   identifier should be ensured by the caller, e.g., the scanner.+--+-- * for reasons of simplicity the complete lexeme is hashed.+mkIdent            :: Position -> String -> Name -> Ident+mkIdent pos s name  = Ident s (quad s) (mkNodeInfo' pos (pos,length s) name)++-- | returns an /internal/ identifier (has internal position and no unique name)+internalIdent   :: String -> Ident+internalIdent s  = Ident s (quad s) (mkNodeInfoOnlyPos internalPos)++-- | return an /internal/ identifier with position info+internalIdentAt :: Position -> String -> Ident+internalIdentAt pos s = Ident s (quad s) (mkNodeInfoPosLen pos (pos, length s))++-- | returns a /builtin/ identifier (has builtin position and no unique name)+builtinIdent   :: String -> Ident+builtinIdent s  = Ident s (quad s) (mkNodeInfoOnlyPos builtinPos)++-- | return @True@ if the given identifier is /internal/+isInternalIdent :: Ident -> Bool+isInternalIdent (Ident _ _ nodeinfo) = isInternalPos (posOfNode nodeinfo)++-- | string of an identifier+identToString               :: Ident -> String+identToString (Ident s _ _)  = s++-- | dump the identifier string and its positions for debugging purposes+dumpIdent     :: Ident -> String+dumpIdent ide  = identToString ide ++ " at " ++ show (nodeInfo ide)
+ src/Language/ObjC/Data/InputStream.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE CPP, BangPatterns #-}+{-# OPTIONS -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Data.InputStream+-- Copyright   :  (c) 2008,2011 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  experimental+-- Portability :  ghc+--+-- Compile time input abstraction for the parser, relying on ByteString.+-- The String interface only supports Latin-1 since alex-3, as alex now requires+-- byte based access to the input stream.+-------------------------------------------------------------------------------+module Language.ObjC.Data.InputStream (+    InputStream, readInputStream,inputStreamToString,inputStreamFromString,+    takeByte, takeChar, inputStreamEmpty, takeChars,+    countLines,+)+where++import Data.Word++#ifndef NO_BYTESTRING+import Data.ByteString (ByteString)+import qualified Data.ByteString as BSW+import qualified Data.ByteString.Char8 as BSC+#else+import qualified Data.Char as Char+#endif++-- Generic InputStream stuff++-- | read a file into an 'InputStream'+readInputStream :: FilePath -> IO InputStream++-- | convert 'InputStream' to 'String'+inputStreamToString :: InputStream -> String+{-# INLINE inputStreamToString #-}++-- | convert a 'String' to an 'InputStream'+inputStreamFromString :: String -> InputStream++-- | @(b,is') = takeByte is@ reads and removes+-- the first byte @b@ from the 'InputStream' @is@+takeByte :: InputStream -> (Word8, InputStream)+{-# INLINE takeByte #-}++-- | @(c,is') = takeChar is@ reads and removes+-- the first character @c@ from the 'InputStream' @is@+takeChar :: InputStream -> (Char, InputStream)+{-# INLINE takeChar #-}++-- | return @True@ if the given input stream is empty+inputStreamEmpty :: InputStream -> Bool+{-# INLINE inputStreamEmpty #-}++-- | @str = takeChars n is@ returns the first @n@ characters+-- of the given input stream, without removing them+takeChars :: Int -> InputStream -> [Char]+{-# INLINE takeChars #-}++-- | @countLines@ returns the number of text lines  in the+-- given 'InputStream'+countLines :: InputStream -> Int++#ifndef NO_BYTESTRING++type InputStream = ByteString+takeByte bs = BSW.head  bs `seq`  (BSW.head bs, BSW.tail bs)+takeChar bs = BSC.head bs `seq`  (BSC.head bs, BSC.tail bs)+inputStreamEmpty = BSW.null+#ifndef __HADDOCK__+takeChars 0  _    = []+takeChars !n bstr = let str = BSC.unpack $ BSC.take n bstr --leaks+                    in  tail str `seq` str+#endif+readInputStream       = BSW.readFile++inputStreamToString   = BSC.unpack+inputStreamFromString = BSC.pack+countLines             = length . BSC.lines+++#else++type InputStream = String+takeByte bs+  | Char.isLatin1 c = let b = fromIntegral (Char.ord c) in b `seq` (b, tail bs)+  | otherwise       = error "takeByte: not a latin-1 character"+  where c = head bs+takeChar bs = (head bs, tail bs)+inputStreamEmpty = null+takeChars n str = take n str+readInputStream = readFile+inputStreamToString = id+inputStreamFromString = id+countLines = length . lines+#endif+
+ src/Language/ObjC/Data/Name.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Data.Name+-- Copyright   :  (c) 2008 Benedikt Huber+--                (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  experimental+-- Portability :  ghc+--+-- Unique Names with fast equality (newtype 'Int')+module Language.ObjC.Data.Name (+Name(..),newNameSupply, namesStartingFrom+) where+import Data.Ix+import Data.Generics++-- | Name is a unique identifier+newtype Name = Name { nameId :: Int } deriving (Show, Read, Eq, Ord, Ix, Data, Typeable)++instance Enum Name where+    toEnum = Name+    fromEnum (Name n) = n++-- | return an infinite stream of 'Name's starting with @nameId@ 0+newNameSupply :: [Name]+newNameSupply = namesStartingFrom 0++-- | get the infinite stream of unique names starting from the given integer+namesStartingFrom :: Int -> [Name]+namesStartingFrom k = [Name k..]
+ src/Language/ObjC/Data/Node.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Syntax.Attributes+-- Copyright   :  (c) [1995..1999] Manuel M. T. Chakravarty+--                (c) 2008 Benedikt Huber (stripped radically)+--                (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  experimental+-- Portability :  ghc+--+-- source position and unqiue name+-----------------------------------------------------------------------------+module Language.ObjC.Data.Node (+   NodeInfo(..), undefNode, isUndefNode,+   mkNodeInfoOnlyPos,mkNodeInfoPosLen, mkNodeInfo,mkNodeInfo',+   internalNode, -- deprecated, use undefNode+   CNode(nodeInfo), fileOfNode,+   posOfNode, nameOfNode, getLastTokenPos, lengthOfNode,+   eqByName,+) where+import Language.ObjC.Data.Position+import Language.ObjC.Data.Name     (Name)+import Data.Generics++-- | Parsed entity attribute+data NodeInfo = OnlyPos  !Position {-# UNPACK #-} !PosLength        -- only pos and last token (for internal stuff only)+              | NodeInfo !Position {-# UNPACK #-} !PosLength {-# UNPACK #-} !Name  -- pos, last token and unique name+           deriving (Data,Typeable)++instance Show NodeInfo where+    showsPrec d (OnlyPos p l) =+      (showString "(OnlyPos ") . (showsPrec d p) . (showString " ") . (showsPrec d l) . (showString ")")+    showsPrec d (NodeInfo p l n) =+      (showString "(NodeInfo ") . (showsPrec d p) . (showString " ") . (showsPrec d l) . (showString " ") . (showsPrec d n) . (showString ")")++-- name equality of attributes, used to define (name) equality of objects+instance Eq NodeInfo where+  (NodeInfo   _ _ id1) == (NodeInfo   _ _ id2) = id1 == id2+  _               == _               =+    error "Attributes: Attempt to compare `OnlyPos' attributes!"++-- attribute ordering+instance Ord NodeInfo where+  (NodeInfo   _ _ id1) <= (NodeInfo   _ _ id2) = id1 <= id2+  _               <= _               =+    error "Attributes: Attempt to compare `OnlyPos' attributes!"++instance Pos NodeInfo where+  posOf (OnlyPos pos _) = pos+  posOf (NodeInfo pos _ _) = pos++-- | get the number of characters an AST node spans+lengthOfNode :: NodeInfo -> Maybe Int+lengthOfNode ni = len+    where+    len = case ni of NodeInfo firstPos lastTok _ -> computeLength firstPos lastTok+                     OnlyPos firstPos lastTok -> computeLength firstPos lastTok+    computeLength pos (PL lastPos len')+      | len' < 0   = Nothing+      | otherwise = Just (posOffset lastPos + len' - posOffset pos)++-- | get the position and length of the last token+getLastTokenPos :: NodeInfo -> PosLength+getLastTokenPos (NodeInfo _ lastTok _) = lastTok+getLastTokenPos (OnlyPos _ lastTok) = lastTok++-- | a class for convenient access to the attributes of an attributed object+class CNode a where+  nodeInfo :: a -> NodeInfo+instance CNode NodeInfo where+  nodeInfo = id+instance (CNode a, CNode b) => CNode (Either a b) where+  nodeInfo = either nodeInfo nodeInfo++nameOfNode :: NodeInfo -> Maybe Name+nameOfNode (OnlyPos _ _) = Nothing+nameOfNode (NodeInfo _ _ name) = Just name+posOfNode :: NodeInfo -> Position+posOfNode ni = case ni of (OnlyPos pos _) -> pos; (NodeInfo pos _ _) -> pos+fileOfNode :: (CNode a) => a -> Maybe FilePath+fileOfNode = fmap posFile . justIf isSourcePos . posOfNode . nodeInfo where+    justIf predicate x | predicate x = Just x+                       | otherwise   = Nothing++-- | equality by name+eqByName           :: CNode a => a -> a -> Bool+eqByName obj1 obj2  = (nodeInfo obj1) == (nodeInfo obj2)+++-- attribute identifier creation+-- -----------------------------+{-# DEPRECATED internalNode "use undefNode instead" #-}+internalNode :: NodeInfo+internalNode = undefNode++-- | create a node with neither name nor positional information+undefNode :: NodeInfo+undefNode = OnlyPos nopos (PL nopos nO)++-- | return True if the node carries neither name nor positional information+isUndefNode :: NodeInfo -> Bool+isUndefNode (OnlyPos p _) | isNoPos p = True+                          | otherwise = False+isUndefNode _ = False++nO :: Int+nO = (-1)++-- |+-- | Given only a source position, create a new node attribute+mkNodeInfoOnlyPos :: Position -> NodeInfo+mkNodeInfoOnlyPos pos  = OnlyPos pos (PL nopos nO)++-- | Given a source position and the position and length of the last token, create a new node attribute+mkNodeInfoPosLen :: Position -> (Position,Int) -> NodeInfo+mkNodeInfoPosLen p pl = OnlyPos p (uncurry PL pl)++-- | Given a source position and a unique name, create a new attribute+-- identifier+mkNodeInfo :: Position -> Name -> NodeInfo+mkNodeInfo pos name  = NodeInfo pos (PL nopos nO) name++-- | Given a source position, the position and length of the last token and a unique name, create a new attribute+-- identifier. Strict in+mkNodeInfo' :: Position -> (Position,Int) -> Name -> NodeInfo+mkNodeInfo' pos lasttok name = NodeInfo pos (uncurry PL lasttok) name+
+ src/Language/ObjC/Data/Position.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Data.Position+-- Copyright   :  (c) [1995..2000] Manuel M. T. Chakravarty+--                    [2008..2009] Benedikt Huber+--                (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  experimental+-- Portability :  ghc+--+-- Source code position+-----------------------------------------------------------------------------+module Language.ObjC.Data.Position (+  --+  -- source text positions+  --+  Position(..),+  position,+  PosLength(..),+  mkPosLength,+  unPosLength,+  posFile,posRow,posColumn,posOffset,+  initPos, isSourcePos,+  nopos, isNoPos,+  builtinPos, isBuiltinPos,+  internalPos, isInternalPos,+  incPos, retPos, adjustPos,+  incOffset,+  Pos(..),+) where+import Data.Generics++-- | uniform representation of source file positions+data Position = Position { posOffset' :: {-# UNPACK #-} !Int  -- ^ absolute offset in the preprocessed file+                         , posFile' :: String                -- ^ source file+                         , posRow'  :: {-# UNPACK #-} !Int     -- ^ row (line)  in the original file. Affected by #LINE pragmas.+                         , posColumn' :: {-# UNPACK #-} !Int  -- ^ column in the preprocessed file. Inaccurate w.r.t. to the original+                                                             --   file in the presence of preprocessor macros.+                         }+              | NoPosition+              | BuiltinPosition+              | InternalPosition+                deriving (Eq, Ord, Typeable, Data)++posFile :: Position -> String+posFile (Position{posFile' = ps}) = ps+posFile pos = show pos++posRow :: Position -> Int+posRow (Position{posRow' = pr}) = pr+posRow _ = (-1)++posColumn :: Position -> Int+posColumn (Position{posColumn' = pc}) = pc+posColumn _ = (-1)++posOffset :: Position -> Int+posOffset (Position{posOffset' = po}) = po+posOffset _ = (-1)++-- | Position and length of a token+data PosLength = PL !Position+                    {-# UNPACK #-} !Int+     deriving (Eq, Ord, Data, Typeable, Show)++mkPosLength :: Position -> Int -> PosLength+mkPosLength = PL++unPosLength :: PosLength -> (Position, Int)+unPosLength (PL pos l) = (pos,l)++instance Show Position where+  show (Position _ fname row _) = "(" ++ show fname ++ ": line " ++ show row ++ ")"+  show NoPosition               = "<no file>"+  show BuiltinPosition          = "<builtin>"+  show InternalPosition         = "<internal>"++{-# DEPRECATED posColumn "column number information is inaccurate in presence of macros - do not rely on it." #-}++-- | @position absoluteOffset fileName lineNumber columnNumber@ initializes a @Position@ using the given arguments+position :: Int -> String -> Int -> Int -> Position+position = Position++-- | class of type which aggregate a source code location+class Pos a where+    posOf :: a -> Position++-- | initialize a Position to the start of the translation unit starting in the given file+initPos :: FilePath -> Position+initPos file = Position 0 file 1 1++-- | returns @True@ if the given position refers to an actual source file+isSourcePos :: Position -> Bool+isSourcePos (Position _ _ _ _) = True+isSourcePos _                  = False++-- | no position (for unknown position information)+nopos :: Position+nopos  = NoPosition++-- | returns @True@ if the there is no position information available+isNoPos :: Position -> Bool+isNoPos NoPosition = True+isNoPos _          = False++-- | position attached to built-in objects+--+builtinPos :: Position+builtinPos  = BuiltinPosition++-- | returns @True@ if the given position refers to a builtin definition+isBuiltinPos :: Position -> Bool+isBuiltinPos BuiltinPosition = True+isBuiltinPos _               = False++-- | position used for internal errors+internalPos :: Position+internalPos = InternalPosition++-- | returns @True@ if the given position is internal+isInternalPos :: Position -> Bool+isInternalPos InternalPosition = True+isInternalPos _                = False++{-# INLINE incPos #-}+-- | advance column+incPos :: Position -> Int -> Position+incPos (Position offs fname row col) n = Position (offs + n) fname row (col + n)+incPos p _                             = p++{-# INLINE retPos #-}+-- | advance to next line+retPos :: Position -> Position+retPos (Position offs fname row _) = Position (offs+1) fname (row + 1) 1+retPos p                           = p++{-# INLINE adjustPos #-}+-- | adjust position: change file and line number, reseting column to 1. This is usually+--   used for #LINE pragmas. The absolute offset is not changed - this can be done+--   by @adjustPos newFile line . incPos (length pragma)@.+adjustPos :: FilePath -> Int -> Position -> Position+adjustPos fname row (Position offs _ _ _) = Position offs fname row 1+adjustPos _ _ p                           = p++{-# INLINE incOffset #-}+-- | advance just the offset+incOffset :: Position -> Int -> Position+incOffset (Position o f r c) n = Position (o + n) f r c+incOffset p _n                 = p
+ src/Language/ObjC/Data/RList.hs view
@@ -0,0 +1,53 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Data.RList+-- Copyright   :  (c) [2007..2008] Duncan Coutts, Benedikt Huber+--                (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  : jwlato@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Due to the way the grammar is constructed we very often have to build lists+-- in reverse. To make sure we do this consistently and correctly we have a+-- newtype to wrap the reversed style of list:+-----------------------------------------------------------------------------+module Language.ObjC.Data.RList (+    RList,Reversed(..),+    empty,singleton,snoc,rappend,appendr,rappendr,rmap,reverse,+    viewr,+)+where+import Prelude hiding (reverse)+import qualified Data.List as List++newtype Reversed a = Reversed a+type RList a = Reversed [a]+empty :: Reversed [a]+empty = Reversed []++singleton :: a -> Reversed [a]+singleton x = Reversed [x]++snoc :: Reversed [a] -> a -> Reversed [a]+snoc (Reversed xs) x = Reversed (x : xs)+infixr 5 `snoc`++rappend :: Reversed [a] -> [a] -> Reversed [a]+rappend (Reversed xs) ys = Reversed (List.reverse ys ++ xs)++appendr :: [a] -> Reversed [a] -> Reversed [a]+appendr xs (Reversed ys) = Reversed (ys ++ List.reverse xs)++rappendr :: Reversed [a] -> Reversed [a] -> Reversed [a]+rappendr (Reversed xs) (Reversed ys) = Reversed (ys ++ xs)++rmap :: (a -> b) -> Reversed [a] -> Reversed [b]+rmap f (Reversed xs) = Reversed (map f xs)++reverse :: Reversed [a] -> [a]+reverse (Reversed xs) = List.reverse xs++viewr :: Reversed [a] -> (Reversed [a] , a)+viewr (Reversed []) = error "viewr: empty RList"+viewr (Reversed (x:xs)) = (Reversed xs, x)
+ src/Language/ObjC/Parser.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Parser+-- Copyright   :  (c) 2008 Benedikt Huber+--                (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  : jwlato@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Language.ObjC parser+-----------------------------------------------------------------------------+module Language.ObjC.Parser (+    -- * Simple API+    parseC, parseLazyC,+    -- * Parser Monad+    P,execParser,execLazyParser, execParser_,builtinTypeNames,+    -- * Exposed Parsers+    translUnitP, extDeclP, statementP, expressionP,+    -- * Parser Monad+    ParseError(..)+)+where+import Language.ObjC.Parser.Parser+import Language.ObjC.Parser.ParserMonad (execParser, execLazyParser, ParseError(..),P)+import Language.ObjC.Parser.Builtin (builtinTypeNames)++import Language.ObjC.Data++-- | run the given parser using a new name supply and builtin typedefs+--   see 'execParser'+--+-- Synopsis: @runParser parser inputStream initialPos@+execParser_ :: P a -> InputStream -> Position -> Either ParseError a+execParser_ parser input pos =+  fmap fst $ execParser parser input pos builtinTypeNames newNameSupply
+ src/Language/ObjC/Parser/Builtin.hs view
@@ -0,0 +1,21 @@+-- |+-- Module      :  Language.ObjC.Parser.Builtin+-- Copyright   :  (c) 2001 Manuel M. T. Chakravarty+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Portability :  portable+--+-- This module provides information about builtin entities.+--+--  Currently, only builtin type names are supported.  The only builtin type+--  name is `__builtin_va_list', which is a builtin of GNU C.+--+module Language.ObjC.Parser.Builtin (+  builtinTypeNames+) where+import Language.ObjC.Data.Ident (Ident, builtinIdent)++-- predefined type names+--+builtinTypeNames :: [Ident]+builtinTypeNames  = [builtinIdent "__builtin_va_list"]
+ src/Language/ObjC/Parser/Lexer.x view
@@ -0,0 +1,545 @@+-----------------------------------------------------------------------------+-- Module      :  Lexer.x+-- Copyright   : (c) [1999..2004] Manuel M T Chakravarty+--               (c) 2005 Duncan Coutts+--               (c) 2008 Benedikt Huber+--               (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Portability :  portable+--+--  Lexer for C files, after being processed by the C preprocessor+--+--  We assume that the input already went through cpp.  Thus, we do not handle+--  comments and preprocessor directives here.  It supports the+--  C99 `restrict' extension: <http://www.lysator.liu.se/c/restrict.html> as+--  well as inline functions.+--+--  Comments:+--+--  * Universal character names and multi-character character constants,+--    as well as trigraphs are unsupported. They are lexed, but yield an error.+--+--  * We add `typedef-name' (K&R 8.9) as a token, as proposed in K&R A13.+--    However, as these tokens cannot be recognized lexically, but require a+--    context analysis, they are never produced by the lexer, but instead have+--    to be introduced in a later phase (by converting the corresponding+--    identifiers).+--+--  * We also recognize GNU C `__attribute__', `__extension__', `__complex__',+--    `__const',  `__const__', `__imag', `__imag__', `__inline', `__inline__',+--    `__real', `__real__, `__restrict', and `__restrict__'.+--+--  * Any line starting with `#pragma' is ignored.+--+--  With K&R we refer to ``The C Programming Language'', second edition, Brain+--  W. Kernighan and Dennis M. Ritchie, Prentice Hall, 1988.+--+--  With C99 we refer to ``ISO/IEC 9899:TC3'',+--  available online at http://www.open-std.org/JTC1/SC22/WG14/www/docs/n1256.pdf.+--+--- TODO ----------------------------------------------------------------------+--+--  * There are more GNU C specific keywords.  Add them and change `Parser.y'+--    correspondingly (in particular, most tokens within __attribute ((...))+--    expressions are actually keywords, but we handle them as identifiers at+--    the moment).+--+--  * Add support for bytestrings++{+{-# LANGUAGE BangPatterns #-}++module Language.ObjC.Parser.Lexer (lexC, parseError) where++import Data.Char (chr, isDigit)+import Data.Word (Word8)+import Control.Monad (liftM, when)++import Language.ObjC.Data.InputStream+  (InputStream, inputStreamEmpty, takeByte, takeChar, takeChars)++-- (    InputStream, readInputStream,inputStreamToString,inputStreamFromString,+--     takeByte, takeChar, inputStreamEmpty, takeChars,+--     countLines,+-- )+import Language.ObjC.Data.Position+import Language.ObjC.Data.Ident    (mkIdent)++import Language.ObjC.Syntax.Constants++import Language.ObjC.Parser.Tokens+import Language.ObjC.Parser.ParserMonad+}++$space = [ \ \t ]                           -- horizontal white space+$eol   = \n                                 -- end of line++$letter   = [a-zA-Z]+$identletter = [a-zA-Z_\$]                  -- GNU extension: allow $ in variable names+$octdigit = 0-7+$digit    = 0-9+$digitNZ  = 1-9+$hexdigit = [0-9a-fA-F]++$inchar   = \0-\255 # [ \\ \' \n \r ]       -- valid character in char constant+$instr    = \0-\255 # [ \\ \" \n \r ]       -- valid character in a string literal+$anyButNL = \0-\255 # \n+$infname  = \ -\127 # [ \\ \" ]             -- valid character in a filename++@sp  = $space*++-- character escape sequence (follows K&R A2.5.2)+--+-- * also used for strings+-- * C99: 6.4.4.4+@charesc  = \\([ntvbrfaeE\\\?\'\"]|$octdigit{1,3}|x$hexdigit+)+@ucn      = \\u$hexdigit{4}|\\U$hexdigit{8}++-- components of integer constants+--+-- * C99: 6.4.4.1+@int = $digitNZ$digit*++-- integer suffixes+@llsuffix  = ll|LL+@gnusuffix = [ij]?+@intsuffix = [uU][lL]?|[uU]@llsuffix|[lL][uU]?|@llsuffix[uU]?+@intgnusuffix = @intsuffix@gnusuffix?|@gnusuffix@intsuffix?++-- components of float constants (follows K&R A2.5.3)+--+-- * C99: 6.4.4.2+@digits    = $digit++@intpart   = @digits+@fractpart = @digits++@mantpart  = @intpart?\.@fractpart|@intpart\.+@exppart   = [eE][\+\-]?@digits++@hexprefix = 0x+@hexdigits = $hexdigit++@hexmant   = @hexdigits?\.@hexdigits|@hexdigits\.+@binexp    = [pP][\+\-]?@digits++@floatsuffix    = [fFlL]+@floatgnusuffix = @floatsuffix@gnusuffix?|@gnusuffix@floatsuffix?++++tokens :-++-- whitespace (follows K&R A2.1)+--+-- * horizontal and vertical tabs, newlines, and form feeds are filter out by+--   `Lexers.ctrlLexer'+--+-- * comments are not handled, as we assume the input already went through cpp+--+$white+         ;++-- #line directive (K&R A12.6)+--+-- * allows further ints after the file name a la GCC; as the GCC CPP docu+--   doesn't say how many ints there can be, we allow an unbound number+--+\#$space*@int$space*(\"($infname|@charesc)*\"$space*)?(@int$space*)*\r?$eol+  { \pos len str -> setPos (adjustLineDirective len (takeChars len str) pos) >> lexToken' False }++-- #pragma directive (K&R A12.8)+--+-- * we simply ignore any #pragma (but take care to update the position+--   information)+--+\#$space*pragma$anyButNL*$eol   ;++-- #ident directive, eg used by rcs/cvs+--+-- * we simply ignore any #ident (but take care to update the position+--   information)+--+\#$space*ident$anyButNL*$eol    ;++-- objective-C compiler directives, e.g. "@class"+@$identletter+ { \pos len str -> idkwtok (takeChars len str) pos }++-- identifiers and keywords (follows K&R A2.3 and A2.4)+--+$identletter($identletter|$digit)*  { \pos len str -> idkwtok (takeChars len str) pos }++-- constants (follows K&R A2.5)+--+-- * K&R,C99 explicitly mention `enumeration-constants'; however, as they are+--   lexically identifiers, we do not have an extra case for them+--++-- integer constants (follows K&R A2.5.1, C99 6.4.4.1)+-- NOTE: 0 is lexed as octal integer constant, and readCOctal takes care of this+0$octdigit*@intgnusuffix?       { token_plus CTokILit readCOctal }+$digitNZ$digit*@intgnusuffix?   { token_plus CTokILit (readCInteger DecRepr) }+0[xX]$hexdigit+@intgnusuffix?   { token_plus CTokILit (readCInteger HexRepr . drop 2) }++(0$octdigit*|$digitNZ$digit*|0[xX]$hexdigit+)[uUlL]+ { token_fail "Invalid integer constant suffix" }++-- character constants (follows K&R A2.5.2, C99 6.4.4.4)+--+-- * Universal Character Names are unsupported and cause an error.+\'($inchar|@charesc)\'  { token CTokCLit (cChar . fst . unescapeChar . tail) }+L\'($inchar|@charesc)\' { token CTokCLit (cChar_w . fst . unescapeChar . tail . tail) }+\'($inchar|@charesc){2,}\' { token CTokCLit (flip cChars False . unescapeMultiChars .tail) }+L\'($inchar|@charesc){2,}\' { token CTokCLit (flip cChars True . unescapeMultiChars . tail . tail) }++-- float constants (follows K&R A2.5.3. C99 6.4.4.2)+--+-- * NOTE: Hexadecimal floating constants without binary exponents are forbidden.+--         They generate a lexer error, because they are hard to recognize in the parser.+(@mantpart@exppart?|@intpart@exppart)@floatgnusuffix?  { token CTokFLit readCFloat }+@hexprefix(@hexmant|@hexdigits)@binexp@floatgnusuffix? { token CTokFLit readCFloat }+@hexprefix@hexmant                                     { token_fail "Hexadecimal floating constant requires an exponent" }++-- string literal (follows K&R A2.6)+-- C99: 6.4.5.+\"($instr|@charesc)*\"      { token CTokSLit (cString . unescapeString . init . tail) }+L\"($instr|@charesc)*\"     { token CTokSLit (cString_w . unescapeString . init . tail . tail) }++-- objective-C NSString literal+\@\"($instr|@charesc)*\"    { token (flip CTokObjC) (ObjCNSSLit . cString . unescapeString . init . tail . tail) }++L?\'@ucn\'                        { token_fail "Universal character names are unsupported" }+L?\'\\[^0-7'\"\?\\abfnrtvuUx]\'     { token_fail "Invalid escape sequence" }+L?\"($inchar|@charesc)*@ucn($inchar|@charesc|@ucn)*\" { token_fail "Universal character names in string literals are unsupported"}++-- operators and separators+--+"("   { token_ 1 CTokLParen }+")"   { token_ 1 CTokRParen  }+"["   { token_ 1 CTokLBracket }+"]"   { token_ 1 CTokRBracket }+"->"  { token_ 2 CTokArrow }+"."   { token_ 1 CTokDot }+"!"   { token_ 1 CTokExclam }+"~"   { token_ 1 CTokTilde }+"++"  { token_ 2 CTokInc }+"--"  { token_ 2 CTokDec }+"+"   { token_ 1 CTokPlus }+"-"   { token_ 1 CTokMinus }+"*"   { token_ 1 CTokStar }+"/"   { token_ 1 CTokSlash }+"%"   { token_ 1 CTokPercent }+"&"   { token_ 1 CTokAmper }+"<<"  { token_ 2 CTokShiftL }+">>"  { token_ 2 CTokShiftR }+"<"   { token_ 1 CTokLess }+"<="  { token_ 2 CTokLessEq }+">"   { token_ 1 CTokHigh }+">="  { token_ 2 CTokHighEq }+"=="  { token_ 2 CTokEqual }+"!="  { token_ 2 CTokUnequal }+"^"   { token_ 1 CTokHat }+"|"   { token_ 1 CTokBar }+"&&"  { token_ 2 CTokAnd }+"||"  { token_ 2 CTokOr }+"?"   { token_ 1 CTokQuest }+":"   { token_ 1 CTokColon }+"="   { token_ 1 CTokAssign }+"+="  { token_ 2 CTokPlusAss }+"-="  { token_ 2 CTokMinusAss }+"*="  { token_ 2 CTokStarAss }+"/="  { token_ 2 CTokSlashAss }+"%="  { token_ 2 CTokPercAss }+"&="  { token_ 2 CTokAmpAss }+"^="  { token_ 2 CTokHatAss }+"|="  { token_ 2 CTokBarAss }+"<<=" { token_ 3 CTokSLAss }+">>=" { token_ 3 CTokSRAss }+","   { token_ 1 CTokComma }+\;    { token_ 1 CTokSemic }+"{"   { token_ 1 CTokLBrace }+"}"   { token_ 1 CTokRBrace }+"..." { token_ 3 CTokEllipsis }+++{+-- Fix the 'octal' lexing of '0'+readCOctal :: String -> Either String CInteger+readCOctal s@('0':r) =+    case r of+        (c:_) | isDigit c -> readCInteger OctalRepr r+        _                 -> readCInteger DecRepr s++-- We use the odd looking list of string patterns here rather than normal+-- string literals since GHC converts the latter into a sequence of string+-- comparisons (ie a linear search) but it translates the former using its+-- effecient pattern matching which gives us the expected radix-style search.+-- This change makes a significant performance difference [chak]+--+{-+alignof @__, asm @__, auto+break, bool _Bool,+case, char, const @__, continue, complex _Complex __complex__+default, do, double,+else, enum, extern,+float, for, goto,+if, inline @__, int, long,+register, restrict @__, return+short, signed @__, sizeof, static, struct, switch,+typedef, typeof @__, thread __thread,+union, unsigned, void, volatile @__,+while,+label __label__+(CTokGnuC GnuCAttrTok) __attribute __attribute__+(CTokGnuC GnuCExtTok) __extension__+(CTokGnuC GnuCComplexReal) __real __real__+(CTokGnuC GnuCComplexImag) __imag __imag__+(CTokGnuC GnuCVaArg) __builtin_va_arg+(CTokGnuC GnuCOffsetof) __builtin_offsetof+(CTokGnuC GnuCTyCompat) __builtin_types_compatible_p+-}+-- Tokens: alignof __alignof __alignof__ asm __asm __asm__ __attribute __attribute__ auto _Bool break __builtin_offsetof __builtin_types_compatible_p __builtin_va_arg case char _Complex __complex__ const __const __const__ continue default do double else enum __extension__ extern float for goto if __imag __imag__ inline __inline __inline__ int __label__ long __real __real__ register __restrict __restrict__ return short signed __signed __signed__ sizeof static struct switch __thread typedef typeof __typeof __typeof__ union unsigned void volatile __volatile __volatile__ while+idkwtok ('_' : 'B' : 'o' : 'o' : 'l' : []) = tok 5 CTokBool+idkwtok ('_' : 'C' : 'o' : 'm' : 'p' : 'l' : 'e' : 'x' : []) = tok 8 CTokComplex+idkwtok ('_' : '_' : 'a' : 'l' : 'i' : 'g' : 'n' : 'o' : 'f' : []) = tok 9 CTokAlignof+idkwtok ('a' : 'l' : 'i' : 'g' : 'n' : 'o' : 'f' : []) = tok 7 CTokAlignof+idkwtok ('_' : '_' : 'a' : 'l' : 'i' : 'g' : 'n' : 'o' : 'f' : '_' : '_' : []) = tok 11 CTokAlignof+idkwtok ('_' : '_' : 'a' : 's' : 'm' : []) = tok 5 CTokAsm+idkwtok ('a' : 's' : 'm' : []) = tok 3 CTokAsm+idkwtok ('_' : '_' : 'a' : 's' : 'm' : '_' : '_' : []) = tok 7 CTokAsm+idkwtok ('_' : '_' : 'a' : 't' : 't' : 'r' : 'i' : 'b' : 'u' : 't' : 'e' : []) = tok 11 (CTokGnuC GnuCAttrTok)+idkwtok ('_' : '_' : 'a' : 't' : 't' : 'r' : 'i' : 'b' : 'u' : 't' : 'e' : '_' : '_' : []) = tok 13 (CTokGnuC GnuCAttrTok)+idkwtok ('a' : 'u' : 't' : 'o' : []) = tok 4 CTokAuto+idkwtok ('b' : 'r' : 'e' : 'a' : 'k' : []) = tok 5 CTokBreak+idkwtok ('_' : '_' : 'b' : 'u' : 'i' : 'l' : 't' : 'i' : 'n' : '_' : 'o' : 'f' : 'f' : 's' : 'e' : 't' : 'o' : 'f' : []) = tok 18 (CTokGnuC GnuCOffsetof)+idkwtok ('_' : '_' : 'b' : 'u' : 'i' : 'l' : 't' : 'i' : 'n' : '_' : 't' : 'y' : 'p' : 'e' : 's' : '_' : 'c' : 'o' : 'm' : 'p' : 'a' : 't' : 'i' : 'b' : 'l' : 'e' : '_' : 'p' : []) = tok 28 (CTokGnuC GnuCTyCompat)+idkwtok ('_' : '_' : 'b' : 'u' : 'i' : 'l' : 't' : 'i' : 'n' : '_' : 'v' : 'a' : '_' : 'a' : 'r' : 'g' : []) = tok 16 (CTokGnuC GnuCVaArg)+idkwtok ('c' : 'a' : 's' : 'e' : []) = tok 4 CTokCase+idkwtok ('c' : 'h' : 'a' : 'r' : []) = tok 4 CTokChar+idkwtok ('_' : '_' : 'c' : 'o' : 'm' : 'p' : 'l' : 'e' : 'x' : '_' : '_' : []) = tok 11 CTokComplex+idkwtok ('_' : '_' : 'c' : 'o' : 'n' : 's' : 't' : []) = tok 7 CTokConst+idkwtok ('c' : 'o' : 'n' : 's' : 't' : []) = tok 5 CTokConst+idkwtok ('_' : '_' : 'c' : 'o' : 'n' : 's' : 't' : '_' : '_' : []) = tok 9 CTokConst+idkwtok ('c' : 'o' : 'n' : 't' : 'i' : 'n' : 'u' : 'e' : []) = tok 8 CTokContinue+idkwtok ('d' : 'e' : 'f' : 'a' : 'u' : 'l' : 't' : []) = tok 7 CTokDefault+idkwtok ('d' : 'o' : []) = tok 2 CTokDo+idkwtok ('d' : 'o' : 'u' : 'b' : 'l' : 'e' : []) = tok 6 CTokDouble+idkwtok ('e' : 'l' : 's' : 'e' : []) = tok 4 CTokElse+idkwtok ('e' : 'n' : 'u' : 'm' : []) = tok 4 CTokEnum+idkwtok ('_' : '_' : 'e' : 'x' : 't' : 'e' : 'n' : 's' : 'i' : 'o' : 'n' : '_' : '_' : []) = tok 13 (CTokGnuC GnuCExtTok)+idkwtok ('e' : 'x' : 't' : 'e' : 'r' : 'n' : []) = tok 6 CTokExtern+idkwtok ('f' : 'l' : 'o' : 'a' : 't' : []) = tok 5 CTokFloat+idkwtok ('f' : 'o' : 'r' : []) = tok 3 CTokFor+idkwtok ('g' : 'o' : 't' : 'o' : []) = tok 4 CTokGoto+idkwtok ('i' : 'f' : []) = tok 2 CTokIf+idkwtok ('_' : '_' : 'i' : 'm' : 'a' : 'g' : []) = tok 6 (CTokGnuC GnuCComplexImag)+idkwtok ('_' : '_' : 'i' : 'm' : 'a' : 'g' : '_' : '_' : []) = tok 8 (CTokGnuC GnuCComplexImag)+idkwtok ('_' : '_' : 'i' : 'n' : 'l' : 'i' : 'n' : 'e' : []) = tok 8 CTokInline+idkwtok ('i' : 'n' : 'l' : 'i' : 'n' : 'e' : []) = tok 6 CTokInline+idkwtok ('_' : '_' : 'i' : 'n' : 'l' : 'i' : 'n' : 'e' : '_' : '_' : []) = tok 10 CTokInline+idkwtok ('i' : 'n' : 't' : []) = tok 3 CTokInt+idkwtok ('_' : '_' : 'l' : 'a' : 'b' : 'e' : 'l' : '_' : '_' : []) = tok 9 CTokLabel+idkwtok ('l' : 'o' : 'n' : 'g' : []) = tok 4 CTokLong+idkwtok ('_' : '_' : 'r' : 'e' : 'a' : 'l' : []) = tok 6 (CTokGnuC GnuCComplexReal)+idkwtok ('_' : '_' : 'r' : 'e' : 'a' : 'l' : '_' : '_' : []) = tok 8 (CTokGnuC GnuCComplexReal)+idkwtok ('r' : 'e' : 'g' : 'i' : 's' : 't' : 'e' : 'r' : []) = tok 8 CTokRegister+idkwtok ('_' : '_' : 'r' : 'e' : 's' : 't' : 'r' : 'i' : 'c' : 't' : []) = tok 10 CTokRestrict+idkwtok ('r' : 'e' : 's' : 't' : 'r' : 'i' : 'c' : 't' : []) = tok 8 CTokRestrict+idkwtok ('_' : '_' : 'r' : 'e' : 's' : 't' : 'r' : 'i' : 'c' : 't' : '_' : '_' : []) = tok 12 CTokRestrict+idkwtok ('r' : 'e' : 't' : 'u' : 'r' : 'n' : []) = tok 6 CTokReturn+idkwtok ('s' : 'h' : 'o' : 'r' : 't' : []) = tok 5 CTokShort+idkwtok ('_' : '_' : 's' : 'i' : 'g' : 'n' : 'e' : 'd' : []) = tok 8 CTokSigned+idkwtok ('s' : 'i' : 'g' : 'n' : 'e' : 'd' : []) = tok 6 CTokSigned+idkwtok ('_' : '_' : 's' : 'i' : 'g' : 'n' : 'e' : 'd' : '_' : '_' : []) = tok 10 CTokSigned+idkwtok ('s' : 'i' : 'z' : 'e' : 'o' : 'f' : []) = tok 6 CTokSizeof+idkwtok ('s' : 't' : 'a' : 't' : 'i' : 'c' : []) = tok 6 CTokStatic+idkwtok ('s' : 't' : 'r' : 'u' : 'c' : 't' : []) = tok 6 CTokStruct+idkwtok ('s' : 'w' : 'i' : 't' : 'c' : 'h' : []) = tok 6 CTokSwitch+idkwtok ('_' : '_' : 't' : 'h' : 'r' : 'e' : 'a' : 'd' : []) = tok 8 CTokThread+idkwtok ('t' : 'y' : 'p' : 'e' : 'd' : 'e' : 'f' : []) = tok 7 CTokTypedef+idkwtok ('_' : '_' : 't' : 'y' : 'p' : 'e' : 'o' : 'f' : []) = tok 8 CTokTypeof+idkwtok ('t' : 'y' : 'p' : 'e' : 'o' : 'f' : []) = tok 6 CTokTypeof+idkwtok ('_' : '_' : 't' : 'y' : 'p' : 'e' : 'o' : 'f' : '_' : '_' : []) = tok 10 CTokTypeof+idkwtok ('u' : 'n' : 'i' : 'o' : 'n' : []) = tok 5 CTokUnion+idkwtok ('u' : 'n' : 's' : 'i' : 'g' : 'n' : 'e' : 'd' : []) = tok 8 CTokUnsigned+idkwtok ('v' : 'o' : 'i' : 'd' : []) = tok 4 CTokVoid+idkwtok ('_' : '_' : 'v' : 'o' : 'l' : 'a' : 't' : 'i' : 'l' : 'e' : []) = tok 10 CTokVolatile+idkwtok ('v' : 'o' : 'l' : 'a' : 't' : 'i' : 'l' : 'e' : []) = tok 8 CTokVolatile+idkwtok ('_' : '_' : 'v' : 'o' : 'l' : 'a' : 't' : 'i' : 'l' : 'e' : '_' : '_' : []) = tok 12 CTokVolatile+idkwtok ('w' : 'h' : 'i' : 'l' : 'e' : []) = tok 5 CTokWhile+idkwtok ('@' : 'i' : 'n' : 't' : 'e' : 'r' : 'f' : 'a' : 'c' : 'e' : [] ) = tok 10 (CTokObjC ObjCInterface)+idkwtok ('@' : 'i' : 'm' : 'p' : 'l' : 'e' : 'm' : 'e' : 'n' : 't' : 'a' : 't' : 'i' : 'o' : 'n' : [] ) = tok 15 (CTokObjC ObjCImplementation)+idkwtok ('@' : 'e' : 'n' : 'd' : [] )       = tok 4  (CTokObjC ObjCEnd)+idkwtok ('@' : 'r' : 'e' : 'q' : 'u' : 'i' : 'r' : 'e' : 'd' : [] )  = tok 9  (CTokObjC ObjCRequired)+idkwtok ('@' : 'o' : 'p' : 't' : 'i' : 'o' : 'n' : 'a' : 'l' : [] )  = tok 9  (CTokObjC ObjCOptional)+idkwtok ('@' : 's' : 'e' : 'l' : 'e' : 'c' : 't' : 'o' : 'r' : [] )  = tok 9  (CTokObjC ObjCSelector)+idkwtok ('@' : 'p' : 'r' : 'o' : 't' : 'o' : 'c' : 'o' : 'l' : [] )  = tok 9  (CTokObjC ObjCProtocol)+idkwtok ('@' : 'e' : 'n' : 'c' : 'o' : 'd' : 'e' : [] )    = tok 7  (CTokObjC ObjCEncode)+idkwtok ('@' : 'c' : 'l' : 'a' : 's' : 's' : [] )     = tok 6  (CTokObjC ObjCClass)+idkwtok ('@' : 'p' : 'r' : 'i' : 'v' : 'a' : 't' : 'e' : [] )   = tok 8  (CTokObjC ObjCPriv)+idkwtok ('@' : 'p' : 'r' : 'o' : 'p' : 'e' : 'r' : 't' : 'y' : [] )  = tok 9  (CTokObjC ObjCProperty)+idkwtok ('@' : 'p' : 'r' : 'o' : 't' : 'e' : 'c' : 't' : 'e' : 'd' : [] ) = tok 10 (CTokObjC ObjCProt)+idkwtok ('@' : 'p' : 'u' : 'b' : 'l' : 'i' : 'c' : [] )    = tok 7  (CTokObjC ObjCPub)+idkwtok ('@' : 'p' : 'a' : 'c' : 'k' : 'a' : 'g' : 'e' : [] )   = tok 8  (CTokObjC ObjCPackage)+idkwtok ('i' : 'n' : [] )                             = tok 2  (CTokObjC ObjCIn)+idkwtok ('o' : 'u' : 't' : [] )                       = tok 3  (CTokObjC ObjCOut)+idkwtok ('i' : 'n' : 'o' : 'u' : 't' : [] )           = tok 5  (CTokObjC ObjCInOut)+idkwtok ('o' : 'n' : 'e' : 'w' : 'a' : 'y' : [] )     = tok 6  (CTokObjC ObjCOneway)+idkwtok ('b' : 'y' : 'c' : 'o' : 'p' : 'y' : [] )     = tok 6  (CTokObjC ObjCBycopy)+idkwtok ('s' : 'u' : 'p' : 'e' : 'r' : [] )           = tok 5  (CTokObjC ObjCSuper)++idkwtok cs = \ (!pos) -> do+  name <- getNewName+  let len = case length cs of l -> l+  let ident = mkIdent pos cs name+  idType  <- isSpecial ident+  return $ case idType of+    Nothing    -> CTokIdent   (PL pos len) ident+    Just TyDef -> CTokTyIdent (PL pos len) ident+    Just CName -> CTokObjC (ObjCClassIdent ident) (PL pos len)++ignoreAttribute :: P ()+ignoreAttribute = skipTokens (0::Int)+  where skipTokens :: Int -> P ()+        skipTokens n = do+          tok <- lexToken' False+          case tok of+            CTokRParen _ | n == 1    -> return ()+                         | otherwise -> skipTokens (n-1)+            CTokLParen _             -> skipTokens (n+1)+            _                        -> skipTokens n++tok :: Int -> (PosLength -> CToken) -> Position -> LP s CToken+tok len tc !pos = return (tc (PL pos len))++adjustLineDirective :: Int -> String -> Position -> Position+adjustLineDirective pragmaLen str pos =+    offs' `seq` fname' `seq` row' `seq` (position offs' fname' row' 1)+    where+    offs'           = (posOffset pos) + pragmaLen+    str'            = dropWhite . drop 1 $ str+    (rowStr, str'') = span isDigit str'+    row'        = read rowStr+    str'''      = dropWhite str''+    fnameStr    = takeWhile (/= '"') . drop 1 $ str'''+    fname       = posFile pos+    fname'      | null str''' || head str''' /= '"' = fname+     -- try and get more sharing of file name strings+     | fnameStr == fname     = fname+     | otherwise             = fnameStr+    --+    dropWhite = dropWhile (\c -> c == ' ' || c == '\t')++-- special utility for the lexer+unescapeMultiChars :: String -> [Char]+unescapeMultiChars cs@(_ : _ : _) = case unescapeChar cs of (c,cs') -> c : unescapeMultiChars cs'+unescapeMultiChars ('\'' : []) = []+unescapeMultiChars _ = error "Unexpected end of multi-char constant"++{-# INLINE token_ #-}+-- token that ignores the string+token_ :: Int -> (PosLength -> CToken) -> Position -> Int -> InputStream -> LP s CToken+token_ len tok !pos _ _ = return (tok (PL pos len))++{-# INLINE token_fail #-}+-- error token+token_fail :: String -> Position ->+              Int -> InputStream -> LP s CToken+token_fail errmsg pos _ _ =   failP pos [ "Lexical Error !", errmsg ]+++{-# INLINE token #-}+-- token that uses the string+token :: (PosLength -> a -> CToken) -> (String -> a)+      -> Position -> Int -> InputStream -> LP s CToken+token tok read !pos len str = return (tok (PL pos len) (read $ takeChars len str))++{-# INLINE token_plus #-}+-- token that may fail+token_plus :: (PosLength -> a -> CToken) -> (String -> Either String a)+      -> Position -> Int -> InputStream -> LP s 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 (PL pos len) ok++-- -----------------------------------------------------------------------------+-- The input type++type AlexInput = (Position,   -- current position,+                  InputStream)     -- current input string++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar _ = error "alexInputPrevChar not used"++-- for alex-3.0+alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)+alexGetByte (p,is) | inputStreamEmpty is = Nothing+                   | otherwise  = let (b,s) = takeByte is in+                                  -- this is safe for latin-1, but ugly+                                  let !p' = alexMove p (chr (fromIntegral b)) in p' `seq`+                                  Just (b, (p', s))++alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar (p,is) | inputStreamEmpty is = Nothing+                   | otherwise  = let (c,s) = takeChar is in+                                  let !p'   = alexMove p c in p' `seq`+                                  Just (c, (p', s))++alexMove :: Position -> Char -> Position+alexMove pos ' '  = incPos pos 1+alexMove pos '\n' = retPos pos+alexMove pos '\r' = incOffset pos 1+alexMove pos _    = incPos pos 1++lexicalError :: LP s a+lexicalError = do+  pos <- getPos+  (c,cs) <- liftM takeChar getInput+  failP pos+        ["Lexical error !",+         "The character " ++ show c ++ " does not fit here."]++parseError :: LP s a+parseError = do+  tok <- getLastToken+  failP (posOf tok)+        ["Syntax error !",+         "The symbol `" ++ show tok ++ "' does not fit here."]++-- there is a problem with ignored tokens here (that aren't skipped)+-- consider+-- 1 > int x;+-- 2 > LINE "ex.c" 4+-- 4 > int y;+-- when we get to LINE, we have [int (1,1),x (1,4)] in the token cache.+-- Now we run+-- > action  (pos 2,0) 14 "LINE \"ex.c\" 3\n"+-- which in turn adjusts the position and then calls lexToken again+-- we get `int (pos 4,0)', and have [x (1,4), int (4,1) ] in the token cache (fine)+-- but then, we again call setLastToken when returning and get [int (4,1),int (4,1)] in the token cache (bad)+-- to resolve this, recursive calls invoke lexToken' False.+lexToken :: P CToken+lexToken = lexToken' True++lexToken' :: Bool -> P CToken+lexToken' modifyCache = do+  !pos <- getPos+  inp <- getInput+  case alexScan (pos, inp) 0 of+    AlexEOF -> do+        handleEofToken+        return CTokEof+    AlexError inp' -> lexicalError+    AlexSkip  (pos', inp') len -> do+        setPos pos'+        setInput inp'+        lexToken' modifyCache+    AlexToken (pos', inp') len action -> do+        setPos pos'+        setInput inp'+        tok <- action pos len inp+        when modifyCache $ setLastToken tok+        return tok++lexC :: (CToken -> P a) -> P a+lexC cont = do+  tok <- lexToken+  cont tok+}
+ src/Language/ObjC/Parser/Parser.y view
@@ -0,0 +1,2785 @@+-----------------------------------------------------------------------------+-- Module      :  Parser.y+-- Copyright   :  (c) 2005-2007 Duncan Coutts+--                (c) 2008 Benedikt Huber+--                (c) [1999..2004] Manuel M T Chakravarty+--                (c) 2012 John W. Lato+--                Portions copyright 1989, 1990 James A. Roskind+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Portability :  portable+--+--  Parser for C translation units, which have already been run through the C+--  preprocessor. It is recommended to use the `strict' flag for happy.+--+--  The parser recognizes all of ISO C 99 and most GNU C extensions.+--+--  With C99 we refer to the ISO C99 standard, specifically the section numbers+--  used below refer to this report:+--+--    <http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf>+--+-- GNU extensions are documented in the gcc parser+--+--    <http://gcc.gnu.org/viewcvs/trunk/gcc/c-parser.c>+--+-- and in: <http://gcc.gnu.org/onlinedocs/gcc/C-Extensions.html>+--+-- The set of supported extensions is documented in+--+--    <http://www.sivity.net/projects/language.c/wiki/Cee>+------------------------------------------------------------------+{+module Language.ObjC.Parser.Parser (+  -- * Parse a C translation unit+  parseC, parseLazyC,+  -- * Exposed Parsers+  translUnitP, extDeclP, statementP, expressionP+) where++-- Relevant C99 sections:+--+-- 6.5 Expressions .1 - .17 and 6.6 (almost literally)+--  Supported GNU extensions:+--     - Allow a compound statement as an expression+--     - Various __builtin_* forms that take type parameters+--     - `alignof' expression or type+--     - `__extension__' to suppress warnings about extensions+--     - Allow taking address of a label with: && label+--     - Omitting the `then' part of conditional expressions+--     - complex numbers+--+-- 6.7 C Declarations .1 -.8+--  Supported GNU extensions:+--     - '__thread' thread local storage (6.7.1)+--+-- 6.8 Statements .1 - .8+--  Supported GNU extensions:+--    - case ranges (C99 6.8.1)+--    - '__label__ ident;' declarations (C99 6.8.2)+--    - computed gotos (C99 6.8.6)+--+-- 6.9 Translation unit+--  Supported GNU extensions:+--     - allow empty translation_unit+--     - allow redundant ';'+--     - allow extension keyword before external declaration+--     - asm definitions+--+--  Since some of the grammar productions are quite difficult to read,+--  (especially those involved with the decleration syntax) we document them+--  with an extended syntax that allows a more consise representation:+--+--  Ordinary rules+--+--   foo      named terminal or non-terminal+--+--   'c'      terminal, literal character token+--+--   A B      concatenation+--+--   A | B    alternation+--+--   (A)      grouping+--+--  Extended rules+--+--   A?       optional, short hand for (A|) or [A]{ 0==A || 1==A }+--+--   ...      stands for some part of the grammar omitted for clarity+--+--   {A}      represents sequences, 0 or more.+--+--   <permute> modifier which states that any permutation of the immediate subterms is valid+--+--+--- TODO ----------------------------------------------------------------------+--+--  !* We ignore the C99 static keyword (see C99 6.7.5.3)+--  !* We do not distinguish in the AST between incomplete array types and+--      complete variable length arrays ([ '*' ] means the latter). (see C99 6.7.5.2)+--  !* The AST doesn't allow recording __attribute__ of unnamed struct field+--     (see , struct_default_declaring_list, struct_identifier_declarator)+--  !* see `We're being far to liberal here' (... struct definition within structs)+--  * Documentation isn't complete and consistent yet.++import Prelude    hiding (reverse)+import qualified Data.List as List+import Control.Monad (mplus)+import Language.ObjC.Parser.Builtin   (builtinTypeNames)+import Language.ObjC.Parser.Lexer     (lexC, parseError)+import Language.ObjC.Parser.Tokens    (CToken(..), GnuCTok(..), ObjCTok (..), posLenOfTok)+import Language.ObjC.Parser.ParserMonad++import Language.ObjC.Data.RList+import Language.ObjC.Data.InputStream+import Language.ObjC.Data.Ident+import Language.ObjC.Data.Name+import Language.ObjC.Data.Node+import Language.ObjC.Data.Position+import Language.ObjC.Syntax++}+-- in order to document the parsers, we have to alias them+%name translation_unit translation_unit+%name lazy_translation_unit lazy_translation_unit+%name external_declaration external_declaration+%name statement statement+%name expression expression++%tokentype { CToken }++%monad { P } { >>= } { return }+%lexer { lexC } { CTokEof }++-- expected conflicts:+--  inherited from language-objc, this is ok+--  1.  if '(' expression ')' statement . else  -- probably ok+-- +--    the next two should be fixed if possible, they're related to+--    objective-C method definitions, and require more brainpower.+--  2.  struct_or_union attrs_opt identifier . '{'+--  3.  enum attrs_opt identifier . '{'+--+--  this one is from Obj-C, and is ok.+--  4.  "@implementation" class_name '(' ident . ')'+%expect 4++%token++'('		{ CTokLParen	_ }+')'		{ CTokRParen	_ }+'['		{ CTokLBracket	_ }+']'		{ CTokRBracket	_ }+"->"		{ CTokArrow	_ }+'.'		{ CTokDot	_ }+'!'		{ CTokExclam	_ }+'~'		{ CTokTilde	_ }+"++"		{ CTokInc	_ }+"--"		{ CTokDec	_ }+'+'		{ CTokPlus	_ }+'-'		{ CTokMinus	_ }+'*'		{ CTokStar	_ }+'/'		{ CTokSlash	_ }+'%'		{ CTokPercent	_ }+'&'		{ CTokAmper	_ }+"<<"		{ CTokShiftL	_ }+">>"		{ CTokShiftR	_ }+'<'		{ CTokLess	_ }+"<="		{ CTokLessEq	_ }+'>'		{ CTokHigh	_ }+">="		{ CTokHighEq	_ }+"=="		{ CTokEqual	_ }+"!="		{ CTokUnequal	_ }+'^'		{ CTokHat	_ }+'|'		{ CTokBar	_ }+"&&"		{ CTokAnd	_ }+"||"		{ CTokOr	_ }+'?'		{ CTokQuest	_ }+':'		{ CTokColon	_ }+'='		{ CTokAssign	_ }+"+="		{ CTokPlusAss	_ }+"-="		{ CTokMinusAss	_ }+"*="		{ CTokStarAss	_ }+"/="		{ CTokSlashAss	_ }+"%="		{ CTokPercAss	_ }+"&="		{ CTokAmpAss	_ }+"^="		{ CTokHatAss	_ }+"|="		{ CTokBarAss	_ }+"<<="		{ CTokSLAss	_ }+">>="		{ CTokSRAss	_ }+','		{ CTokComma	_ }+';'		{ CTokSemic	_ }+'{'		{ CTokLBrace	_ }+'}'		{ CTokRBrace	_ }+"..."		{ CTokEllipsis	_ }+alignof		{ CTokAlignof	_ }+asm		{ CTokAsm	_ }+auto		{ CTokAuto	_ }+break		{ CTokBreak	_ }+"_Bool"		{ CTokBool	_ }+case		{ CTokCase	_ }+char		{ CTokChar	_ }+const		{ CTokConst	_ }+continue	{ CTokContinue	_ }+"_Complex"	{ CTokComplex	_ }+default		{ CTokDefault	_ }+do		{ CTokDo	_ }+double		{ CTokDouble	_ }+else		{ CTokElse	_ }+enum		{ CTokEnum	_ }+extern		{ CTokExtern	_ }+float		{ CTokFloat	_ }+for		{ CTokFor	_ }+goto		{ CTokGoto	_ }+if		{ CTokIf	_ }+inline		{ CTokInline	_ }+int		{ CTokInt	_ }+long		{ CTokLong	_ }+"__label__"	{ CTokLabel	_ }+register	{ CTokRegister	_ }+restrict	{ CTokRestrict	_ }+return		{ CTokReturn	_ }+short		{ CTokShort	_ }+signed		{ CTokSigned	_ }+sizeof		{ CTokSizeof	_ }+static		{ CTokStatic	_ }+struct		{ CTokStruct	_ }+switch		{ CTokSwitch	_ }+typedef		{ CTokTypedef	_ }+typeof		{ CTokTypeof	_ }+"__thread"	{ CTokThread	_ }+union		{ CTokUnion	_ }+unsigned	{ CTokUnsigned	_ }+void		{ CTokVoid	_ }+volatile	{ CTokVolatile	_ }+while		{ CTokWhile	_ }+cchar		{ CTokCLit   _ _ }		-- character constant+cint		{ CTokILit   _ _ }		-- integer constant+cfloat		{ CTokFLit   _ _ }		-- float constant+cstr		{ CTokSLit   _ _ }		-- string constant (no escapes)+ident		{ CTokIdent  _ $$ }		-- identifier+tyident		{ CTokTyIdent _ $$ }		-- `typedef-name' identifier+"__attribute__"	{ CTokGnuC GnuCAttrTok _ }	-- special GNU C tokens+"__extension__"	{ CTokGnuC GnuCExtTok  _ }	-- special GNU C tokens+"__real__"        { CTokGnuC GnuCComplexReal _ }+"__imag__"        { CTokGnuC GnuCComplexImag _ }+-- special GNU C builtin 'functions' that actually take types as parameters:+"__builtin_va_arg"		{ CTokGnuC GnuCVaArg    _ }+"__builtin_offsetof"		{ CTokGnuC GnuCOffsetof _ }+"__builtin_types_compatible_p"	{ CTokGnuC GnuCTyCompat _ }+"@class"        { CTokObjC ObjCClass        	_ }+"@interface"    { CTokObjC ObjCInterface	_ }+"@implementation" { CTokObjC ObjCImplementation	_ }+"@property"     { CTokObjC ObjCProperty 	_ }+"@end"          { CTokObjC ObjCEnd          	_ }+"@required"     { CTokObjC ObjCRequired         _ }+"@optional"     { CTokObjC ObjCOptional         _ }+"@selector"     { CTokObjC ObjCSelector         _ }+"@protocol"     { CTokObjC ObjCProtocol         _ }+"@encode"       { CTokObjC ObjCEncode          	_ }+classname       { CTokObjC (ObjCClassIdent $$)  _ } -- `class' identifier+"@private"      { CTokObjC ObjCPriv          	_ }+"@protected"    { CTokObjC ObjCProt          	_ }+"@public"       { CTokObjC ObjCPub          	_ }+"@package"      { CTokObjC ObjCPackage          _ }+"in"            { CTokObjC ObjCIn               _ }+"out"           { CTokObjC ObjCOut              _ }+"inout"         { CTokObjC ObjCInOut            _ }+"oneway"        { CTokObjC ObjCOneway           _ }+"bycopy"        { CTokObjC ObjCBycopy           _ }+"super"         { CTokObjC ObjCSuper            _ }+nsstr		{ CTokObjC (ObjCNSSLit _)       _ }  -- NSString constant (no escapes)++%%+++-- parse a complete Objective-C translation unit+-- we have to take special care of empty translation units+translation_unit :: { CTranslUnit }+translation_unit+  : ext_decl_list	{% let decls = reverse $1 in+                       case decls of+                           []     -> do{ n <- getNewName; p <- getCurrentPosition; return $ CTranslUnit decls (mkNodeInfo' p (p,0) n) }+                           (d:ds) -> withNodeInfo d $ CTranslUnit decls }++-- parse a complete Objective-C translation unit lazily+lazy_translation_unit :: { () }+lazy_translation_unit+  : {- empty -}                                 { () }+  | lazy_translation_unit ';'                   { () }+  | lazy_translation_unit external_declaration  {% parsedLazily $2 >> return () }+++-- parse a list of external declarations, making up a C translation unit (C99 6.9)+--+-- * GNU extensions:+--     allow empty translation_unit+--     allow redundant ';'+--+ext_decl_list :: { Reversed [CExtDecl] }+ext_decl_list+  : {- empty -}                         { empty }+  | ext_decl_list ';'                   { $1 }+  | ext_decl_list external_declaration  { $1 `snoc` $2 }+++-- parse external C declaration (C99 6.9)+--+-- * GNU extensions:+--     allow extension keyword before external declaration+--     asm definitions+external_declaration :: { CExtDecl }+external_declaration+  : function_definition		              { CFDefExt $1 }+  | declaration			              { CDeclExt $1 }+  | class_list			              { ObjCClassExt $1 }+  | class_interface                           { ObjCIfaceExt $1 }+  | class_implementation                      { ObjCImplExt $1 }+  | category_dec                              { ObjCCatExt $1 }+  | category_impl                             { ObjCCatImplExt $1 }+  | proto_dec                                 { ObjCProtoExt $1 }+  | "__extension__" external_declaration  { $2 }+  | asm '(' string_literal ')' ';'		  {% withNodeInfo $1 $ CAsmExt $3 }++proto_dec :: { ObjCProtoDec }+proto_dec+  : "@protocol" plist ';'+      {% withNodeInfo $1 $ ObjCForwardProtoDec (reverse $2) [] }+  | "@protocol" ident opt_proto_ref_list proto_decs "@end"+      {% withNodeInfo $1 $ ObjCProtoDec $2 (reverse $3) ( reverse $4) [] }+  | "@protocol" classname opt_proto_ref_list proto_decs "@end"+      {% withNodeInfo $1 $ ObjCProtoDec $2 (reverse $3) ( reverse $4) [] }++  -- protocol declarations with optional heading attributes+  | attrs "@protocol" plist ';'+      {% withNodeInfo $1 $ ObjCForwardProtoDec (reverse $3) $1 }+  | attrs "@protocol" ident opt_proto_ref_list proto_decs "@end"+      {% withNodeInfo $1 $ ObjCProtoDec $3 (reverse $4) ( reverse $5) $1 }+  | attrs "@protocol" classname opt_proto_ref_list proto_decs "@end"+      {% withNodeInfo $1 $ ObjCProtoDec $3 (reverse $4) ( reverse $5) $1 }++proto_decs :: { Reversed [ObjCProtoDeclBlock] }+proto_decs+  : proto_decs  preq    { $1 `snoc` $2 }+  | proto_decs  popt    { $1 `snoc` $2 }+  | pdef                { singleton $1 }+  |                     { empty        }+++preq :: { ObjCProtoDeclBlock }+  : "@required" nonempty_interface_declaration_list+       {% withNodeInfo $1 $ ObjCReqProtoBlock (reverse $2) }++popt :: { ObjCProtoDeclBlock }+  : "@optional" nonempty_interface_declaration_list+       {% withNodeInfo $1 $ ObjCOptProtoBlock (reverse $2) }++pdef :: { ObjCProtoDeclBlock }+  : nonempty_interface_declaration_list+       {% withNodeInfo $1 $ ObjCProtoDeclBlock (reverse $1) }++plist :: { Reversed [Ident] }+plist+  : identifier                  { singleton $1 }+  | classname                   { singleton $1 }+  | plist ',' identifier       { $1 `snoc` $3 }+  | plist ',' classname        { $1 `snoc` $3 }++-- parse an Objective-C class list (ObjC)+class_list :: { ObjCClassDef }+class_list+  : "@class" class_declarator_list ';'+        {% withNodeInfo $1 $ ObjCClassDef (reverse $2) }++-- parse a comma-separated list of class declarators+class_declarator_list :: { Reversed [ObjCClassDeclr] }+class_declarator_list+  : class_declarator                            { singleton $1 }+  | class_declarator_list ',' class_declarator	{ $1 `snoc` $3 }++-- an Objective-C category defintion+category_dec :: { ObjCCatDec }+category_dec+  : "@interface" ident_or_class_or_typedef '(' ident_or_class_or_typedef ')' opt_proto_ref_list interface_declaration_list "@end"+      {% withNodeInfo $1 $ ObjCCatDec $2 $4 (reverse $6) (reverse $7) [] }+  | attrs "@interface" ident_or_class_or_typedef '(' ident_or_class_or_typedef ')' opt_proto_ref_list interface_declaration_list "@end"+      {% withNodeInfo $1 $ ObjCCatDec $3 $5 (reverse $7) (reverse $8) $1 }++ident_or_class_or_typedef :: { Ident }+  : ident      { $1 }+  | tyident    { $1 }+  | classname  { $1 }++class_implementation :: { ObjCImpl }+class_implementation+  : "@implementation" class_name ':' class_name instance_variables impl_def_list "@end"+  	{% (withNodeInfo $1 $ ObjCImpl $2 (Just $4) (reverse $5) (reverse $6)) }+  | "@implementation" class_name '{' instance_var_block_list '}' impl_def_list "@end"+  	{% (withNodeInfo $1 $ ObjCImpl $2 Nothing (reverse $4) (reverse $6)) }+  | "@implementation" class_name nonE_impl_def_list "@end"+  	{% (withNodeInfo $1 $ ObjCImpl $2 Nothing [] (reverse $3)) }+  | "@implementation" class_name "@end"+  	{% (withNodeInfo $1 $ ObjCImpl $2 Nothing [] []) }++category_impl :: { ObjCCatImpl }+category_impl+  : "@implementation" classname '(' ident ')' impl_def_list "@end"+  	{% (withNodeInfo $1 $ ObjCCatImpl $2 $4 (reverse $6) ) }++-- parse an interface declaration (ObjC)+-- +class_interface :: { ObjCIface }+class_interface+  : "@interface" class_declarator opt_superclass opt_proto_ref_list instance_variables interface_declaration_list "@end"+  	{% (withNodeInfo $1 $ ObjCIface $2 $3 (reverse $4) (reverse $5) (reverse $6) [] ) }+  | attrs "@interface" class_declarator opt_superclass opt_proto_ref_list instance_variables interface_declaration_list "@end"+  	{% (withNodeInfo $1 $ ObjCIface $3 $4 (reverse $5) (reverse $6) (reverse $7) $1 ) }++-- an optional superclass declaration+opt_superclass :: { Maybe ObjCClassNm }+opt_superclass+  : ':' class_name {% return (Just $2) }+  |                {% return Nothing }++-- parse a class name, as specified via @class or @interface+-- +-- class_name :- classname+class_name :: { ObjCClassNm }+class_name+  : classname  {% withNodeInfo $1 (ObjCClassNm $1) }++nonempty_interface_declaration_list :: { Reversed [ObjCIfaceDecl] }+nonempty_interface_declaration_list+  : nonempty_interface_declaration_list interface_declaration { ($1 `snoc` $2) }+  | interface_declaration                                     { singleton $1 }++nonE_impl_def_list :: { Reversed [ObjCImplDef] }+  : nonE_impl_def_list impl_def { ($1 `snoc` $2) }+  | impl_def                    { singleton $1 }++impl_def_list :: { Reversed [ObjCImplDef] }+  : impl_def_list impl_def { ($1 `snoc` $2) }+  |                        { empty }++impl_def :: { ObjCImplDef }+impl_def+  : method_definition         { ObjCImplMethod $1 }+  | function_definition       { ObjCImplFun $1 }+  | declaration               { ObjCImplDec $1 }++-- TODO: currently no support for the optional declaration_list.  These+-- conflict with the parameter_type parsing of method_selector, and the+-- ambiguity is yet to be resolved.+method_definition :: { ObjCMethodDef }+method_definition+  : '+' method_selector compound_statement+      {% let (sel,attrs) = $2 in withNodeInfo $1 (ObjCMethodDef ObjCClassMethod Nothing sel [] $3) }+  | '-' method_selector compound_statement+      {% let (sel,attrs) = $2 in withNodeInfo $1 (ObjCMethodDef ObjCInstanceMethod Nothing sel [] $3) }+  | '+' '(' type_name ')' method_selector compound_statement+      {% let (sel,attrs) = $5 in  withNodeInfo $1 (ObjCMethodDef ObjCClassMethod (Just $3) sel [] $6) }+  | '-' '(' type_name ')' method_selector compound_statement+      {% let (sel,attrs) = $5 in withNodeInfo $1 (ObjCMethodDef ObjCInstanceMethod (Just $3) sel [] $6) }++interface_declaration_list :: { Reversed [ObjCIfaceDecl] }+interface_declaration_list+  : interface_declaration_list interface_declaration { ($1 `snoc` $2) }+  |                                                  { empty }++interface_declaration :: { ObjCIfaceDecl }+interface_declaration+  : "@property" '(' property_modifiers ')' declaration+      {% withNodeInfo $3 (\at -> ObjCPropDecl (reverse $3) $5 at) >>= \pdecl -> withNodeInfo $1 (ObjCIfacePropDecl pdecl) }+  | "@property" declaration+      {% withNodeInfo $2 (\at -> ObjCPropDecl [] $2 at) >>= \pdecl -> withNodeInfo $1 (ObjCIfacePropDecl pdecl) }+  | declaration+      {% withNodeInfo $1 (ObjCIfaceDecl $1) }+  | method_declaration+      {% withNodeInfo $1 (ObjCIfaceMethodDecl $1) }++method_declaration :: { ObjCMethodDecl }+method_declaration+  : '+' method_selector ';'+      {% let (sel,attrs) = $2 in withNodeInfo $1 (ObjCMethodDecl ObjCClassMethod Nothing sel attrs) }+  | '-' method_selector ';'+      {% let (sel,attrs) = $2 in withNodeInfo $1 (ObjCMethodDecl ObjCInstanceMethod Nothing sel attrs) }+  | '+' '(' type_name ')' method_selector ';'+      {% let (sel,attrs) = $5 in  withNodeInfo $1 (ObjCMethodDecl ObjCClassMethod (Just $3) sel attrs) }+  | '-' '(' type_name ')' method_selector ';'+      {% let (sel,attrs) = $5 in withNodeInfo $1 (ObjCMethodDecl ObjCInstanceMethod (Just $3) sel attrs) }++keyword_declarator_list :: { Reversed [ObjCKeyDeclr] }+keyword_declarator_list+  : keyword_declarator                           { singleton $1 }+  | keyword_declarator_list keyword_declarator   { $1 `snoc` $2 }++keyword_declarator :: { ObjCKeyDeclr }+keyword_declarator+  : ':' ident+         {% withNodeInfo $1 (ObjCKeyDeclr Nothing Nothing $2) }+  | ':' '(' type_name ')' ident+         {% withNodeInfo $1 (ObjCKeyDeclr Nothing (Just $3) $5) }+  | selector ':' ident+         {% withNodeInfo $1 (ObjCKeyDeclr (Just $1) Nothing $3) }+  | selector ':' '(' type_name ')' ident+         {% withNodeInfo $1 (ObjCKeyDeclr (Just $1) (Just $4) $6) }++selector :: { ObjCSel }+selector+  : ident      {% withNodeInfo $1 (ObjCSel $1) }+  | tyident    {% withNodeInfo $1 (ObjCSel $1) }+  | classname  {% withNodeInfo $1 (ObjCSel $1) }+  | "in"       {% withNodeInfo $1 ObjCInSel    }+  | "out"      {% withNodeInfo $1 ObjCOutSel   }++selector_name   :: { ObjCSelName }+selector_name+  : selector  {% withNodeInfo $1 $ ObjCSelPlain $1 }+  | keyword_name_list {% withNodeInfo $1 $ ObjCSelKeys (reverse $1) }++keyword_name_list :: { Reversed [ObjCSelKeyName] }+keyword_name_list+  : keyword_name                      { singleton $1 }+  | keyword_name_list keyword_name    { $1 `snoc` $2 }++keyword_name :: { ObjCSelKeyName }+keyword_name+  : selector ':'    {% withNodeInfo $1 $ ObjCSelKeyName (Just $1) }+  | ':'             {% withNodeInfo $1 $ ObjCSelKeyName Nothing   }++method_selector :: { (ObjCMethodSel,[CAttr]) }+method_selector+  : selector  attrs_opt+        {% withNodeInfo $1 $ \at -> (ObjCUnaryMethod $1 at, $2) }+  | keyword_declarator_list attrs_opt+        {% withNodeInfo $1 $ \at -> (ObjCMethod (reverse $1) Nothing at, $2) }+  | keyword_declarator_list ',' parameter_type_list+              {% withNodeInfo $1 $ \at -> (ObjCMethod (reverse $1) (Just $3) at, []) }+  | keyword_declarator_list ',' "..." attrs_opt+        {% withNodeInfo $1 $ \at -> (ObjCEllipseMethod (reverse $1) at, $4) }+++property_modifiers :: { Reversed [ObjCPropMod] }+property_modifiers+  : property_modifier                        { singleton $1 }+  | property_modifiers ',' property_modifier { $1 `snoc` $3 }++property_modifier :: { ObjCPropMod }+property_modifier+  : ident '=' ident+      {% withNodeInfo $1 $ ObjCPropMod $1 (Just $3) }+  | ident+      {% withNodeInfo $1 $ ObjCPropMod $1 Nothing }++-- parse a set of instance variable declarations+instance_variables :: { Reversed [ObjCInstanceVarBlock] }+instance_variables+  : '{' instance_var_block_list '}'  { $2 }+  | '{'                         '}'  { empty }+  |                                  { empty }++instance_var_block_list :: { Reversed [ObjCInstanceVarBlock] }+instance_var_block_list+  : instance_var_block                               { singleton $1 }+  | instance_var_block_list qual_instance_var_block  { ($1 `snoc` $2) }+  +instance_var_block :: { ObjCInstanceVarBlock }+instance_var_block+  : nonempty_struct_declaration_list+      {% withNodeInfo $1 (ObjCInstanceVarBlock Nothing (reverse $1)) }+  | qual_instance_var_block    {% return $1 }++qual_instance_var_block :: { ObjCInstanceVarBlock }+qual_instance_var_block+  : block_vis nonempty_struct_declaration_list+      {% withNodeInfo $1 (ObjCInstanceVarBlock (Just $1) (reverse $2)) }++block_vis :: { ObjCVisSpec }+block_vis+  : "@private"    {% withNodeInfo $1 (ObjCVisSpec ObjCPrivVis)    }+  | "@protected"  {% withNodeInfo $1 (ObjCVisSpec ObjCProtVis)    }+  | "@public"     {% withNodeInfo $1 (ObjCVisSpec ObjCPubVis)     }+  | "@package"    {% withNodeInfo $1 (ObjCVisSpec ObjCPackageVis) }+  | block_vis ';' {% return $1 }++opt_proto_ref_list :: { Reversed [ObjCProtoNm] }+opt_proto_ref_list+  : '<' protocol_ref_list '>'     { $2 }+  |                               { empty }++-- An optional protocol reference list+protocol_ref_list :: { Reversed [ObjCProtoNm] }+protocol_ref_list+  : protocol_ref                                { singleton $1 }+  | protocol_ref_list ',' protocol_ref   	{ ($1 `snoc` $3) }++-- a single protocol reference+-- protocols live in a separate namespace from typedefs and+-- class names, so they're all eligible for protocol names++protocol_ref :: { ObjCProtoNm }+protocol_ref+  : ident+       {% withNodeInfo $1 (ObjCProtoNm $1) }+  | classname+       {% withNodeInfo $1 (ObjCProtoNm $1) }+  | tyident+       {% withNodeInfo $1 (ObjCProtoNm $1) }++-- parse a class declarator+-- +-- class_declarator :- ident | classname+--+class_declarator :: { ObjCClassDeclr }+class_declarator+  : ident+  	{% let cn = $1 in addClass cn >> withNodeInfo $1 (ObjCClassDeclr cn) }+  | classname+        {% withNodeInfo $1 (ObjCClassDeclr $1) }++-- parse C function definition (C99 6.9.1)+--+-- function_definition :- specifiers? fun-declarator compound-statement+--                        specifiers? old-fun-declarator  declaration-list compound-statement+--+-- The specifiers are a list consisting of type-names (int, struct foo, ...),+-- storage-class specifiers (extern, static,...) and type qualifiers (const, volatile, ...).+--+--   declaration_specifier      :- <permute> type-qualifier* storage-class+ typename+    "extern unsigned static volatile int f()"+--   type_specifier             :- <permute> type-qualifier* typename+                   "const int f()", "long int f()"+--   declaration_qualifier_list :- <permute> type_qualifier* storage-class+              "extern static const f()"+--   type_qualifier_list        :- type-qualifier+                                       "const f()"+--+-- * GNU extension:+--    __attribute__ annotations+--+function_definition :: { CFunDef }+function_definition+  :                            function_declarator compound_statement+  	{% leaveScope >> (withNodeInfo $1 $ CFunDef [] $1 [] $2) }++  |                      attrs function_declarator compound_statement+    {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftCAttrs $1) $2 [] $3) }++  | declaration_specifier      function_declarator compound_statement+	  {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) }++  | type_specifier             function_declarator compound_statement+	  {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) }++  | declaration_qualifier_list function_declarator compound_statement+	  {% leaveScope >> (withNodeInfo $1 $ CFunDef (reverse $1) $2 [] $3) }++  | type_qualifier_list   function_declarator compound_statement+	  {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 [] $3) }++  | type_qualifier_list   attrs function_declarator compound_statement+	  {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1 ++ liftCAttrs $2) $3 [] $4) }++  -- old function declarators++  |                            function_declarator_old declaration_list compound_statement+  	{% withNodeInfo $1 $ CFunDef [] $1 (reverse $2) $3 }++  |                      attrs function_declarator_old declaration_list compound_statement+  	{% withNodeInfo $2 $ CFunDef (liftCAttrs $1) $2 (reverse $3) $4 }++  | declaration_specifier      function_declarator_old declaration_list compound_statement+  	{% withNodeInfo $1 $ CFunDef $1 $2 (reverse $3) $4 }++  | type_specifier             function_declarator_old declaration_list compound_statement+  	{% withNodeInfo $1 $ CFunDef $1 $2 (reverse $3) $4 }++  | declaration_qualifier_list function_declarator_old declaration_list compound_statement+  	{% withNodeInfo $1 $ CFunDef (reverse $1) $2 (reverse $3) $4 }++  | type_qualifier_list   function_declarator_old declaration_list compound_statement+  	{% withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 (reverse $3) $4 }++  | type_qualifier_list attrs  function_declarator_old declaration_list compound_statement+  	{% withNodeInfo $1 $ CFunDef (liftTypeQuals $1  ++ liftCAttrs $2) $3 (reverse $4) $5 }++-- Read declarator and put function+function_declarator :: { CDeclr }+function_declarator+  : identifier_declarator+  	{% let declr = reverseDeclr $1 in+  	   enterScope >> doFuncParamDeclIdent declr >> return declr }+++-- parse C statement (C99 6.8)+--+-- * GNU extension: ' __asm__ (...); ' statements+--+statement :: { CStat }+statement+  : labeled_statement			{ $1 }+  | compound_statement		{ $1 }+  | expression_statement	{ $1 }+  | selection_statement		{ $1 }+  | iteration_statement		{ $1 }+  | jump_statement			  { $1 }+  | asm_statement			    {% withNodeInfo $1 (CAsm $1) }+++-- parse C labeled statement (C99 6.8.1)+--+-- * GNU extension: case ranges+--+labeled_statement :: { CStat }+labeled_statement+  : identifier ':' attrs_opt statement		{% withNodeInfo $1 $ CLabel $1 $4 $3 }+  | case constant_expression ':' statement	{% withNodeInfo $1 $ CCase $2 $4 }+  | default ':' statement			{% withNodeInfo $1 $ CDefault $3 }+  | case constant_expression "..." constant_expression ':' statement+  	{% withNodeInfo $1 $ CCases $2 $4 $6 }+++-- parse C compound statement (C99 6.8.2)+--+-- * GNU extension: '__label__ ident;' declarations+--+compound_statement :: { CStat }+compound_statement+  : '{' enter_scope block_item_list leave_scope '}'+  	{% withNodeInfo $1 $ CCompound [] (reverse $3) }++  | '{' enter_scope label_declarations block_item_list leave_scope '}'+  	{% withNodeInfo $1 $ CCompound (reverse $3) (reverse $4) }+++-- No syntax for these, just side effecting semantic actions.+--+enter_scope :: { () }+enter_scope : {% enterScope }+leave_scope :: { () }+leave_scope : {% leaveScope }+++block_item_list :: { Reversed [CBlockItem] }+block_item_list+  : {- empty -}			{ empty }+  | block_item_list block_item	{ $1 `snoc` $2 }++block_item :: { CBlockItem }+block_item+  : statement			{ CBlockStmt $1 }+  | nested_declaration		{ $1 }++nested_declaration :: { CBlockItem }+nested_declaration+  : declaration				{ CBlockDecl $1 }+  | nested_function_definition		{ CNestedFunDef $1 }+  | "__extension__" nested_declaration	{ $2 }++nested_function_definition :: { CFunDef }+nested_function_definition+  : declaration_specifier      function_declarator compound_statement+	{% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) }++  | type_specifier             function_declarator compound_statement+	{% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) }++  | declaration_qualifier_list function_declarator compound_statement+	{% leaveScope >> (withNodeInfo $1 $ CFunDef (reverse $1) $2 [] $3) }++  | type_qualifier_list   function_declarator compound_statement+	{% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 [] $3) }++  | type_qualifier_list   attrs function_declarator compound_statement+	{% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1 ++ liftCAttrs $2) $3 [] $4) }+++label_declarations :: { Reversed [Ident] }+label_declarations+  : "__label__" identifier_list ';'			{ $2  } --TODO+  | label_declarations "__label__" identifier_list ';'	{ $1 `rappendr` $3 }+++-- parse C expression statement (C99 6.8.3)+--+expression_statement :: { CStat }+expression_statement+  : ';'				{% withNodeInfo $1 $ CExpr Nothing }+  | expression ';'		{% withNodeInfo $1 $ CExpr (Just $1) }+++-- parse C selection statement (C99 6.8.4)+--+selection_statement :: { CStat }+selection_statement+  : if '(' expression ')' statement+	{% withNodeInfo $1 $ CIf $3 $5 Nothing }++  | if '(' expression ')' statement else statement+	{% withNodeInfo $1 $ CIf $3 $5 (Just $7) }++  | switch '(' expression ')' statement	+	{% withNodeInfo $1 $ CSwitch $3 $5 }+++-- parse C iteration statement (C99 6.8.5)+--+iteration_statement :: { CStat }+iteration_statement+  : while '(' expression ')' statement+  	{% withNodeInfo $1 $ CWhile $3 $5 False }++  | do statement while '(' expression ')' ';'+  	{% withNodeInfo $1 $ CWhile $5 $2 True }++  | for '(' expression_opt ';' expression_opt ';' expression_opt ')' statement+	{% withNodeInfo $1 $ CFor (Left $3) $5 $7 $9 }++  | for '(' enter_scope declaration expression_opt ';' expression_opt ')' statement leave_scope+	{% withNodeInfo $1 $ CFor (Right $4) $5 $7 $9 }+++-- parse C jump statement (C99 6.8.6)+--+-- * GNU extension: computed gotos+--+jump_statement :: { CStat }+jump_statement+  : goto identifier ';'			{% withNodeInfo $1 $ CGoto $2 }+  | goto '*' expression ';'		{% withNodeInfo $1 $ CGotoPtr $3 }+  | continue ';'			    {% withNodeInfo $1 $ CCont }+  | break ';'				    {% withNodeInfo $1 $ CBreak }+  | return expression_opt ';'	{% withNodeInfo $1 $ CReturn $2 }+++-- parse GNU C __asm__ statement (compatible with C99: J.5.10)+--+-- asm_stmt    :- asm volatile? ( "asm..." : output-operands : input-operands : asm-clobbers )+-- asm_operand :- [operand-name] "constraint" ( expr )+-- asm_clobber :- "r1", "r2", ...+--+asm_statement :: { CAsmStmt }+asm_statement+  : asm maybe_type_qualifier '(' string_literal ')' ';'+  	{% withNodeInfo $1 $ CAsmStmt $2 $4 [] [] [] }++  | asm maybe_type_qualifier '(' string_literal ':' asm_operands ')' ';'+  	{% withNodeInfo $1 $ CAsmStmt $2 $4 $6 [] [] }++  | asm maybe_type_qualifier '(' string_literal ':' asm_operands ':' asm_operands ')' ';'+  	{% withNodeInfo $1 $ CAsmStmt $2 $4 $6 $8 [] }++  | asm maybe_type_qualifier '(' string_literal ':' asm_operands ':' asm_operands ':' asm_clobbers ')' ';'+  	{% withNodeInfo $1 $ CAsmStmt $2 $4 $6 $8 (reverse $10) }+++maybe_type_qualifier :: { Maybe CTypeQual }+maybe_type_qualifier+  : {- empty -}		  { Nothing }+  | type_qualifier	  { Just $1 }++asm_operands :: { [CAsmOperand] }+asm_operands+  : {- empty -}				{ [] }+  | nonnull_asm_operands    { reverse $1 }++nonnull_asm_operands :: { Reversed [CAsmOperand] }+nonnull_asm_operands+  : asm_operand					          { singleton $1 }+  | nonnull_asm_operands ',' asm_operand  { $1 `snoc` $3 }++asm_operand :: { CAsmOperand }+asm_operand+  : string_literal '(' expression ')'			      {% withNodeInfo $1 $ CAsmOperand Nothing $1 $3 }+  | '[' ident ']' string_literal '(' expression ')'   {% withNodeInfo $1 $ CAsmOperand (Just $2) $4 $6 }+  | '[' tyident ']' string_literal '(' expression ')' {% withNodeInfo $1 $ CAsmOperand (Just $2) $4 $6 }+++asm_clobbers :: { Reversed [CStrLit] }+asm_clobbers+  : string_literal			        { singleton $1 }+  | asm_clobbers ',' string_literal	{ $1 `snoc` $3 }++{-+---------------------------------------------------------------------------------------------------------------+---------------------------------------------------------------------------------------------------------------+-- Declarations+---------------------------------------------------------------------------------------------------------------+---------------------------------------------------------------------------------------------------------------++Declarations are the most complicated part of the grammar, and shall be summarized here.+To allow a lightweight notation, we will use the modifier <permute> to indicate that the order of the immidieate right-hand+sides doesn't matter.+ - <permute> a* b+ c   === any sequence of a's, b's and c's, which contains exactly 1 'c' and at least one 'b'++-- storage class and type qualifier+---------------------------------------------------------------------------------------------------------------+attr                       :-   __attribute__((..))+storage_class              :-   typedef | extern | static | auto | register | __thread+type_qualifier             :-   const | volatile | restrict | inline+type_qualifier_list        :-   type_qualifier+++declaration_qualifier      :-   storage_class | type_qualifier+declaration_qualifier_list :-   <permute> type_qualifier* storage_class+++qualifiers                 :-   declaration_qualifier_list | type_qualifier_list+                           :=   <permute> (type_qualifier|storage_class)+++-- type names+---------------------------------------------------------------------------------------------------------------+declaration_specifier      :- <permute> type_qualifier* storage_class+ (basic_type_name+ | elaborated_type_name | tyident )+type_specifier             :- <permute> type_qualifier* (basic_type_name+ | elaborated_type_name | tyident)++specifiers                 :- declaration_specifier | type_specifier+                           := <permute> type_qualifier* storage_class* (basic_type_name+ | elaborated_type_name | tyident )++-- struct/union/enum declarations+---------------------------------------------------------------------------------------------------------------+sue_declaration_specifier :- <permute> type_qualifier* storage_class+ elaborated_type_name+sue_type_specifier        :- <permute> type_qualifier* elaborated_type_name++sue_declaration           := sue_declaration_specifier | sue_type_specifier+                          :- <permute> type_qualifier* storage_class* elaborated_type_name++-- declarators+---------------------------------------------------------------------------------------------------------------+identifier_declarator :- ( '*' (type_qualifier | attr)* ) * ident     [ array_decl | "(" parameter-list ")" ]+                               plus additional parenthesis' ending ^^ here+typedef_declartor     :-+declarator            :- identifier_declarator | typedef_declarator++-- Declaration lists+---------------------------------------------------------------------------------------------------------------+default_declaring_list :- qualifiers ( identifier_declarator asm*attrs* initializer? )_comma_list++declaring_list         :- specifiers ( declarator asm*attrs* initializer? )_comma_list++declaration_list := default_declaring_list | declaring_list++-- Declaration+---------------------------------------------------------------------------------------------------------------+declaration = sue_declaration | declaration_list++---------------------------------------------------------------------------------------------------------------+---------------------------------------------------------------------------------------------------------------+-- Attributes+-- (citing http://gcc.gnu.org/onlinedocs/gcc/Attribute-Syntax.html)+---------------------------------------------------------------------------------------------------------------+---------------------------------------------------------------------------------------------------------------++"Attributes may appear after the colon following a label (expect case and default)"++labeled_statement :- identifier ':' attrs_opt statement++"Attributes may go either immediately after the struct/union/enum keyword or after the closing brace"++struct attrs_opt ...+struct ... { } attrs_opt++"In general: Attributes appear as part of declarations, either belonging to a declaration or declarator"++"Any list of specifiers and qualifiers at the start of a declaration may contain attribute specifiers"+"An attribute list may appear immediately before the comma, = or semicolon terminating a declaration of an identifier"++---------------------------------------------------------------------------------------------------------------+For the parser, we modified the following rules to be interleaved with attributes:++default_declaring_list' :-  (declaration_qualifier_list' | type_qualifier_list' attr*)+                                             identifier_declarator asm*attr* initializer?+                                 { ',' attr* identifier_declarator asm*attr* initializer? }+declaring_list' :-          specifier' declarator asm*attr* initializer?+                                 { ',' attr* declarator asm*attr* initializer? }+++type_qualifier_list' is like type_qualifier_list, but with preceeding and/or interleaving (but not terminating) __attribute__ annotations.+declaration_qualifier_list', declaration_specifier' and type_specifier' are like their unprimed variants, but with arbitrary preceeding, interleaving and/or terminating __attribute__ annotations.++"An attribute list may appear immediately before a declarator other than the first in a comma seperated list of declarators"++"The attribute specifiers may be the only specifiers present (implicit int)" [not supported]++"Attribute specifiers may be mixed with type qualifiers appearing inside the [] of an parameter array declarator"++tbc.+-}++++-- parse C declaration (C99 6.7)+declaration :: { CDecl }+declaration+  : sue_declaration_specifier ';'+  	{% withNodeInfo $1 $ CDecl (reverse $1) [] }++  | sue_type_specifier ';'+  	{% withNodeInfo $1 $ CDecl (reverse $1) [] }++  | declaring_list ';'+  	{% case $1 of CDecl declspecs dies at -> withLength at (CDecl declspecs (List.reverse dies)) }++  | default_declaring_list ';'+  	{% case $1 of CDecl declspecs dies at -> withLength at (CDecl declspecs (List.reverse dies)) }+++declaration_list :: { Reversed [CDecl] }+declaration_list+  : {- empty -}					 { empty }+  | declaration_list declaration { $1 `snoc` $2 }+++-- * SUMMARY: default_declaring_list :- qualifier* identifier_declarator asm_attrs initializer?+--                                                 { ',' identifier_declarator asm_attrs initializer? }+--+-- * GNU extensions+--   __attribute__ annotations imm. before an declarator (see Attribute Syntax, paragraph 11)+--   asm + __attribute__ annotations (end of declarations, see Attribute Syntax, paragraph 12)+--   The assembler annotation is used to specifiy an assembler name for the declarator.+--+default_declaring_list :: { CDecl }+default_declaring_list+  : declaration_qualifier_list identifier_declarator asm_attrs_opt {-{}-} initializer_opt+  	{% let declspecs = reverse $1 in+  	   do{ declr <- withAsmNameAttrs $3 $2+           ; doDeclIdent declspecs declr+           ; withNodeInfo $1 $+                CDecl declspecs [(Just (reverseDeclr declr), $4, Nothing)] }}++  | type_qualifier_list identifier_declarator asm_attrs_opt {-{}-} initializer_opt+  	{% let declspecs = liftTypeQuals $1 in+  	   do{ declr <- withAsmNameAttrs $3 $2+           ; doDeclIdent declspecs declr+           ; withNodeInfo $1 $ CDecl declspecs [(Just (reverseDeclr declr), $4, Nothing)] }}++  | type_qualifier_list attrs identifier_declarator asm_attrs_opt {-{}-} initializer_opt -- FIX 1600+  	{% let declspecs = liftTypeQuals $1 in+  	   do{ declr <- withAsmNameAttrs $4 $3+           ; doDeclIdent declspecs declr+           ; withNodeInfo $1 $ CDecl (declspecs ++ liftCAttrs $2) [(Just (reverseDeclr declr), $5, Nothing)] }}++  -- GNU extension: __attribute__ as the only qualifier+  | attrs identifier_declarator asm_attrs_opt {-{}-} initializer_opt+    {% let declspecs = liftCAttrs $1 in+       do{ declr <- withAsmNameAttrs $3 $2+           ; doDeclIdent declspecs declr+           ; withNodeInfo $1 $ CDecl declspecs [(Just (reverseDeclr declr), $4, Nothing)] }}++  | default_declaring_list ',' attrs_opt identifier_declarator asm_attrs_opt {-{}-} initializer_opt+  	{% case $1 of+             CDecl declspecs dies at -> do+               declr <- withAsmNameAttrs (fst $5, snd $5 ++ $3) $4+               doDeclIdent declspecs declr+               withLength at $ CDecl declspecs ((Just (reverseDeclr declr), $6, Nothing) : dies)  }++-- assembler, followed by attribute annotation+asm_attrs_opt :: { (Maybe CStrLit, [CAttr]) }+asm_attrs_opt+  : asm_opt attrs_opt+  { ($1,$2) }++--+-- SUMMARY: declaring_list :- specifier* declarator asm_attrs initializer?+--                                 { ',' declarator asm_attrs initializer? }+--+-- GNU extensions:+--      __attribute__ annotations imm. before an declarator (see Attribute Syntax, paragraph 11)+--      asm + __attribute__ annotations (end of declarations, see Attribute Syntax, paragraph 12)+--+declaring_list :: { CDecl }+declaring_list+  : declaration_specifier declarator asm_attrs_opt initializer_opt+  	{% do{+  	   declr <- withAsmNameAttrs $3 $2;+  	   doDeclIdent $1 declr;+       withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr declr), $4, Nothing)] }+    }++  | type_specifier declarator asm_attrs_opt initializer_opt+  	{% do{+  	   declr <- withAsmNameAttrs $3 $2;+  	   doDeclIdent $1 declr;+       withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr declr), $4, Nothing)] }+    }++  | declaring_list ',' attrs_opt declarator asm_attrs_opt initializer_opt+  	{% case $1 of+             CDecl declspecs dies at -> do+               declr <- withAsmNameAttrs (fst $5, snd $5 ++ $3) $4+               doDeclIdent declspecs declr+               return (CDecl declspecs ((Just (reverseDeclr declr), $6, Nothing) : dies) at) }+++-- parse C declaration specifiers (C99 6.7)+--+-- * <permute> type_qualifier* storage_class+ (basic_type_name+ | elaborated_type_name | tyident )+--+declaration_specifier :: { [CDeclSpec] }+declaration_specifier+  : basic_declaration_specifier		{ reverse $1 }	-- Arithmetic or void+  | sue_declaration_specifier		{ reverse $1 }	  -- Struct/Union/Enum+  | typedef_declaration_specifier	{ reverse $1 }	-- Typedef+  | classname_declaration_specifier	{ reverse $1 }	-- class name+++-- A mixture of type qualifiers (const, volatile, restrict, inline) and storage class specifiers+-- (extern, static, auto, register, __thread), in any order, but containing at least one storage class specifier.+--+-- declaration_qualifier_list :- <permute> type_qualifier* storage_class++--+-- GNU extensions+--   * arbitrary interleaved __attribute__ annotations+--+declaration_qualifier_list :: { Reversed [CDeclSpec] }+declaration_qualifier_list+  : storage_class+  	{ singleton (CStorageSpec $1) }++  | attrs storage_class+  	{ reverseList (liftCAttrs $1) `snoc` (CStorageSpec $2) }++  | type_qualifier_list storage_class+  	{ rmap CTypeQual $1 `snoc` CStorageSpec $2 }++  | type_qualifier_list attrs storage_class+  	{ (rmap CTypeQual $1 `rappend` liftCAttrs $2) `snoc` CStorageSpec $3 }++  | declaration_qualifier_list declaration_qualifier+  	{ $1 `snoc` $2 }++  | declaration_qualifier_list attr+  	{ addTrailingAttrs $1 $2 }++--+-- declaration_qualifier :- storage_class | type_qualifier+--+declaration_qualifier :: { CDeclSpec }+declaration_qualifier+  : storage_class		{ CStorageSpec $1 }+  | type_qualifier		{ CTypeQual $1 }     -- const or volatile+++-- parse C storage class specifier (C99 6.7.1)+--+-- * GNU extensions: '__thread' thread local storage+--+storage_class :: { CStorageSpec }+storage_class+  : typedef			{% withNodeInfo $1 $ CTypedef }+  | extern			{% withNodeInfo $1 $ CExtern }+  | static			{% withNodeInfo $1 $ CStatic }+  | auto			{% withNodeInfo $1 $ CAuto }+  | register			{% withNodeInfo $1 $ CRegister }+  | "__thread"			{% withNodeInfo $1 $ CThread }+++-- parse C type specifier (C99 6.7.2)+--+-- This recignises a whole list of type specifiers rather than just one+-- as in the C99 grammar.+--+-- type_specifier :- <permute> type_qualifier* (basic_type_name+ | elaborated_type_name | g)+--+type_specifier :: { [CDeclSpec] }+type_specifier+  : basic_type_specifier		{ reverse $1 }	-- Arithmetic or void+  | sue_type_specifier			{ reverse $1 }	-- Struct/Union/Enum+  | typedef_type_specifier		{ reverse $1 }	-- Typedef+  | classname_type_specifier            { reverse $1 }  -- class name++basic_type_name :: { CTypeSpec }+basic_type_name+  : void			{% withNodeInfo $1 $ CVoidType }+  | char			{% withNodeInfo $1 $ CCharType }+  | short			{% withNodeInfo $1 $ CShortType }+  | int				{% withNodeInfo $1 $ CIntType }+  | long			{% withNodeInfo $1 $ CLongType }+  | float			{% withNodeInfo $1 $ CFloatType }+  | double			{% withNodeInfo $1 $ CDoubleType }+  | signed			{% withNodeInfo $1 $ CSignedType }+  | unsigned			{% withNodeInfo $1 $ CUnsigType }+  | "_Bool"			{% withNodeInfo $1 $ CBoolType }+  | "_Complex"			{% withNodeInfo $1 $ CComplexType }+++-- A mixture of type qualifiers, storage class and basic type names in any+-- order, but containing at least one basic type name and at least one storage+-- class specifier.+--+-- basic_declaration_specifier :- <permute> type_qualifier* storage_class+ basic_type_name++--+--   GNU extensions+--     arbitrary interleaved __attribute__ annotations+--+basic_declaration_specifier :: { Reversed [CDeclSpec] }+basic_declaration_specifier+  : declaration_qualifier_list basic_type_name+  	{ $1 `snoc` CTypeSpec $2 }++  | basic_type_specifier storage_class+  	{ $1 `snoc` CStorageSpec $2 }++  | basic_declaration_specifier declaration_qualifier+  	{ $1 `snoc` $2 }++  | basic_declaration_specifier basic_type_name+  	{ $1 `snoc` CTypeSpec $2 }++  | basic_declaration_specifier attr+  	{ addTrailingAttrs $1 $2 }+++-- A mixture of type qualifiers and basic type names in any order, but+-- containing at least one basic type name.+--+-- basic_type_specifier :- <permute> type_qualifier* basic_type_name++--+--   GNU extensions+--     arbitrary interleaved __attribute__ annotations+--+basic_type_specifier :: { Reversed [CDeclSpec] }+basic_type_specifier+  -- Arithmetic or void+  : basic_type_name+  	{ singleton (CTypeSpec $1) }++  | attrs basic_type_name+  	{ (reverseList $ liftCAttrs $1) `snoc` (CTypeSpec $2) }++  | type_qualifier_list basic_type_name+  	{ rmap CTypeQual $1 `snoc` CTypeSpec $2 }++  | type_qualifier_list attrs basic_type_name+  	{ rmap CTypeQual $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec $3 }++  | basic_type_specifier type_qualifier+  	{ $1 `snoc` CTypeQual $2 }++  | basic_type_specifier basic_type_name+  	{ $1 `snoc` CTypeSpec $2 }++  | basic_type_specifier attr+     { addTrailingAttrs $1 $2 }+++-- A named or anonymous struct, union or enum type along with at least one+-- storage class and any mix of type qualifiers.+--+-- * Summary:+--   sue_declaration_specifier :- <permute> type_qualifier* storage_class+ elaborated_type_name+--+sue_declaration_specifier :: { Reversed [CDeclSpec] }+sue_declaration_specifier+  : declaration_qualifier_list elaborated_type_name+  	{ $1 `snoc` CTypeSpec $2 }++  | sue_type_specifier storage_class+  	{ $1 `snoc` CStorageSpec $2 }++  | sue_declaration_specifier declaration_qualifier+  	{ $1 `snoc` $2 }+  	+  | sue_declaration_specifier attr+  	{ addTrailingAttrs $1 $2 }+++-- A struct, union or enum type (named or anonymous) with optional leading and+-- trailing type qualifiers.+--+-- * Summary:+--   sue_type_specifier :- <permute> type_qualifier* elaborated_type_name+--+-- * GNU Extensions: records __attribute__ annotations+--+sue_type_specifier :: { Reversed [CDeclSpec] }+sue_type_specifier+  -- struct/union/enum+  : elaborated_type_name+  	{ singleton (CTypeSpec $1) }++  | attrs elaborated_type_name+  	{ (reverseList $ liftCAttrs $1) `snoc` (CTypeSpec $2) }++  | type_qualifier_list elaborated_type_name+  	{ rmap CTypeQual $1 `snoc` CTypeSpec $2 }++  | type_qualifier_list attrs elaborated_type_name+  	{ rmap CTypeQual  $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec $3 }++  | sue_type_specifier type_qualifier+  	{ $1 `snoc` CTypeQual $2 }+  	+  | sue_type_specifier attr+    { addTrailingAttrs $1 $2 }++-- A typedef'ed type identifier with at least one storage qualifier and any+-- number of type qualifiers+--+-- * Summary:+--   typedef_declaration_specifier :- <permute> type_qualifier* storage_class+ tyident+--+-- * Note:+--   the tyident can also be a: typeof '(' ... ')'+--+typedef_declaration_specifier :: { Reversed [CDeclSpec] }+typedef_declaration_specifier+  : typedef_type_specifier storage_class+  	{ $1 `snoc` CStorageSpec $2 }+  	+  | declaration_qualifier_list tyident+  	{% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (CTypeDef $2 at) }++  | declaration_qualifier_list tyident '<' protocol_ref_list '>'+  	{% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (ObjCTypeProto $2 (reverse $4) at) }++  | declaration_qualifier_list typeof '(' expression ')'+  	{% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (CTypeOfExpr $4 at) }++  | declaration_qualifier_list typeof '(' type_name ')'+  	{% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (CTypeOfType $4 at) }++  | typedef_declaration_specifier declaration_qualifier+  	{ $1 `snoc` $2 }++  | typedef_declaration_specifier attr+  	{ addTrailingAttrs $1 $2 }++-- A class type identifier with at least one storage qualifier and any+-- number of type qualifiers+--+classname_declaration_specifier :: { Reversed [CDeclSpec] }+classname_declaration_specifier+  : classname_type_specifier storage_class+  	{ $1 `snoc` CStorageSpec $2 }+  	+  | declaration_qualifier_list classname opt_proto_ref_list+  	{% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (ObjCClassProto $2 (reverse $3) at) }++  | classname_declaration_specifier declaration_qualifier+  	{ $1 `snoc` $2 }++  | classname_declaration_specifier attr+  	{ addTrailingAttrs $1 $2 }++-- typedef'ed type identifier with optional leading and trailing type qualifiers+--+-- * Summary:+--   type_qualifier* ( tyident | typeof '('...')' ) type_qualifier*+--+typedef_type_specifier :: { Reversed [CDeclSpec] }+typedef_type_specifier+  : tyident+  	{% withNodeInfo $1 $ \at -> singleton (CTypeSpec (CTypeDef $1 at)) }++  | tyident '<' protocol_ref_list '>'+  	{% withNodeInfo $1 $ \at -> singleton (CTypeSpec (ObjCTypeProto $1 (reverse $3) at)) }++  | typeof '(' expression ')'+  	{% withNodeInfo $1 $ \at -> singleton (CTypeSpec (CTypeOfExpr $3 at)) }++  | typeof '(' type_name ')'+  	{% withNodeInfo $1 $ \at -> singleton (CTypeSpec (CTypeOfType $3 at)) }++  | type_qualifier_list tyident+  	{% withNodeInfo $2 $ \at -> rmap CTypeQual  $1 `snoc` CTypeSpec (CTypeDef $2 at) }++  | type_qualifier_list tyident '<' protocol_ref_list '>'+  	{% withNodeInfo $2 $ \at -> rmap CTypeQual  $1 `snoc` CTypeSpec (ObjCTypeProto $2 (reverse $4) at) }++  | type_qualifier_list typeof '(' expression ')'+  	{% withNodeInfo $2 $ \at -> rmap CTypeQual  $1 `snoc` CTypeSpec (CTypeOfExpr $4 at) }++  | type_qualifier_list typeof '(' type_name ')'+  	{% withNodeInfo $2 $ \at -> rmap CTypeQual  $1 `snoc` CTypeSpec (CTypeOfType $4 at) }++  -- repeat with attrs (this could be easier if type qualifier list wouldn't allow leading attributes)+  | attrs tyident+  	{% withNodeInfo $2 $ \at -> reverseList (liftCAttrs $1) `snoc` (CTypeSpec (CTypeDef $2 at)) }++  | attrs tyident '<' protocol_ref_list '>'+  	{% withNodeInfo $2 $ \at -> reverseList (liftCAttrs $1) `snoc` (CTypeSpec (ObjCTypeProto $2 (reverse $4) at)) }++  | attrs typeof '(' expression ')'+  	{% withNodeInfo $1 $ \at -> reverseList (liftCAttrs $1) `snoc`  (CTypeSpec (CTypeOfExpr $4 at)) }++  | attrs typeof '(' type_name ')'+  	{% withNodeInfo $2 $ \at -> reverseList (liftCAttrs $1) `snoc`  (CTypeSpec (CTypeOfType $4 at)) }++  | type_qualifier_list attrs tyident+  	{% withNodeInfo $3 $ \at -> rmap CTypeQual  $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec (CTypeDef $3 at) }++  | type_qualifier_list attrs tyident '<' protocol_ref_list '>'+  	{% withNodeInfo $3 $ \at -> rmap CTypeQual  $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec (ObjCTypeProto $3 (reverse $5) at) }++  | type_qualifier_list attrs typeof '(' expression ')'+  	{% withNodeInfo $3 $ \at -> rmap CTypeQual  $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec (CTypeOfExpr $5 at) }++  | type_qualifier_list attrs typeof '(' type_name ')'+  	{% withNodeInfo $3 $ \at -> rmap CTypeQual  $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec (CTypeOfType $5 at) }++  | typedef_type_specifier type_qualifier+  	{ $1 `snoc` CTypeQual $2 }++  | typedef_type_specifier attr+  	{ addTrailingAttrs $1 $2 }+++-- class name type identifier with optional leading and trailing type qualifiers+--+-- * Summary:+--   type_qualifier* ( classname ) type_qualifier*+--+classname_type_specifier :: { Reversed [CDeclSpec] }+classname_type_specifier+  : classname opt_proto_ref_list+  	{% withNodeInfo $1 $ \at -> singleton (CTypeSpec (ObjCClassProto $1 (reverse $2) at)) }++  | type_qualifier_list classname opt_proto_ref_list+  	{% withNodeInfo $2 $ \at -> rmap CTypeQual  $1 `snoc` CTypeSpec (ObjCClassProto $2 (reverse $3) at) }++  -- repeat with attrs (this could be easier if type qualifier list wouldn't allow leading attributes)+  | attrs classname opt_proto_ref_list+  	{% withNodeInfo $2 $ \at -> reverseList (liftCAttrs $1) `snoc` (CTypeSpec (ObjCClassProto $2 (reverse $3) at)) }++  | type_qualifier_list attrs classname opt_proto_ref_list+  	{% withNodeInfo $3 $ \at -> rmap CTypeQual  $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec (ObjCClassProto $3 (reverse $4) at) }++  | classname_type_specifier type_qualifier+  	{ $1 `snoc` CTypeQual $2 }++  | classname_type_specifier attr+  	{ addTrailingAttrs $1 $2 }+++-- A named or anonymous struct, union or enum type.+--+-- * Summary:+--   (struct|union|enum) (identifier? '{' ... '}' | identifier)+--+elaborated_type_name :: { CTypeSpec }+elaborated_type_name+  : struct_or_union_specifier	{% withNodeInfo $1 $ CSUType $1 }+  | enum_specifier		{% withNodeInfo $1 $ CEnumType $1 }+++-- parse C structure or union declaration (C99 6.7.2.1)+--+-- * Summary:+--    (struct|union) (identifier? '{' ... '}' | identifier)+--+struct_or_union_specifier :: { CStructUnion }+struct_or_union_specifier+  : struct_or_union attrs_opt identifier '{' struct_declaration_list  '}'+  	{% withNodeInfo $1 $ CStruct (unL $1) (Just $3) (Just$ reverse $5) $2 }++  | struct_or_union attrs_opt '{' struct_declaration_list  '}'+  	{% withNodeInfo $1 $ CStruct (unL $1) Nothing   (Just$ reverse $4) $2 }++  | struct_or_union attrs_opt identifier+  	{% withNodeInfo $1 $ CStruct (unL $1) (Just $3) Nothing $2 }+++struct_or_union :: { Located CStructTag }+struct_or_union+  : struct			{ L CStructTag (posOf $1) }+  | union			{ L CUnionTag (posOf $1) }+++struct_declaration_list :: { Reversed [CDecl] }+struct_declaration_list+  : {- empty -}						{ empty }+  | struct_declaration_list ';'				{ $1 }+  | struct_declaration_list struct_declaration		{ $1 `snoc` $2 }++nonempty_struct_declaration_list :: { Reversed [CDecl] }+nonempty_struct_declaration_list+  : struct_declaration                                  { singleton $1 }+  | nonempty_struct_declaration_list ';'                { $1 }+  | nonempty_struct_declaration_list struct_declaration { $1 `snoc` $2 }+++-- parse C structure declaration (C99 6.7.2.1)+--+struct_declaration :: { CDecl }+struct_declaration+  : struct_declaring_list ';'+  	{ case $1 of CDecl declspecs dies at -> CDecl declspecs (List.reverse dies) at }++  | struct_default_declaring_list';'+  	{ case $1 of CDecl declspecs dies at -> CDecl declspecs (List.reverse dies) at }++  | "__extension__" struct_declaration	{ $2 }+++--+--  * Note: doesn't redeclare typedef+--+--  TODO: FIXME: AST doesn't allow recording attributes of unnamed struct members+struct_default_declaring_list :: { CDecl }+struct_default_declaring_list+  : type_qualifier_list attrs_opt struct_identifier_declarator+  	{% withNodeInfo $1 $ case $3 of (d,s) -> CDecl (liftTypeQuals $1 ++ liftCAttrs $2) [(d,Nothing,s)] }++  -- GNU extension: __attribute__ as only type qualifier+  | attrs struct_identifier_declarator+    {% withNodeInfo $1 $ case $2 of (d,s) -> CDecl (liftCAttrs $1) [(d,Nothing,s)] }+  -- attrs_opt apply to the declared object+  | struct_default_declaring_list ',' attrs_opt struct_identifier_declarator+  	{ case $1 of+            CDecl declspecs dies at ->+              case $4 of+                (Just d,s) -> CDecl declspecs ((Just $ appendObjAttrs $3 d,Nothing,s) : dies) at+                (Nothing,s) -> CDecl declspecs ((Nothing,Nothing,s) : dies) at } -- FIXME++-- * GNU extensions:+--     allow anonymous nested structures and unions+--     FIXME: cannot record attribute of unnamed field+struct_declaring_list :: { CDecl }+struct_declaring_list+  : type_specifier struct_declarator attrs_opt+  	{% withNodeInfo $1 $ case $2 of { (Just d,s)  -> CDecl $1 [(Just $! appendObjAttrs $3 d,Nothing,s)]+                                    ; (Nothing,s) -> CDecl $1 [(Nothing,Nothing,s)]  } } {- DO FIXME -}+  | struct_declaring_list ',' attrs_opt struct_declarator attrs_opt+  	{ case $1 of+            CDecl declspecs dies attr ->+              case $4 of+                (Just d,s) -> CDecl declspecs ((Just$ appendObjAttrs ($3++$5) d,Nothing,s) : dies) attr+                (Nothing,s) -> CDecl declspecs ((Nothing,Nothing,s) : dies) attr }++  -- FIXME: We're being far too liberal in the parsing here, we really want to just+  -- allow unnamed struct and union fields but we're actually allowing any+  -- unnamed struct member. Making it allow only unnamed structs or unions in+  -- the parser is far too tricky, it makes things ambiguous. So we'll have to+  -- diagnose unnamed fields that are not structs/unions in a later stage.++  -- Note that a plain type specifier can have a trailing attribute++  | type_specifier+     {% withNodeInfo $1 $ CDecl $1 []  }+++-- parse C structure declarator (C99 6.7.2.1)+--+struct_declarator :: { (Maybe CDeclr, Maybe CExpr) }+struct_declarator+  : declarator					       { (Just (reverseDeclr $1), Nothing) }+  | ':' constant_expression			   { (Nothing, Just $2) }+  | declarator ':' constant_expression { (Just (reverseDeclr $1), Just $3) }++-- FIXME: anonymous bitfield doesn't allow recording of attributes+struct_identifier_declarator :: { (Maybe CDeclr, Maybe CExpr) }+struct_identifier_declarator+  : identifier_declarator				{ (Just (reverseDeclr $1), Nothing) }+  | ':' constant_expression				{ (Nothing, Just $2) }+  | identifier_declarator ':' constant_expression	{ (Just (reverseDeclr $1), Just $3) }+  | struct_identifier_declarator attr+    {  case $1 of {   (Nothing,expr) -> (Nothing,expr) {- FIXME -}+                    ; (Just (CDeclr name derived asmname attrs node), bsz) ->+                                        (Just (CDeclr name derived asmname (attrs++$2) node),bsz)+                  }+    }++-- parse C enumeration declaration (C99 6.7.2.2)+--+-- * Summary:+--   enum (identifier? '{' ... '}' | identifier)+--+enum_specifier :: { CEnum }+enum_specifier+  : enum attrs_opt '{' enumerator_list '}'+  	{% withNodeInfo $1 $ CEnum Nothing   (Just$ reverse $4) $2 }++  | enum attrs_opt '{' enumerator_list ',' '}'+  	{% withNodeInfo $1 $ CEnum Nothing   (Just$ reverse $4) $2 }++  | enum attrs_opt identifier '{' enumerator_list '}'+  	{% withNodeInfo $1 $ CEnum (Just $3) (Just$ reverse $5) $2 }++  | enum attrs_opt identifier '{' enumerator_list ',' '}'+  	{% withNodeInfo $1 $ CEnum (Just $3) (Just$ reverse $5) $2 }++  | enum attrs_opt identifier+  	{% withNodeInfo $1 $ CEnum (Just $3) Nothing $2           }++enumerator_list :: { Reversed [(Ident, Maybe CExpr)] }+enumerator_list+  : enumerator					{ singleton $1 }+  | enumerator_list ',' enumerator		{ $1 `snoc` $3 }+++enumerator :: { (Ident, Maybe CExpr) }+enumerator+  : identifier					{ ($1, Nothing) }+  | identifier '=' constant_expression		{ ($1, Just $3) }+++-- parse C type qualifier (C99 6.7.3)+--+-- Objective-C protocol qualifiers are also acceptable+type_qualifier :: { CTypeQual }+type_qualifier+  : const		{% withNodeInfo $1 $ CConstQual }+  | volatile		{% withNodeInfo $1 $ CVolatQual }+  | restrict		{% withNodeInfo $1 $ CRestrQual }+  | inline		{% withNodeInfo $1 $ CInlineQual }+  | proto_qualifier     { ObjCProtoQual $1 }++proto_qualifier :: { ObjCProtoQual }+proto_qualifier+  : "in"        {% withNodeInfo $1 ObjCInQual }+  | "out"       {% withNodeInfo $1 ObjCOutQual }+  | "inout"     {% withNodeInfo $1 ObjCInOutQual }+  | "oneway"    {% withNodeInfo $1 ObjCOnewayQual }+  | "bycopy"    {% withNodeInfo $1 ObjCBycopyQual }++-- a list containing at least one type_qualifier (const, volatile, restrict, inline)+--    and additionally CAttrs+type_qualifier_list :: { Reversed [CTypeQual] }+type_qualifier_list+  : attrs_opt type_qualifier	             { reverseList (map CAttrQual $1) `snoc` $2 }+  | type_qualifier_list type_qualifier	     { $1 `snoc` $2 }+  | type_qualifier_list attrs type_qualifier { ($1 `rappend` map CAttrQual $2) `snoc` $3}	++-- parse C declarator (C99 6.7.5)+--+declarator :: { CDeclrR }+declarator+  : identifier_declarator		{ $1 }+  | typedef_declarator			{ $1 }+++-- Parse GNU C's asm annotations+--+-- Those annotations allow to give an assembler name to a function or identifier.+asm_opt :: { Maybe CStrLit }+asm_opt+  : {- empty -}				          { Nothing }+  | asm '(' string_literal ')'	{ Just $3 }++--+-- typedef_declarator :-++typedef_declarator :: { CDeclrR }+typedef_declarator+  -- would be ambiguous as parameter+  : paren_typedef_declarator		{ $1 }++  -- not ambiguous as param+  | parameter_typedef_declarator	{ $1 }+++-- parameter_typedef_declarator :- tyident declarator_postfix?+--                              | '(' attrs? clean_typedef_declarator ')' declarator_postfix?+--                              |  '*' attrs? type_qualifier_list? parameter_typedef_declarator+--+parameter_typedef_declarator :: { CDeclrR }+parameter_typedef_declarator+  : tyident+  	{% withNodeInfo $1 $ mkVarDeclr $1 }++  | tyident postfixing_abstract_declarator+  	{% withNodeInfo $1 $ \at -> $2 (mkVarDeclr $1 at) }++  | clean_typedef_declarator+  	{ $1 }+++-- The  following have at least one '*'.+-- There is no (redundant) '(' between the '*' and the tyident.+--+-- clean_typedef_declarator :-  '(' attrs? clean_typedef_declarator ')' declarator_postfix?+--                            | '*' attrs? type_qualifier_list? parameter_typedef_declarator+--+clean_typedef_declarator :: { CDeclrR }+clean_typedef_declarator+  : clean_postfix_typedef_declarator+  	{ $1 }++  | '*' parameter_typedef_declarator+  	{% withNodeInfo $1 $ ptrDeclr $2 [] }++  | '*' attrs parameter_typedef_declarator+  	{% withAttribute $1 $2 $ ptrDeclr $3 [] }++  | '*' type_qualifier_list  parameter_typedef_declarator+  	{% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) }++  | '*' type_qualifier_list attrs parameter_typedef_declarator+  	{% withAttribute $1 $3 $ ptrDeclr $4 (reverse $2)  }++-- clean_postfix_typedef_declarator :- ( attrs? clean_typedef_declarator ) declarator_postfix?+--+clean_postfix_typedef_declarator :: { CDeclrR }+clean_postfix_typedef_declarator+  : '(' clean_typedef_declarator ')'						              { $2 }+  | '(' clean_typedef_declarator ')' postfixing_abstract_declarator		  { $4 $2 }+  | '(' attrs clean_typedef_declarator ')'	                              { appendDeclrAttrs $2 $3 }+  | '(' attrs clean_typedef_declarator ')' postfixing_abstract_declarator { appendDeclrAttrs $2 ($5 $3) }+++-- The following have a redundant '(' placed+-- immediately to the left of the tyident+--+paren_typedef_declarator :: { CDeclrR }+paren_typedef_declarator+  : paren_postfix_typedef_declarator+  	{ $1 }++  -- redundant paren+  | '*' '(' simple_paren_typedef_declarator ')'+  	{% withNodeInfo $1 $ ptrDeclr $3 [] }++  | '*' type_qualifier_list '(' simple_paren_typedef_declarator ')'+  	{% withNodeInfo $1 $ ptrDeclr $4 (reverse $2) }+  | '*' type_qualifier_list attrs '(' simple_paren_typedef_declarator ')'+  	{% withAttribute $1 $3 $ ptrDeclr $5 (reverse $2)  }++  | '*' paren_typedef_declarator+  	{% withNodeInfo $1 $ ptrDeclr $2 [] }++  | '*' type_qualifier_list paren_typedef_declarator+  	{% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) }+  | '*' type_qualifier_list attrs paren_typedef_declarator+  	{% withAttribute $1 $3 $ ptrDeclr $4 (reverse $2) }++-- redundant paren to left of tname+paren_postfix_typedef_declarator :: { CDeclrR }+paren_postfix_typedef_declarator+  : '(' paren_typedef_declarator ')'+  	{ $2 }++  -- redundant paren+  | '(' simple_paren_typedef_declarator postfixing_abstract_declarator ')'+  	{ $3 $2 }++  | '(' paren_typedef_declarator ')' postfixing_abstract_declarator+  	{ $4 $2 }+++-- Just a type name in any number of nested brackets+--+simple_paren_typedef_declarator :: { CDeclrR }+simple_paren_typedef_declarator+  : tyident+  	{% withNodeInfo $1 $ mkVarDeclr $1 }++  | '(' simple_paren_typedef_declarator ')'+  	{ $2 }++--+-- Declarators+-- * Summary+--   declarator :- ( '*' (type_qualifier | attr)* )* ident ( array_decl | "(" parameter-list ")" )?+--      + additional parenthesis+--+identifier_declarator :: { CDeclrR }+identifier_declarator+  : unary_identifier_declarator			{ $1 }+  | paren_identifier_declarator			{ $1 }+++unary_identifier_declarator :: { CDeclrR }+unary_identifier_declarator+  : postfix_identifier_declarator+  	{ $1 }++  | '*' identifier_declarator+  	{% withNodeInfo $1 $ ptrDeclr $2 [] }++  | '*' attrs identifier_declarator+  	{% withAttribute $1 $2 $ ptrDeclr $3 [] }++  | '*' type_qualifier_list identifier_declarator+  	{% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) }++  | '*' type_qualifier_list attrs identifier_declarator+  	{% withAttribute $1 $3 $ ptrDeclr $4 (reverse $2) }++  | '^' identifier_declarator+  	{% withNodeInfo $1 $ blkDeclr $2 [] }++  | '^' attrs identifier_declarator+  	{% withAttribute $1 $2 $ blkDeclr $3 [] }++  | '^' type_qualifier_list identifier_declarator+  	{% withNodeInfo $1 $ blkDeclr $3 (reverse $2) }++  | '^' type_qualifier_list attrs identifier_declarator+  	{% withAttribute $1 $3 $ blkDeclr $4 (reverse $2) }++postfix_identifier_declarator :: { CDeclrR }+postfix_identifier_declarator+  : paren_identifier_declarator postfixing_abstract_declarator+  	{ $2 $1 }++   | '('  unary_identifier_declarator ')'+   	{ $2 }++   | '(' unary_identifier_declarator ')' postfixing_abstract_declarator+   	{ $4 $2 }++   | '(' attrs unary_identifier_declarator ')'+     { appendDeclrAttrs $2 $3 }++   | '(' attrs unary_identifier_declarator ')' postfixing_abstract_declarator+     { appendDeclrAttrs $2 ($5 $3) }+++-- just an identifier in any number of nested parenthesis+paren_identifier_declarator :: { CDeclrR }+paren_identifier_declarator+  : ident+  	{% withNodeInfo $1 $ mkVarDeclr $1 }++  | '(' paren_identifier_declarator ')'+  	{ $2 }++  | '(' attrs paren_identifier_declarator ')'+  	{ appendDeclrAttrs $2 $3 }++function_declarator_old :: { CDeclr }+function_declarator_old+  : old_function_declarator+    { reverseDeclr $1 }++old_function_declarator :: { CDeclrR }+old_function_declarator+  : postfix_old_function_declarator+  	{ $1 }++  | '*' old_function_declarator+  	{% withNodeInfo $1 $ ptrDeclr $2 [] } -- FIXME: no attr possible here ???++  | '*' type_qualifier_list old_function_declarator+  	{% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) }++  | '^' old_function_declarator+  	{% withNodeInfo $1 $ blkDeclr $2 [] } -- FIXME: no attr possible here ???++  | '^' type_qualifier_list old_function_declarator+  	{% withNodeInfo $1 $ blkDeclr $3 (reverse $2) }++postfix_old_function_declarator :: { CDeclrR }+postfix_old_function_declarator+  : paren_identifier_declarator '(' identifier_list ')'+  	{% withNodeInfo $1 $ funDeclr $1 (Left $ reverse $3) [] }++  | '(' old_function_declarator ')'+  	{ $2 }++  | '(' old_function_declarator ')' postfixing_abstract_declarator+  	{ $4 $2 }+++-- parse C parameter type list (C99 6.7.5)+--+parameter_type_list :: { ([CDecl], Bool) }+parameter_type_list+  : {- empty -}				{ ([], False)}+  | parameter_list			{ (reverse $1, False) }+  | parameter_list ',' "..."		{ (reverse $1, True) }++parameter_list :: { Reversed [CDecl] }+parameter_list+  : parameter_declaration				{ singleton $1 }+  | parameter_list ',' parameter_declaration	{ $1 `snoc` $3 }++parameter_declaration :: { CDecl }+parameter_declaration+  : declaration_specifier+  	{% withNodeInfo $1 $ CDecl $1 [] }++  | declaration_specifier abstract_declarator+  	{% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $2), Nothing, Nothing)] }++  | declaration_specifier identifier_declarator attrs_opt+  	{% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] }++  | declaration_specifier parameter_typedef_declarator attrs_opt+  	{% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] }++  | declaration_qualifier_list+  	{% withNodeInfo $1 $ CDecl (reverse $1) [] }++  | declaration_qualifier_list abstract_declarator+  	{% withNodeInfo $1 $ CDecl (reverse $1) [(Just (reverseDeclr $2), Nothing, Nothing)] }++  | declaration_qualifier_list identifier_declarator attrs_opt+  	{% withNodeInfo $1 $ CDecl (reverse $1) [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] }++  | type_specifier+  	{% withNodeInfo $1 $ CDecl $1 [] }++  | type_specifier abstract_declarator+  	{% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $2), Nothing, Nothing)] }++  | type_specifier identifier_declarator attrs_opt+  	{% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] }++  | type_specifier parameter_typedef_declarator attrs_opt+  	{% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $! appendDeclrAttrs $3 $2), Nothing, Nothing)] }++  | type_qualifier_list+  	{% withNodeInfo $1 $ CDecl (liftTypeQuals $1) [] }+  | type_qualifier_list attr+  	{% withNodeInfo $1 $ CDecl (liftTypeQuals $1 ++ liftCAttrs $2) [] }++  | type_qualifier_list abstract_declarator+  	{% withNodeInfo $1 $ CDecl (liftTypeQuals $1) [(Just (reverseDeclr $2), Nothing, Nothing)] }++  | type_qualifier_list identifier_declarator attrs_opt+  	{% withNodeInfo $1 $ CDecl (liftTypeQuals $1) [(Just (reverseDeclr$ appendDeclrAttrs $3 $2), Nothing, Nothing)] }+++identifier_list :: { Reversed [Ident] }+identifier_list+  : ident				{ singleton $1 }+  | identifier_list ',' ident		{ $1 `snoc` $3 }+++-- parse C type name (C99 6.7.6)+--+type_name :: { CDecl }+type_name+  :  type_specifier+  	{% withNodeInfo $1 $ CDecl $1 [] }++  |  type_specifier abstract_declarator+  	{% withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr $2), Nothing, Nothing)] }++  |  type_qualifier_list attr+  	{% withNodeInfo $1 $ CDecl (liftTypeQuals $1 ++ liftCAttrs $2) [] }++  |  type_qualifier_list abstract_declarator+  	{% withNodeInfo $1 $ CDecl (liftTypeQuals $1) [(Just (reverseDeclr $2), Nothing, Nothing)] }++-- parse C abstract declarator (C99 6.7.6)+--+-- postfix starts with '('+-- postfixing starts with '(' or '['+-- unary start with '*'+abstract_declarator :: { CDeclrR }+abstract_declarator+  : unary_abstract_declarator	    { $1 }+  | postfix_abstract_declarator		{ $1 }+  | postfixing_abstract_declarator  { $1 emptyDeclr }++--+-- FIXME+--  | postfixing_abstract_declarator attrs_opt	{ $1 emptyDeclr }+++postfixing_abstract_declarator :: { CDeclrR -> CDeclrR }+postfixing_abstract_declarator+  : array_abstract_declarator+  	{ $1 }++  | '(' parameter_type_list ')'+  	{% withNodeInfo $1 $ \at declr -> case $2 of+             (params, variadic) -> funDeclr declr (Right (params,variadic)) [] at }+++-- * TODO: Note that we recognise but ignore the C99 static keyword (see C99 6.7.5.3)+--+-- * TODO: We do not distinguish in the AST between incomplete array types and+-- complete variable length arrays ([ '*' ] means the latter). (see C99 6.7.5.2)+--+array_abstract_declarator :: { CDeclrR -> CDeclrR }+array_abstract_declarator+  : postfix_array_abstract_declarator+  	{ $1 }++  | array_abstract_declarator postfix_array_abstract_declarator+  	{ \decl -> $2 ($1 decl) }++--+-- TODO: record static+postfix_array_abstract_declarator :: { CDeclrR -> CDeclrR }+postfix_array_abstract_declarator+  : '[' assignment_expression_opt ']'+  	{% withNodeInfo $1 $ \at declr -> arrDeclr declr [] False False $2 at }++  | '[' attrs assignment_expression_opt ']'+  	{% withAttributePF $1 $2 $ \at declr -> arrDeclr declr [] False False $3 at }++  | '[' type_qualifier_list assignment_expression_opt ']'+  	{% withNodeInfo $1 $ \at declr -> arrDeclr declr (reverse $2) False False $3 at }++  | '[' type_qualifier_list attrs assignment_expression_opt ']'+  	{% withAttributePF $1 $3 $ \at declr -> arrDeclr declr (reverse $2) False False $4 at }++  | '[' static attrs_opt assignment_expression ']'+  	{% withAttributePF $1 $3 $ \at declr -> arrDeclr declr [] False True (Just $4) at }++  | '[' static type_qualifier_list attrs_opt assignment_expression ']'+  	{% withAttributePF $1 $4 $ \at declr -> arrDeclr declr (reverse $3) False True (Just $5) at }++  | '[' type_qualifier_list attrs_opt static attrs_opt assignment_expression ']'+  	{% withAttributePF $1 ($3 ++ $5) $ \at declr -> arrDeclr declr (reverse $2) False True  (Just $6) at }++  | '[' '*' attrs_opt ']'+  	{% withAttributePF $1 $3 $ \at declr -> arrDeclr declr [] True False Nothing at }+  | '[' attrs '*' attrs_opt ']'+  	{% withAttributePF $1 ($2 ++ $4) $ \at declr -> arrDeclr declr [] True False Nothing at }++  | '[' type_qualifier_list '*' attrs_opt ']'+  	{% withAttributePF $1 $4 $ \at declr -> arrDeclr declr (reverse $2) True False Nothing at }+  | '[' type_qualifier_list attrs '*' attrs_opt ']'+  	{% withAttributePF $1 ($3 ++ $5) $ \at declr -> arrDeclr declr (reverse $2) True False Nothing at }++unary_abstract_declarator :: { CDeclrR }+unary_abstract_declarator+  : '*'+  	{% withNodeInfo $1 $ ptrDeclr emptyDeclr [] }++  | '*' type_qualifier_list attrs_opt+  	{% withAttribute $1 $3 $ ptrDeclr emptyDeclr (reverse $2)  }++  | '*' abstract_declarator+  	{% withNodeInfo $1 $ ptrDeclr $2 [] }++  | '*' type_qualifier_list abstract_declarator+  	{% withNodeInfo $1 $ ptrDeclr $3 (reverse $2) }++  | '*' attrs+  	{% withAttribute $1 $2 $ ptrDeclr emptyDeclr [] }+  | '*' attrs abstract_declarator+  	{% withAttribute $1 $2 $ ptrDeclr $3 [] }++  | '^'+  	{% withNodeInfo $1 $ blkDeclr emptyDeclr [] }++  | '^' type_qualifier_list attrs_opt+  	{% withAttribute $1 $3 $ blkDeclr emptyDeclr (reverse $2)  }++  | '^' abstract_declarator+  	{% withNodeInfo $1 $ blkDeclr $2 [] }++  | '^' type_qualifier_list abstract_declarator+  	{% withNodeInfo $1 $ blkDeclr $3 (reverse $2) }++  | '^' attrs+  	{% withAttribute $1 $2 $ blkDeclr emptyDeclr [] }+  | '^' attrs abstract_declarator+  	{% withAttribute $1 $2 $ blkDeclr $3 [] }++-- postfix_ad starts with '(', postfixing with '(' or '[', unary_abstract starts with '*'+postfix_abstract_declarator :: { CDeclrR }+postfix_abstract_declarator+  : '(' unary_abstract_declarator ')'					{ $2 }+  | '(' postfix_abstract_declarator ')'					{ $2 }+  | '(' postfixing_abstract_declarator ')'				{ $2 emptyDeclr }+  | '(' unary_abstract_declarator ')' postfixing_abstract_declarator	{ $4 $2 }++-- FIX 0700+  | '(' attrs unary_abstract_declarator ')'				     	{ appendDeclrAttrs $2 $3 }+  | '(' attrs postfix_abstract_declarator ')'					{ appendDeclrAttrs $2 $3 }+  | '(' attrs postfixing_abstract_declarator ')'				{ appendDeclrAttrs $2 ($3 emptyDeclr) }+  | '(' attrs unary_abstract_declarator ')' postfixing_abstract_declarator	{ appendDeclrAttrs $2 ($5 $3) }+  | postfix_abstract_declarator attr						    { appendDeclrAttrs $2 $1 }+++-- parse C initializer (C99 6.7.8)+--+initializer :: { CInit }+initializer+  : assignment_expression		{% withNodeInfo $1 $ CInitExpr $1 }+  | '{' initializer_list '}'		{% withNodeInfo $1 $ CInitList (reverse $2) }+  | '{' initializer_list ',' '}'	{% withNodeInfo $1 $ CInitList (reverse $2) }+++initializer_opt :: { Maybe CInit }+initializer_opt+  : {- empty -}			{ Nothing }+  | '=' initializer		{ Just $2 }+++initializer_list :: { Reversed CInitList }+initializer_list+  : {- empty -}						{ empty }+  | initializer						{ singleton ([],$1) }+  | designation initializer				{ singleton ($1,$2) }+  | initializer_list ',' initializer			{ $1 `snoc` ([],$3) }+  | initializer_list ',' designation initializer	{ $1 `snoc` ($3,$4) }+++-- designation+--+-- * GNU extensions:+--     old style member designation: 'ident :'+--+-- array designations are not allowed here due to a conflict with ObjC messages+--+designation :: { [CDesignator] }+designation+  : designator_list '='		{ reverse $1 }+  | identifier ':'		{% withNodeInfo $1 $ \at -> [CMemberDesig $1 at] }+++designator_list :: { Reversed [CDesignator] }+designator_list+ : designator				{ singleton $1 }+ | designator_list designator		{ $1 `snoc` $2 }+++designator :: { CDesignator }+designator+  : '[' constant_expression ']'		{% withNodeInfo $1 $ CArrDesig $2 }+  | '.' identifier			{% withNodeInfo $1 $ CMemberDesig $2 }+  | array_designator			{ $1 }+++array_designator :: { CDesignator }+array_designator+  : '[' constant_expression "..." constant_expression ']'+  	{% withNodeInfo $1 $ CRangeDesig $2 $4 }+++-- parse C primary expression (C99 6.5.1)+--+-- We cannot use a typedef name as a variable+--+-- * GNU extensions:+--     allow a compound statement as an expression+--     __builtin_va_arg+--     __builtin_offsetof+--     __builtin_types_compatible_p+-- +-- * Objective-C support:+--    Code block definitions+primary_expression :: { CExpr }+primary_expression+  : ident                       {% withNodeInfo $1 $ CVar $1 }+  | constant                    { CConst $1 }+  | string_literal              { CConst (liftStrLit $1) }+  | '(' expression ')'          { $2 }++  -- GNU extensions+  | '(' compound_statement ')'+  	{% withNodeInfo $1 $ CStatExpr $2 }++  | "__builtin_va_arg" '(' assignment_expression ',' type_name ')'+  	{% withNodeInfo $1 $ CBuiltinExpr . CBuiltinVaArg $3 $5 }++  | "__builtin_offsetof" '(' type_name ',' offsetof_member_designator ')'+  	{% withNodeInfo $1 $ CBuiltinExpr . CBuiltinOffsetOf $3 (reverse $5) }++  | "__builtin_types_compatible_p" '(' type_name ',' type_name ')'+  	{% withNodeInfo $1 $ CBuiltinExpr . CBuiltinTypesCompatible $3 $5 }++  -- objective-C support+  | '^' '(' parameter_type_list ')' compound_statement+        {% withNodeInfo $1 $ CBlockExpr $3 $5 }+  |  message_expression+        {% withNodeInfo $1 $ ObjCMessageExpr $1 }+  | "@selector" '(' selector_name ')'+        {% withNodeInfo $1 $ ObjCSelectorExpr $3 }+  | "@protocol" '(' ident ')'+        {% withNodeInfo $1 $ ObjCProtoExpr $3 }+  | "@encode" '(' type_name ')'+        {% withNodeInfo $1 $ ObjCEncodeExpr $3 }+  | nsstring_literal           { ObjCConst $1 }++message_expression :: { ObjCMsgExpr }+message_expression+  : '[' class_name message_selector ']'+        {% withNodeInfo $1 $ ObjCMsgClass $2 $3 }+  | '[' expression message_selector ']'+        {% withNodeInfo $1 $ ObjCMsgExpr $2 $3 }+  | '[' "super" message_selector ']'+        {% withNodeInfo $1 $ ObjCMsgSup $3 }++message_selector :: { ObjCMsgSel }+message_selector+  : selector {% withNodeInfo $1 $ ObjCMsgSel $1 }+  | keyword_argument_list {% withNodeInfo $1 $ ObjCKeyArgs (reverse $1) }++keyword_argument_list :: { Reversed [ObjCKeyArg] }+keyword_argument_list+  : keyword_argument                       { singleton $1 }+  | keyword_argument_list keyword_argument { $1 `snoc` $2 }++keyword_argument :: { ObjCKeyArg }+keyword_argument+  : keyword_name expression {% withNodeInfo $1 $ ObjCKeyArg $1 $2 }++offsetof_member_designator :: { Reversed [CDesignator] }+offsetof_member_designator+  : identifier						                        {% withNodeInfo $1 $ singleton . CMemberDesig $1 }+  | offsetof_member_designator '.' identifier		  {% withNodeInfo $3 $ ($1 `snoc`) . CMemberDesig $3 }+  | offsetof_member_designator '[' expression ']'	{% withNodeInfo $3 $ ($1 `snoc`) . CArrDesig $3 }+++-- parse C postfix expression (C99 6.5.2)+--+postfix_expression :: { CExpr }+postfix_expression+  : primary_expression+  	{ $1 }++  | postfix_expression '[' expression ']'+  	{% withNodeInfo $1 $ CIndex $1 $3 }++  | postfix_expression '(' ')'+  	{% withNodeInfo $1 $ CCall $1 [] }++  | postfix_expression '(' argument_expression_list ')'+  	{% withNodeInfo $1 $ CCall $1 (reverse $3) }++  | postfix_expression '.' identifier+  	{% withNodeInfo $1 $ CMember $1 $3 False }++  | postfix_expression "->" identifier+  	{% withNodeInfo $1 $ CMember $1 $3 True }++  | postfix_expression "++"+  	{% withNodeInfo $1 $ CUnary CPostIncOp $1 }++  | postfix_expression "--"+  	{% withNodeInfo $1 $ CUnary CPostDecOp $1 }++  | '(' type_name ')' '{' initializer_list '}'+  	{% withNodeInfo $1 $ CCompoundLit $2 (reverse $5) }++  | '(' type_name ')' '{' initializer_list ',' '}'+  	{% withNodeInfo $1 $ CCompoundLit $2 (reverse $5) }+++argument_expression_list :: { Reversed [CExpr] }+argument_expression_list+  : assignment_expression				{ singleton $1 }+  | argument_expression_list ',' assignment_expression	{ $1 `snoc` $3 }+++-- parse C unary expression (C99 6.5.3)+--+-- * GNU extensions:+--     'alignof' expression or type+--     '__real' and '__imag' expression+--     '__extension__' to suppress warnings about extensions+--     allow taking address of a label with: && label+--+unary_expression :: { CExpr }+unary_expression+  : postfix_expression			{ $1 }+  | "++" unary_expression		{% withNodeInfo $1 $ CUnary CPreIncOp $2 }+  | "--" unary_expression		{% withNodeInfo $1 $ CUnary CPreDecOp $2 }+  | "__extension__" cast_expression	{ $2 }+  | unary_operator cast_expression	{% withNodeInfo $1 $ CUnary (unL $1) $2 }+  | sizeof unary_expression		{% withNodeInfo $1 $ CSizeofExpr $2 }+  | sizeof '(' type_name ')'		{% withNodeInfo $1 $ CSizeofType $3 }+  -- GNU: alignof, complex and && extension+  | alignof unary_expression		{% withNodeInfo $1 $ CAlignofExpr $2 }+  | alignof '(' type_name ')'		{% withNodeInfo $1 $ CAlignofType $3 }+  | "__real__" unary_expression    {% withNodeInfo $1 $ CComplexReal $2 }+  | "__imag__" unary_expression    {% withNodeInfo $1 $ CComplexImag $2 }+  | "&&" identifier			{% withNodeInfo $1 $ CLabAddrExpr $2 }+++unary_operator :: { Located CUnaryOp }+unary_operator+  : '&'		{ L CAdrOp  (posOf $1) }+  | '*'		{ L CIndOp  (posOf $1) }+  | '+'		{ L CPlusOp (posOf $1) }+  | '-'		{ L CMinOp  (posOf $1) }+  | '~'		{ L CCompOp (posOf $1) }+  | '!'		{ L CNegOp  (posOf $1) }+++-- parse C cast expression (C99 6.5.4)+--+cast_expression :: { CExpr }+cast_expression+  : unary_expression			{ $1 }+  | '(' type_name ')' cast_expression	{% withNodeInfo $1 $ CCast $2 $4 }+++-- parse C multiplicative expression (C99 6.5.5)+--+multiplicative_expression :: { CExpr }+multiplicative_expression+  : cast_expression+  	{ $1 }++  | multiplicative_expression '*' cast_expression+  	{% withNodeInfo $1 $ CBinary CMulOp $1 $3 }++  | multiplicative_expression '/' cast_expression+  	{% withNodeInfo $1 $ CBinary CDivOp $1 $3 }++  | multiplicative_expression '%' cast_expression+  	{% withNodeInfo $1 $ CBinary CRmdOp $1 $3 }+++-- parse C additive expression (C99 6.5.6)+--+additive_expression :: { CExpr }+additive_expression+  : multiplicative_expression+  	{ $1 }++  | additive_expression '+' multiplicative_expression+  	{% withNodeInfo $1 $ CBinary CAddOp $1 $3 }++  | additive_expression '-' multiplicative_expression+  	{% withNodeInfo $1 $ CBinary CSubOp $1 $3 }+++-- parse C shift expression (C99 6.5.7)+--+shift_expression :: { CExpr }+shift_expression+  : additive_expression+  	{ $1 }++  | shift_expression "<<" additive_expression+  	{% withNodeInfo $1 $ CBinary CShlOp $1 $3 }++  | shift_expression ">>" additive_expression+  	{% withNodeInfo $1 $ CBinary CShrOp $1 $3 }+++-- parse C relational expression (C99 6.5.8)+--+relational_expression :: { CExpr }+relational_expression+  : shift_expression+  	{ $1 }++  | relational_expression '<' shift_expression+  	{% withNodeInfo $1 $ CBinary CLeOp $1 $3 }++  | relational_expression '>' shift_expression+  	{% withNodeInfo $1 $ CBinary CGrOp $1 $3 }++  | relational_expression "<=" shift_expression+  	{% withNodeInfo $1 $ CBinary CLeqOp $1 $3 }++  | relational_expression ">=" shift_expression+  	{% withNodeInfo $1 $ CBinary CGeqOp $1 $3 }+++-- parse C equality expression (C99 6.5.9)+--+equality_expression :: { CExpr }+equality_expression+  : relational_expression+  	{ $1 }++  | equality_expression "==" relational_expression+  	{% withNodeInfo $1 $ CBinary CEqOp  $1 $3 }++  | equality_expression "!=" relational_expression+  	{% withNodeInfo $1 $ CBinary CNeqOp $1 $3 }+++-- parse C bitwise and expression (C99 6.5.10)+--+and_expression :: { CExpr }+and_expression+  : equality_expression+  	{ $1 }++  | and_expression '&' equality_expression+  	{% withNodeInfo $1 $ CBinary CAndOp $1 $3 }+++-- parse C bitwise exclusive or expression (C99 6.5.11)+--+exclusive_or_expression :: { CExpr }+exclusive_or_expression+  : and_expression+  	{ $1 }++  | exclusive_or_expression '^' and_expression+  	{% withNodeInfo $1 $ CBinary CXorOp $1 $3 }+++-- parse C bitwise or expression (C99 6.5.12)+--+inclusive_or_expression :: { CExpr }+inclusive_or_expression+  : exclusive_or_expression+  	{ $1 }++  | inclusive_or_expression '|' exclusive_or_expression+  	{% withNodeInfo $1 $ CBinary COrOp $1 $3 }+++-- parse C logical and expression (C99 6.5.13)+--+logical_and_expression :: { CExpr }+logical_and_expression+  : inclusive_or_expression+  	{ $1 }++  | logical_and_expression "&&" inclusive_or_expression+  	{% withNodeInfo $1 $ CBinary CLndOp $1 $3 }+++-- parse C logical or expression (C99 6.5.14)+--+logical_or_expression :: { CExpr }+logical_or_expression+  : logical_and_expression+  	{ $1 }++  | logical_or_expression "||" logical_and_expression+  	{% withNodeInfo $1 $ CBinary CLorOp $1 $3 }+++-- parse C conditional expression (C99 6.5.15)+--+-- * GNU extensions:+--     omitting the `then' part+conditional_expression :: { CExpr }+conditional_expression+  : logical_or_expression+  	{ $1 }++  | logical_or_expression '?' expression ':' conditional_expression+  	{% withNodeInfo $1 $ CCond $1 (Just $3) $5 }++  | logical_or_expression '?' ':' conditional_expression+  	{% withNodeInfo $1 $ CCond $1 Nothing $4 }+++-- parse C assignment expression (C99 6.5.16)+--+-- * NOTE: LHS of assignment is more restricted than in gcc.+--         `x ? y : z = 3' parses in gcc as `(x ? y : z) = 3',+--         but `x ? y : z' is not an unary expression.+assignment_expression :: { CExpr }+assignment_expression+  : conditional_expression+  	{ $1 }++  | unary_expression assignment_operator assignment_expression+  	{% withNodeInfo $1 $ CAssign (unL $2) $1 $3 }+++assignment_operator :: { Located CAssignOp }+assignment_operator+  : '='			{ L CAssignOp (posOf $1) }+  | "*="		{ L CMulAssOp (posOf $1) }+  | "/="		{ L CDivAssOp (posOf $1) }+  | "%="		{ L CRmdAssOp (posOf $1) }+  | "+="		{ L CAddAssOp (posOf $1) }+  | "-="		{ L CSubAssOp (posOf $1) }+  | "<<="		{ L CShlAssOp (posOf $1) }+  | ">>="		{ L CShrAssOp (posOf $1) }+  | "&="		{ L CAndAssOp (posOf $1) }+  | "^="		{ L CXorAssOp (posOf $1) }+  | "|="		{ L COrAssOp  (posOf $1) }+++-- parse C expression (C99 6.5.17)+--+expression :: { CExpr }+expression+  : assignment_expression+  	{ $1 }++  | assignment_expression ',' comma_expression+  	{% let es = reverse $3 in withNodeInfo es $ CComma ($1:es) }++comma_expression :: { Reversed [CExpr] }+comma_expression+  : assignment_expression			{ singleton $1 }+  | comma_expression ',' assignment_expression	{ $1 `snoc` $3 }+++-- The following was used for clarity+expression_opt :: { Maybe CExpr }+expression_opt+  : {- empty -}		{ Nothing }+  | expression		{ Just $1 }+++-- The following was used for clarity+assignment_expression_opt :: { Maybe CExpr }+assignment_expression_opt+  : {- empty -}				{ Nothing }+  | assignment_expression		{ Just $1 }+++-- parse C constant expression (C99 6.6)+--+constant_expression :: { CExpr }+constant_expression+  : conditional_expression			{ $1 }+++-- parse C constants+--+constant :: { CConst }+constant+  : cint	  {% withNodeInfo $1 $ case $1 of CTokILit _ i -> CIntConst i }+  | cchar	  {% withNodeInfo $1 $ case $1 of CTokCLit _ c -> CCharConst c }+  | cfloat	{% withNodeInfo $1 $ case $1 of CTokFLit _ f -> CFloatConst f }+++string_literal :: { CStrLit }+string_literal+  : cstr+  	{% withNodeInfo $1 $ case $1 of CTokSLit _ s -> CStrLit s }++  | cstr string_literal_list+  	{% withNodeInfo $1 $ case $1 of CTokSLit _ s -> CStrLit (concatCStrings (s : reverse $2)) }+++string_literal_list :: { Reversed [CString] }+string_literal_list+  : cstr			{ case $1 of CTokSLit _ s -> singleton s }+  | string_literal_list cstr	{ case $2 of CTokSLit _ s -> $1 `snoc` s }++-- no support for lists of string literals, is that even valid Obj-C?+nsstring_literal :: { ObjCConst }+nsstring_literal+  : nsstr+  	{% withNodeInfo $1 $ case $1 of CTokObjC (ObjCNSSLit s) _ -> ObjCStrConst s }+++identifier :: { Ident }+identifier+  : ident		{ $1 }+  | tyident		{ $1 }+++-- parse GNU C attribute annotation+attrs_opt ::	{ [CAttr] }+attrs_opt+  : {- empty -}						{ [] }+  | attrs         				{ $1 }++-- GNU C attribute annotation+attrs :: { [CAttr] }+attrs+  : attr						{ $1 }+  | attrs attr	    { $1 ++ $2 }++attr :: { [CAttr] }+attr+  : "__attribute__" '(' '(' attribute_list ')' ')'	{ reverse $4 }++attribute_list :: { Reversed [CAttr] }+  : attribute						          { case $1 of Nothing -> empty; Just attr -> singleton attr }+  | attribute_list ',' attribute	{ (maybe id (flip snoc) $3) $1 }+++attribute :: { Maybe CAttr }+attribute+  : {- empty -}						         { Nothing }+  | ident						               {% withNodeInfo $1 $ Just . CAttr $1  [] }+  | const						               {% withNodeInfo $1 $ Just . CAttr (internalIdent "const") [] }+  | ident '(' attribute_params ')' {% withNodeInfo $1 $ Just . CAttr $1 (reverse $3) }+  | ident '(' ')'					         {% withNodeInfo $1 $ Just . CAttr $1 [] }++attribute_params :: { Reversed [CExpr] }+attribute_params+  : constant_expression					              { singleton $1 }+  | attribute_params ',' constant_expression	{ $1 `snoc` $3 }+++{++--  sometimes it is neccessary to reverse an unreversed list+reverseList :: [a] -> Reversed [a]+reverseList = Reversed . List.reverse++-- We occasionally need things to have a location when they don't naturally+-- have one built in as tokens and most AST elements do.+--+data Located a = L !a !Position++unL :: Located a -> a+unL (L a pos) = a++instance Pos (Located a) where+  posOf (L _ pos) = pos++-- FIXME: the next 3 inlines here increase the object file size by  70%+-- Check whether the speed win is worth it+{-# INLINE withNodeInfo #-}+withNodeInfo :: Pos node => node -> (NodeInfo -> a) -> P a+withNodeInfo node mkAttrNode = do+  name <- getNewName+  lastTok <- getSavedToken+  let !firstPos = posOf node+      !attrs = mkNodeInfo' firstPos (unPosLength . posLenOfTok $! lastTok) name+  return $! mkAttrNode attrs++{-# INLINE withLength #-}+withLength :: NodeInfo -> (NodeInfo -> a) -> P a+withLength nodeinfo mkAttrNode = do+  lastTok <- getSavedToken+  let !firstPos = posOfNode nodeinfo+  let !attrs = mkNodeInfo' firstPos (unPosLength . posLenOfTok $! lastTok)+               (maybe (error "nameOfNode") id (nameOfNode nodeinfo))+  return $! mkAttrNode attrs++data CDeclrR = CDeclrR (Maybe Ident) (Reversed [CDerivedDeclr]) (Maybe CStrLit) [CAttr] NodeInfo+reverseDeclr :: CDeclrR -> CDeclr+reverseDeclr (CDeclrR ide reversedDDs asmname cattrs at)+    = CDeclr ide (reverse reversedDDs) asmname cattrs at+instance CNode (CDeclrR) where+    nodeInfo (CDeclrR _ _ _ _ n) = n+instance Pos (CDeclrR) where+    posOf (CDeclrR _ _ _ _ n) = posOf n++{-# INLINE withAttribute #-}+withAttribute :: Pos node => node -> [CAttr] -> (NodeInfo -> CDeclrR) -> P CDeclrR+withAttribute node cattrs mkDeclrNode = do+  name <- getNewName+  let attrs = mkNodeInfo (posOf node) name+  let newDeclr = appendDeclrAttrs cattrs $ mkDeclrNode attrs+  attrs `seq` newDeclr `seq` return newDeclr++-- postfixing variant+{-# INLINE withAttributePF #-}+withAttributePF :: Pos node => node -> [CAttr] -> (NodeInfo -> CDeclrR -> CDeclrR) -> P (CDeclrR -> CDeclrR)+withAttributePF node cattrs mkDeclrCtor = do+  name <- getNewName+  let attrs = mkNodeInfo (posOf node) name+  let newDeclr = appendDeclrAttrs cattrs . mkDeclrCtor attrs+  attrs `seq` newDeclr `seq` return newDeclr++-- add top level attributes for a declarator.+--+-- In the following example+--+-- > int declr1, __attribute__((a1)) * __attribute__((a2)) y() __asm__("$" "y") __attribute__((a3));+--+-- the attributes `a1' and `a3' are top-level attributes for y.+-- The (pseudo)-AST for the second declarator is+--+-- > CDeclr "y"+-- >        [CFunDeclr ..., CPtrDeclr __attribute__((a2)) ... ]+-- >        (asm "$y")+-- >        [__attribute__((a1)), __attribute__((a3)) ]+--+-- So assembler names and preceeding and trailing attributes are recorded in object declarator.+--+appendObjAttrs :: [CAttr] -> CDeclr -> CDeclr+appendObjAttrs newAttrs (CDeclr ident indirections asmname cAttrs at)+    = CDeclr ident indirections asmname (cAttrs ++ newAttrs) at+appendObjAttrsR :: [CAttr] -> CDeclrR -> CDeclrR+appendObjAttrsR newAttrs (CDeclrR ident indirections asmname cAttrs at)+    = CDeclrR ident indirections asmname (cAttrs ++ newAttrs) at++setAsmName :: Maybe CStrLit  -> CDeclrR -> P CDeclrR+setAsmName mAsmName (CDeclrR ident indirections oldName cattrs at) =+    case combineName mAsmName oldName of+        Left (n1,n2)       -> failP (posOf n2) ["Duplicate assembler name: ",showName n1,showName n2]+        Right newName      -> return $ CDeclrR ident indirections newName cattrs at+  where+  combineName Nothing Nothing = Right Nothing+  combineName Nothing oldname@(Just _)  = Right oldname+  combineName newname@(Just _) Nothing  = Right newname+  combineName (Just n1) (Just n2) = Left (n1,n2)+  showName (CStrLit cstr _) = show cstr++withAsmNameAttrs :: (Maybe CStrLit, [CAttr]) -> CDeclrR -> P CDeclrR+withAsmNameAttrs (mAsmName, newAttrs) declr = setAsmName mAsmName (appendObjAttrsR newAttrs declr)++appendDeclrAttrs :: [CAttr] -> CDeclrR -> CDeclrR+appendDeclrAttrs newAttrs (CDeclrR ident (Reversed []) asmname cattrs at)+    = CDeclrR ident empty asmname (cattrs ++ newAttrs) at+appendDeclrAttrs newAttrs (CDeclrR ident (Reversed (x:xs)) asmname cattrs at)+    = CDeclrR ident (Reversed (appendAttrs x : xs)) asmname cattrs at+  where+    appendAttrs (CPtrDeclr typeQuals at)           = CPtrDeclr (typeQuals ++ map CAttrQual newAttrs) at+    appendAttrs (CBlkDeclr typeQuals at)           = CBlkDeclr (typeQuals ++ map CAttrQual newAttrs) at+    appendAttrs (CArrDeclr typeQuals arraySize at) = CArrDeclr (typeQuals ++ map CAttrQual newAttrs) arraySize at+    appendAttrs (CFunDeclr parameters cattrs at)   = CFunDeclr parameters (cattrs ++ newAttrs) at++ptrDeclr :: CDeclrR -> [CTypeQual] -> NodeInfo -> CDeclrR+ptrDeclr (CDeclrR ident derivedDeclrs asmname cattrs dat) tyquals at+    = CDeclrR ident (derivedDeclrs `snoc` CPtrDeclr tyquals at) asmname cattrs dat++blkDeclr :: CDeclrR -> [CTypeQual] -> NodeInfo -> CDeclrR+blkDeclr (CDeclrR ident derivedDeclrs asmname cattrs dat) tyquals at+    = CDeclrR ident (derivedDeclrs `snoc` CBlkDeclr tyquals at) asmname cattrs dat++funDeclr :: CDeclrR -> (Either [Ident] ([CDecl],Bool)) -> [CAttr] -> NodeInfo -> CDeclrR+funDeclr (CDeclrR ident derivedDeclrs asmname dcattrs dat) params cattrs at+    = CDeclrR ident (derivedDeclrs `snoc` CFunDeclr params cattrs at) asmname dcattrs dat+arrDeclr :: CDeclrR -> [CTypeQual] -> Bool -> Bool -> Maybe CExpr -> NodeInfo -> CDeclrR+arrDeclr (CDeclrR ident derivedDeclrs asmname cattrs dat) tyquals var_sized static_size size_expr_opt at+    = arr_sz `seq` ( CDeclrR ident (derivedDeclrs `snoc` CArrDeclr tyquals arr_sz at) asmname cattrs dat )+    where+    arr_sz = case size_expr_opt of+                 Just e  -> CArrSize static_size e+                 Nothing -> CNoArrSize var_sized++liftTypeQuals :: Reversed [CTypeQual] -> [CDeclSpec]+liftTypeQuals = map CTypeQual . reverse++-- lift CAttrs to DeclSpecs+--+liftCAttrs :: [CAttr] -> [CDeclSpec]+liftCAttrs = map (CTypeQual . CAttrQual)++-- when we parsed (decl_spec_1,...,decl_spec_n,attrs), add the __attributes__s to the declspec list+-- needs special care when @decl_spec_n@ is a SUE definition+addTrailingAttrs :: Reversed [CDeclSpec] -> [CAttr] -> Reversed [CDeclSpec]+addTrailingAttrs declspecs new_attrs =+    case viewr declspecs of+        (specs_init, CTypeSpec (CSUType (CStruct tag name (Just def) def_attrs su_node) node))+            -> (specs_init `snoc` CTypeSpec (CSUType (CStruct tag name (Just def) (def_attrs ++ new_attrs) su_node) node))+        (specs_init, CTypeSpec (CEnumType (CEnum name (Just def) def_attrs e_node) node))+            -> (specs_init `snoc` CTypeSpec (CEnumType (CEnum name (Just def) (def_attrs ++ new_attrs) e_node) node))+        _ -> declspecs `rappend` (liftCAttrs new_attrs)++-- convenient instance, the position of a list of things is the position of+-- the first thing in the list+--+instance Pos a => Pos [a] where+  posOf (x:_) = posOf x+  posOf []    = nopos++instance Pos a => Pos (Reversed a) where+  posOf (Reversed x) = posOf x++emptyDeclr :: CDeclrR+emptyDeclr       = CDeclrR Nothing empty Nothing [] undefNode+mkVarDeclr :: Ident -> NodeInfo -> CDeclrR+mkVarDeclr ident = CDeclrR (Just ident) empty Nothing []++-- Take the identifiers and use them to update the typedef'ed identifier set+-- if the decl is defining a typedef then we add it to the set,+-- if it's a var decl then that shadows typedefed (classnam) identifiers+--+doDeclIdent :: [CDeclSpec] -> CDeclrR -> P ()+doDeclIdent declspecs (CDeclrR mIdent _ _ _ _) =+  case mIdent of+    Nothing -> return ()+    Just ident | any iypedef declspecs -> addTypedef ident+               | otherwise             -> shadowSymbol ident++  where iypedef (CStorageSpec (CTypedef _)) = True+        iypedef _                           = False++doFuncParamDeclIdent :: CDeclr -> P ()+doFuncParamDeclIdent (CDeclr _ (CFunDeclr params _ _ : _) _ _ _) =+  sequence_+    [ case getCDeclrIdent declr of+        Nothing -> return ()+        Just ident -> shadowSymbol ident+    | CDecl _ dle _  <- either (const []) fst params+    , (Just declr, _, _) <- dle ]+doFuncParamDeclIdent _ = return ()++-- extract all identifiers+getCDeclrIdent :: CDeclr -> Maybe Ident+getCDeclrIdent (CDeclr mIdent _ _ _ _) = mIdent++happyError :: P a+happyError = parseError++-- * public interface++-- | @parseC input initialPos@ parses the given preprocessed Objective-C+-- source input and returns the AST or a list of parse errors.+parseC :: InputStream -> Position -> Either ParseError CTranslUnit+parseC input initialPosition =+  fmap fst $ execParser translUnitP input initialPosition builtinTypeNames (namesStartingFrom 0)++parseLazyC :: InputStream -> Position -> ([CExtDecl], Either ParseError ())+parseLazyC input initialPosition =+  execLazyParser translUnitLP input initialPosition builtinTypeNames (namesStartingFrom 0)++-- | @translUnitP@ provides a parser for a complete C translation unit, i.e. a list of external declarations.+translUnitP :: P CTranslUnit+translUnitP = translation_unit++translUnitLP :: P ()+translUnitLP = lazy_translation_unit++-- | @extDeclP@ provides a parser for an external (file-scope) declaration+extDeclP :: P CExtDecl+extDeclP = external_declaration++-- | @statementP@ provides a parser for C statements+statementP :: P CStat+statementP = statement++-- | @expressionP@ provides a parser for C expressions+expressionP :: P CExpr+expressionP = expression+}
+ src/Language/ObjC/Parser/ParserMonad.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE TupleSections+            ,BangPatterns+            ,NoMonomorphismRestriction+            ,GeneralizedNewtypeDeriving+            ,DeriveFunctor #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Syntax.ParserMonad+-- Copyright   :  (c) [1999..2004] Manuel M T Chakravarty+--                (c) 2005-2007 Duncan Coutts+--                (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Portability :  portable+--+-- Monad for the C lexer and parser+--+--  This monad has to be usable with Alex and Happy. Some things in it are+--  dictated by that, eg having to be able to remember the last token.+--+--  The monad also provides a unique name supply (via the Name module)+--+--  For parsing C we have to maintain a set of identifiers that we know to be+--  typedef'ed type identifiers. We also must deal correctly with scope so we+--  keep a list of sets of identifiers so we can save the outer scope when we+--  enter an inner scope.+module Language.ObjC.Parser.ParserMonad (+  LP,+  P,+  IType (..),+  TMap,+  execParser,+  execLazyParser,+  failP,+  getNewName,           -- :: (PMonad p) => p Name+  addTypedef,           -- :: Ident -> P ()+  shadowSymbol,         -- :: Ident -> P ()+  isTypeIdent,          -- :: Ident -> P Bool+  addClass,             -- :: Ident -> P ()+  isClass,              -- :: Ident -> P Bool+  isSpecial,            -- :: Ident -> P IType+  enterScope,           -- :: (PMonad p) => p ()+  leaveScope,           -- :: (PMonad p) => p ()+  setPos,               -- :: Position -> P ()+  getPos,               -- :: (PMonad p) => p Position+  getInput,             -- :: (PMonad p) => p String+  setInput,             -- :: String -> P ()+  getLastToken,         -- :: (PMonad p) => p CToken+  getSavedToken,        -- :: (PMonad p) => p CToken+  setLastToken,         -- :: CToken -> P ()+  handleEofToken,       -- :: (PMonad p) => p ()+  getCurrentPosition,   -- :: (PMonad p) => p Position+  ParseError(..),+  parsedLazily,         -- :: s -> LP [s] s+  ) where++import Language.ObjC.Data.Error (internalErr, showErrorInfo,ErrorInfo(..),ErrorLevel(..))+import Language.ObjC.Data.Position  (Position(..))+import Language.ObjC.Data.InputStream+import Language.ObjC.Data.Name    (Name)+import Language.ObjC.Data.Ident    (Ident)+import Language.ObjC.Parser.Tokens (CToken(CTokEof))+import Language.ObjC.Syntax.AST    (CExtDecl)++import Data.Map  (Map)+import qualified Data.Map as Map++import Control.Applicative++newtype ParseError = ParseError ([String],Position)+instance Show ParseError where+    show (ParseError (msgs,pos)) = showErrorInfo "Syntax Error !" (ErrorInfo LevelError pos msgs)++-- | For typedef'd or classname identifiers, indicate which type they are+data IType = TyDef | CName deriving (Eq, Show, Ord, Enum)++type TMap = Map Ident IType++data ParseResult a+  = POk !PState a+  | PFailed [String] Position   -- The error message and position+ deriving (Functor)++data PState = PState {+  curPos     :: !Position,        -- position at current input location+  curInput   :: !InputStream,     -- the current input+  prevToken  ::  CToken,          -- the previous token+  savedToken ::  CToken,          -- and the token before that+  namesupply :: ![Name],          -- the name unique supply+  tyidents   :: !(TMap),          -- the set of typedef'ed identifiers+  scopes     :: [TMap]            -- the tyident sets for outer scopes+ }++-- | a minimal state-like representation, so we don't need to depend on mtl+class (Functor p, Monad p) => PMonad p where+  get :: p PState+  put :: PState -> p ()+  modify :: (PState -> PState) -> p ()+  modify f = get >>= put . f++failP :: Position -> [String] -> LP s a+failP pos m = LP $ \s pSt -> (PFailed m pos, s)++-- | Default parser type, so CExtDecls can be parsed lazily+type P a = LP [CExtDecl] a++-- | A Lazy Parser Monad.  Highly experimental+newtype LP s a = LP { unLP :: s -> PState -> (ParseResult a, s) }+  deriving (Functor)++instance Monad (LP s) where+  {-# INLINE return #-}+  return a = LP $ \s !pSt -> (POk pSt a, s)+  {-# INLINE (>>=) #-}+  (LP m) >>= f = LP $ \s !pSt ->+                   let (r1, s1) = m s2 pSt+                       (r2, s2) = case r1 of+                                     POk pSt' a -> unLP (f a) s pSt'+                                     PFailed err pos -> (PFailed err pos, s)+                   in (r2, s1)+  {-# INLINE fail #-}+  fail m = LP $ \s pSt -> (PFailed [m] (curPos pSt), s)++instance PMonad (LP s) where+  get      = LP $ \s !pst -> (POk pst pst, s)+  put st   = LP $ \s _    -> (POk st (), s)+  modify f = LP $ \s !pst -> (POk (f pst) (), s)++getL :: LP s s+getL = LP $ \s !pst -> (POk pst s, s)++modifyL :: (s -> s) -> LP s ()+modifyL f = LP $ \s !pst -> (POk pst (),f s)++putL :: s -> LP s ()+putL = modifyL . const++instance Applicative (LP s) where+  {-# INLINE pure #-}+  pure = return+  {-# INLINE (<*>) #-}+  f <*> m = f >>= \f' -> m >>= \m' -> pure (f' m')++-- | execute the given parser on the supplied input stream.+--   returns 'ParseError' if the parser failed, and a pair of+--   result and remaining name supply otherwise+-- +--   Lazy parsing results are ignored.+--+-- Synopsis: @execParser parser inputStream initialPos predefinedTypedefs uniqNameSupply@+execParser :: LP [s] a -> InputStream -> Position -> [Ident] -> [Name]+           -> Either ParseError (a,[Name])+execParser (LP parser) input pos builtins names =+  case fst $ parser [] initialState of+    PFailed message errpos -> Left (ParseError (message,errpos))+    POk st result -> Right (result, namesupply st)+  where initialState = PState {+          curPos = pos,+          curInput = input,+          prevToken = internalErr "CLexer.execParser: Touched undefined token!",+          savedToken = internalErr "CLexer.execParser: Touched undefined token (safed token)!",+          namesupply = names,+          tyidents = Map.fromList $ map (,TyDef) builtins,+          scopes   = []+        }++-- | execute the given parser on the supplied input stream.+-- +--   returns a lazy list of results, and either the parse result+--   or a ParseError if there was an error.+-- +--   The list should be consumed as far as possible before checking the result is+--   evaluated for maximum laziness.+--+-- Synopsis: @execParser parser inputStream initialPos predefinedTypedefs uniqNameSupply@+execLazyParser+  :: LP [s] a+  -> InputStream+  -> Position+  -> [Ident]+  -> [Name]+  -> ([s], Either ParseError a)+execLazyParser (LP parser) input pos builtins names =+  let (res, lzparse) = parser [] initialState+      procRes        = case res of+                         PFailed message errpos -> Left (ParseError (message,errpos))+                         POk _ result -> Right result+  in  (lzparse, procRes)+  where initialState = PState {+          curPos = pos,+          curInput = input,+          prevToken = internalErr "CLexer.execParser: Touched undefined token!",+          savedToken = internalErr "CLexer.execParser: Touched undefined token (saved token)!",+          namesupply = names,+          tyidents = Map.fromList $ map (,TyDef) builtins,+          scopes   = []+        }++withState :: PMonad p => (PState -> (PState, a)) -> p a+withState f = get >>= \p -> case f p of+                  (pst', a) -> put pst' >> return a+{-# INLINE withState #-}++withState' :: PMonad p => (PState -> (PState, a)) -> p a+withState' f = get >>= \p -> case f p of+                  (pst', !a) -> put pst' >> return a+{-# INLINE withState' #-}++getNewName :: (PMonad p) => p Name+getNewName = withState' $ \s@PState{namesupply=(n:ns)} -> (s{namesupply=ns}, n)++setPos :: (PMonad p) => Position -> p ()+setPos pos = modify $ \ !s -> s{curPos=pos}++getPos :: (PMonad p) => p Position+getPos = (\st -> curPos st) <$> get++addTypedef :: (PMonad p) => Ident -> p ()+addTypedef ident = modify $ \s@PState{tyidents=tyids} ->+                             s{tyidents = Map.insert ident TyDef tyids}++shadowSymbol :: (PMonad p) => Ident -> p ()+shadowSymbol ident = modify $ \s@PState{tyidents=tyids} ->+                             -- optimisation: mostly the ident will not be in+                             -- the tyident set so do a member lookup to avoid+                             -- churn induced by calling delete+                             -- (JL: I dont follow this reasoning, if it's not present the map+                             --  shouldn't change, hence no churn...)+                             s{tyidents = if ident `Map.member` tyids+                                            then ident `Map.delete` tyids+                                            else tyids }++-- withState' :: PMonad p => (PState -> (PState, a)) -> p a+isTypeIdent :: (PMonad p) => Ident -> p Bool+isTypeIdent ident =  (\s -> maybe False (== TyDef)+                       . Map.lookup ident $ tyidents s)+                     <$> get++addClass :: (PMonad p) => Ident -> p ()+addClass ident = modify $ \s@PState{tyidents=tyids} ->+                             s{tyidents = Map.insert ident CName tyids}++isClass :: (PMonad p) => Ident -> p Bool+isClass ident = (\s -> maybe False (== CName)+                       . Map.lookup ident $ tyidents s)+                <$> get++isSpecial :: (PMonad p) => Ident -> p (Maybe IType)+isSpecial ident = (\s -> Map.lookup ident $ tyidents s) <$> get++enterScope :: (PMonad p) => p ()+enterScope = modify $ \s@PState{tyidents=tyids,scopes=ss} -> s{scopes=tyids:ss}++leaveScope :: (PMonad p) => p ()+leaveScope = modify $ \s@PState{scopes=ss} ->+                     case ss of+                       []          -> error "leaveScope: already in global scope"+                       (tyids:ss') -> s{tyidents=tyids, scopes=ss'}++getInput :: (PMonad p) => p InputStream+getInput = curInput <$> get++setInput :: (PMonad p) => InputStream -> p ()+setInput i = modify (\s -> s{curInput=i})++getLastToken :: (PMonad p) => p CToken+getLastToken = prevToken <$> get++getSavedToken :: (PMonad p) => p CToken+getSavedToken = savedToken <$> get++-- | @setLastToken modifyCache tok@+setLastToken :: (PMonad p) => CToken -> p ()+setLastToken CTokEof = modify $ \s -> s{savedToken=(prevToken s)}+setLastToken tok     = modify $ \s -> s{prevToken=tok,savedToken=(prevToken s)}++-- | handle an End-Of-File token (changes savedToken)+handleEofToken :: (PMonad p) => p ()+handleEofToken = modify $ \s -> s{savedToken=(prevToken s)}++getCurrentPosition :: (PMonad p) => p Position+getCurrentPosition = curPos <$> get++-- | Insert a parsed value into the lazy parsing stream+parsedLazily :: s -> LP [s] s+parsedLazily s = s <$ modifyL (s:)
+ src/Language/ObjC/Parser/Tokens.hs view
@@ -0,0 +1,407 @@+{-# OPTIONS  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Parser.Tokens+-- Copyright   :  [1999..2004] Manuel M T Chakravarty+--                2005 Duncan Coutts+--                2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Portability :  portable+--+--  C Tokens for the C lexer.+--+-----------------------------------------------------------------------------+module Language.ObjC.Parser.Tokens (+  CToken(..)+ ,posLenOfTok+ ,GnuCTok(..)+ ,ObjCTok(..)+)++where++import Language.ObjC.Data.Position    (Position, Pos(..)+                                      ,PosLength, unPosLength)+import Language.ObjC.Data.Ident       (Ident, identToString)+import Language.ObjC.Syntax.Constants (CChar, CInteger, CFloat, CString)++-- token definition+-- ----------------++-- possible tokens (EXPORTED)+--+data CToken = CTokLParen   !PosLength            -- `('+            | CTokRParen   !PosLength            -- `)'+            | CTokLBracket !PosLength            -- `['+            | CTokRBracket !PosLength            -- `]'+            | CTokArrow    !PosLength            -- `->'+            | CTokDot      !PosLength            -- `.'+            | CTokExclam   !PosLength            -- `!'+            | CTokTilde    !PosLength            -- `~'+            | CTokInc      !PosLength            -- `++'+            | CTokDec      !PosLength            -- `--'+            | CTokPlus     !PosLength            -- `+'+            | CTokMinus    !PosLength            -- `-'+            | CTokStar     !PosLength            -- `*'+            | CTokSlash    !PosLength            -- `/'+            | CTokPercent  !PosLength            -- `%'+            | CTokAmper    !PosLength            -- `&'+            | CTokShiftL   !PosLength            -- `<<'+            | CTokShiftR   !PosLength            -- `>>'+            | CTokLess     !PosLength            -- `<'+            | CTokLessEq   !PosLength            -- `<='+            | CTokHigh     !PosLength            -- `>'+            | CTokHighEq   !PosLength            -- `>='+            | CTokEqual    !PosLength            -- `=='+            | CTokUnequal  !PosLength            -- `!='+            | CTokHat      !PosLength            -- `^'+            | CTokBar      !PosLength            -- `|'+            | CTokAnd      !PosLength            -- `&&'+            | CTokOr       !PosLength            -- `||'+            | CTokQuest    !PosLength            -- `?'+            | CTokColon    !PosLength            -- `:'+            | CTokAssign   !PosLength            -- `='+            | CTokPlusAss  !PosLength            -- `+='+            | CTokMinusAss !PosLength            -- `-='+            | CTokStarAss  !PosLength            -- `*='+            | CTokSlashAss !PosLength            -- `/='+            | CTokPercAss  !PosLength            -- `%='+            | CTokAmpAss   !PosLength            -- `&='+            | CTokHatAss   !PosLength            -- `^='+            | CTokBarAss   !PosLength            -- `|='+            | CTokSLAss    !PosLength            -- `<<='+            | CTokSRAss    !PosLength            -- `>>='+            | CTokComma    !PosLength            -- `,'+            | CTokSemic    !PosLength            -- `;'+            | CTokLBrace   !PosLength            -- `{'+            | CTokRBrace   !PosLength            -- `}'+            | CTokEllipsis !PosLength            -- `...'+            | CTokAlignof  !PosLength            -- `alignof'+                                                -- (or `__alignof',+                                                -- `__alignof__')+            | CTokAsm      !PosLength            -- `asm'+                                                -- (or `__asm',+                                                -- `__asm__')+            | CTokAuto     !PosLength            -- `auto'+            | CTokBreak    !PosLength            -- `break'+            | CTokBool     !PosLength            -- `_Bool'+            | CTokCase     !PosLength            -- `case'+            | CTokChar     !PosLength            -- `char'+            | CTokConst    !PosLength            -- `const'+                                                -- (or `__const', `__const__')+            | CTokContinue !PosLength            -- `continue'+            | CTokComplex  !PosLength            -- `_Complex'+            | CTokDefault  !PosLength            -- `default'+            | CTokDo       !PosLength            -- `do'+            | CTokDouble   !PosLength            -- `double'+            | CTokElse     !PosLength            -- `else'+            | CTokEnum     !PosLength            -- `enum'+            | CTokExtern   !PosLength            -- `extern'+            | CTokFloat    !PosLength            -- `float'+            | CTokFor      !PosLength            -- `for'+            | CTokGoto     !PosLength            -- `goto'+            | CTokIf       !PosLength            -- `if'+            | CTokInline   !PosLength            -- `inline'+                                                -- (or `__inline',+                                                -- `__inline__')+            | CTokInt      !PosLength            -- `int'+            | CTokLong     !PosLength            -- `long'+            | CTokLabel    !PosLength            -- `__label__'+            | CTokRegister !PosLength            -- `register'+            | CTokRestrict !PosLength            -- `restrict'+                                                -- (or `__restrict',+                                                -- `__restrict__')+            | CTokReturn   !PosLength            -- `return'+            | CTokShort    !PosLength            -- `short'+            | CTokSigned   !PosLength            -- `signed'+                                                -- (or `__signed',+                                                -- `__signed__')+            | CTokSizeof   !PosLength            -- `sizeof'+            | CTokStatic   !PosLength            -- `static'+            | CTokStruct   !PosLength            -- `struct'+            | CTokSwitch   !PosLength            -- `switch'+            | CTokTypedef  !PosLength            -- `typedef'+            | CTokTypeof   !PosLength            -- `typeof'+            | CTokThread   !PosLength            -- `__thread'+            | CTokUnion    !PosLength            -- `union'+            | CTokUnsigned !PosLength            -- `unsigned'+            | CTokVoid     !PosLength            -- `void'+            | CTokVolatile !PosLength            -- `volatile'+                                                -- (or `__volatile',+                                                -- `__volatile__')+            | CTokWhile    !PosLength            -- `while'+            | CTokCLit     !PosLength !CChar     -- character constant+            | CTokILit     !PosLength !CInteger  -- integer constant+            | CTokFLit     !PosLength CFloat     -- float constant+            | CTokSLit     !PosLength CString    -- string constant+            | CTokIdent    !PosLength !Ident     -- identifier++              -- not generated here, but in `CParser.parseCHeader'+            | CTokTyIdent  !PosLength !Ident     -- `typedef-name' identifier+            | CTokGnuC !GnuCTok !PosLength       -- special GNU C tokens+            | CTokObjC !ObjCTok !PosLength       -- objective-C tokens+            | CTokEof                           -- end of file++-- special tokens used in GNU C extensions to ANSI C+--+data GnuCTok = GnuCAttrTok              -- `__attribute__'+             | GnuCExtTok               -- `__extension__'+             | GnuCVaArg                -- `__builtin_va_arg'+             | GnuCOffsetof             -- `__builtin_offsetof'+             | GnuCTyCompat             -- `__builtin_types_compatible_p'+             | GnuCComplexReal          -- `__real__'+             | GnuCComplexImag          -- `__imag__'++-- | tokens used for Objective-C+data ObjCTok = ObjCInterface            -- `@interface'+             | ObjCImplementation       -- `@implementation'+             | ObjCEnd                  -- `@end'+             | ObjCRequired             -- `@required'+             | ObjCOptional             -- `@optional'+             | ObjCClass                -- `@class'+             | ObjCProperty             -- `@property'+             | ObjCSelector             -- `@selector'+             | ObjCProtocol             -- `@protocol'+             | ObjCEncode               -- `@encode'+             | ObjCClassIdent !Ident    -- `class-name' identifier+             | ObjCPriv                 -- `@private'+             | ObjCProt                 -- `@protected'+             | ObjCPub                  -- `@public'+             | ObjCPackage              -- `@package'+             | ObjCIn                   -- `in'+             | ObjCOut                  -- `out'+             | ObjCInOut                -- `inout'+             | ObjCOneway               -- `oneway'+             | ObjCBycopy               -- `bycopy'+             | ObjCSuper                -- `super'+             | ObjCNSSLit CString       -- NSString constant++instance Pos CToken where+  posOf = fst . unPosLength . posLenOfTok++-- token position and length+posLenOfTok :: CToken -> PosLength+posLenOfTok (CTokLParen   pos  ) = pos+posLenOfTok (CTokRParen   pos  ) = pos+posLenOfTok (CTokLBracket pos  ) = pos+posLenOfTok (CTokRBracket pos  ) = pos+posLenOfTok (CTokArrow    pos  ) = pos+posLenOfTok (CTokDot      pos  ) = pos+posLenOfTok (CTokExclam   pos  ) = pos+posLenOfTok (CTokTilde    pos  ) = pos+posLenOfTok (CTokInc      pos  ) = pos+posLenOfTok (CTokDec      pos  ) = pos+posLenOfTok (CTokPlus     pos  ) = pos+posLenOfTok (CTokMinus    pos  ) = pos+posLenOfTok (CTokStar     pos  ) = pos+posLenOfTok (CTokSlash    pos  ) = pos+posLenOfTok (CTokPercent  pos  ) = pos+posLenOfTok (CTokAmper    pos  ) = pos+posLenOfTok (CTokShiftL   pos  ) = pos+posLenOfTok (CTokShiftR   pos  ) = pos+posLenOfTok (CTokLess     pos  ) = pos+posLenOfTok (CTokLessEq   pos  ) = pos+posLenOfTok (CTokHigh     pos  ) = pos+posLenOfTok (CTokHighEq   pos  ) = pos+posLenOfTok (CTokEqual    pos  ) = pos+posLenOfTok (CTokUnequal  pos  ) = pos+posLenOfTok (CTokHat      pos  ) = pos+posLenOfTok (CTokBar      pos  ) = pos+posLenOfTok (CTokAnd      pos  ) = pos+posLenOfTok (CTokOr       pos  ) = pos+posLenOfTok (CTokQuest    pos  ) = pos+posLenOfTok (CTokColon    pos  ) = pos+posLenOfTok (CTokAssign   pos  ) = pos+posLenOfTok (CTokPlusAss  pos  ) = pos+posLenOfTok (CTokMinusAss pos  ) = pos+posLenOfTok (CTokStarAss  pos  ) = pos+posLenOfTok (CTokSlashAss pos  ) = pos+posLenOfTok (CTokPercAss  pos  ) = pos+posLenOfTok (CTokAmpAss   pos  ) = pos+posLenOfTok (CTokHatAss   pos  ) = pos+posLenOfTok (CTokBarAss   pos  ) = pos+posLenOfTok (CTokSLAss    pos  ) = pos+posLenOfTok (CTokSRAss    pos  ) = pos+posLenOfTok (CTokComma    pos  ) = pos+posLenOfTok (CTokSemic    pos  ) = pos+posLenOfTok (CTokLBrace   pos  ) = pos+posLenOfTok (CTokRBrace   pos  ) = pos+posLenOfTok (CTokEllipsis pos  ) = pos+posLenOfTok (CTokAlignof  pos  ) = pos+posLenOfTok (CTokAsm      pos  ) = pos+posLenOfTok (CTokAuto     pos  ) = pos+posLenOfTok (CTokBreak    pos  ) = pos+posLenOfTok (CTokBool     pos  ) = pos+posLenOfTok (CTokCase     pos  ) = pos+posLenOfTok (CTokChar     pos  ) = pos+posLenOfTok (CTokConst    pos  ) = pos+posLenOfTok (CTokContinue pos  ) = pos+posLenOfTok (CTokComplex  pos  ) = pos+posLenOfTok (CTokDefault  pos  ) = pos+posLenOfTok (CTokDo       pos  ) = pos+posLenOfTok (CTokDouble   pos  ) = pos+posLenOfTok (CTokElse     pos  ) = pos+posLenOfTok (CTokEnum     pos  ) = pos+posLenOfTok (CTokExtern   pos  ) = pos+posLenOfTok (CTokFloat    pos  ) = pos+posLenOfTok (CTokFor      pos  ) = pos+posLenOfTok (CTokGoto     pos  ) = pos+posLenOfTok (CTokInt      pos  ) = pos+posLenOfTok (CTokInline   pos  ) = pos+posLenOfTok (CTokIf       pos  ) = pos+posLenOfTok (CTokLong     pos  ) = pos+posLenOfTok (CTokLabel    pos  ) = pos+posLenOfTok (CTokRegister pos  ) = pos+posLenOfTok (CTokRestrict pos  ) = pos+posLenOfTok (CTokReturn   pos  ) = pos+posLenOfTok (CTokShort    pos  ) = pos+posLenOfTok (CTokSigned   pos  ) = pos+posLenOfTok (CTokSizeof   pos  ) = pos+posLenOfTok (CTokStatic   pos  ) = pos+posLenOfTok (CTokStruct   pos  ) = pos+posLenOfTok (CTokSwitch   pos  ) = pos+posLenOfTok (CTokTypedef  pos  ) = pos+posLenOfTok (CTokTypeof   pos  ) = pos+posLenOfTok (CTokThread   pos  ) = pos+posLenOfTok (CTokUnion    pos  ) = pos+posLenOfTok (CTokUnsigned pos  ) = pos+posLenOfTok (CTokVoid     pos  ) = pos+posLenOfTok (CTokVolatile pos  ) = pos+posLenOfTok (CTokWhile    pos  ) = pos+posLenOfTok (CTokCLit     pos _) = pos+posLenOfTok (CTokILit     pos _) = pos+posLenOfTok (CTokFLit     pos _) = pos+posLenOfTok (CTokSLit     pos _) = pos+posLenOfTok (CTokIdent    pos _) = pos+posLenOfTok (CTokTyIdent  pos _) = pos+posLenOfTok (CTokGnuC   _ pos  ) = pos+posLenOfTok (CTokObjC   _ pos  ) = pos+posLenOfTok CTokEof = error "tokenPos: Eof"++instance Show CToken where+  showsPrec _ (CTokLParen   _  ) = showString "("+  showsPrec _ (CTokRParen   _  ) = showString ")"+  showsPrec _ (CTokLBracket _  ) = showString "["+  showsPrec _ (CTokRBracket _  ) = showString "]"+  showsPrec _ (CTokArrow    _  ) = showString "->"+  showsPrec _ (CTokDot      _  ) = showString "."+  showsPrec _ (CTokExclam   _  ) = showString "!"+  showsPrec _ (CTokTilde    _  ) = showString "~"+  showsPrec _ (CTokInc      _  ) = showString "++"+  showsPrec _ (CTokDec      _  ) = showString "--"+  showsPrec _ (CTokPlus     _  ) = showString "+"+  showsPrec _ (CTokMinus    _  ) = showString "-"+  showsPrec _ (CTokStar     _  ) = showString "*"+  showsPrec _ (CTokSlash    _  ) = showString "/"+  showsPrec _ (CTokPercent  _  ) = showString "%"+  showsPrec _ (CTokAmper    _  ) = showString "&"+  showsPrec _ (CTokShiftL   _  ) = showString "<<"+  showsPrec _ (CTokShiftR   _  ) = showString ">>"+  showsPrec _ (CTokLess     _  ) = showString "<"+  showsPrec _ (CTokLessEq   _  ) = showString "<="+  showsPrec _ (CTokHigh     _  ) = showString ">"+  showsPrec _ (CTokHighEq   _  ) = showString ">="+  showsPrec _ (CTokEqual    _  ) = showString "=="+  showsPrec _ (CTokUnequal  _  ) = showString "!="+  showsPrec _ (CTokHat      _  ) = showString "^"+  showsPrec _ (CTokBar      _  ) = showString "|"+  showsPrec _ (CTokAnd      _  ) = showString "&&"+  showsPrec _ (CTokOr       _  ) = showString "||"+  showsPrec _ (CTokQuest    _  ) = showString "?"+  showsPrec _ (CTokColon    _  ) = showString ":"+  showsPrec _ (CTokAssign   _  ) = showString "="+  showsPrec _ (CTokPlusAss  _  ) = showString "+="+  showsPrec _ (CTokMinusAss _  ) = showString "-="+  showsPrec _ (CTokStarAss  _  ) = showString "*="+  showsPrec _ (CTokSlashAss _  ) = showString "/="+  showsPrec _ (CTokPercAss  _  ) = showString "%="+  showsPrec _ (CTokAmpAss   _  ) = showString "&="+  showsPrec _ (CTokHatAss   _  ) = showString "^="+  showsPrec _ (CTokBarAss   _  ) = showString "|="+  showsPrec _ (CTokSLAss    _  ) = showString "<<="+  showsPrec _ (CTokSRAss    _  ) = showString ">>="+  showsPrec _ (CTokComma    _  ) = showString ","+  showsPrec _ (CTokSemic    _  ) = showString ";"+  showsPrec _ (CTokLBrace   _  ) = showString "{"+  showsPrec _ (CTokRBrace   _  ) = showString "}"+  showsPrec _ (CTokEllipsis _  ) = showString "..."+  showsPrec _ (CTokAlignof  _  ) = showString "alignof"+  showsPrec _ (CTokAsm      _  ) = showString "asm"+  showsPrec _ (CTokAuto     _  ) = showString "auto"+  showsPrec _ (CTokBool _)       = showString "_Bool"+  showsPrec _ (CTokBreak    _  ) = showString "break"+  showsPrec _ (CTokCase     _  ) = showString "case"+  showsPrec _ (CTokChar     _  ) = showString "char"+  showsPrec _ (CTokComplex _)    = showString "_Complex"+  showsPrec _ (CTokConst    _  ) = showString "const"+  showsPrec _ (CTokContinue _  ) = showString "continue"+  showsPrec _ (CTokDefault  _  ) = showString "default"+  showsPrec _ (CTokDouble   _  ) = showString "double"+  showsPrec _ (CTokDo       _  ) = showString "do"+  showsPrec _ (CTokElse     _  ) = showString "else"+  showsPrec _ (CTokEnum     _  ) = showString "enum"+  showsPrec _ (CTokExtern   _  ) = showString "extern"+  showsPrec _ (CTokFloat    _  ) = showString "float"+  showsPrec _ (CTokFor      _  ) = showString "for"+  showsPrec _ (CTokGoto     _  ) = showString "goto"+  showsPrec _ (CTokIf       _  ) = showString "if"+  showsPrec _ (CTokInline   _  ) = showString "inline"+  showsPrec _ (CTokInt      _  ) = showString "int"+  showsPrec _ (CTokLong     _  ) = showString "long"+  showsPrec _ (CTokLabel    _  ) = showString "__label__"+  showsPrec _ (CTokRegister _  ) = showString "register"+  showsPrec _ (CTokRestrict _  ) = showString "restrict"+  showsPrec _ (CTokReturn   _  ) = showString "return"+  showsPrec _ (CTokShort    _  ) = showString "short"+  showsPrec _ (CTokSigned   _  ) = showString "signed"+  showsPrec _ (CTokSizeof   _  ) = showString "sizeof"+  showsPrec _ (CTokStatic   _  ) = showString "static"+  showsPrec _ (CTokStruct   _  ) = showString "struct"+  showsPrec _ (CTokSwitch   _  ) = showString "switch"+  showsPrec _ (CTokTypedef  _  ) = showString "typedef"+  showsPrec _ (CTokTypeof   _  ) = showString "typeof"+  showsPrec _ (CTokThread   _  ) = showString "__thread"+  showsPrec _ (CTokUnion    _  ) = showString "union"+  showsPrec _ (CTokUnsigned _  ) = showString "unsigned"+  showsPrec _ (CTokVoid     _  ) = showString "void"+  showsPrec _ (CTokVolatile _  ) = showString "volatile"+  showsPrec _ (CTokWhile    _  ) = showString "while"+  showsPrec _ (CTokCLit     _ c) = shows c+  showsPrec _ (CTokILit     _ i) = shows i+  showsPrec _ (CTokFLit     _ f) = shows f+  showsPrec _ (CTokSLit     _ s) = shows s+  showsPrec _ (CTokIdent    _ i) = (showString . identToString) i+  showsPrec _ (CTokTyIdent  _ i) =+    (showString . identToString) i . showString " <typedef> "+  showsPrec _ (CTokGnuC GnuCAttrTok _) = showString "__attribute__"+  showsPrec _ (CTokGnuC GnuCExtTok  _) = showString "__extension__"+  showsPrec _ (CTokGnuC GnuCComplexReal _) = showString "__real__"+  showsPrec _ (CTokGnuC GnuCComplexImag  _) = showString "__imag__"+  showsPrec _ (CTokGnuC GnuCVaArg    _) = showString "__builtin_va_arg"+  showsPrec _ (CTokGnuC GnuCOffsetof _) = showString "__builtin_offsetof"+  showsPrec _ (CTokGnuC GnuCTyCompat _) = showString "__builtin_types_compatible_p"+  showsPrec _ (CTokObjC ObjCInterface _) = showString "@interface"+  showsPrec _ (CTokObjC ObjCImplementation _) = showString "@implementation"+  showsPrec _ (CTokObjC ObjCEnd _)       = showString "@end"+  showsPrec _ (CTokObjC ObjCRequired _)  = showString "@required"+  showsPrec _ (CTokObjC ObjCOptional _)  = showString "@optional"+  showsPrec _ (CTokObjC ObjCClass _)     = showString "@class"+  showsPrec _ (CTokObjC ObjCSelector _)  = showString "@selector"+  showsPrec _ (CTokObjC ObjCProtocol _)  = showString "@protocol"+  showsPrec _ (CTokObjC ObjCEncode _)    = showString "@encode"+  showsPrec _ (CTokObjC ObjCIn _)        = showString "in"+  showsPrec _ (CTokObjC ObjCOut _)       = showString "out"+  showsPrec _ (CTokObjC ObjCInOut _)     = showString "inout"+  showsPrec _ (CTokObjC ObjCOneway _)    = showString "oneway"+  showsPrec _ (CTokObjC ObjCBycopy _)    = showString "bycopy"+  showsPrec _ (CTokObjC ObjCSuper  _)    = showString "super"+  showsPrec _ (CTokObjC ObjCProperty _)  = showString "@property"+  showsPrec _ (CTokObjC (ObjCClassIdent i) _) =+    showString (identToString i) . showString " <classname> "+  showsPrec _ (CTokObjC ObjCPriv _)      = showString "@private"+  showsPrec _ (CTokObjC ObjCProt _)      = showString "@protected"+  showsPrec _ (CTokObjC ObjCPub _)       = showString "@public"+  showsPrec _ (CTokObjC ObjCPackage _)   = showString "@package"+  showsPrec _ (CTokObjC (ObjCNSSLit s) _) = shows s+  showsPrec _ CTokEof = error "show CToken : CTokEof"
+ src/Language/ObjC/Pretty.hs view
@@ -0,0 +1,724 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Pretty+-- Copyright   :  Copyright (c) 2007 Bertram Felgenhauer+--                          (c) 2008 Benedikt Huber+--                          (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  : jwlato@gmail.com+-- Stability   : experimental+-- Portability : portable+--+-- This module provides a pretty printer for the parse tree+-- ('Language.ObjC.Syntax.AST').+-----------------------------------------------------------------------------+module Language.ObjC.Pretty (+    -- * Pretty Printing+    Pretty (..),+    -- * Testing+    prettyUsingInclude+) where+import Data.List (isSuffixOf)+import qualified Data.Set as Set+import Text.PrettyPrint.HughesPJ+import Debug.Trace {- for warnings -}++import Language.ObjC.Data+import Language.ObjC.Syntax++-- | A class of types which can be pretty printed+class Pretty p where+    -- | pretty print the given value+    pretty     :: p -> Doc+    -- | @prettyPrec prec p@ pretty prints p assuming+    -- that the surrounding context has a precedence of+    -- @prec@+    prettyPrec :: Int -> p -> Doc++    pretty       = prettyPrec 0+    prettyPrec _ = pretty++-- pretty print optional chunk+maybeP :: (p -> Doc) -> Maybe p -> Doc+maybeP = maybe empty++-- pretty print when flag is true+ifP :: Bool -> Doc -> Doc+ifP flag doc = if flag then doc else empty++-- pretty print _optional_ list, i.e. [] ~ Nothing and (x:xs) ~ Just (x:xs)+mlistP :: ([p] -> Doc) -> [p] -> Doc+mlistP pp xs = maybeP pp (if null xs then Nothing else Just xs)++-- pretty print identifier+identP :: Ident -> Doc+identP = text . identToString++-- pretty print attribute annotations+attrlistP :: [CAttr] -> Doc+attrlistP [] = empty+attrlistP attrs = text "__attribute__" <> parens (parens (hcat . punctuate comma . map pretty $ attrs))++-- analogous to showParen+parenPrec :: Int -> Int -> Doc -> Doc+parenPrec prec prec2 t = if prec <= prec2 then t else parens t++-- indent a chunk of code+ii :: Doc -> Doc+ii = nest 4++-- Pretty instances+instance Pretty CTranslUnit where+    pretty (CTranslUnit edecls _) = vcat (map pretty edecls)++-- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives.+--+-- The resulting file may not compile (because of missing @#define@ directives and similar things), but is very useful+-- for testing, as otherwise the pretty printed file will be cluttered with declarations from system headers.+prettyUsingInclude :: CTranslUnit -> Doc+prettyUsingInclude (CTranslUnit edecls _) =+  includeWarning headerFiles+    $$+  (vcat $ map (either includeHeader pretty) mappedDecls)+  where+    (headerFiles,mappedDecls) = foldr addDecl (Set.empty,[]) $ map tagIncludedDecls edecls+    tagIncludedDecls edecl | isHeaderFile ((posFile . posOf) edecl) = Left ((posFile . posOf) edecl)+                           | otherwise = Right edecl+    addDecl decl@(Left headerRef) (headerSet, ds)+      | Set.member headerRef headerSet = (headerSet, ds)+      | otherwise = (Set.insert headerRef headerSet, decl : ds)+    addDecl decl (headerSet,ds) = (headerSet, decl : ds)+    includeHeader hFile = text "#include" <+> doubleQuotes (text hFile)+    isHeaderFile = (".h" `isSuffixOf`)+    includeWarning hs | Set.null hs = empty+                      | otherwise = text "/* Warning: The #include directives in this file aren't necessarily correct. */"++-- TODO: Check need of __extension__+instance Pretty CExtDecl where+    pretty (CDeclExt decl) = pretty decl <> semi+    pretty (CFDefExt fund) = pretty fund+    pretty (ObjCClassExt   cls) = pretty cls+    pretty (ObjCIfaceExt   cls) = pretty cls+    pretty (ObjCImplExt    cls) = pretty cls+    pretty (ObjCCatExt     ct)  = pretty ct+    pretty (ObjCCatImplExt ct)  = pretty ct+    pretty (ObjCProtoExt   pr)  = pretty pr+    pretty (CAsmExt  asmStmt _) = text "asm" <> parens (pretty asmStmt) <> semi++-- TODO: Check that old-style and new-style aren't mixed+instance Pretty CFunDef where+    pretty (CFunDef declspecs declr decls stat _) =          -- Example:+            hsep (map pretty declspecs)                      -- __attribute__((noreturn)) static long+        <+> pretty declr                                     -- foo(b)+        $+$ (ii . vcat . map (<> semi) . map pretty) decls   --     register long b;+        $$ prettyPrec (-1) stat                              -- {  ...+                                                             -- }++instance Pretty ObjCClassDef where+    pretty (ObjCClassDef decls _) =+      text "@class"+      <+> hsep (punctuate comma (map pretty decls))+      <> semi++instance Pretty ObjCClassDeclr where+    pretty (ObjCClassDeclr nm _) = identP nm++instance Pretty (ObjCCatDec) where+    pretty (ObjCCatDec i1 i2 protos decls attrs _) =+      attrlistP attrs+      $$ text "@interface" <+> identP i1 <+> parens (identP i2)+      $$ pProto protos+      $$ sep (map pretty decls)+      $$ text "@end"++instance Pretty (ObjCCatImpl) where+    pretty (ObjCCatImpl i1 i2 defs _) =+      text "@implementation" <+> identP i1 <+> parens (identP i2)+      $$ sep (map pretty defs)+      $$ text "@end"++instance Pretty ObjCIface where+    pretty (ObjCIface cn sp protos vars decls attrs _) =+      attrlistP attrs+      $$ text "@interface" <+> pretty cn+      <+> maybe empty ((text ":" <+>) . pretty) sp+      <+> pProto protos+      <+> pVars vars+      $$ sep (map pretty decls)+      $$ text "@end"++instance Pretty ObjCImpl where+    pretty (ObjCImpl cn sp vars defs _) =+      text "@implementation" <+> pretty cn+      <+> maybe empty ((text ":" <+>) . pretty) sp+      <+> pVars vars+      $$ sep (map pretty defs)+      $$ text "@end"++instance Pretty ObjCImplDef where+    pretty (ObjCImplDec dec) = pretty dec+    pretty (ObjCImplMethod def) = pretty def+    pretty (ObjCImplFun def) = pretty def++instance Pretty ObjCProtoDec where+    pretty (ObjCForwardProtoDec ids attrs _) =+      attrlistP attrs+      $$ text "@protocol" <+> hsep (punctuate comma $ map identP ids) <+> semi+    pretty (ObjCProtoDec p refs decls attrs _) =+      attrlistP attrs+      $$ text "@protocol" <+> identP p <+> pProto refs+      $$ sep (map pretty decls)+      $$ text "@end"++instance Pretty ObjCProtoDeclBlock where+    pretty (ObjCProtoDeclBlock decs _) = sep $ map pretty decs+    pretty (ObjCReqProtoBlock decs _)  =+      text "@required" $$ sep (map pretty decs)+    pretty (ObjCOptProtoBlock decs _)  =+      text "@optional" $$ sep (map pretty decs)++instance Pretty ObjCIfaceDecl where+    pretty (ObjCIfaceDecl decl _)       = pretty decl <> semi+    pretty (ObjCIfaceMethodDecl decl _) = pretty decl <> semi+    pretty (ObjCIfacePropDecl decl _)   = pretty decl <> semi++instance Pretty ObjCMethodDecl where+    pretty (ObjCMethodDecl typ typName sel attrs _) =+      hsep [pretty typ,pName typName,pretty sel,attrlistP attrs]+      where pName = maybe empty (parens . pretty)++instance Pretty ObjCMethodDef where+    pretty (ObjCMethodDef typ typName sel decls stmt _) =+      hsep [pretty typ, pName typName, pretty sel]+      $+$ (ii . vcat . map (<> semi) . map pretty) decls+      $+$ pretty stmt+      where pName = maybe empty (parens . pretty)++instance Pretty ObjCMethodType where+    pretty ObjCClassMethod    = text "+"+    pretty ObjCInstanceMethod = text "-"++instance Pretty ObjCMethodSel where+    pretty (ObjCUnaryMethod sel _)      = pretty sel+    pretty (ObjCMethod keys Nothing _)  = hsep $ map pretty keys+    pretty (ObjCMethod keys (Just p) _) =+      hsep (map pretty keys) <+> comma <+> prettyParams (Right p)+    pretty (ObjCEllipseMethod keys _)   =+      hsep (map pretty keys) <+> comma <+> text "..."++instance Pretty ObjCSel where+    pretty (ObjCSel nm _) = identP nm+    pretty (ObjCInSel _)  = text "in"+    pretty (ObjCOutSel _) = text "out"++instance Pretty ObjCKeyDeclr where+    pretty (ObjCKeyDeclr mSel mT nm _) =+      p1 mSel <> colon <> p2 mT <+> identP nm+      where p1 = maybe empty pretty+            p2 = maybe empty (parens . pretty)++instance Pretty ObjCPropDecl where+    pretty (ObjCPropDecl pmods decl _) =+      text "@property" <+> p1 pmods <+> pretty decl+      where p1 [] = empty+            p1 ts = parens (hsep $ punctuate comma $ map pretty ts)++instance Pretty ObjCPropMod where+    pretty (ObjCPropMod nm mval _) =+      identP nm <+> maybe empty ((text "=" <+>) . identP) mval++pVars :: [ObjCInstanceVarBlock] -> Doc+pVars [] = empty+pVars vars = lbrace $$ sep (map pretty vars) $$ rbrace++pProto :: [ObjCProtoNm] -> Doc+pProto [] = empty+pProto pl = angles . hsep . punctuate comma $ map pretty pl++angles :: Doc -> Doc+angles doc = text "<" <> doc <> text ">"++instance Pretty ObjCInstanceVarBlock where+    pretty (ObjCInstanceVarBlock mvis decls _) =+      maybe empty pretty mvis $$ hsep (map ((<> semi) . pretty ) decls)++instance Pretty ObjCVisSpec where+    pretty (ObjCVisSpec vt _) = pretty vt++instance Pretty ObjCVisType where+    pretty ObjCPrivVis    = text "@private"+    pretty ObjCProtVis    = text "@protected"+    pretty ObjCPubVis     = text "@public"+    pretty ObjCPackageVis = text "@package"++instance Pretty ObjCClassNm where+    pretty (ObjCClassNm nm _) = identP nm++instance Pretty ObjCProtoNm where+    pretty (ObjCProtoNm nm _) = identP nm++instance Pretty CStat where+    pretty (CLabel ident stat cattrs _) = identP ident <> text ":" <+> attrlistP cattrs $$ pretty stat+    pretty (CCase expr stat _) =+        text "case" <+> pretty expr <> text ":" $$ pretty stat+    pretty (CCases expr1 expr2 stat _) =+        text "case" <+> pretty expr1 <+> text "..."+                    <+> pretty expr2 <> text ":" $$ pretty stat+    pretty (CDefault stat _) = text "default:" $$ pretty stat+    pretty (CExpr expr _) = ii $ maybeP pretty expr <> semi+    pretty c@(CCompound _ _ _) = prettyPrec 0 c+    pretty (CIf expr stat estat _) =+        ii $  text "if" <+> parens (pretty expr)+                $+$ prettyBody stat+                $$  maybeP prettyElse estat+      where+        prettyBody c@(CCompound _ _ _) = prettyPrec (-1) c+        prettyBody nonCompound         = prettyPrec (-1) (CCompound [] [CBlockStmt nonCompound] undefined)+        prettyElse (CIf else_if_expr else_if_stat else_stat _) =+          text "else if" <+> parens (pretty else_if_expr)+            $+$ prettyBody else_if_stat+            $$  maybeP prettyElse else_stat+        prettyElse else_stmt =+          text "else"+            $+$ prettyBody else_stmt++    pretty (CSwitch expr stat _) =+        ii $ text "switch" <+> text "(" <> pretty expr <> text ")"+               $+$ prettyPrec (-1) stat+    pretty (CWhile expr stat False _) =+        ii $ text "while" <+> text "(" <> pretty expr <> text ")"+               $+$ prettyPrec (-1) stat+    pretty (CWhile expr stat True _) =+        ii $ text "do" $+$ prettyPrec (-1) stat+               $$ text "while" <+> text "(" <> pretty expr <> text ");"+    pretty (CFor for_init cond step stat _) =+        ii $ text "for" <+> text "("+               <> either (maybeP pretty) pretty for_init <> semi+               <+> maybeP pretty cond <> semi+               <+> maybeP pretty step <> text ")" $+$ prettyPrec (-1) stat+    pretty (CGoto ident _) = ii $ text "goto" <+> identP ident <> semi+    pretty (CGotoPtr expr _) = ii $ text "goto" <+> text "*" <+> prettyPrec 30 expr <> semi+    pretty (CCont _) = ii $ text "continue" <> semi+    pretty (CBreak _) = ii $ text "break" <> semi+    pretty (CReturn Nothing _) = ii $ text "return" <> semi+    pretty (CReturn (Just e) _) = ii $ text "return" <+> pretty e <> semi+    pretty (CAsm asmStmt _) = pretty asmStmt+    prettyPrec p (CCompound localLabels bis _) =+        let inner = text "{" $+$ mlistP ppLblDecls localLabels $+$ vcat (map pretty bis) $$ text "}"+        in  if p == -1 then inner else ii inner+        where ppLblDecls =  vcat . map (\l -> text "__label__" <+> identP l <+> semi)+    prettyPrec _ p = pretty p++instance Pretty CAsmStmt where+    pretty (CAsmStmt tyQual expr outOps inOps clobbers _) =+        ii $ text "__asm__" <+>+             maybeP pretty tyQual <>+             parens asmStmt <> semi+      where+        asmStmt = pretty expr <+>+                  (if all null [inOps,outOps] && null clobbers then empty else ops)+        ops     =  text ":" <+> hcat (punctuate comma (map pretty outOps)) <+>+                   text ":" <+> hcat (punctuate comma (map pretty inOps)) <+>+                   (if null clobbers then empty else clobs)+        clobs   =  text ":" <+> hcat (punctuate comma (map pretty clobbers))++instance Pretty CAsmOperand where+    -- asm_operand :~ [operand-name] "constraint" ( expr )+    pretty (CAsmOperand mArgName cnstr expr _) =+        maybeP (\argName -> text "[" <> identP argName <> text "]") mArgName <+>+        pretty cnstr <+>+        parens (pretty expr)++-- TODO: Check need of __extension__+instance Pretty CBlockItem where+    pretty (CBlockStmt stat) = pretty stat+    pretty (CBlockDecl decl) = ii $ pretty decl <> semi+    pretty (CNestedFunDef fundef) = ii $ pretty fundef++instance Pretty CDecl where+    -- CAVEAT:+    -- we may not print __attribute__s directly after typespecs,+    -- as this may change the semantics of the declaration.+    -- The parser fixes this, but to avoid hard-to-track code generator+    -- errors, we enforce this invariant on the AST level.+    pretty (CDecl specs divs _) =+        hsep (map pretty checked_specs) <+> hsep (punctuate comma (map p divs))+            where+            -- possible hint for AST improvement - (declr, initializer, expr, attrs)+            -- currently there are no sensible attributes for unnamed bitfields though+            p (declr, initializer, expr) =+                maybeP (prettyDeclr False 0) declr <+>+                maybeP ((text ":" <+>) . pretty) expr <+>+                attrlistP (getAttrs declr) <+>+                maybeP ((text "=" <+>) . pretty) initializer+            checked_specs =+                case any isAttrAfterSUE  (zip specs (tail specs)) of+                    True -> trace+                              ("Warning: AST Invariant violated: __attribute__ specifier following struct/union/enum:"+++                               (show $ map pretty specs))+                            specs+                    False -> specs+            isAttrAfterSUE (CTypeSpec ty,CTypeQual (CAttrQual _)) = isSUEDef ty+            isAttrAfterSUE _ = False+            getAttrs Nothing = []+            getAttrs (Just (CDeclr _ _ _ cattrs _)) = cattrs++instance Pretty CDeclSpec where+    pretty (CStorageSpec sp) = pretty sp+    pretty (CTypeSpec sp) = pretty sp+    pretty (CTypeQual qu) = pretty qu++instance Pretty CStorageSpec where+    pretty (CAuto _) = text "auto"+    pretty (CRegister _) = text "register"+    pretty (CStatic _) = text "static"+    pretty (CExtern _) = text "extern"+    pretty (CTypedef _) = text "typedef"+    pretty (CThread _) = text "__thread"++instance Pretty CTypeSpec where+    pretty (CVoidType _)        = text "void"+    pretty (CCharType _)        = text "char"+    pretty (CShortType _)       = text "short"+    pretty (CIntType _)         = text "int"+    pretty (CLongType _)        = text "long"+    pretty (CFloatType _)       = text "float"+    pretty (CDoubleType _)      = text "double"+    pretty (CSignedType _)      = text "signed"+    pretty (CUnsigType _)       = text "unsigned"+    pretty (CBoolType _)        = text "_Bool"+    pretty (CComplexType _)     = text "_Complex"+    pretty (CSUType union _)    = pretty union+    pretty (CEnumType enum _)   = pretty enum+    pretty (CTypeDef ident _)   = identP ident+    pretty (CTypeOfExpr expr _) =+        text "typeof" <> text "(" <> pretty expr <> text ")"+    pretty (CTypeOfType decl _) =+        text "typeof" <> text "(" <> pretty decl <> text ")"+    pretty (ObjCClassProto ident protos _)   =+        identP ident <+> pProto protos+    pretty (ObjCTypeProto  ident protos _)   =+        identP ident <+> pProto protos++instance Pretty CTypeQual where+    pretty (CConstQual _) = text "const"+    pretty (CVolatQual _) = text "volatile"+    pretty (CRestrQual _) = text "__restrict"+    pretty (CInlineQual _) = text "inline"+    pretty (CAttrQual a)  = attrlistP [a]+    pretty (ObjCProtoQual pq)  = pretty pq++instance Pretty ObjCProtoQual where+    pretty (ObjCInQual     _) = text "in"+    pretty (ObjCOutQual    _) = text "out"+    pretty (ObjCInOutQual  _) = text "inout"+    pretty (ObjCOnewayQual _) = text "oneway"+    pretty (ObjCBycopyQual _) = text "bycopy"++instance Pretty CStructUnion where+    pretty (CStruct tag ident Nothing cattrs _) = pretty tag <+> attrlistP cattrs <+> maybeP identP ident+    pretty (CStruct tag ident (Just []) cattrs _) =+        pretty tag <+> attrlistP cattrs <+> maybeP identP ident <+> text "{ }"+    pretty (CStruct tag ident (Just decls) cattrs _) = vcat [+        pretty tag <+> attrlistP cattrs <+> maybeP identP ident <+> text "{",+        ii $ sep (map (<> semi) (map pretty decls)),+        text "}"]++instance Pretty CStructTag where+    pretty CStructTag = text "struct"+    pretty CUnionTag  = text "union"++instance Pretty CEnum where+    pretty (CEnum enum_ident Nothing cattrs _) = text "enum" <+> attrlistP cattrs <+> maybeP identP enum_ident+    pretty (CEnum enum_ident (Just vals) cattrs _) = vcat [+        text "enum" <+> attrlistP cattrs <+> maybeP identP enum_ident <+> text "{",+        ii $ sep (punctuate comma (map p vals)),+        text "}"] where+        p (ident, expr) = identP ident <+> maybeP ((text "=" <+>) . pretty) expr++--  Analyze a declarator and return a human-readable description+--   See C99 Spec p 115ff.+-- describeDeclr :: CDeclr -> Doc+-- describeDeclr declr =+--     let declrs = reverse (declrChain declr) in+--     endDescr (foldl descrDeclr undefined declrs)+--+--   where+--   declrChain declr@(CVarDeclr _ _ _ _) = [declr]+--   declrChain declr@(CPtrDeclr _ ideclr _)   = declr : declrChain ideclr+--   declrChain declr@(CBlkDeclr _ ideclr _)   = declr : declrChain ideclr+--   declrChain declr@(CArrDeclr ideclr _ _ _) = declr : declrChain ideclr+--   declrChain declr@(CFunDeclr ideclr _ _ _)   = declr : declrChain ideclr+--+--   descrDeclr _ (CVarDeclr ident asm cattrs _) = single False $ \_ ->+--       maybe (text "<anonymous>") identP ident <+>+--       maybeP (\asmname -> parens (text "asm:" <+> pretty asmname)) asm <+>+--       text "is" <+> (if null cattrs then empty else prettyList (map CAttrQual cattrs) <> comma)+--   descrDeclr (pre,isPlural) (CPtrDeclr quals declr _) = single isPlural $ \pluralize ->+--   descrDeclr (pre,isPlural) (CBlkDeclr quals declr _) = single isPlural $ \pluralize ->+--       pre <+> indefArticle isPlural <> prettyList quals <+> pluralize "block of " "blocks of"+--   descrDeclr (pre,isPlural) (CArrDeclr declr quals expr _) = plural isPlural $ \pluralize ->+--       pre <+> indefArticle' isPlural <> prettyList quals <+> pluralize "array of" "arrays of"+--   descrDeclr (pre,isPlural) (CFunDeclr declr params cattrs _) = single isPlural $ \pluralize ->+--       pre <+> indefArticle isPlural <> prettyList (map CAttrQual cattrs) <+> pluralize "function returning" "functions returning"+--   endDescr (pre, isPlural) =  pre <+> text (if isPlural then "<typed objects>" else "a <typed object>")+--   single :: Bool -> ( (String -> String -> Doc) -> a ) -> (a, Bool)+--   single isPlural mkDescr = (mkDescr (pluralize isPlural), isPlural)+--   plural :: Bool -> ( (String -> String -> Doc) -> a ) -> (a, Bool)+--   plural isPlural mkDescr = (mkDescr (pluralize isPlural), True)+--   indefArticle isPlural  = text$ if isPlural then "" else "a "+--   indefArticle' isPlural = text$ if isPlural then "" else "an "+--   pluralize isPlural s p = text (if isPlural then p else s)+--   prettyList :: (Pretty a) => [a] -> Doc+--   prettyList = hsep . punctuate comma . map pretty+instance Pretty CDeclr where+    prettyPrec prec declr = prettyDeclr True prec declr++prettyDeclr :: Bool -> Int -> CDeclr -> Doc+prettyDeclr show_attrs prec (CDeclr name derived_declrs asmname cattrs _) =+    ppDeclr prec (reverse derived_declrs) <+> prettyAsmName asmname <+> ifP show_attrs (attrlistP cattrs)+    where+    ppDeclr _ [] = maybeP identP name+    --'*' __attribute__? qualifiers declarator+    ppDeclr p (CPtrDeclr quals _ : declrs) =+        parenPrec p 5 $ text "*" <> hsep (map pretty quals) <+> ppDeclr 5 declrs+    ppDeclr p (CBlkDeclr quals _ : declrs) =+        parenPrec p 5 $ text "^" <> hsep (map pretty quals) <+> ppDeclr 5 declrs++    -- declarator[ __attribute__? qualifiers expr ]+    ppDeclr p (CArrDeclr quals size _ : declrs) =+        parenPrec p 6 $ ppDeclr 6 declrs <> brackets (hsep (map pretty quals) <+> pretty size)+    -- declarator ( arguments )+    -- or (__attribute__ declarator) (arguments)+    ppDeclr _ (CFunDeclr params fun_attrs _ : declrs) =+        (if not (null fun_attrs) then parens (attrlistP fun_attrs <+> ppDeclr 5 declrs) else ppDeclr 6 declrs)+        <> parens (prettyParams params)+++-- | pretty-print parameters (used by function declarators and code blocks)+prettyParams :: Either [Ident] ([CDecl], Bool) -> Doc+prettyParams (Right (decls, isVariadic)) =+ sep (punctuate comma (map pretty decls))+ <> (if isVariadic then text "," <+> text "..." else empty)+prettyParams (Left oldStyleIds) =+ hsep (punctuate comma (map identP oldStyleIds))++prettyAsmName :: Maybe CStrLit -> Doc+prettyAsmName asm_name_opt+    = maybe empty (\asm_name -> text "__asm__" <> parens (pretty asm_name)) asm_name_opt++instance Pretty CArrSize where+  pretty (CNoArrSize completeType) = ifP completeType (text "*")+  pretty (CArrSize staticMod expr) = ifP staticMod (text "static") <+> pretty expr+-- initializer :: { CInit }+-- initializer :- assignment_expression+--              | '{' (designation? initializer)_cs_list '}'+instance Pretty CInit where+    pretty (CInitExpr expr _) = pretty expr+    pretty (CInitList initl _) =+        text "{" <+> hsep (punctuate comma (map p initl)) <+> text "}" where+        p ([], initializer)     = pretty initializer+        p (desigs, initializer) = hsep (map pretty desigs) <+> text "=" <+> pretty initializer++-- designation :- designator_list '='+--             | array_range_designator+-- arr_designator :- '[' constant_expression ']'+-- member_designator :-  '.' identifier+-- arr_range _designator :- '[' constant_expression "..." constant_expression ']'++instance Pretty CDesignator where+    pretty (CArrDesig expr _) = text "[" <> pretty expr <> text "]"+    pretty (CMemberDesig ident _) = text "." <> identP ident+    pretty (CRangeDesig expr1 expr2 _) =+        text "[" <> pretty expr1 <+> text "..." <+> pretty expr2 <> text "]"++instance Pretty CAttr where+    pretty (CAttr attrName [] _) = identP attrName+    pretty (CAttr attrName attrParams _) = identP attrName <> parens (hsep . punctuate comma . map pretty $ attrParams)++instance Pretty CExpr where+    prettyPrec p (CComma exprs _) =+        parenPrec p (-1) $ hsep (punctuate comma (map (prettyPrec 2) exprs))+    prettyPrec p (CAssign op expr1 expr2 _) =+        parenPrec p 2 $ prettyPrec 3 expr1 <+> pretty op <+> prettyPrec 2 expr2+    prettyPrec p (CCond expr1 expr2 expr3 _) =+        parenPrec p 2 $ prettyPrec 4 expr1 <+> text "?" -- NB: assignment only has a higher precedence if cond is on the rhs+           <+> maybeP pretty expr2 <+> text ":" <+> prettyPrec 4 expr3+    prettyPrec p (CBinary op expr1 expr2 _) =+        let prec = binPrec op+        in  parenPrec p prec $ prettyPrec prec expr1+                             <+> pretty op <+> prettyPrec (prec + 1) expr2+    prettyPrec p (CCast decl expr _) =+        parenPrec p 25 $ text "(" <> pretty decl <> text ")"+                       <+> prettyPrec 25 expr+    prettyPrec p (CUnary CPostIncOp expr _) =+        parenPrec p 26 $ prettyPrec 26 expr <> text "++"+    prettyPrec p (CUnary CPostDecOp expr _) =+        parenPrec p 26 $ prettyPrec 26 expr <> text "--"+    prettyPrec p (CUnary op expr@(CUnary _ _ _) _) =+        --                             parens aren't necessary, but look nicer imho+        parenPrec p 25 $ pretty op <+> parens (prettyPrec 25 expr)+    prettyPrec p (CUnary op expr _) =+        parenPrec p 25 $ pretty op <> prettyPrec 25 expr+    prettyPrec p (CSizeofExpr expr _) =+        parenPrec p 25 $ text "sizeof" <> parens (pretty expr)+    prettyPrec p (CSizeofType decl _) =+        parenPrec p 25 $ text "sizeof" <> parens (pretty decl)+    prettyPrec p (CAlignofExpr expr _) =+        parenPrec p 25 $ text "__alignof" <> parens (pretty expr)+    prettyPrec p (CAlignofType decl _) =+        parenPrec p 25 $ text "__alignof" <> parens (pretty decl)+    prettyPrec p (CComplexReal expr _) =+        parenPrec p 25 $ text "__real" <+> prettyPrec 25 expr+    prettyPrec p (CComplexImag expr _) =+        parenPrec p 25 $ text "__imag" <+> prettyPrec 25 expr+    prettyPrec p (CIndex expr1 expr2 _) =+        parenPrec p 26 $ prettyPrec 26 expr1+                       <> text "[" <> pretty expr2 <> text "]"+    prettyPrec p (CCall expr args _) =+        parenPrec p 30 $ prettyPrec 30 expr <> text "("+            <> (sep . punctuate comma . map pretty) args <> text ")"+    prettyPrec p (CMember expr ident deref _) =+        parenPrec p 26 $ prettyPrec 26 expr+                       <> text (if deref then "->" else ".") <> identP ident+    prettyPrec _p (CVar ident _) = identP ident+    prettyPrec _p (CConst constant) = pretty constant+    prettyPrec _p (CCompoundLit decl initl _) =+        parens (pretty decl) <+> (braces . hsep . punctuate comma) (map p initl) where+        p ([], initializer)           = pretty initializer+        p (mems, initializer) = hcat (punctuate (text ".") (map pretty mems)) <+> text "=" <+> pretty initializer++    prettyPrec _p (CStatExpr stat _) =+        text "(" <> pretty stat <> text ")"++    -- unary_expr :- && ident  {- address of label -}+    prettyPrec _p (CLabAddrExpr ident _) = text "&&" <> identP ident++    prettyPrec _p (CBuiltinExpr builtin) = pretty builtin++    prettyPrec _p (CBlockExpr params statement _) =+      text "^" <+> parens (prettyParams $ Right params) <+> pretty statement++    prettyPrec _p (ObjCMessageExpr msg _) = pretty msg+    prettyPrec _p (ObjCSelectorExpr sn _) =+      text "@selector" <+> parens (pretty sn)+    prettyPrec _p (ObjCProtoExpr i _) = text "@protocol" <+> parens (identP i)+    prettyPrec _p (ObjCEncodeExpr decls _) =+      text "@encode" <+> parens (pretty decls)+    prettyPrec _p (ObjCConst cnst) = pretty cnst++instance Pretty ObjCConst where+    pretty (ObjCStrConst str _) = text "@" <> text (show str)++instance Pretty ObjCSelName where+    pretty (ObjCSelPlain sn _) = pretty sn+    pretty (ObjCSelKeys skns _) = hsep (map pretty skns)++instance Pretty ObjCSelKeyName where+    pretty (ObjCSelKeyName Nothing  _) = colon+    pretty (ObjCSelKeyName (Just s) _) = pretty s <> colon++instance Pretty ObjCMsgExpr where+    pretty (ObjCMsgExpr expr sel _) = brackets $ pretty expr  <+> pretty sel+    pretty (ObjCMsgClass cn  sel _) = brackets $ pretty cn    <+> pretty sel+    pretty (ObjCMsgSup       sel _) = brackets $ text "super" <+> pretty sel++instance Pretty ObjCMsgSel where+    pretty (ObjCMsgSel sel _) = pretty sel+    pretty (ObjCKeyArgs args _) = hsep $ map pretty args++instance Pretty ObjCKeyArg where+    pretty (ObjCKeyArg selname expr _) = pretty selname <> pretty expr++instance Pretty CBuiltin where+    pretty (CBuiltinVaArg expr ty_name _) =+        text "__builtin_va_arg" <+>+        (parens $ pretty expr <> comma <+> pretty ty_name)+    -- The first desig has to be a member field.+    pretty (CBuiltinOffsetOf ty_name (CMemberDesig field1 _ : desigs) _) =+        text "__builtin_offsetof" <+>+        (parens $ pretty ty_name <> comma <+> identP field1 <> hcat (map pretty desigs) )+    pretty (CBuiltinOffsetOf _ty_name otherDesigs _) =+        error $ "Inconsistent AST: Cannot interpret designators in offsetOf: "++ show (hcat$ map pretty otherDesigs)+    pretty (CBuiltinTypesCompatible ty1 ty2 _) =+        text "__builtin_types_compatible_p" <+>+        (parens $ pretty ty1 <> comma <+> pretty ty2)++instance Pretty CAssignOp where+  pretty op = text $ case op of+    CAssignOp -> "="+    CMulAssOp -> "*="+    CDivAssOp -> "/="+    CRmdAssOp -> "%="+    CAddAssOp -> "+="+    CSubAssOp -> "-="+    CShlAssOp -> "<<="+    CShrAssOp -> ">>="+    CAndAssOp -> "&="+    CXorAssOp -> "^="+    COrAssOp  -> "|="++instance Pretty CBinaryOp where+  pretty op = text $ case op of+    CMulOp -> "*"+    CDivOp -> "/"+    CRmdOp -> "%"+    CAddOp -> "+"+    CSubOp -> "-"+    CShlOp -> "<<"+    CShrOp -> ">>"+    CLeOp  -> "<"+    CGrOp  -> ">"+    CLeqOp -> "<="+    CGeqOp -> ">="+    CEqOp  -> "=="+    CNeqOp -> "!="+    CAndOp -> "&"+    CXorOp -> "^"+    COrOp  -> "|"+    CLndOp -> "&&"+    CLorOp -> "||"++instance Pretty CUnaryOp where+  pretty op = text $ case op of+    CPreIncOp  -> "++"+    CPreDecOp  -> "--"+    CPostIncOp -> "++"+    CPostDecOp -> "--"+    CAdrOp     -> "&"+    CIndOp     -> "*"+    CPlusOp    -> "+"+    CMinOp     -> "-"+    CCompOp    -> "~"+    CNegOp     -> "!"++instance Pretty CConst where+    pretty (CIntConst   int_const _) = text (show int_const)+    pretty (CCharConst  chr _) = text (show chr)+    pretty (CFloatConst flt _) = text (show flt)+    pretty (CStrConst   str _) = text (show str)++instance Pretty CStrLit where+    pretty (CStrLit   str _) = text (show str)++-- precedence of C operators+binPrec :: CBinaryOp -> Int+binPrec CMulOp = 20+binPrec CDivOp = 20+binPrec CRmdOp = 20+binPrec CAddOp = 19+binPrec CSubOp = 19+binPrec CShlOp = 18+binPrec CShrOp = 18+binPrec CLeOp  = 17+binPrec CGrOp  = 17+binPrec CLeqOp = 17+binPrec CGeqOp = 17+binPrec CEqOp  = 16+binPrec CNeqOp = 16+binPrec CAndOp = 15+binPrec CXorOp = 14+binPrec COrOp  = 13+binPrec CLndOp = 12+binPrec CLorOp = 11
+ src/Language/ObjC/Syntax.hs view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Syntax+-- Copyright   :  (c) 2008 Benedikt Huber+--                (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  : jwlato@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Syntax of C files: The abstract syntax tree and constants.+-----------------------------------------------------------------------------+module Language.ObjC.Syntax (+     -- * Constants+     module Language.ObjC.Syntax.Constants,+     -- * Syntax tree+     module Language.ObjC.Syntax.AST,+     -- * Construction utility functions+     module Language.ObjC.Syntax.Builders+)+where+import Language.ObjC.Syntax.AST+import Language.ObjC.Syntax.Constants+import Language.ObjC.Syntax.Builders
+ src/Language/ObjC/Syntax/AST.hs view
@@ -0,0 +1,2129 @@+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Syntax.AST+-- Copyright   :  (c) [1999..2007] Manuel M T Chakravarty+--                (c) 2008 Benedikt Huber+--                (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  : jwlato@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Abstract syntax of C source and header files.+--+--  The tree structure is based on the grammar in Appendix A of K&R.  The+--  abstract syntax simplifies the concrete syntax by merging similar concrete+--  constructs into a single type of abstract tree structure: declarations are+--  merged with structure declarations, parameter declarations and type names,+--  and declarators are merged with abstract declarators.+--+--  With K&R we refer to ``The C Programming Language'', second edition, Brain+--  W. Kernighan and Dennis M. Ritchie, Prentice Hall, 1988. The AST supports all+--  of C99 <http://www.open-std.org/JTC1/SC22/WG14/www/docs/n1256.pdf> and several+--  GNU extensions <http://gcc.gnu.org/onlinedocs/gcc/C-Extensions.html>.+-----------------------------------------------------------------------------+module Language.ObjC.Syntax.AST (+  -- * C translation units+  CTranslUnit,  CExtDecl,+  CTranslationUnit(..),  CExternalDeclaration(..),+  -- * Declarations+  CFunDef,  CDecl, CStructUnion, CEnum,+  CFunctionDef(..),  CDeclaration(..),+  CStructTag(..), CStructureUnion(..),  CEnumeration(..),+  -- ** Objective-C extensions+  ObjCIface, ObjCClassDef, ObjCProtoNm, ObjCInstanceVarBlock, ObjCVisSpec,+  ObjCPropDecl, ObjCSel, ObjCMethodSel, ObjCMethodDecl, ObjCProtoDec,+  ObjCProtoDeclBlock, ObjCCatDec, ObjCImpl, ObjCCatImpl, ObjCMethodDef,+  ObjCImplDef,+  ObjCInterface(..), ObjCClassListDef(..), ObjCProtocolName(..),+  ObjCInstanceVariableBlock(..),ObjCVisibilitySpec(..),ObjCVisType(..),+  ObjCPropertyDeclaration(..), ObjCSelector(..), ObjCMethodSelector(..),+  ObjCMethodType(..), ObjCMethodDeclaration(..), ObjCProtocolDec(..),+  ObjCProtocolDeclBlock(..), ObjCCategoryDec(..), ObjCImplementation(..),+  ObjCCategoryImplementation(..), ObjCMethodDefinition(..),+  ObjCImplementationDefinition(..),+  -- * Declaration attributes+  CDeclSpec, partitionDeclSpecs,+  CStorageSpec, CTypeSpec, isSUEDef, CTypeQual, CAttr,+  CDeclarationSpecifier(..), CStorageSpecifier(..), CTypeSpecifier(..),+  CTypeQualifier(..), CAttribute(..),+  -- * Objective-C extensions+  ObjCPropMod, ObjCProtoQual,+  ObjCPropertyModifier(..), ObjCProtoQualifier(..),+  -- * Declarators+  CDeclr,CDerivedDeclr,CArrSize,+  CDeclarator(..), CDerivedDeclarator(..), CArraySize(..),+  -- ** Objective-C Extensions+  ObjCClassNm, ObjCClassDeclr, ObjCIfaceDecl, ObjCKeyDeclr,+  ObjCClassName(..), ObjCClassDeclarator(..), ObjCInterfaceDeclaration(..),+  ObjCKeywordDeclarator(..),+  -- * Initialization+  CInit, CInitList, CDesignator,+  CInitializer(..), CInitializerList, CPartDesignator(..),+  -- * Statements+  CStat, CBlockItem, CAsmStmt, CAsmOperand,+  CStatement(..), CCompoundBlockItem(..),+  CAssemblyStatement(..), CAssemblyOperand(..),+  -- * Expressions+  CExpr, CExpression(..),+  CAssignOp(..), CBinaryOp(..), CUnaryOp(..),+  CBuiltin, CBuiltinThing(..),+  -- ** Objective-C Extensions+  ObjCMsgExpr, ObjCMsgSel, ObjCKeyArg, ObjCSelName, ObjCSelKeyName,+  ObjCMessageExpression(..), ObjCMessageSelector(..), ObjCKeywordArg(..),+  ObjCSelectorName(..), ObjCSelectorKeyName(..),+  -- * Constants+  CConst, CStrLit, cstringOfLit, liftStrLit,+  CConstant(..), CStringLiteral(..),+  -- ** Objective-C Extensions+  ObjCConst,+  ObjCConstant(..)+) where+import Language.ObjC.Syntax.Constants+import Language.ObjC.Syntax.Ops+import Language.ObjC.Data.Ident+import Language.ObjC.Data.Node+import Language.ObjC.Data.Position+import Data.Generics++-- | Complete C tranlsation unit (C99 6.9, K&R A10)+--+-- A complete C translation unit, for example representing a C header or source file.+-- It consists of a list of external (i.e. toplevel) declarations.+type CTranslUnit = CTranslationUnit NodeInfo+data CTranslationUnit a+  = CTranslUnit [CExternalDeclaration a] a+    deriving (Show, Data, Typeable {-! ,CNode ,Functor, Annotated !-})++-- | External C declaration (C99 6.9, K&R A10)+--+-- Either a toplevel declaration, function definition, class, category,+-- protocol, or external assembler.+type CExtDecl = CExternalDeclaration NodeInfo+data CExternalDeclaration a+  = CDeclExt (CDeclaration a)+  | CFDefExt (CFunctionDef a)+  | ObjCIfaceExt (ObjCInterface a)+  | ObjCImplExt  (ObjCImplementation a)+  | ObjCClassExt (ObjCClassListDef a)+  | ObjCProtoExt (ObjCProtocolDec a)+  | ObjCCatExt (ObjCCategoryDec a)+  | ObjCCatImplExt (ObjCCategoryImplementation a)+  | CAsmExt  (CStringLiteral a) a+    deriving (Show, Data,Typeable {-! ,CNode ,Functor, Annotated !-})++-- | C function definition (C99 6.9.1, K&R A10.1)+--+-- A function definition is of the form @CFunDef specifiers declarator decllist? stmt@.+--+-- * @specifiers@ are the type and storage-class specifiers of the function.+--   The only storage-class specifiers allowed are /extern/ and /static/.+--+-- * The @declarator@ must be such that the declared identifier has /function type/.+--   The return type shall be void or an object type other than array type.+--+-- * The optional declaration list @decllist@ is for old-style function declarations.+--+-- * The statement @stmt@ is a compound statement.+type CFunDef = CFunctionDef NodeInfo+data CFunctionDef a+  = CFunDef+    [CDeclarationSpecifier a] -- type specifier and qualifier+    (CDeclarator a)           -- declarator+    [CDeclaration a]          -- optional declaration list+    (CStatement a)            -- compound statement+    a+    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})++type ObjCCatDec = ObjCCategoryDec NodeInfo++-- | Objective-C Category definition ('@interface')+data ObjCCategoryDec a =+  ObjCCatDec+    !Ident+    !Ident+    [ObjCProtocolName a]      -- protocol reference list+    [ObjCInterfaceDeclaration a]  -- interface declaration list+    [CAttribute a]+    a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++type ObjCCatImpl = ObjCCategoryImplementation NodeInfo++-- | Objective-C Category implementation '@implementation'+data ObjCCategoryImplementation a =+  ObjCCatImpl+    !Ident+    !Ident+    [ObjCImplementationDefinition a]+    a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++type ObjCClassDef = ObjCClassListDef NodeInfo++-- | Objective-C class listing+-- +-- @class NSObject, NSArray;+data ObjCClassListDef a =+  ObjCClassDef [ObjCClassDeclarator a] a+  deriving (Show, Data, Typeable {-! , CNode, Functor, Annotated !-})++type ObjCProtoDec = ObjCProtocolDec NodeInfo++-- | Objective-C protocol declaration+data ObjCProtocolDec a =+    ObjCForwardProtoDec [Ident] [CAttribute a] a+  | ObjCProtoDec !Ident+                 [ObjCProtocolName a]+                 [ObjCProtocolDeclBlock a]+                 [CAttribute a]+                 a+  deriving (Show, Data, Typeable {-! , CNode, Functor, Annotated !-})++type ObjCProtoDeclBlock = ObjCProtocolDeclBlock NodeInfo++data ObjCProtocolDeclBlock a =+    ObjCProtoDeclBlock [ObjCInterfaceDeclaration a] a+  | ObjCReqProtoBlock  [ObjCInterfaceDeclaration a] a+  | ObjCOptProtoBlock  [ObjCInterfaceDeclaration a] a+  deriving (Show, Data, Typeable {-! , CNode, Functor, Annotated !-})++type ObjCIface = ObjCInterface NodeInfo++-- | Interface declaration, '@interface'+data ObjCInterface a =+  ObjCIface+    (ObjCClassDeclarator a)   -- class name+    (Maybe (ObjCClassName a)) -- superclass+    [ObjCProtocolName a]      --  protocol reference list+    [ObjCInstanceVariableBlock a] -- instance variables+    [ObjCInterfaceDeclaration a]  -- interface declaration list+    [CAttribute a]                -- optional attributes+    a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++type ObjCImpl = ObjCImplementation NodeInfo++-- | Implementation declaration, '@implementation'+data ObjCImplementation a =+  ObjCImpl+    (ObjCClassName a)                -- class name+    (Maybe (ObjCClassName a))        -- superclass+    [ObjCInstanceVariableBlock a]    -- instance variables+    [ObjCImplementationDefinition a] -- implementation definition+    a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++type ObjCClassDeclr = ObjCClassDeclarator NodeInfo++data ObjCClassDeclarator a =+  ObjCClassDeclr !Ident a+ deriving (Show, Data, Typeable, Functor {-! ,CNode, Annotated !-})++type ObjCClassNm = ObjCClassName NodeInfo++data ObjCClassName a = ObjCClassNm !Ident a+ deriving (Show, Data, Typeable, Functor {-! ,CNode, Annotated !-})++type ObjCProtoNm = ObjCProtocolName NodeInfo++data ObjCProtocolName a = ObjCProtoNm !Ident a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++type ObjCInstanceVarBlock = ObjCInstanceVariableBlock NodeInfo++data ObjCInstanceVariableBlock a =+  ObjCInstanceVarBlock+  (Maybe (ObjCVisibilitySpec a))+  [CDeclaration a]+  a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++type ObjCVisSpec = ObjCVisibilitySpec NodeInfo++data ObjCVisibilitySpec a =+  ObjCVisSpec !ObjCVisType a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++-- | Available visibility specifications.+data ObjCVisType =+    ObjCPrivVis+  | ObjCProtVis+  | ObjCPubVis+  | ObjCPackageVis+  deriving (Show, Data, Typeable, Enum)+ +type ObjCIfaceDecl = ObjCInterfaceDeclaration NodeInfo++data ObjCInterfaceDeclaration a =+    ObjCIfaceDecl (CDeclaration a) a+  | ObjCIfaceMethodDecl (ObjCMethodDeclaration a) a+  | ObjCIfacePropDecl   (ObjCPropertyDeclaration a) a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})+++type ObjCImplDef = ObjCImplementationDefinition NodeInfo++data ObjCImplementationDefinition a =+    ObjCImplDec    (CDeclaration a)+  | ObjCImplMethod (ObjCMethodDefinition a)+  | ObjCImplFun    (CFunctionDef a)+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++type ObjCMethodDecl = ObjCMethodDeclaration NodeInfo++data ObjCMethodDeclaration a =+    ObjCMethodDecl+    !ObjCMethodType+    (Maybe (CDeclaration a))+    (ObjCMethodSelector a)+    [CAttribute a]+    a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++type ObjCMethodDef = ObjCMethodDefinition NodeInfo++data ObjCMethodDefinition a =+    ObjCMethodDef+    !ObjCMethodType+    (Maybe (CDeclaration a))+    (ObjCMethodSelector a)+    [CDeclaration a]+    (CStatement a)+    a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++data ObjCMethodType = ObjCClassMethod | ObjCInstanceMethod+  deriving (Show, Data, Typeable, Enum)++type ObjCMethodSel = ObjCMethodSelector NodeInfo++data ObjCMethodSelector a =+    ObjCUnaryMethod (ObjCSelector a) a+  | ObjCMethod [ObjCKeywordDeclarator a] (Maybe ([CDeclaration a],Bool)) a+  | ObjCEllipseMethod [ObjCKeywordDeclarator a] a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++type ObjCKeyDeclr = ObjCKeywordDeclarator NodeInfo++data ObjCKeywordDeclarator a =+   ObjCKeyDeclr+   (Maybe (ObjCSelector a)) -- selector+   (Maybe (CDeclaration a)) -- type name+   !Ident+   a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++type ObjCPropDecl = ObjCPropertyDeclaration NodeInfo++data ObjCPropertyDeclaration a =+   ObjCPropDecl+   [ObjCPropertyModifier a]+   (CDeclaration a)+   a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})++type ObjCPropMod = ObjCPropertyModifier NodeInfo++data ObjCPropertyModifier a =+    ObjCPropMod !Ident (Maybe Ident) a+  deriving (Show, Data, Typeable, Functor {-! ,CNode ,Annotated !-})+++-- | C declarations (K&R A8, C99 6.7), including structure declarations, parameter+--   declarations and type names.+--+-- A declaration is of the form @CDecl specifiers init-declarator-list@, where the form of the declarator list's+--  elements depends on the kind of declaration:+--+-- 1) Toplevel declarations (K&R A8, C99 6.7 declaration)+--+--   * C99 requires that there is at least one specifier, though this is merely a syntactic restriction+--+--   * at most one storage class specifier is allowed per declaration+--+--   * the elements of the non-empty @init-declarator-list@ are of the form @(Just declr, init?, Nothing)@.+--      The declarator @declr@ has to be present and non-abstract and the initialization expression is+--      optional.+--+-- 2) Structure declarations (K&R A8.3, C99 6.7.2.1 struct-declaration)+--+--   Those are the declarations of a structure's members.+--+--   * do not allow storage specifiers+--+--   * in strict C99, the list of declarators has to be non-empty+--+--   * the elements of @init-declarator-list@ are either of the form @(Just declr, Nothing, size?)@,+--     representing a member with optional bit-field size, or of the form @(Nothing, Nothing, Just size)@,+--     for unnamed bitfields. @declr@ has to be non-abstract.+--+--   * no member of a structure shall have incomplete type+--+-- 3) Parameter declarations (K&R A8.6.3, C99 6.7.5 parameter-declaration)+--+--   * @init-declarator-list@ must contain at most one triple of the form @(Just declr, Nothing, Nothing)@,+--     i.e. consist of a single declarator, which is allowed to be abstract (i.e. unnamed).+--+-- 4) Type names (A8.8, C99 6.7.6)+--+--   * do not allow storage specifiers+--+--   * @init-declarator-list@ must contain at most one triple of the form @(Just declr, Nothing, Nothing)@.+--     where @declr@ is an abstract declarator (i.e. doesn't contain a declared identifier)+--+type CDecl = CDeclaration NodeInfo+data CDeclaration a+  = CDecl+    [CDeclarationSpecifier a] -- type specifier and qualifier, __attribute__+    [(Maybe (CDeclarator a),  -- declarator (may be omitted)+      Maybe (CInitializer a), -- optional initialize+      Maybe (CExpression a))] -- optional size (const expr)+    a+    deriving (Show, Data,Typeable {-! ,CNode ,Annotated !-})++-- Derive instance is a little bit ugly+instance Functor CDeclaration where+  fmap f (CDecl specs declarators annot) =+    CDecl (map (fmap f) specs) (map fmap3m declarators) (f annot)+      where fmap3m (a,b,c) = (fmap (fmap f) a, fmap (fmap f) b, fmap (fmap f) c)++-- | C declarator (K&R A8.5, C99 6.7.5) and abstract declarator (K&R A8.8, C99 6.7.6)+--+-- A declarator declares a single object, function, or type. It is always associated with+-- a declaration ('CDecl'), which specifies the declaration's type and the additional storage qualifiers and+-- attributes, which apply to the declared object.+--+-- A declarator is of the form @CDeclr name? indirections asm-name? attrs _@, where+-- @name@ is the name of the declared object (missing for abstract declarators),+-- @declquals@ is a set of additional declaration specifiers,+-- @asm-name@ is the optional assembler name and attributes is a set of+-- attrs is a set of @__attribute__@ annotations for the declared object.+--+-- @indirections@ is a set of pointer, array and function declarators, which modify the type of the declared object as+-- described below. If the /declaration/ specifies the non-derived type @T@,+-- and we have @indirections = [D1, D2, ..., Dn]@ than the declared object has type+-- @(D1 `indirect` (D2 `indirect` ...  (Dn `indirect` T)))@, where+--+--  * @(CPtrDeclr attrs) `indirect` T@ is /attributed pointer to T/+--+--  * @(CFunDeclr attrs) `indirect` T@ is /attributed function returning T/+--+--  * @(CArrayDeclr attrs) `indirect` T@ is /attributed array of elemements of type T/+--+-- Examples (simplified attributes):+--+--  * /x/ is an int+--+-- > int x;+-- > CDeclr "x" []+--+--  * /x/ is a restrict pointer to a const pointer to int+--+-- > const int * const * restrict x;+-- > CDeclr "x" [CPtrDeclr [restrict], CPtrDeclr [const]]+--+--  * /f/ is an function return a constant pointer to int+--+-- > int* const f();+-- > CDeclr "f" [CFunDeclr [],CPtrDeclr [const]]+--+--  * /f/ is a constant pointer to a function returning int+--+-- > int (* const f)(); ==>+-- > CDeclr "f" [CPtrDeclr [const], CFunDeclr []]+type CDeclr = CDeclarator NodeInfo+data CDeclarator a+  = CDeclr (Maybe Ident) [CDerivedDeclarator a] (Maybe (CStringLiteral a)) [CAttribute a] a+    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+++-- | Derived declarators, see 'CDeclr'+--+-- Indirections are qualified using type-qualifiers and generic attributes, and additionally+--+--    * The size of an array is either a constant expression, variable length ('*') or missing; in the last case, the+--      type of the array is incomplete. The qualifier static is allowed for function arguments only, indicating that+--      the supplied argument is an array of at least the given size.+--+--    * New style parameter lists have the form @Right (declarations, isVariadic)@, old style parameter lists have the+--      form @Left (parameter-names)@+type CDerivedDeclr = CDerivedDeclarator NodeInfo+data CDerivedDeclarator a+  = CPtrDeclr [CTypeQualifier a] a+  -- ^ Pointer declarator @CPtrDeclr tyquals declr@+  | CBlkDeclr [CTypeQualifier a] a+  -- ^ Block declarator @CBlkDeclr tyquals declr@+  | CArrDeclr [CTypeQualifier a] (CArraySize a) a+  -- ^ Array declarator @CArrDeclr declr tyquals size-expr?@+  | CFunDeclr (Either [Ident] ([CDeclaration a],Bool)) [CAttribute a] a+    -- ^ Function declarator @CFunDeclr declr (old-style-params | new-style-params) c-attrs@+    deriving (Show, Data,Typeable {-! ,CNode , Annotated !-})++-- Derived instance relies on fmap2+instance Functor CDerivedDeclarator where+        fmap _f (CPtrDeclr a1 a2) = CPtrDeclr (fmap (fmap _f) a1) (_f a2)+        fmap _f (CBlkDeclr a1 a2) = CBlkDeclr (fmap (fmap _f) a1) (_f a2)+        fmap _f (CArrDeclr a1 a2 a3)+          = CArrDeclr (fmap (fmap _f) a1) (fmap _f a2) (_f a3)+        fmap _f (CFunDeclr a1 a2 a3)+          = CFunDeclr (fmap (fmapFirst (fmap (fmap _f))) a1) (fmap (fmap _f) a2)+              (_f a3)+          where fmapFirst f (a,b) = (f a, b)++-- | Size of an array+type CArrSize = CArraySize NodeInfo+data CArraySize a+  = CNoArrSize !Bool               -- ^ @CUnknownSize isCompleteType@+  | CArrSize !Bool (CExpression a) -- ^ @CArrSize isStatic expr@+    deriving (Show, Data,Typeable {-! , Functor !-})+++-- | C statement (K&R A9, C99 6.8)+--+type CStat = CStatement NodeInfo+data CStatement a+  -- | An (attributed) label followed by a statement+  = CLabel  !Ident (CStatement a) [CAttribute a] a+  -- | A statement of the form @case expr : stmt@+  | CCase (CExpression a) (CStatement a) a+  -- | A case range of the form @case lower ... upper : stmt@+  | CCases (CExpression a) (CExpression a) (CStatement a) a+  -- | The default case @default : stmt@+  | CDefault (CStatement a) a+  -- | A simple statement, that is in C: evaluating an expression with+  --   side-effects and discarding the result.+  | CExpr (Maybe (CExpression a)) a+  -- | compound statement @CCompound localLabels blockItems at@+  | CCompound [Ident] [CCompoundBlockItem a] a+  -- | conditional statement @CIf ifExpr thenStmt maybeElseStmt at@+  | CIf (CExpression a) (CStatement a) (Maybe (CStatement a)) a+  -- | switch statement @CSwitch selectorExpr switchStmt@, where+  -- @switchStmt@ usually includes /case/, /break/ and /default/+  -- statements+  | CSwitch (CExpression a) (CStatement a) a+  -- | while or do-while statement @CWhile guard stmt isDoWhile at@+  | CWhile (CExpression a) (CStatement a) Bool a+  -- | for statement @CFor init expr-2 expr-3 stmt@, where @init@ is+  -- either a declaration or initializing expression+  | CFor (Either (Maybe (CExpression a)) (CDeclaration a))+    (Maybe (CExpression a))+    (Maybe (CExpression a))+    (CStatement a)+    a+  -- | goto statement @CGoto label@+  | CGoto !Ident a+  -- | computed goto @CGotoPtr labelExpr@+  | CGotoPtr (CExpression a) a+  -- | continue statement+  | CCont a+  -- | break statement+  | CBreak a+  -- | return statement @CReturn returnExpr@+  | CReturn (Maybe (CExpression a)) a+  -- | assembly statement+  | CAsm (CAssemblyStatement a) a+    deriving (Show, Data,Typeable {-! , CNode , Annotated !-})++-- Derived instance relies on fmap2 :(+instance Functor CStatement where+        fmap _f (CLabel a1 a2 a3 a4)+          = CLabel a1 (fmap _f a2) (fmap (fmap _f) a3) (_f a4)+        fmap _f (CCase a1 a2 a3) = CCase (fmap _f a1) (fmap _f a2) (_f a3)+        fmap _f (CCases a1 a2 a3 a4)+          = CCases (fmap _f a1) (fmap _f a2) (fmap _f a3) (_f a4)+        fmap _f (CDefault a1 a2) = CDefault (fmap _f a1) (_f a2)+        fmap _f (CExpr a1 a2) = CExpr (fmap (fmap _f) a1) (_f a2)+        fmap _f (CCompound a1 a2 a3)+          = CCompound a1 (fmap (fmap _f) a2) (_f a3)+        fmap _f (CIf a1 a2 a3 a4)+          = CIf (fmap _f a1) (fmap _f a2) (fmap (fmap _f) a3) (_f a4)+        fmap _f (CSwitch a1 a2 a3)+          = CSwitch (fmap _f a1) (fmap _f a2) (_f a3)+        fmap _f (CWhile a1 a2 a3 a4)+          = CWhile (fmap _f a1) (fmap _f a2) a3 (_f a4)+        fmap _f (CFor a1 a2 a3 a4 a5)+          = CFor (mapEither (fmap (fmap _f)) (fmap _f) a1)+                 (fmap (fmap _f) a2) (fmap (fmap _f) a3) (fmap _f a4)+                 (_f a5)+          where mapEither f1 f2 = either (Left . f1) (Right . f2)+        fmap _f (CGoto a1 a2) = CGoto a1 (_f a2)+        fmap _f (CGotoPtr a1 a2) = CGotoPtr (fmap _f a1) (_f a2)+        fmap _f (CCont a1) = CCont (_f a1)+        fmap _f (CBreak a1) = CBreak (_f a1)+        fmap _f (CReturn a1 a2) = CReturn (fmap (fmap _f) a1) (_f a2)+        fmap _f (CAsm a1 a2) = CAsm (fmap _f a1) (_f a2)++-- | GNU Assembler statement+--+-- > CAssemblyStatement type-qual? asm-expr out-ops in-ops clobbers _+--+-- is an inline assembler statement.+-- The only type-qualifier (if any) allowed is /volatile/.+-- @asm-expr@ is the actual assembler epxression (a string), @out-ops@ and @in-ops@ are the input+-- and output operands of the statement.+-- @clobbers@ is a list of registers which are clobbered when executing the assembler statement+type CAsmStmt = CAssemblyStatement NodeInfo+data CAssemblyStatement a+  = CAsmStmt+    (Maybe (CTypeQualifier a)) -- maybe volatile+    (CStringLiteral a)         -- assembler expression (String)+    [CAssemblyOperand a]       -- output operands+    [CAssemblyOperand a]       -- input operands+    [CStringLiteral a]         -- Clobbers+    a+    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})++-- | Assembler operand+--+-- @CAsmOperand argName? constraintExpr arg@ specifies an operand for an assembler+-- statement.+type CAsmOperand = CAssemblyOperand NodeInfo+data CAssemblyOperand a+  = CAsmOperand+    (Maybe Ident)       -- argument name+    (CStringLiteral a)  -- constraint expr+    (CExpression a)     -- argument+    a+    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})++-- | C99 Block items+--+--  Things that may appear in compound statements: either statements, declarations+--   or nested function definitions.+type CBlockItem = CCompoundBlockItem NodeInfo+data CCompoundBlockItem a+  = CBlockStmt    (CStatement a)    -- ^ A statement+  | CBlockDecl    (CDeclaration a)  -- ^ A local declaration+  | CNestedFunDef (CFunctionDef a)  -- ^ A nested function (GNU C)+    deriving (Show, Data,Typeable {-! , CNode , Functor, Annotated !-})++-- | C declaration specifiers and qualifiers+--+-- Declaration specifiers include at most one storage-class specifier (C99 6.7.1),+-- type specifiers (6.7.2) and type qualifiers (6.7.3).+type CDeclSpec = CDeclarationSpecifier NodeInfo+data CDeclarationSpecifier a+  = CStorageSpec (CStorageSpecifier a) -- ^ storage-class specifier or typedef+  | CTypeSpec    (CTypeSpecifier a)    -- ^ type name+  | CTypeQual    (CTypeQualifier a)    -- ^ type qualifier+    deriving (Show, Data,Typeable {-! ,CNode ,Functor, Annotated !-})+++-- | Separate the declaration specifiers+--+-- Note that inline isn't actually a type qualifier, but a function specifier.+-- @__attribute__@ of a declaration qualify declarations or declarators (but not types),+-- and are therefore separated as well.+partitionDeclSpecs :: [CDeclarationSpecifier a]+                   -> ( [CStorageSpecifier a], [CAttribute a]+                      , [CTypeQualifier a], [CTypeSpecifier a], Bool)+partitionDeclSpecs = foldr deals ([],[],[],[],False) where+    deals (CTypeQual (CInlineQual _)) (sts,ats,tqs,tss,_) = (sts,ats,tqs,tss,True)+    deals (CStorageSpec sp) (sts,ats,tqs,tss,inline)  = (sp:sts,ats,tqs,tss,inline)+    deals (CTypeQual (CAttrQual attr)) (sts,ats,tqs,tss,inline)  = (sts,attr:ats,tqs,tss,inline)+    deals (CTypeQual tq) (sts,ats,tqs,tss,inline)     = (sts,ats,tq:tqs,tss,inline)+    deals (CTypeSpec ts) (sts,ats,tqs,tss,inline)     = (sts,ats,tqs,ts:tss,inline)++-- | C storage class specifier (and typedefs) (K&R A8.1, C99 6.7.1)+type CStorageSpec = CStorageSpecifier NodeInfo+data CStorageSpecifier a+  = CAuto     a     -- ^ auto+  | CRegister a     -- ^ register+  | CStatic   a     -- ^ static+  | CExtern   a     -- ^ extern+  | CTypedef  a     -- ^ typedef+  | CThread   a     -- ^ GNUC thread local storage+    deriving (Show, Eq,Ord,Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+++-- | C type specifier (K&R A8.2, C99 6.7.2)+--+-- Type specifiers are either basic types such as @char@ or @int@,+-- @struct@, @union@ or @enum@ specifiers or typedef names.+--+-- As a GNU extension, a @typeof@ expression also is a type specifier.+-- +-- Objective-C class names and specifiers of the form 'typdefname <Protocols>'+-- are also allowed.+type CTypeSpec = CTypeSpecifier NodeInfo+data CTypeSpecifier a+  = CVoidType    a+  | CCharType    a+  | CShortType   a+  | CIntType     a+  | CLongType    a+  | CFloatType   a+  | CDoubleType  a+  | CSignedType  a+  | CUnsigType   a+  | CBoolType    a+  | CComplexType a+  | CSUType      (CStructureUnion a) a      -- ^ Struct or Union specifier+  | CEnumType    (CEnumeration a)    a      -- ^ Enumeration specifier+  | CTypeDef     !Ident        a      -- ^ Typedef name+  | CTypeOfExpr  (CExpression a)  a  -- ^ @typeof(expr)@+  | CTypeOfType  (CDeclaration a) a  -- ^ @typeof(type)@+  | ObjCClassProto !Ident [ObjCProtocolName a] a      -- ^ class name with protocol list+  | ObjCTypeProto  !Ident [ObjCProtocolName a] a      -- ^ Typedef name with protocol list+    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+++-- | returns @True@ if the given typespec is a struct, union or enum /definition/+isSUEDef :: CTypeSpecifier a -> Bool+isSUEDef (CSUType (CStruct _ _ (Just _) _ _) _) = True+isSUEDef (CEnumType (CEnum _ (Just _) _ _) _) = True+isSUEDef _ = False++-- | C type qualifiers (K&R A8.2, C99 6.7.3), function specifiers (C99 6.7.4), and attributes.+--+-- @const@, @volatile@ and @restrict@ type qualifiers and @inline@ function specifier.+-- Additionally, @__attribute__@ annotations for declarations and declarators.+type CTypeQual = CTypeQualifier NodeInfo+data CTypeQualifier a+  = CConstQual a+  | CVolatQual a+  | CRestrQual a+  | CInlineQual a+  | CAttrQual  (CAttribute a)+  | ObjCProtoQual (ObjCProtoQualifier a)+    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})++type ObjCProtoQual = ObjCProtoQualifier NodeInfo++data ObjCProtoQualifier a =+    ObjCInQual a+  | ObjCOutQual a+  | ObjCInOutQual a+  | ObjCBycopyQual a+  | ObjCOnewayQual a+    deriving (Show, Data, Typeable, Functor {-! , CNode, Annotated !-})++-- | C structure or union specifiers (K&R A8.3, C99 6.7.2.1)+--+-- @CStruct tag identifier struct-decls c-attrs@ represents a struct or union specifier (depending on @tag@).+--+--   * either @identifier@ or the declaration list @struct-decls@ (or both) have to be present.+--+--     Example: in @struct foo x;@, the identifier is present, in @struct { int y; } x@ the declaration list, and+--     in @struct foo { int y; } x;@ both of them.+--+--   * @c-attrs@ is a list of @__attribute__@ annotations associated with the struct or union specifier+type CStructUnion = CStructureUnion NodeInfo+data CStructureUnion a+  = CStruct+    !CStructTag+    (Maybe Ident)+    (Maybe [CDeclaration a])  -- member declarations+    [CAttribute a]            -- __attribute__s+    a+    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+++-- | A tag to determine wheter we refer to a @struct@ or @union@, see 'CStructUnion'.+data CStructTag = CStructTag+                | CUnionTag+                deriving (Show, Eq,Data,Typeable)+++-- | C enumeration specifier (K&R A8.4, C99 6.7.2.2)+--+-- @CEnum identifier enumerator-list attrs@ represent as enum specifier+--+--  * Either the identifier or the enumerator-list (or both) have to be present.+--+--  * If @enumerator-list@ is present, it has to be non-empty.+--+--  * The enumerator list is of the form @(enumeration-constant, enumeration-value?)@, where the latter+--    is an optional constant integral expression.+--+--  * @attrs@ is a list of @__attribute__@ annotations associated with the enumeration specifier+type CEnum = CEnumeration NodeInfo+data CEnumeration a+  = CEnum+    (Maybe Ident)+    (Maybe [(Ident,                   -- variant name+             Maybe (CExpression a))]) -- explicit variant value+    [CAttribute a]                    -- __attribute__s+    a+    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})++++-- | C initialization (K&R A8.7, C99 6.7.8)+--+-- Initializers are either assignment expressions or initializer lists+-- (surrounded in curly braces), whose elements are themselves+-- initializers, paired with an optional list of designators.+type CInit = CInitializer NodeInfo+data CInitializer a+  -- | assignment expression+  = CInitExpr (CExpression a) a+  -- | initialization list (see 'CInitList')+  | CInitList (CInitializerList a) a+    deriving (Show, Data,Typeable {-! ,CNode , Annotated !-})++-- deriving Functor does not work (type synonym)+instance Functor CInitializer where+        fmap _f (CInitExpr a1 a2) = CInitExpr (fmap _f a1) (_f a2)+        fmap _f (CInitList a1 a2) = CInitList (fmapInitList _f a1) (_f a2)+fmapInitList :: (a->b) -> (CInitializerList a) -> (CInitializerList b)+fmapInitList _f = map (\(desigs, initializer) -> (fmap (fmap _f) desigs, fmap _f initializer))++-- | Initializer List+--+-- The members of an initializer list are of the form @(designator-list,initializer)@.+-- The @designator-list@ specifies one member of the compound type which is initialized.+-- It is allowed to be empty - in this case the initializer refers to the+-- ''next'' member of the compound type (see C99 6.7.8).+--+-- Examples (simplified expressions and identifiers):+--+-- > -- int x[3][4] = { [0][3] = 4, [2] = 5, 8 };+-- > --   corresponds to the assignments+-- > -- x[0][3] = 4; x[2][0] = 5; x[2][1] = 8;+-- > let init1 = ([CArrDesig 0, CArrDesig 3], CInitExpr 4)+-- >     init2 = ([CArrDesig 2]             , CInitExpr 5)+-- >     init3 = ([]                        , CInitExpr 8)+-- > in  CInitList [init1, init2, init3]+--+-- > -- struct { struct { int a[2]; int b[2]; int c[2]; } s; } x = { .s = { {2,3} , .c[0] = 1 } };+-- > --   corresponds to the assignments+-- > -- x.s.a[0] = 2; x.s.a[1] = 3; x.s.c[0] = 1;+-- > let init_s_0 = CInitList [ ([], CInitExpr 2), ([], CInitExpr 3)]+-- >     init_s   = CInitList [+-- >                            ([], init_s_0),+-- >                            ([CMemberDesig "c", CArrDesig 0], CInitExpr 1)+-- >                          ]+-- > in  CInitList [(CMemberDesig "s", init_s)]+type CInitList = CInitializerList NodeInfo+type CInitializerList a = [([CPartDesignator a], CInitializer a)]++-- | Designators+--+-- A designator specifies a member of an object, either an element or range of an array,+-- or the named member of a struct \/ union.+type CDesignator = CPartDesignator NodeInfo+data CPartDesignator a+  -- | array position designator+  = CArrDesig     (CExpression a) a+  -- | member designator+  | CMemberDesig  !Ident a+  -- | array range designator @CRangeDesig from to _@ (GNU C)+  | CRangeDesig (CExpression a) (CExpression a) a+    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+++-- | @__attribute__@ annotations+--+-- Those are of the form @CAttr attribute-name attribute-parameters@,+-- and serve as generic properties of some syntax tree elements.+type CAttr = CAttribute NodeInfo+data CAttribute a = CAttr !Ident [CExpression a] a+                    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+++-- | C expression (K&R A7)+--+-- * these can be arbitrary expression, as the argument of `sizeof' can be+--   arbitrary, even if appearing in a constant expression+--+-- * GNU C extensions: @alignof@, @__real@, @__imag@, @({ stmt-expr })@, @&& label@ and built-ins+-- * objective-C style code blocks+--+type CExpr = CExpression NodeInfo+data CExpression a+  = CComma       [CExpression a]         -- comma expression list, n >= 2+                 a+  | CAssign      !CAssignOp              -- assignment operator+                 (CExpression a)         -- l-value+                 (CExpression a)         -- r-value+                 a+  | CCond        (CExpression a)         -- conditional+                 (Maybe (CExpression a)) -- true-expression (GNU allows omitting)+                 (CExpression a)         -- false-expression+                 a+  | CBinary      CBinaryOp               -- binary operator+                 (CExpression a)         -- lhs+                 (CExpression a)         -- rhs+                 a+  | CCast        (CDeclaration a)        -- type name+                 (CExpression a)+                 a+  | CUnary       CUnaryOp                -- unary operator+                 (CExpression a)+                 a+  | CSizeofExpr  (CExpression a)+                 a+  | CSizeofType  (CDeclaration a)        -- type name+                 a+  | CAlignofExpr (CExpression a)+                 a+  | CAlignofType (CDeclaration a)        -- type name+                 a+  | CComplexReal (CExpression a)         -- real part of complex number+                 a+  | CComplexImag (CExpression a)         -- imaginary part of complex number+                 a+  | CIndex       (CExpression a)         -- array+                 (CExpression a)         -- index+                 a+  | CCall        (CExpression a)         -- function+                 [CExpression a]         -- arguments+                 a+  | CMember      (CExpression a)         -- structure+                 !Ident                  -- member name+                 !Bool                   -- deref structure? (True for `->')+                 a+  | CVar         !Ident                  -- identifier (incl. enumeration const)+                 a+  | CConst       (CConstant a)           -- ^ integer, character, floating point and string constants+  | CCompoundLit (CDeclaration a)+                 (CInitializerList a)    -- type name & initialiser list+                 a                       -- ^ C99 compound literal+  | CStatExpr    (CStatement a) a        -- ^ GNU C compound statement as expr+  | CLabAddrExpr !Ident a                -- ^ GNU C address of label+  | CBuiltinExpr (CBuiltinThing a)       -- ^ builtin expressions, see 'CBuiltin'+  -- objective-c additions+  | CBlockExpr   ([CDeclaration a],Bool) (CStatement a) a -- ^ Code block definition, new-style params, compound statement+  | ObjCMessageExpr  (ObjCMessageExpression a) a -- ^ Obj-c message+  | ObjCSelectorExpr (ObjCSelectorName a) a      -- ^ selector name+  | ObjCProtoExpr Ident a                        -- ^ @protocol expression+  | ObjCEncodeExpr (CDeclaration a) a            -- ^ @encode expression+  | ObjCConst    (ObjCConstant a)                -- ^ NSString constant+    deriving (Data,Typeable,Show, Functor {-! ,CNode , Annotated !-})++type ObjCSelName = ObjCSelectorName NodeInfo++data ObjCSelectorName a =+    ObjCSelPlain (ObjCSelector a) a+  | ObjCSelKeys [ObjCSelectorKeyName a] a+    deriving (Data,Typeable,Show, Functor {-! ,CNode , Annotated !-})++type ObjCSelKeyName = ObjCSelectorKeyName NodeInfo++data ObjCSelectorKeyName a =+    ObjCSelKeyName (Maybe (ObjCSelector a)) a+    deriving (Data,Typeable,Show, Functor {-! ,CNode , Annotated !-})++type ObjCSel = ObjCSelector NodeInfo++data ObjCSelector a =+    ObjCSel Ident a+  | ObjCInSel a+  | ObjCOutSel a+    deriving (Data,Typeable,Show, Functor {-! ,CNode , Annotated !-})++type ObjCMsgExpr = ObjCMessageExpression NodeInfo++data ObjCMessageExpression a =+    ObjCMsgExpr (CExpression a)    (ObjCMessageSelector a) a+  | ObjCMsgClass (ObjCClassName a) (ObjCMessageSelector a) a+  | ObjCMsgSup                     (ObjCMessageSelector a) a+    deriving (Data,Typeable,Show, Functor {-! ,CNode , Annotated !-})++type ObjCMsgSel = ObjCMessageSelector NodeInfo++data ObjCMessageSelector a =+   ObjCMsgSel (ObjCSelector a) a+ | ObjCKeyArgs [ObjCKeywordArg a] a+    deriving (Data,Typeable,Show, Functor {-! ,CNode , Annotated !-})++type ObjCKeyArg = ObjCKeywordArg NodeInfo++data ObjCKeywordArg a =+    ObjCKeyArg (ObjCSelectorKeyName a) (CExpression a) a+    deriving (Data,Typeable,Show, Functor {-! ,CNode , Annotated !-})++-- | GNU Builtins, which cannot be typed in C99+type CBuiltin = CBuiltinThing NodeInfo+data CBuiltinThing a+  = CBuiltinVaArg (CExpression a) (CDeclaration a) a            -- ^ @(expr, type)@+  | CBuiltinOffsetOf (CDeclaration a) [CPartDesignator a] a -- ^ @(type, designator-list)@+  | CBuiltinTypesCompatible (CDeclaration a) (CDeclaration a) a  -- ^ @(type,type)@+    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})++-- | Objective-C constant (NSString)+type ObjCConst = ObjCConstant NodeInfo++data ObjCConstant a+  = ObjCStrConst CString a+    deriving (Show, Data, Typeable, Functor {-! ,CNode, Annotated !-})++-- | C constant (K&R A2.5 & A7.2)+type CConst = CConstant NodeInfo+data CConstant a+  = CIntConst   CInteger a+  | CCharConst  CChar a+  | CFloatConst CFloat a+  | CStrConst   CString a+    deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+++-- | Attributed string literals+type CStrLit = CStringLiteral NodeInfo+data CStringLiteral a = CStrLit CString a+            deriving (Show, Data,Typeable {-! ,CNode ,Functor ,Annotated !-})+++cstringOfLit :: CStringLiteral a -> CString+cstringOfLit (CStrLit cstr _) = cstr++-- | Lift a string literal to a C constant+liftStrLit :: CStringLiteral a -> CConstant a+liftStrLit (CStrLit str at) = CStrConst str at++-- | All AST nodes are annotated. Inspired by the Annotated+-- class of Niklas Broberg's haskell-src-exts package.+-- In principle, we could have Copointed superclass instead+-- of @ann@, for the price of another dependency.+class (Functor ast) => Annotated ast where+  -- | get the annotation of an AST node+  annotation :: ast a -> a+  -- | change the annotation (non-recursively)+  --   of an AST node. Use fmap for recursively+  --   modifying the annotation.+  amap  :: (a->a) -> ast a -> ast a++-- fmap2 :: (a->a') -> (a,b) -> (a',b)+-- fmap2 f (a,b) = (f a, b)++-- Instances generated using derive-2.*+-- GENERATED START++ +instance (CNode t1) => CNode (CTranslationUnit t1) where+        nodeInfo (CTranslUnit _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CTranslationUnit t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CTranslationUnit where+        fmap _f (CTranslUnit a1 a2)+          = CTranslUnit (fmap (fmap _f) a1) (_f a2)++ +instance Annotated CTranslationUnit where+        annotation (CTranslUnit _ n) = n+        amap f (CTranslUnit a_1 a_2) = CTranslUnit a_1 (f a_2)++ +instance (CNode t1) => CNode (CExternalDeclaration t1) where+        nodeInfo (CDeclExt d) = nodeInfo d+        nodeInfo (CFDefExt d) = nodeInfo d+        nodeInfo (ObjCIfaceExt d) = nodeInfo d+        nodeInfo (ObjCImplExt d) = nodeInfo d+        nodeInfo (ObjCClassExt d) = nodeInfo d+        nodeInfo (ObjCProtoExt d) = nodeInfo d+        nodeInfo (ObjCCatExt d) = nodeInfo d+        nodeInfo (ObjCCatImplExt d) = nodeInfo d+        nodeInfo (CAsmExt _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CExternalDeclaration t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CExternalDeclaration where+        fmap _f (CDeclExt a1) = CDeclExt (fmap _f a1)+        fmap _f (CFDefExt a1) = CFDefExt (fmap _f a1)+        fmap _f (ObjCIfaceExt a1) = ObjCIfaceExt (fmap _f a1)+        fmap _f (ObjCImplExt a1) = ObjCImplExt (fmap _f a1)+        fmap _f (ObjCClassExt a1) = ObjCClassExt (fmap _f a1)+        fmap _f (ObjCProtoExt a1) = ObjCProtoExt (fmap _f a1)+        fmap _f (ObjCCatExt a1) = ObjCCatExt (fmap _f a1)+        fmap _f (ObjCCatImplExt a1) = ObjCCatImplExt (fmap _f a1)+        fmap _f (CAsmExt a1 a2) = CAsmExt (fmap _f a1) (_f a2)++ +instance Annotated CExternalDeclaration where+        annotation (CDeclExt n) = annotation n+        annotation (CFDefExt n) = annotation n+        annotation (ObjCIfaceExt n) = annotation n+        annotation (ObjCImplExt n) = annotation n+        annotation (ObjCClassExt n) = annotation n+        annotation (ObjCProtoExt n) = annotation n+        annotation (ObjCCatExt n) = annotation n+        annotation (ObjCCatImplExt n) = annotation n+        annotation (CAsmExt _ n) = n+        amap f (CDeclExt n) = CDeclExt (amap f n)+        amap f (CFDefExt n) = CFDefExt (amap f n)+        amap f (ObjCIfaceExt n) = ObjCIfaceExt (amap f n)+        amap f (ObjCImplExt n) = ObjCImplExt (amap f n)+        amap f (ObjCClassExt n) = ObjCClassExt (amap f n)+        amap f (ObjCProtoExt n) = ObjCProtoExt (amap f n)+        amap f (ObjCCatExt n) = ObjCCatExt (amap f n)+        amap f (ObjCCatImplExt n) = ObjCCatImplExt (amap f n)+        amap f (CAsmExt a_1 a_2) = CAsmExt a_1 (f a_2)++ +instance (CNode t1) => CNode (CFunctionDef t1) where+        nodeInfo (CFunDef _ _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CFunctionDef t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CFunctionDef where+        fmap _f (CFunDef a1 a2 a3 a4 a5)+          = CFunDef (fmap (fmap _f) a1) (fmap _f a2) (fmap (fmap _f) a3)+              (fmap _f a4)+              (_f a5)++ +instance Annotated CFunctionDef where+        annotation (CFunDef _ _ _ _ n) = n+        amap f (CFunDef a_1 a_2 a_3 a_4 a_5)+          = CFunDef a_1 a_2 a_3 a_4 (f a_5)++ +instance (CNode t1) => CNode (ObjCCategoryDec t1) where+        nodeInfo (ObjCCatDec _ _ _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCCategoryDec t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCCategoryDec where+        annotation (ObjCCatDec _ _ _ _ _ n) = n+        amap f (ObjCCatDec a_1 a_2 a_3 a_4 a_5 a_6)+          = ObjCCatDec a_1 a_2 a_3 a_4 a_5 (f a_6)++ +instance (CNode t1) => CNode (ObjCCategoryImplementation t1) where+        nodeInfo (ObjCCatImpl _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCCategoryImplementation t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCCategoryImplementation where+        annotation (ObjCCatImpl _ _ _ n) = n+        amap f (ObjCCatImpl a_1 a_2 a_3 a_4)+          = ObjCCatImpl a_1 a_2 a_3 (f a_4)++ +instance (CNode t1) => CNode (ObjCClassListDef t1) where+        nodeInfo (ObjCClassDef _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCClassListDef t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor ObjCClassListDef where+        fmap _f (ObjCClassDef a1 a2)+          = ObjCClassDef (fmap (fmap _f) a1) (_f a2)++ +instance Annotated ObjCClassListDef where+        annotation (ObjCClassDef _ n) = n+        amap f (ObjCClassDef a_1 a_2) = ObjCClassDef a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCProtocolDec t1) where+        nodeInfo (ObjCForwardProtoDec _ _ n) = nodeInfo n+        nodeInfo (ObjCProtoDec _ _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCProtocolDec t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor ObjCProtocolDec where+        fmap _f (ObjCForwardProtoDec a1 a2 a3)+          = ObjCForwardProtoDec a1 (fmap (fmap _f) a2) (_f a3)+        fmap _f (ObjCProtoDec a1 a2 a3 a4 a5)+          = ObjCProtoDec a1 (fmap (fmap _f) a2) (fmap (fmap _f) a3)+              (fmap (fmap _f) a4)+              (_f a5)++ +instance Annotated ObjCProtocolDec where+        annotation (ObjCForwardProtoDec _ _ n) = n+        annotation (ObjCProtoDec _ _ _ _ n) = n+        amap f (ObjCForwardProtoDec a_1 a_2 a_3)+          = ObjCForwardProtoDec a_1 a_2 (f a_3)+        amap f (ObjCProtoDec a_1 a_2 a_3 a_4 a_5)+          = ObjCProtoDec a_1 a_2 a_3 a_4 (f a_5)++ +instance (CNode t1) => CNode (ObjCProtocolDeclBlock t1) where+        nodeInfo (ObjCProtoDeclBlock _ n) = nodeInfo n+        nodeInfo (ObjCReqProtoBlock _ n) = nodeInfo n+        nodeInfo (ObjCOptProtoBlock _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCProtocolDeclBlock t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor ObjCProtocolDeclBlock where+        fmap _f (ObjCProtoDeclBlock a1 a2)+          = ObjCProtoDeclBlock (fmap (fmap _f) a1) (_f a2)+        fmap _f (ObjCReqProtoBlock a1 a2)+          = ObjCReqProtoBlock (fmap (fmap _f) a1) (_f a2)+        fmap _f (ObjCOptProtoBlock a1 a2)+          = ObjCOptProtoBlock (fmap (fmap _f) a1) (_f a2)++ +instance Annotated ObjCProtocolDeclBlock where+        annotation (ObjCProtoDeclBlock _ n) = n+        annotation (ObjCReqProtoBlock _ n) = n+        annotation (ObjCOptProtoBlock _ n) = n+        amap f (ObjCProtoDeclBlock a_1 a_2)+          = ObjCProtoDeclBlock a_1 (f a_2)+        amap f (ObjCReqProtoBlock a_1 a_2) = ObjCReqProtoBlock a_1 (f a_2)+        amap f (ObjCOptProtoBlock a_1 a_2) = ObjCOptProtoBlock a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCInterface t1) where+        nodeInfo (ObjCIface _ _ _ _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCInterface t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCInterface where+        annotation (ObjCIface _ _ _ _ _ _ n) = n+        amap f (ObjCIface a_1 a_2 a_3 a_4 a_5 a_6 a_7)+          = ObjCIface a_1 a_2 a_3 a_4 a_5 a_6 (f a_7)++ +instance (CNode t1) => CNode (ObjCImplementation t1) where+        nodeInfo (ObjCImpl _ _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCImplementation t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCImplementation where+        annotation (ObjCImpl _ _ _ _ n) = n+        amap f (ObjCImpl a_1 a_2 a_3 a_4 a_5)+          = ObjCImpl a_1 a_2 a_3 a_4 (f a_5)++ +instance (CNode t1) => CNode (ObjCClassDeclarator t1) where+        nodeInfo (ObjCClassDeclr _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCClassDeclarator t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCClassDeclarator where+        annotation (ObjCClassDeclr _ n) = n+        amap f (ObjCClassDeclr a_1 a_2) = ObjCClassDeclr a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCClassName t1) where+        nodeInfo (ObjCClassNm _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCClassName t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCClassName where+        annotation (ObjCClassNm _ n) = n+        amap f (ObjCClassNm a_1 a_2) = ObjCClassNm a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCProtocolName t1) where+        nodeInfo (ObjCProtoNm _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCProtocolName t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCProtocolName where+        annotation (ObjCProtoNm _ n) = n+        amap f (ObjCProtoNm a_1 a_2) = ObjCProtoNm a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCInstanceVariableBlock t1) where+        nodeInfo (ObjCInstanceVarBlock _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCInstanceVariableBlock t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCInstanceVariableBlock where+        annotation (ObjCInstanceVarBlock _ _ n) = n+        amap f (ObjCInstanceVarBlock a_1 a_2 a_3)+          = ObjCInstanceVarBlock a_1 a_2 (f a_3)++ +instance (CNode t1) => CNode (ObjCVisibilitySpec t1) where+        nodeInfo (ObjCVisSpec _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCVisibilitySpec t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCVisibilitySpec where+        annotation (ObjCVisSpec _ n) = n+        amap f (ObjCVisSpec a_1 a_2) = ObjCVisSpec a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCInterfaceDeclaration t1) where+        nodeInfo (ObjCIfaceDecl _ n) = nodeInfo n+        nodeInfo (ObjCIfaceMethodDecl _ n) = nodeInfo n+        nodeInfo (ObjCIfacePropDecl _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCInterfaceDeclaration t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCInterfaceDeclaration where+        annotation (ObjCIfaceDecl _ n) = n+        annotation (ObjCIfaceMethodDecl _ n) = n+        annotation (ObjCIfacePropDecl _ n) = n+        amap f (ObjCIfaceDecl a_1 a_2) = ObjCIfaceDecl a_1 (f a_2)+        amap f (ObjCIfaceMethodDecl a_1 a_2)+          = ObjCIfaceMethodDecl a_1 (f a_2)+        amap f (ObjCIfacePropDecl a_1 a_2) = ObjCIfacePropDecl a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCImplementationDefinition t1)+         where+        nodeInfo (ObjCImplDec d) = nodeInfo d+        nodeInfo (ObjCImplMethod d) = nodeInfo d+        nodeInfo (ObjCImplFun d) = nodeInfo d+ +instance (CNode t1) => Pos (ObjCImplementationDefinition t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCImplementationDefinition where+        annotation (ObjCImplDec n) = annotation n+        annotation (ObjCImplMethod n) = annotation n+        annotation (ObjCImplFun n) = annotation n+        amap f (ObjCImplDec n) = ObjCImplDec (amap f n)+        amap f (ObjCImplMethod n) = ObjCImplMethod (amap f n)+        amap f (ObjCImplFun n) = ObjCImplFun (amap f n)++ +instance (CNode t1) => CNode (ObjCMethodDeclaration t1) where+        nodeInfo (ObjCMethodDecl _ _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCMethodDeclaration t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCMethodDeclaration where+        annotation (ObjCMethodDecl _ _ _ _ n) = n+        amap f (ObjCMethodDecl a_1 a_2 a_3 a_4 a_5)+          = ObjCMethodDecl a_1 a_2 a_3 a_4 (f a_5)++ +instance (CNode t1) => CNode (ObjCMethodDefinition t1) where+        nodeInfo (ObjCMethodDef _ _ _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCMethodDefinition t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCMethodDefinition where+        annotation (ObjCMethodDef _ _ _ _ _ n) = n+        amap f (ObjCMethodDef a_1 a_2 a_3 a_4 a_5 a_6)+          = ObjCMethodDef a_1 a_2 a_3 a_4 a_5 (f a_6)++ +instance (CNode t1) => CNode (ObjCMethodSelector t1) where+        nodeInfo (ObjCUnaryMethod _ n) = nodeInfo n+        nodeInfo (ObjCMethod _ _ n) = nodeInfo n+        nodeInfo (ObjCEllipseMethod _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCMethodSelector t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCMethodSelector where+        annotation (ObjCUnaryMethod _ n) = n+        annotation (ObjCMethod _ _ n) = n+        annotation (ObjCEllipseMethod _ n) = n+        amap f (ObjCUnaryMethod a_1 a_2) = ObjCUnaryMethod a_1 (f a_2)+        amap f (ObjCMethod a_1 a_2 a_3) = ObjCMethod a_1 a_2 (f a_3)+        amap f (ObjCEllipseMethod a_1 a_2) = ObjCEllipseMethod a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCKeywordDeclarator t1) where+        nodeInfo (ObjCKeyDeclr _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCKeywordDeclarator t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCKeywordDeclarator where+        annotation (ObjCKeyDeclr _ _ _ n) = n+        amap f (ObjCKeyDeclr a_1 a_2 a_3 a_4)+          = ObjCKeyDeclr a_1 a_2 a_3 (f a_4)++ +instance (CNode t1) => CNode (ObjCPropertyDeclaration t1) where+        nodeInfo (ObjCPropDecl _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCPropertyDeclaration t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCPropertyDeclaration where+        annotation (ObjCPropDecl _ _ n) = n+        amap f (ObjCPropDecl a_1 a_2 a_3) = ObjCPropDecl a_1 a_2 (f a_3)++ +instance (CNode t1) => CNode (ObjCPropertyModifier t1) where+        nodeInfo (ObjCPropMod _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCPropertyModifier t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCPropertyModifier where+        annotation (ObjCPropMod _ _ n) = n+        amap f (ObjCPropMod a_1 a_2 a_3) = ObjCPropMod a_1 a_2 (f a_3)++ +instance (CNode t1) => CNode (CDeclaration t1) where+        nodeInfo (CDecl _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CDeclaration t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated CDeclaration where+        annotation (CDecl _ _ n) = n+        amap f (CDecl a_1 a_2 a_3) = CDecl a_1 a_2 (f a_3)++ +instance (CNode t1) => CNode (CDeclarator t1) where+        nodeInfo (CDeclr _ _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CDeclarator t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CDeclarator where+        fmap _f (CDeclr a1 a2 a3 a4 a5)+          = CDeclr a1 (fmap (fmap _f) a2) (fmap (fmap _f) a3)+              (fmap (fmap _f) a4)+              (_f a5)++ +instance Annotated CDeclarator where+        annotation (CDeclr _ _ _ _ n) = n+        amap f (CDeclr a_1 a_2 a_3 a_4 a_5)+          = CDeclr a_1 a_2 a_3 a_4 (f a_5)++ +instance (CNode t1) => CNode (CDerivedDeclarator t1) where+        nodeInfo (CPtrDeclr _ n) = nodeInfo n+        nodeInfo (CBlkDeclr _ n) = nodeInfo n+        nodeInfo (CArrDeclr _ _ n) = nodeInfo n+        nodeInfo (CFunDeclr _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CDerivedDeclarator t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated CDerivedDeclarator where+        annotation (CPtrDeclr _ n) = n+        annotation (CBlkDeclr _ n) = n+        annotation (CArrDeclr _ _ n) = n+        annotation (CFunDeclr _ _ n) = n+        amap f (CPtrDeclr a_1 a_2) = CPtrDeclr a_1 (f a_2)+        amap f (CBlkDeclr a_1 a_2) = CBlkDeclr a_1 (f a_2)+        amap f (CArrDeclr a_1 a_2 a_3) = CArrDeclr a_1 a_2 (f a_3)+        amap f (CFunDeclr a_1 a_2 a_3) = CFunDeclr a_1 a_2 (f a_3)++ +instance Functor CArraySize where+        fmap _ (CNoArrSize a1) = CNoArrSize a1+        fmap _f (CArrSize a1 a2) = CArrSize a1 (fmap _f a2)++ +instance (CNode t1) => CNode (CStatement t1) where+        nodeInfo (CLabel _ _ _ n) = nodeInfo n+        nodeInfo (CCase _ _ n) = nodeInfo n+        nodeInfo (CCases _ _ _ n) = nodeInfo n+        nodeInfo (CDefault _ n) = nodeInfo n+        nodeInfo (CExpr _ n) = nodeInfo n+        nodeInfo (CCompound _ _ n) = nodeInfo n+        nodeInfo (CIf _ _ _ n) = nodeInfo n+        nodeInfo (CSwitch _ _ n) = nodeInfo n+        nodeInfo (CWhile _ _ _ n) = nodeInfo n+        nodeInfo (CFor _ _ _ _ n) = nodeInfo n+        nodeInfo (CGoto _ n) = nodeInfo n+        nodeInfo (CGotoPtr _ n) = nodeInfo n+        nodeInfo (CCont d) = nodeInfo d+        nodeInfo (CBreak d) = nodeInfo d+        nodeInfo (CReturn _ n) = nodeInfo n+        nodeInfo (CAsm _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CStatement t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated CStatement where+        annotation (CLabel _ _ _ n) = n+        annotation (CCase _ _ n) = n+        annotation (CCases _ _ _ n) = n+        annotation (CDefault _ n) = n+        annotation (CExpr _ n) = n+        annotation (CCompound _ _ n) = n+        annotation (CIf _ _ _ n) = n+        annotation (CSwitch _ _ n) = n+        annotation (CWhile _ _ _ n) = n+        annotation (CFor _ _ _ _ n) = n+        annotation (CGoto _ n) = n+        annotation (CGotoPtr _ n) = n+        annotation (CCont n) = n+        annotation (CBreak n) = n+        annotation (CReturn _ n) = n+        annotation (CAsm _ n) = n+        amap f (CLabel a_1 a_2 a_3 a_4) = CLabel a_1 a_2 a_3 (f a_4)+        amap f (CCase a_1 a_2 a_3) = CCase a_1 a_2 (f a_3)+        amap f (CCases a_1 a_2 a_3 a_4) = CCases a_1 a_2 a_3 (f a_4)+        amap f (CDefault a_1 a_2) = CDefault a_1 (f a_2)+        amap f (CExpr a_1 a_2) = CExpr a_1 (f a_2)+        amap f (CCompound a_1 a_2 a_3) = CCompound a_1 a_2 (f a_3)+        amap f (CIf a_1 a_2 a_3 a_4) = CIf a_1 a_2 a_3 (f a_4)+        amap f (CSwitch a_1 a_2 a_3) = CSwitch a_1 a_2 (f a_3)+        amap f (CWhile a_1 a_2 a_3 a_4) = CWhile a_1 a_2 a_3 (f a_4)+        amap f (CFor a_1 a_2 a_3 a_4 a_5) = CFor a_1 a_2 a_3 a_4 (f a_5)+        amap f (CGoto a_1 a_2) = CGoto a_1 (f a_2)+        amap f (CGotoPtr a_1 a_2) = CGotoPtr a_1 (f a_2)+        amap f (CCont a_1) = CCont (f a_1)+        amap f (CBreak a_1) = CBreak (f a_1)+        amap f (CReturn a_1 a_2) = CReturn a_1 (f a_2)+        amap f (CAsm a_1 a_2) = CAsm a_1 (f a_2)++ +instance (CNode t1) => CNode (CAssemblyStatement t1) where+        nodeInfo (CAsmStmt _ _ _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CAssemblyStatement t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CAssemblyStatement where+        fmap _f (CAsmStmt a1 a2 a3 a4 a5 a6)+          = CAsmStmt (fmap (fmap _f) a1) (fmap _f a2) (fmap (fmap _f) a3)+              (fmap (fmap _f) a4)+              (fmap (fmap _f) a5)+              (_f a6)++ +instance Annotated CAssemblyStatement where+        annotation (CAsmStmt _ _ _ _ _ n) = n+        amap f (CAsmStmt a_1 a_2 a_3 a_4 a_5 a_6)+          = CAsmStmt a_1 a_2 a_3 a_4 a_5 (f a_6)++ +instance (CNode t1) => CNode (CAssemblyOperand t1) where+        nodeInfo (CAsmOperand _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CAssemblyOperand t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CAssemblyOperand where+        fmap _f (CAsmOperand a1 a2 a3 a4)+          = CAsmOperand a1 (fmap _f a2) (fmap _f a3) (_f a4)++ +instance Annotated CAssemblyOperand where+        annotation (CAsmOperand _ _ _ n) = n+        amap f (CAsmOperand a_1 a_2 a_3 a_4)+          = CAsmOperand a_1 a_2 a_3 (f a_4)++ +instance (CNode t1) => CNode (CCompoundBlockItem t1) where+        nodeInfo (CBlockStmt d) = nodeInfo d+        nodeInfo (CBlockDecl d) = nodeInfo d+        nodeInfo (CNestedFunDef d) = nodeInfo d+ +instance (CNode t1) => Pos (CCompoundBlockItem t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CCompoundBlockItem where+        fmap _f (CBlockStmt a1) = CBlockStmt (fmap _f a1)+        fmap _f (CBlockDecl a1) = CBlockDecl (fmap _f a1)+        fmap _f (CNestedFunDef a1) = CNestedFunDef (fmap _f a1)++ +instance Annotated CCompoundBlockItem where+        annotation (CBlockStmt n) = annotation n+        annotation (CBlockDecl n) = annotation n+        annotation (CNestedFunDef n) = annotation n+        amap f (CBlockStmt n) = CBlockStmt (amap f n)+        amap f (CBlockDecl n) = CBlockDecl (amap f n)+        amap f (CNestedFunDef n) = CNestedFunDef (amap f n)++ +instance (CNode t1) => CNode (CDeclarationSpecifier t1) where+        nodeInfo (CStorageSpec d) = nodeInfo d+        nodeInfo (CTypeSpec d) = nodeInfo d+        nodeInfo (CTypeQual d) = nodeInfo d+ +instance (CNode t1) => Pos (CDeclarationSpecifier t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CDeclarationSpecifier where+        fmap _f (CStorageSpec a1) = CStorageSpec (fmap _f a1)+        fmap _f (CTypeSpec a1) = CTypeSpec (fmap _f a1)+        fmap _f (CTypeQual a1) = CTypeQual (fmap _f a1)++ +instance Annotated CDeclarationSpecifier where+        annotation (CStorageSpec n) = annotation n+        annotation (CTypeSpec n) = annotation n+        annotation (CTypeQual n) = annotation n+        amap f (CStorageSpec n) = CStorageSpec (amap f n)+        amap f (CTypeSpec n) = CTypeSpec (amap f n)+        amap f (CTypeQual n) = CTypeQual (amap f n)++ +instance (CNode t1) => CNode (CStorageSpecifier t1) where+        nodeInfo (CAuto d) = nodeInfo d+        nodeInfo (CRegister d) = nodeInfo d+        nodeInfo (CStatic d) = nodeInfo d+        nodeInfo (CExtern d) = nodeInfo d+        nodeInfo (CTypedef d) = nodeInfo d+        nodeInfo (CThread d) = nodeInfo d+ +instance (CNode t1) => Pos (CStorageSpecifier t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CStorageSpecifier where+        fmap _f (CAuto a1) = CAuto (_f a1)+        fmap _f (CRegister a1) = CRegister (_f a1)+        fmap _f (CStatic a1) = CStatic (_f a1)+        fmap _f (CExtern a1) = CExtern (_f a1)+        fmap _f (CTypedef a1) = CTypedef (_f a1)+        fmap _f (CThread a1) = CThread (_f a1)++ +instance Annotated CStorageSpecifier where+        annotation (CAuto n) = n+        annotation (CRegister n) = n+        annotation (CStatic n) = n+        annotation (CExtern n) = n+        annotation (CTypedef n) = n+        annotation (CThread n) = n+        amap f (CAuto a_1) = CAuto (f a_1)+        amap f (CRegister a_1) = CRegister (f a_1)+        amap f (CStatic a_1) = CStatic (f a_1)+        amap f (CExtern a_1) = CExtern (f a_1)+        amap f (CTypedef a_1) = CTypedef (f a_1)+        amap f (CThread a_1) = CThread (f a_1)++ +instance (CNode t1) => CNode (CTypeSpecifier t1) where+        nodeInfo (CVoidType d) = nodeInfo d+        nodeInfo (CCharType d) = nodeInfo d+        nodeInfo (CShortType d) = nodeInfo d+        nodeInfo (CIntType d) = nodeInfo d+        nodeInfo (CLongType d) = nodeInfo d+        nodeInfo (CFloatType d) = nodeInfo d+        nodeInfo (CDoubleType d) = nodeInfo d+        nodeInfo (CSignedType d) = nodeInfo d+        nodeInfo (CUnsigType d) = nodeInfo d+        nodeInfo (CBoolType d) = nodeInfo d+        nodeInfo (CComplexType d) = nodeInfo d+        nodeInfo (CSUType _ n) = nodeInfo n+        nodeInfo (CEnumType _ n) = nodeInfo n+        nodeInfo (CTypeDef _ n) = nodeInfo n+        nodeInfo (CTypeOfExpr _ n) = nodeInfo n+        nodeInfo (CTypeOfType _ n) = nodeInfo n+        nodeInfo (ObjCClassProto _ _ n) = nodeInfo n+        nodeInfo (ObjCTypeProto _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CTypeSpecifier t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CTypeSpecifier where+        fmap _f (CVoidType a1) = CVoidType (_f a1)+        fmap _f (CCharType a1) = CCharType (_f a1)+        fmap _f (CShortType a1) = CShortType (_f a1)+        fmap _f (CIntType a1) = CIntType (_f a1)+        fmap _f (CLongType a1) = CLongType (_f a1)+        fmap _f (CFloatType a1) = CFloatType (_f a1)+        fmap _f (CDoubleType a1) = CDoubleType (_f a1)+        fmap _f (CSignedType a1) = CSignedType (_f a1)+        fmap _f (CUnsigType a1) = CUnsigType (_f a1)+        fmap _f (CBoolType a1) = CBoolType (_f a1)+        fmap _f (CComplexType a1) = CComplexType (_f a1)+        fmap _f (CSUType a1 a2) = CSUType (fmap _f a1) (_f a2)+        fmap _f (CEnumType a1 a2) = CEnumType (fmap _f a1) (_f a2)+        fmap _f (CTypeDef a1 a2) = CTypeDef a1 (_f a2)+        fmap _f (CTypeOfExpr a1 a2) = CTypeOfExpr (fmap _f a1) (_f a2)+        fmap _f (CTypeOfType a1 a2) = CTypeOfType (fmap _f a1) (_f a2)+        fmap _f (ObjCClassProto a1 a2 a3)+          = ObjCClassProto a1 (fmap (fmap _f) a2) (_f a3)+        fmap _f (ObjCTypeProto a1 a2 a3)+          = ObjCTypeProto a1 (fmap (fmap _f) a2) (_f a3)++ +instance Annotated CTypeSpecifier where+        annotation (CVoidType n) = n+        annotation (CCharType n) = n+        annotation (CShortType n) = n+        annotation (CIntType n) = n+        annotation (CLongType n) = n+        annotation (CFloatType n) = n+        annotation (CDoubleType n) = n+        annotation (CSignedType n) = n+        annotation (CUnsigType n) = n+        annotation (CBoolType n) = n+        annotation (CComplexType n) = n+        annotation (CSUType _ n) = n+        annotation (CEnumType _ n) = n+        annotation (CTypeDef _ n) = n+        annotation (CTypeOfExpr _ n) = n+        annotation (CTypeOfType _ n) = n+        annotation (ObjCClassProto _ _ n) = n+        annotation (ObjCTypeProto _ _ n) = n+        amap f (CVoidType a_1) = CVoidType (f a_1)+        amap f (CCharType a_1) = CCharType (f a_1)+        amap f (CShortType a_1) = CShortType (f a_1)+        amap f (CIntType a_1) = CIntType (f a_1)+        amap f (CLongType a_1) = CLongType (f a_1)+        amap f (CFloatType a_1) = CFloatType (f a_1)+        amap f (CDoubleType a_1) = CDoubleType (f a_1)+        amap f (CSignedType a_1) = CSignedType (f a_1)+        amap f (CUnsigType a_1) = CUnsigType (f a_1)+        amap f (CBoolType a_1) = CBoolType (f a_1)+        amap f (CComplexType a_1) = CComplexType (f a_1)+        amap f (CSUType a_1 a_2) = CSUType a_1 (f a_2)+        amap f (CEnumType a_1 a_2) = CEnumType a_1 (f a_2)+        amap f (CTypeDef a_1 a_2) = CTypeDef a_1 (f a_2)+        amap f (CTypeOfExpr a_1 a_2) = CTypeOfExpr a_1 (f a_2)+        amap f (CTypeOfType a_1 a_2) = CTypeOfType a_1 (f a_2)+        amap f (ObjCClassProto a_1 a_2 a_3)+          = ObjCClassProto a_1 a_2 (f a_3)+        amap f (ObjCTypeProto a_1 a_2 a_3) = ObjCTypeProto a_1 a_2 (f a_3)++ +instance (CNode t1) => CNode (CTypeQualifier t1) where+        nodeInfo (CConstQual d) = nodeInfo d+        nodeInfo (CVolatQual d) = nodeInfo d+        nodeInfo (CRestrQual d) = nodeInfo d+        nodeInfo (CInlineQual d) = nodeInfo d+        nodeInfo (CAttrQual d) = nodeInfo d+        nodeInfo (ObjCProtoQual d) = nodeInfo d+ +instance (CNode t1) => Pos (CTypeQualifier t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CTypeQualifier where+        fmap _f (CConstQual a1) = CConstQual (_f a1)+        fmap _f (CVolatQual a1) = CVolatQual (_f a1)+        fmap _f (CRestrQual a1) = CRestrQual (_f a1)+        fmap _f (CInlineQual a1) = CInlineQual (_f a1)+        fmap _f (CAttrQual a1) = CAttrQual (fmap _f a1)+        fmap _f (ObjCProtoQual a1) = ObjCProtoQual (fmap _f a1)++ +instance Annotated CTypeQualifier where+        annotation (CConstQual n) = n+        annotation (CVolatQual n) = n+        annotation (CRestrQual n) = n+        annotation (CInlineQual n) = n+        annotation (CAttrQual n) = annotation n+        annotation (ObjCProtoQual n) = annotation n+        amap f (CConstQual a_1) = CConstQual (f a_1)+        amap f (CVolatQual a_1) = CVolatQual (f a_1)+        amap f (CRestrQual a_1) = CRestrQual (f a_1)+        amap f (CInlineQual a_1) = CInlineQual (f a_1)+        amap f (CAttrQual n) = CAttrQual (amap f n)+        amap f (ObjCProtoQual n) = ObjCProtoQual (amap f n)++ +instance (CNode t1) => CNode (ObjCProtoQualifier t1) where+        nodeInfo (ObjCInQual d) = nodeInfo d+        nodeInfo (ObjCOutQual d) = nodeInfo d+        nodeInfo (ObjCInOutQual d) = nodeInfo d+        nodeInfo (ObjCBycopyQual d) = nodeInfo d+        nodeInfo (ObjCOnewayQual d) = nodeInfo d+ +instance (CNode t1) => Pos (ObjCProtoQualifier t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCProtoQualifier where+        annotation (ObjCInQual n) = n+        annotation (ObjCOutQual n) = n+        annotation (ObjCInOutQual n) = n+        annotation (ObjCBycopyQual n) = n+        annotation (ObjCOnewayQual n) = n+        amap f (ObjCInQual a_1) = ObjCInQual (f a_1)+        amap f (ObjCOutQual a_1) = ObjCOutQual (f a_1)+        amap f (ObjCInOutQual a_1) = ObjCInOutQual (f a_1)+        amap f (ObjCBycopyQual a_1) = ObjCBycopyQual (f a_1)+        amap f (ObjCOnewayQual a_1) = ObjCOnewayQual (f a_1)++ +instance (CNode t1) => CNode (CStructureUnion t1) where+        nodeInfo (CStruct _ _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CStructureUnion t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CStructureUnion where+        fmap _f (CStruct a1 a2 a3 a4 a5)+          = CStruct a1 a2 (fmap (fmap (fmap _f)) a3) (fmap (fmap _f) a4)+              (_f a5)++ +instance Annotated CStructureUnion where+        annotation (CStruct _ _ _ _ n) = n+        amap f (CStruct a_1 a_2 a_3 a_4 a_5)+          = CStruct a_1 a_2 a_3 a_4 (f a_5)++ +instance (CNode t1) => CNode (CEnumeration t1) where+        nodeInfo (CEnum _ _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CEnumeration t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CEnumeration where+        fmap _f (CEnum a1 a2 a3 a4)+          = CEnum a1 (fmap (fmap (fmap (fmap (fmap _f)))) a2)+              (fmap (fmap _f) a3)+              (_f a4)++ +instance Annotated CEnumeration where+        annotation (CEnum _ _ _ n) = n+        amap f (CEnum a_1 a_2 a_3 a_4) = CEnum a_1 a_2 a_3 (f a_4)++ +instance (CNode t1) => CNode (CInitializer t1) where+        nodeInfo (CInitExpr _ n) = nodeInfo n+        nodeInfo (CInitList _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CInitializer t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated CInitializer where+        annotation (CInitExpr _ n) = n+        annotation (CInitList _ n) = n+        amap f (CInitExpr a_1 a_2) = CInitExpr a_1 (f a_2)+        amap f (CInitList a_1 a_2) = CInitList a_1 (f a_2)++ +instance (CNode t1) => CNode (CPartDesignator t1) where+        nodeInfo (CArrDesig _ n) = nodeInfo n+        nodeInfo (CMemberDesig _ n) = nodeInfo n+        nodeInfo (CRangeDesig _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CPartDesignator t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CPartDesignator where+        fmap _f (CArrDesig a1 a2) = CArrDesig (fmap _f a1) (_f a2)+        fmap _f (CMemberDesig a1 a2) = CMemberDesig a1 (_f a2)+        fmap _f (CRangeDesig a1 a2 a3)+          = CRangeDesig (fmap _f a1) (fmap _f a2) (_f a3)++ +instance Annotated CPartDesignator where+        annotation (CArrDesig _ n) = n+        annotation (CMemberDesig _ n) = n+        annotation (CRangeDesig _ _ n) = n+        amap f (CArrDesig a_1 a_2) = CArrDesig a_1 (f a_2)+        amap f (CMemberDesig a_1 a_2) = CMemberDesig a_1 (f a_2)+        amap f (CRangeDesig a_1 a_2 a_3) = CRangeDesig a_1 a_2 (f a_3)++ +instance (CNode t1) => CNode (CAttribute t1) where+        nodeInfo (CAttr _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CAttribute t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CAttribute where+        fmap _f (CAttr a1 a2 a3) = CAttr a1 (fmap (fmap _f) a2) (_f a3)++ +instance Annotated CAttribute where+        annotation (CAttr _ _ n) = n+        amap f (CAttr a_1 a_2 a_3) = CAttr a_1 a_2 (f a_3)++ +instance (CNode t1) => CNode (CExpression t1) where+        nodeInfo (CComma _ n) = nodeInfo n+        nodeInfo (CAssign _ _ _ n) = nodeInfo n+        nodeInfo (CCond _ _ _ n) = nodeInfo n+        nodeInfo (CBinary _ _ _ n) = nodeInfo n+        nodeInfo (CCast _ _ n) = nodeInfo n+        nodeInfo (CUnary _ _ n) = nodeInfo n+        nodeInfo (CSizeofExpr _ n) = nodeInfo n+        nodeInfo (CSizeofType _ n) = nodeInfo n+        nodeInfo (CAlignofExpr _ n) = nodeInfo n+        nodeInfo (CAlignofType _ n) = nodeInfo n+        nodeInfo (CComplexReal _ n) = nodeInfo n+        nodeInfo (CComplexImag _ n) = nodeInfo n+        nodeInfo (CIndex _ _ n) = nodeInfo n+        nodeInfo (CCall _ _ n) = nodeInfo n+        nodeInfo (CMember _ _ _ n) = nodeInfo n+        nodeInfo (CVar _ n) = nodeInfo n+        nodeInfo (CConst d) = nodeInfo d+        nodeInfo (CCompoundLit _ _ n) = nodeInfo n+        nodeInfo (CStatExpr _ n) = nodeInfo n+        nodeInfo (CLabAddrExpr _ n) = nodeInfo n+        nodeInfo (CBuiltinExpr d) = nodeInfo d+        nodeInfo (CBlockExpr _ _ n) = nodeInfo n+        nodeInfo (ObjCMessageExpr _ n) = nodeInfo n+        nodeInfo (ObjCSelectorExpr _ n) = nodeInfo n+        nodeInfo (ObjCProtoExpr _ n) = nodeInfo n+        nodeInfo (ObjCEncodeExpr _ n) = nodeInfo n+        nodeInfo (ObjCConst d) = nodeInfo d+ +instance (CNode t1) => Pos (CExpression t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated CExpression where+        annotation (CComma _ n) = n+        annotation (CAssign _ _ _ n) = n+        annotation (CCond _ _ _ n) = n+        annotation (CBinary _ _ _ n) = n+        annotation (CCast _ _ n) = n+        annotation (CUnary _ _ n) = n+        annotation (CSizeofExpr _ n) = n+        annotation (CSizeofType _ n) = n+        annotation (CAlignofExpr _ n) = n+        annotation (CAlignofType _ n) = n+        annotation (CComplexReal _ n) = n+        annotation (CComplexImag _ n) = n+        annotation (CIndex _ _ n) = n+        annotation (CCall _ _ n) = n+        annotation (CMember _ _ _ n) = n+        annotation (CVar _ n) = n+        annotation (CConst n) = annotation n+        annotation (CCompoundLit _ _ n) = n+        annotation (CStatExpr _ n) = n+        annotation (CLabAddrExpr _ n) = n+        annotation (CBuiltinExpr n) = annotation n+        annotation (CBlockExpr _ _ n) = n+        annotation (ObjCMessageExpr _ n) = n+        annotation (ObjCSelectorExpr _ n) = n+        annotation (ObjCProtoExpr _ n) = n+        annotation (ObjCEncodeExpr _ n) = n+        annotation (ObjCConst n) = annotation n+        amap f (CComma a_1 a_2) = CComma a_1 (f a_2)+        amap f (CAssign a_1 a_2 a_3 a_4) = CAssign a_1 a_2 a_3 (f a_4)+        amap f (CCond a_1 a_2 a_3 a_4) = CCond a_1 a_2 a_3 (f a_4)+        amap f (CBinary a_1 a_2 a_3 a_4) = CBinary a_1 a_2 a_3 (f a_4)+        amap f (CCast a_1 a_2 a_3) = CCast a_1 a_2 (f a_3)+        amap f (CUnary a_1 a_2 a_3) = CUnary a_1 a_2 (f a_3)+        amap f (CSizeofExpr a_1 a_2) = CSizeofExpr a_1 (f a_2)+        amap f (CSizeofType a_1 a_2) = CSizeofType a_1 (f a_2)+        amap f (CAlignofExpr a_1 a_2) = CAlignofExpr a_1 (f a_2)+        amap f (CAlignofType a_1 a_2) = CAlignofType a_1 (f a_2)+        amap f (CComplexReal a_1 a_2) = CComplexReal a_1 (f a_2)+        amap f (CComplexImag a_1 a_2) = CComplexImag a_1 (f a_2)+        amap f (CIndex a_1 a_2 a_3) = CIndex a_1 a_2 (f a_3)+        amap f (CCall a_1 a_2 a_3) = CCall a_1 a_2 (f a_3)+        amap f (CMember a_1 a_2 a_3 a_4) = CMember a_1 a_2 a_3 (f a_4)+        amap f (CVar a_1 a_2) = CVar a_1 (f a_2)+        amap f (CConst n) = CConst (amap f n)+        amap f (CCompoundLit a_1 a_2 a_3) = CCompoundLit a_1 a_2 (f a_3)+        amap f (CStatExpr a_1 a_2) = CStatExpr a_1 (f a_2)+        amap f (CLabAddrExpr a_1 a_2) = CLabAddrExpr a_1 (f a_2)+        amap f (CBuiltinExpr n) = CBuiltinExpr (amap f n)+        amap f (CBlockExpr a_1 a_2 a_3) = CBlockExpr a_1 a_2 (f a_3)+        amap f (ObjCMessageExpr a_1 a_2) = ObjCMessageExpr a_1 (f a_2)+        amap f (ObjCSelectorExpr a_1 a_2) = ObjCSelectorExpr a_1 (f a_2)+        amap f (ObjCProtoExpr a_1 a_2) = ObjCProtoExpr a_1 (f a_2)+        amap f (ObjCEncodeExpr a_1 a_2) = ObjCEncodeExpr a_1 (f a_2)+        amap f (ObjCConst n) = ObjCConst (amap f n)++ +instance (CNode t1) => CNode (ObjCSelectorName t1) where+        nodeInfo (ObjCSelPlain _ n) = nodeInfo n+        nodeInfo (ObjCSelKeys _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCSelectorName t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCSelectorName where+        annotation (ObjCSelPlain _ n) = n+        annotation (ObjCSelKeys _ n) = n+        amap f (ObjCSelPlain a_1 a_2) = ObjCSelPlain a_1 (f a_2)+        amap f (ObjCSelKeys a_1 a_2) = ObjCSelKeys a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCSelectorKeyName t1) where+        nodeInfo (ObjCSelKeyName _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCSelectorKeyName t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCSelectorKeyName where+        annotation (ObjCSelKeyName _ n) = n+        amap f (ObjCSelKeyName a_1 a_2) = ObjCSelKeyName a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCSelector t1) where+        nodeInfo (ObjCSel _ n) = nodeInfo n+        nodeInfo (ObjCInSel d) = nodeInfo d+        nodeInfo (ObjCOutSel d) = nodeInfo d+ +instance (CNode t1) => Pos (ObjCSelector t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCSelector where+        annotation (ObjCSel _ n) = n+        annotation (ObjCInSel n) = n+        annotation (ObjCOutSel n) = n+        amap f (ObjCSel a_1 a_2) = ObjCSel a_1 (f a_2)+        amap f (ObjCInSel a_1) = ObjCInSel (f a_1)+        amap f (ObjCOutSel a_1) = ObjCOutSel (f a_1)++ +instance (CNode t1) => CNode (ObjCMessageExpression t1) where+        nodeInfo (ObjCMsgExpr _ _ n) = nodeInfo n+        nodeInfo (ObjCMsgClass _ _ n) = nodeInfo n+        nodeInfo (ObjCMsgSup _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCMessageExpression t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCMessageExpression where+        annotation (ObjCMsgExpr _ _ n) = n+        annotation (ObjCMsgClass _ _ n) = n+        annotation (ObjCMsgSup _ n) = n+        amap f (ObjCMsgExpr a_1 a_2 a_3) = ObjCMsgExpr a_1 a_2 (f a_3)+        amap f (ObjCMsgClass a_1 a_2 a_3) = ObjCMsgClass a_1 a_2 (f a_3)+        amap f (ObjCMsgSup a_1 a_2) = ObjCMsgSup a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCMessageSelector t1) where+        nodeInfo (ObjCMsgSel _ n) = nodeInfo n+        nodeInfo (ObjCKeyArgs _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCMessageSelector t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCMessageSelector where+        annotation (ObjCMsgSel _ n) = n+        annotation (ObjCKeyArgs _ n) = n+        amap f (ObjCMsgSel a_1 a_2) = ObjCMsgSel a_1 (f a_2)+        amap f (ObjCKeyArgs a_1 a_2) = ObjCKeyArgs a_1 (f a_2)++ +instance (CNode t1) => CNode (ObjCKeywordArg t1) where+        nodeInfo (ObjCKeyArg _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCKeywordArg t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCKeywordArg where+        annotation (ObjCKeyArg _ _ n) = n+        amap f (ObjCKeyArg a_1 a_2 a_3) = ObjCKeyArg a_1 a_2 (f a_3)++ +instance (CNode t1) => CNode (CBuiltinThing t1) where+        nodeInfo (CBuiltinVaArg _ _ n) = nodeInfo n+        nodeInfo (CBuiltinOffsetOf _ _ n) = nodeInfo n+        nodeInfo (CBuiltinTypesCompatible _ _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CBuiltinThing t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CBuiltinThing where+        fmap _f (CBuiltinVaArg a1 a2 a3)+          = CBuiltinVaArg (fmap _f a1) (fmap _f a2) (_f a3)+        fmap _f (CBuiltinOffsetOf a1 a2 a3)+          = CBuiltinOffsetOf (fmap _f a1) (fmap (fmap _f) a2) (_f a3)+        fmap _f (CBuiltinTypesCompatible a1 a2 a3)+          = CBuiltinTypesCompatible (fmap _f a1) (fmap _f a2) (_f a3)++ +instance Annotated CBuiltinThing where+        annotation (CBuiltinVaArg _ _ n) = n+        annotation (CBuiltinOffsetOf _ _ n) = n+        annotation (CBuiltinTypesCompatible _ _ n) = n+        amap f (CBuiltinVaArg a_1 a_2 a_3) = CBuiltinVaArg a_1 a_2 (f a_3)+        amap f (CBuiltinOffsetOf a_1 a_2 a_3)+          = CBuiltinOffsetOf a_1 a_2 (f a_3)+        amap f (CBuiltinTypesCompatible a_1 a_2 a_3)+          = CBuiltinTypesCompatible a_1 a_2 (f a_3)++ +instance (CNode t1) => CNode (ObjCConstant t1) where+        nodeInfo (ObjCStrConst _ n) = nodeInfo n+ +instance (CNode t1) => Pos (ObjCConstant t1) where+        posOf x = posOf (nodeInfo x)++ +instance Annotated ObjCConstant where+        annotation (ObjCStrConst _ n) = n+        amap f (ObjCStrConst a_1 a_2) = ObjCStrConst a_1 (f a_2)++ +instance (CNode t1) => CNode (CConstant t1) where+        nodeInfo (CIntConst _ n) = nodeInfo n+        nodeInfo (CCharConst _ n) = nodeInfo n+        nodeInfo (CFloatConst _ n) = nodeInfo n+        nodeInfo (CStrConst _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CConstant t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CConstant where+        fmap _f (CIntConst a1 a2) = CIntConst a1 (_f a2)+        fmap _f (CCharConst a1 a2) = CCharConst a1 (_f a2)+        fmap _f (CFloatConst a1 a2) = CFloatConst a1 (_f a2)+        fmap _f (CStrConst a1 a2) = CStrConst a1 (_f a2)++ +instance Annotated CConstant where+        annotation (CIntConst _ n) = n+        annotation (CCharConst _ n) = n+        annotation (CFloatConst _ n) = n+        annotation (CStrConst _ n) = n+        amap f (CIntConst a_1 a_2) = CIntConst a_1 (f a_2)+        amap f (CCharConst a_1 a_2) = CCharConst a_1 (f a_2)+        amap f (CFloatConst a_1 a_2) = CFloatConst a_1 (f a_2)+        amap f (CStrConst a_1 a_2) = CStrConst a_1 (f a_2)++ +instance (CNode t1) => CNode (CStringLiteral t1) where+        nodeInfo (CStrLit _ n) = nodeInfo n+ +instance (CNode t1) => Pos (CStringLiteral t1) where+        posOf x = posOf (nodeInfo x)++ +instance Functor CStringLiteral where+        fmap _f (CStrLit a1 a2) = CStrLit a1 (_f a2)++ +instance Annotated CStringLiteral where+        annotation (CStrLit _ n) = n+        amap f (CStrLit a_1 a_2) = CStrLit a_1 (f a_2)+-- GENERATED STOP
+ src/Language/ObjC/Syntax/Builders.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables, RankNTypes #-}++-- | Functions to assist with writing abstract syntax manually.+module Language.ObjC.Syntax.Builders (+ -- * simple constructors+  idType+ ,idTypeSpec+ ,idSpec+ ,protoType+ -- * create a node with only internal information+ ,nonode+)++where++import Language.ObjC.Syntax.AST+import Language.ObjC.Data.Ident+import Language.ObjC.Data.Node+import Language.ObjC.Data.Position+import Data.Foldable (foldMap)+import Data.Maybe+import Data.Monoid+import Control.Newtype++idType :: CDecl+idType = CDecl [idTypeSpec] [] nonode++idTypeSpec :: CDeclSpec+idTypeSpec = idTypeG nonode++idSpec :: CTypeSpec+idSpec = idSpecG nonode++idTypeG :: a -> CDeclarationSpecifier a+idTypeG = CTypeSpec . idSpecG++-- | Create a type name of @id <protoname>@+protoType :: Ident -> CDecl+protoType pNm = CDecl [CTypeSpec (ObjCTypeProto (internalIdent "id")+                        [ObjCProtoNm pNm nonode] nonode)] [] nonode++-- formerly idQuals+idSpecG :: a -> CTypeSpecifier a+idSpecG = CTypeDef (internalIdent "id")++nonode :: NodeInfo+nonode = mkNodeInfoOnlyPos internalPos
+ src/Language/ObjC/Syntax/Constants.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Syntax.Constants+-- Copyright   :  (c) 2007..2008 Duncan Coutts, Benedikt Huber+--                (c) 2012 John W. Lato+-- License     :  BSD-style+-- Maintainer  : jwlato@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- This module provides support for representing, checking and exporting c+-- constants, i.e. integral, float, character and string constants.+-----------------------------------------------------------------------------+module Language.ObjC.Syntax.Constants (+  -- * Utilities+  escapeChar, unescapeChar, unescapeString,+  Flags(..), noFlags, setFlag, clearFlag, testFlag,+  -- * C char constants (and multi-character character constants)+  cChar, cChar_w, cChars, CChar(..), getCChar, getCCharAsInt, isWideChar, showCharConst,+  -- * C integral constants+  CIntFlag(..), CIntRepr(..), cInteger, CInteger(..), getCInteger,readCInteger,+  -- * C floating point constants+  cFloat,  CFloat(..), readCFloat,+  -- * C string literals+  cString, cString_w, CString(..), getCString, showStringLit, concatCStrings,+)+where+import Data.Bits+import Data.Char+import Numeric (showOct, showHex, readHex, readOct, readDec)+import Data.Generics++-- | C char constants (abstract)+data CChar = CChar+              !Char+              !Bool  -- wide flag+           | CChars+              [Char] -- multi-character character constant+              !Bool   -- wide flag+           deriving (Eq,Ord,Data,Typeable)++instance Show CChar where+    showsPrec _ (CChar c wideflag)   = _showWideFlag wideflag . showCharConst c+    showsPrec _ (CChars cs wideflag) = _showWideFlag wideflag . (sQuote $ concatMap escapeCChar cs)++-- | @showCharConst c@ prepends _a_ String representing the C char constant corresponding to @c@.+-- If necessary uses octal or hexadecimal escape sequences.+showCharConst :: Char -> ShowS+showCharConst c = sQuote $ escapeCChar c++_showWideFlag :: Bool -> ShowS+_showWideFlag flag = if flag then showString "L" else id++-- | get the haskell representation of a char constant+getCChar :: CChar -> [Char]+getCChar (CChar  c _)   = [c]+getCChar (CChars  cs _) = cs++-- | get integer value of a C char constant+-- undefined result for multi-char char constants+getCCharAsInt :: CChar -> Integer+getCCharAsInt (CChar c _) = fromIntegral (fromEnum c)+getCCharAsInt (CChars _cs _) = error "integer value of multi-character character constants is implementation defined"++-- | return @true@ if the character constant is /wide/.+isWideChar :: CChar -> Bool+isWideChar (CChar _ wideFlag) = wideFlag+isWideChar (CChars _ wideFlag) = wideFlag++-- | construct a character constant from a haskell 'Char'+-- Use 'cchar_w' if you want a wide character constant.+cChar :: Char -> CChar+cChar c = CChar c False++-- | construct a wide chararacter constant+cChar_w :: Char -> CChar+cChar_w c = CChar c True++-- | create a multi-character character constant+cChars :: [Char] -> Bool -> CChar+cChars = CChars++-- | datatype for memorizing the representation of an integer+data CIntRepr = DecRepr | HexRepr | OctalRepr deriving (Eq,Ord,Enum,Bounded,Data,Typeable)++-- | datatype representing type flags for integers+data CIntFlag = FlagUnsigned | FlagLong | FlagLongLong | FlagImag deriving (Eq,Ord,Enum,Bounded,Data,Typeable)+instance Show CIntFlag where+    show FlagUnsigned = "u"+    show FlagLong = "L"+    show FlagLongLong = "LL"+    show FlagImag = "i"++{-# SPECIALIZE setFlag :: CIntFlag -> Flags CIntFlag -> Flags CIntFlag #-}+{-# SPECIALIZE clearFlag :: CIntFlag -> Flags CIntFlag -> Flags CIntFlag #-}+{-# SPECIALIZE testFlag :: CIntFlag -> Flags CIntFlag -> Bool #-}++data CInteger = CInteger+                 !Integer+                 !CIntRepr+                 !(Flags CIntFlag)  -- integer flags+                 deriving (Eq,Ord,Data,Typeable)+instance Show CInteger where+    showsPrec _ (CInteger i repr flags) = showInt i . showString (concatMap showIFlag [FlagUnsigned .. ]) where+        showIFlag f = if testFlag f flags then show f else []+        showInt i' = case repr of+                       DecRepr -> shows i'+                       OctalRepr -> showString "0" . showOct i'+                       HexRepr -> showString "0x" . showHex i'++-- To be used in the lexer+-- Note that the flag lexer won't scale+readCInteger :: CIntRepr -> String -> Either String CInteger+readCInteger repr str =+  case readNum str of+    [(n,suffix)] -> mkCInt n suffix+    parseFailed  -> Left $ "Bad Integer literal: "++show parseFailed+  where+    readNum = case repr of DecRepr -> readDec; HexRepr -> readHex; OctalRepr -> readOct+    mkCInt n suffix = either Left (Right . CInteger n repr)  $ readSuffix suffix+    readSuffix = parseFlags noFlags+    parseFlags flags [] = Right flags+    parseFlags flags ('l':'l':fs) = parseFlags (setFlag FlagLongLong flags) fs+    parseFlags flags ('L':'L':fs) = parseFlags (setFlag FlagLongLong flags) fs+    parseFlags flags (f:fs) =+      let go1 flag = parseFlags (setFlag flag flags) fs in+      case f of+        'l' -> go1 FlagLong ; 'L' -> go1 FlagLong+        'u' -> go1 FlagUnsigned ; 'U' -> go1 FlagUnsigned+        'i' -> go1 FlagImag ; 'I' -> go1 FlagImag; 'j' -> go1 FlagImag; 'J' -> go1 FlagImag+        _ -> Left $ "Unexpected flag " ++ show f++getCInteger :: CInteger -> Integer+getCInteger (CInteger i _ _) = i++-- | construct a integer constant (without type flags) from a haskell integer+cInteger :: Integer -> CInteger+cInteger i = CInteger i DecRepr noFlags+++-- | Floats (represented as strings)+data CFloat = CFloat+               !String+               deriving (Eq,Ord,Data,Typeable)+instance Show CFloat where+  showsPrec _ (CFloat internal) = showString internal++cFloat :: Float -> CFloat+cFloat = CFloat . show++-- dummy implementation+readCFloat :: String -> CFloat+readCFloat = CFloat++-- | C String literals+data CString = CString+                [Char]    -- characters+                Bool      -- wide flag+                deriving (Eq,Ord,Data,Typeable)+instance Show CString where+    showsPrec _ (CString str wideflag) = _showWideFlag wideflag . showStringLit str++-- construction+cString :: String -> CString+cString str = CString str False+cString_w :: String -> CString+cString_w str = CString str True++-- selectors+getCString :: CString -> String+getCString (CString str _) = str+isWideString :: CString -> Bool+isWideString (CString _ wideflag) = wideflag++-- | concatenate a list of C string literals+concatCStrings :: [CString] -> CString+concatCStrings cs = CString (concatMap getCString cs) (any isWideString cs)++-- | @showStringLiteral s@ prepends a String representing the C string literal corresponding to @s@.+-- If necessary it uses octal or hexadecimal escape sequences.+showStringLit :: String -> ShowS+showStringLit = dQuote . concatMap showStringChar+  where+  showStringChar c | isSChar c = return c+                     | c == '"'  = "\\\""+                     | otherwise = escapeChar c++++-- | @isAsciiSourceChar b@ returns @True@ if the given character is a character which+--   may appear in a ASCII C source file and is printable.+isAsciiSourceChar :: Char -> Bool+isAsciiSourceChar c = isAscii c && isPrint c++-- | @isCChar c@ returns true, if c is a source character which does not have to be escaped in+--   C char constants (C99: 6.4.4.4)+isCChar :: Char -> Bool+isCChar '\\' = False+isCChar '\'' = False+isCChar '\n' = False+isCChar c = isAsciiSourceChar c++-- | @escapeCChar c@ escapes c for use in a char constant+escapeCChar :: Char -> String+escapeCChar '\'' = "\\'"+escapeCChar c | isCChar c = [c]+              | otherwise = escapeChar c++-- | @isSChar c@ returns true if c is a source character which does not have to be escaped in C string+--  literals (C99: 6.4.5)+isSChar :: Char -> Bool+isSChar '\\' = False+isSChar '\"' = False+isSChar '\n' = False+isSChar c = isAsciiSourceChar c++escapeChar :: Char -> String+escapeChar '\\' = "\\\\"+escapeChar '\a' = "\\a"+escapeChar '\b' = "\\b"+escapeChar '\ESC' = "\\e";+escapeChar '\f' = "\\f"+escapeChar '\n' = "\\n"+escapeChar '\r' = "\\r"+escapeChar '\t' = "\\t"+escapeChar '\v' = "\\v"+escapeChar c  | (ord c) < 512   = '\\' : showOct (ord c) ""+              | otherwise       = '\\' : 'x'  : showHex (ord c) ""++unescapeChar :: String -> (Char, String)+unescapeChar ('\\':c:cs)  = case c of+       'n'  -> ('\n', cs)+       't'  -> ('\t', cs)+       'v'  -> ('\v', cs)+       'b'  -> ('\b', cs)+       'r'  -> ('\r', cs)+       'f'  -> ('\f', cs)+       'a'  -> ('\a', cs)+       'e'  -> ('\ESC', cs)  -- GNU extension+       'E'  -> ('\ESC', cs)  -- GNU extension+       '\\' -> ('\\', cs)+       '?'  -> ('?', cs)+       '\'' -> ('\'', cs)+       '"'  -> ('"', cs)+       'x'  -> case head' "bad escape sequence" (readHex cs) of+                 (i, cs') -> (toEnum i, cs')+       _    -> case head' "bad escape sequence" (readOct (c:cs)) of+                 (i, cs') -> (toEnum i, cs')+unescapeChar (c   :cs)    = (c, cs)+unescapeChar []  = error $ "unescape char: empty string"++unescapeString :: String -> String+unescapeString [] = []+unescapeString cs = case unescapeChar cs of+                        (c, cs') -> c : unescapeString cs'++-- helpers+sQuote :: String -> ShowS+sQuote s t = "'" ++ s ++ "'" ++ t+dQuote :: String -> ShowS+dQuote s t = ('"' : s) ++ "\"" ++ t+head' :: String -> [a] -> a+head' err []  = error err+head' _ (x:_) = x++-- TODO: Move to separate file ?+newtype Flags f = Flags Integer deriving (Eq,Ord,Data,Typeable)+noFlags :: Flags f+noFlags = Flags 0+setFlag :: (Enum f) => f -> Flags f -> Flags f+setFlag flag (Flags k)   = Flags$ k  `setBit` fromEnum flag+clearFlag :: (Enum f) => f -> Flags f -> Flags f+clearFlag flag (Flags k) = Flags$ k `clearBit` fromEnum flag+testFlag :: (Enum f) => f -> Flags f -> Bool+testFlag flag (Flags k)  = k `testBit` fromEnum flag
+ src/Language/ObjC/Syntax/Ops.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Syntax.Ops+-- Copyright   :  (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  : jwlato@gmail.com+-- Stability   : experimental+-- Portability : ghc+--+-- Unary, binary and asssignment operators. Exported via AST.+-----------------------------------------------------------------------------+module Language.ObjC.Syntax.Ops (+-- * Assignment operators+CAssignOp(..),+assignBinop,+-- * Binary operators+CBinaryOp(..),+isCmpOp,+isPtrOp,+isBitOp,+isLogicOp,+-- * Unary operators+CUnaryOp(..),+isEffectfulOp+)+where+import Data.Generics+-- | C assignment operators (K&R A7.17)+data CAssignOp = CAssignOp+               | CMulAssOp+               | CDivAssOp+               | CRmdAssOp              -- ^ remainder and assignment+               | CAddAssOp+               | CSubAssOp+               | CShlAssOp+               | CShrAssOp+               | CAndAssOp+               | CXorAssOp+               | COrAssOp+               deriving (Eq,Ord,Show,Data,Typeable)++assignBinop :: CAssignOp -> CBinaryOp+assignBinop CAssignOp = error "direct assignment has no binary operator"+assignBinop CMulAssOp = CMulOp+assignBinop CDivAssOp = CDivOp+assignBinop CRmdAssOp = CRmdOp+assignBinop CAddAssOp = CAddOp+assignBinop CSubAssOp = CSubOp+assignBinop CShlAssOp = CShlOp+assignBinop CShrAssOp = CShrOp+assignBinop CAndAssOp = CAndOp+assignBinop CXorAssOp = CXorOp+assignBinop COrAssOp  = COrOp++-- | C binary operators (K&R A7.6-15)+--+data CBinaryOp = CMulOp+               | CDivOp+               | CRmdOp                 -- ^ remainder of division+               | CAddOp+               | CSubOp+               | CShlOp                 -- ^ shift left+               | CShrOp                 -- ^ shift right+               | CLeOp                  -- ^ less+               | CGrOp                  -- ^ greater+               | CLeqOp                 -- ^ less or equal+               | CGeqOp                 -- ^ greater or equal+               | CEqOp                  -- ^ equal+               | CNeqOp                 -- ^ not equal+               | CAndOp                 -- ^ bitwise and+               | CXorOp                 -- ^ exclusive bitwise or+               | COrOp                  -- ^ inclusive bitwise or+               | CLndOp                 -- ^ logical and+               | CLorOp                 -- ^ logical or+               deriving (Eq,Ord,Show,Data,Typeable)++isCmpOp :: CBinaryOp -> Bool+isCmpOp op = op `elem` [ CLeqOp, CGeqOp, CLeOp, CGrOp, CEqOp, CNeqOp ]++isPtrOp :: CBinaryOp -> Bool+isPtrOp op = op `elem` [ CAddOp, CSubOp ]++isBitOp :: CBinaryOp -> Bool+isBitOp op = op `elem` [ CShlOp, CShrOp, CAndOp, COrOp, CXorOp ]++isLogicOp :: CBinaryOp -> Bool+isLogicOp op = op `elem` [ CLndOp, CLorOp ]++-- | C unary operator (K&R A7.3-4)+--+data CUnaryOp = CPreIncOp               -- ^ prefix increment operator+              | CPreDecOp               -- ^ prefix decrement operator+              | CPostIncOp              -- ^ postfix increment operator+              | CPostDecOp              -- ^ postfix decrement operator+              | CAdrOp                  -- ^ address operator+              | CIndOp                  -- ^ indirection operator+              | CPlusOp                 -- ^ prefix plus+              | CMinOp                  -- ^ prefix minus+              | CCompOp                 -- ^ one's complement+              | CNegOp                  -- ^ logical negation+              deriving (Eq,Ord,Show,Data,Typeable)++isEffectfulOp :: CUnaryOp -> Bool+isEffectfulOp op = op `elem` [ CPreIncOp, CPreDecOp, CPostIncOp, CPostDecOp ]
+ src/Language/ObjC/Syntax/Utils.hs view
@@ -0,0 +1,76 @@+module Language.ObjC.Syntax.Utils (+  -- * Generic operations+  getSubStmts,+  mapSubStmts,+  mapBlockItemStmts,+  -- * Concrete operations+  getLabels+) where++import Data.List+import Language.ObjC.Data.Ident+import Language.ObjC.Syntax.AST++-- XXX: This is should be generalized !!!+--      Data.Generics sounds attractive, but we really need to control the evaluation order+-- XXX: Expression statements (which are somewhat problematic anyway), aren't handled yet+getSubStmts :: CStat -> [CStat]+getSubStmts (CLabel _ s _ _)      = [s]+getSubStmts (CCase _ s _)         = [s]+getSubStmts (CCases _ _ s _)      = [s]+getSubStmts (CDefault s _)        = [s]+getSubStmts (CExpr _ _)           = []+getSubStmts (CCompound _ body _)  = concatMap compoundSubStmts body+getSubStmts (CIf _ sthen selse _) = maybe [sthen] (\s -> [sthen,s]) selse+getSubStmts (CSwitch _ s _)       = [s]+getSubStmts (CWhile _ s _ _)      = [s]+getSubStmts (CFor _ _ _ s _)      = [s]+getSubStmts (CGoto _ _)           = []+getSubStmts (CGotoPtr _ _)        = []+getSubStmts (CCont _)             = []+getSubStmts (CBreak _)            = []+getSubStmts (CReturn _ _)         = []+getSubStmts (CAsm _ _)            = []++mapSubStmts :: (CStat -> Bool) -> (CStat -> CStat) -> CStat -> CStat+mapSubStmts stop _ s | stop s = s+mapSubStmts stop f (CLabel i s attrs ni) =+  f (CLabel i (mapSubStmts stop f s) attrs ni)+mapSubStmts stop f (CCase e s ni) =+  f (CCase e (mapSubStmts stop f s) ni)+mapSubStmts stop f (CCases e1 e2 s ni) =+  f (CCases e1 e2 (mapSubStmts stop f s) ni)+mapSubStmts stop f (CDefault s ni) =+  f (CDefault (mapSubStmts stop f s) ni)+mapSubStmts stop f (CCompound ls body ni) =+  f (CCompound ls (map (mapBlockItemStmts stop f) body) ni)+mapSubStmts stop f (CIf e sthen selse ni) =+  f (CIf e+     (mapSubStmts stop f sthen)+     (maybe Nothing (Just . mapSubStmts stop f) selse)+     ni)+mapSubStmts stop f (CSwitch e s ni) =+  f (CSwitch e (mapSubStmts stop f s) ni)+mapSubStmts stop f (CWhile e s isdo ni) =+  f (CWhile e (mapSubStmts stop f s) isdo ni)+mapSubStmts stop f (CFor i t a s ni) =+  f (CFor i t a (mapSubStmts stop f s) ni)+mapSubStmts _ f s  = f s++mapBlockItemStmts :: (CStat -> Bool)+                  -> (CStat -> CStat)+                  -> CBlockItem+                  -> CBlockItem+mapBlockItemStmts stop f (CBlockStmt s) = CBlockStmt (mapSubStmts stop f s)+mapBlockItemStmts _ _ bi                = bi++compoundSubStmts :: CBlockItem -> [CStat]+compoundSubStmts (CBlockStmt s)    = [s]+compoundSubStmts (CBlockDecl _)    = []+compoundSubStmts (CNestedFunDef _) = []++getLabels :: CStat -> [Ident]+getLabels (CLabel l s _ _)      = l : getLabels s+getLabels (CCompound ls body _) =+  concatMap (concatMap getLabels . compoundSubStmts) body \\ ls+getLabels stmt                  = concatMap getLabels (getSubStmts stmt)
+ src/Language/ObjC/System.hs view
@@ -0,0 +1,7 @@+module Language.ObjC.System (+  module X+)++where+import Language.ObjC.System.GCC        as X+import Language.ObjC.System.Preprocess as X
+ src/Language/ObjC/System/GCC.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE PatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.System.Gcc+-- Copyright   :  (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Invoking gcc for preprocessing and compiling.+-----------------------------------------------------------------------------+module Language.ObjC.System.GCC (+    GCC,newGCC,+)+where+import Language.ObjC.Data.RList as RList+import Language.ObjC.System.Preprocess+import Data.Maybe+import System.Cmd+import System.Directory+import Data.List++-- | @GCC@ represents a reference to the gcc compiler+newtype GCC = GCC { gccPath :: FilePath }++-- | create a reference to @gcc@+newGCC :: FilePath -> GCC+newGCC = GCC++instance Preprocessor GCC where+    parseCPPArgs _ = gccParseCPPArgs+    runCPP gcc cpp_args =+        do  -- copy the input to the outputfile, because in case the input is preprocessed,+            -- gcc -E will do nothing.+            maybe (return()) (copyWritable (inputFile cpp_args)) (outputFile cpp_args)+            rawSystem (gccPath gcc) (buildCppArgs cpp_args)+                where copyWritable source target = do copyFile source target+                                                      p <- getPermissions target+                                                      setPermissions target p{writable=True}++-- | Parse arguments for preprocessing via GCC.+--   At least one .c, .hc or .h file has to be present.+--   For now we only support the most important gcc options.+--+--   1) Parse all flags relevant to CppArgs+--   2) Move -c,-S,-M? to other_args+--   3) Strip -E+--   4) The rest goes into extra_args+gccParseCPPArgs :: [String] -> Either String (CppArgs, [String])+gccParseCPPArgs args =+    case mungeArgs ((Nothing,Nothing,RList.empty),(RList.empty,RList.empty)) args of+        Left err                   -> Left err+        Right ((Nothing,_,_),_)  -> Left "No .c / .hc / .h source file given"+        Right ((Just input_file,output_file_opt,cpp_opts),(extra_args,other_args))+            -> Right ((rawCppArgs (RList.reverse extra_args) input_file)+                      { outputFile = output_file_opt, cppOptions = RList.reverse cpp_opts },+                      RList.reverse other_args)+    where+    mungeArgs :: ParseArgsState -> [String] -> Either String ParseArgsState+    mungeArgs parsed@( cpp_args@(inp,out,cpp_opts),+                          unparsed@(extra,other))+              unparsed_args =+        case unparsed_args of+            ("-E":rest) -> mungeArgs parsed rest++            (flag:rest) |  flag == "-c"+                        || flag == "-S"+                        || "-M" `isPrefixOf` flag+                        -> mungeArgs (cpp_args,(extra,other `snoc` flag)) rest++            ("-o":file:rest)   | isJust out -> Left "two output files given"+                               | otherwise          -> mungeArgs ((inp,Just file,cpp_opts),unparsed) rest++            (cpp_opt:rest)     | Just (opt,rest') <- getArgOpt cpp_opt rest+                               -> mungeArgs ((inp,out,cpp_opts `snoc` opt),unparsed) rest'++            (cfile:rest)       | any (flip isSuffixOf cfile) (words ".c .hc .h")+                               -> if isJust inp+                                   then Left "two input files given"+                                   else mungeArgs ((Just cfile,out,cpp_opts),unparsed) rest++            (unknown:rest)     -> mungeArgs (cpp_args,(extra `snoc` unknown,other)) rest++            []                 -> Right parsed++    getArgOpt cpp_opt rest | "-I" `isPrefixOf` cpp_opt = Just (IncludeDir (drop 2 cpp_opt),rest)+                           | "-U" `isPrefixOf` cpp_opt = Just (Undefine (drop 2 cpp_opt),rest)+                           | "-D" `isPrefixOf` cpp_opt = Just (getDefine (drop 2 cpp_opt),rest)+    getArgOpt "-include" (f:rest')                     = Just (IncludeFile f, rest')+    getArgOpt _ _ = Nothing+    getDefine opt = let (key,val) = break (== '=') opt in Define key (if null val then "" else tail val)++type ParseArgsState = ((Maybe FilePath, Maybe FilePath, RList CppOption), (RList String, RList String))+++buildCppArgs :: CppArgs -> [String]+buildCppArgs (CppArgs options extra_args _tmpdir input_file output_file_opt) = do+       (concatMap tOption options)+    ++ outputFileOpt+    ++ ["-E", input_file]+    ++ extra_args+    where+    tOption (IncludeDir incl)  = ["-I",incl]+    tOption (Define key value) = [ "-D" ++ key ++ (if null value then "" else "=" ++ value) ]+    tOption (Undefine key)     = [ "-U" ++ key ]+    tOption (IncludeFile f)    = [ "-include", f]+    outputFileOpt = concat [ ["-o",output_file] | output_file <- maybeToList output_file_opt ]+
+ src/Language/ObjC/System/Preprocess.hs view
@@ -0,0 +1,123 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.ObjC.Wrapper.Preprocess+-- Copyright   :  (c) 2008 Benedikt Huber+-- License     :  BSD-style+-- Maintainer  :  jwlato@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Invoking external preprocessors.+-----------------------------------------------------------------------------+module Language.ObjC.System.Preprocess (+    Preprocessor(..),+    CppOption(..),+    CppArgs(..),rawCppArgs,addCppOption,addExtraOption,+    cppFile,+    runPreprocessor,+    isPreprocessed,+)+where+import Language.ObjC.Data.InputStream+import System.Exit+import System.Directory+import System.FilePath+import System.IO+import Control.Exception+import Control.Monad+import Data.List++-- | 'Preprocessor' encapsulates the abstract interface for invoking C preprocessors+class Preprocessor cpp where+    -- | parse the given command line arguments, and return a pair of parsed and ignored arguments+    parseCPPArgs :: cpp -> [String] -> Either String (CppArgs, [String])+    -- | run the preprocessor+    runCPP :: cpp -> CppArgs -> IO ExitCode++-- | file extension of a preprocessed file+preprocessedExt :: String+preprocessedExt = ".i"++-- | Generic Options for the preprocessor+data CppOption =+        IncludeDir FilePath+      | Define String String+      | Undefine String+      | IncludeFile FilePath++-- | Generic arguments for the preprocessor+data CppArgs = CppArgs {+        cppOptions :: [CppOption],+        extraOptions :: [String],+        cppTmpDir  :: Maybe FilePath,+        inputFile  :: FilePath,+        outputFile :: Maybe FilePath+    }++-- | Cpp arguments that only specify the input file name.+cppFile :: FilePath -> CppArgs+cppFile input_file = CppArgs { cppOptions = [], extraOptions = [], cppTmpDir = Nothing, inputFile = input_file, outputFile = Nothing }++-- | use the given preprocessor arguments without analyzing them+rawCppArgs :: [String] -> FilePath -> CppArgs+rawCppArgs opts input_file =+    CppArgs { inputFile = input_file, cppOptions = [], extraOptions = opts, outputFile = Nothing, cppTmpDir = Nothing }++-- | add a typed option to the given preprocessor arguments+addCppOption :: CppArgs -> CppOption -> CppArgs+addCppOption cpp_args opt =+    cpp_args { cppOptions = opt : (cppOptions cpp_args) }++-- | add a string option to the given preprocessor arguments+addExtraOption :: CppArgs -> String -> CppArgs+addExtraOption cpp_args extra =+    cpp_args { extraOptions = extra : (extraOptions cpp_args) }++-- | run the preprocessor and return an 'InputStream' if preprocesssing succeeded+runPreprocessor :: (Preprocessor cpp) => cpp -> CppArgs -> IO (Either ExitCode InputStream)+runPreprocessor cpp cpp_args = do+    bracket+        getActualOutFile+        -- remove outfile if it was temporary+        removeTmpOutFile+        -- invoke preprocessor+        invokeCpp+    where+    getActualOutFile :: IO FilePath+    getActualOutFile = maybe (mkOutputFile (cppTmpDir cpp_args) (inputFile cpp_args)) return (outputFile cpp_args)+    invokeCpp actual_out_file = do+        exit_code <- runCPP cpp (cpp_args { outputFile = Just actual_out_file})+        case exit_code of+            ExitSuccess   -> liftM Right (readInputStream actual_out_file)+            ExitFailure _ -> return $ Left exit_code+    removeTmpOutFile out_file = maybe (removeFile out_file) (\_ -> return ()) (outputFile cpp_args)++-- | create an output file, given  @Maybe tmpdir@ and @inputfile@+mkOutputFile :: Maybe FilePath -> FilePath -> IO FilePath+mkOutputFile tmp_dir_opt input_file =+    do tmpDir <- getTempDir tmp_dir_opt+       mkTmpFile tmpDir (getOutputFileName input_file)+    where+    getTempDir (Just tmpdir) = return tmpdir+    getTempDir Nothing       = getTemporaryDirectory++-- | compute output file name from input file name+getOutputFileName :: FilePath -> FilePath+getOutputFileName fp | hasExtension fp = replaceExtension filename preprocessedExt+                     | otherwise       = addExtension filename preprocessedExt+    where+    filename = takeFileName fp++-- | create a temporary file+mkTmpFile :: FilePath -> FilePath -> IO FilePath+mkTmpFile tmp_dir file_templ = do+    -- putStrLn $ "TmpDir: "++tmp_dir+    -- putStrLn $ "FileTempl: "++file_templ+    (path,file_handle) <- openTempFile tmp_dir file_templ+    hClose file_handle+    return path++-- | guess whether a file is preprocessed (file end with .i)+isPreprocessed :: FilePath -> Bool+isPreprocessed = (".i" `isSuffixOf`)+