diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,23 @@ +John W. Lato + +This project originated from language-c, and would not exist without +the many authors and contributors to that library. + +Benedikt Huber +Manuel M T Chakravarty +Duncan Coutts +Bertram Felgenhauer + +with code contributions and patches from + +Iavor Diatchki +Kevin Charter + +This project originated from the C parser component of c2hs, +for many additional contributors see AUTHORS.c2hs. + +Special thanks for their great support, comments and suggestions to: + +Duncan Coutts +Iavor Diatchki +Don Steward diff --git a/AUTHORS.c2hs b/AUTHORS.c2hs new file mode 100644 --- /dev/null +++ b/AUTHORS.c2hs @@ -0,0 +1,25 @@ +Manuel M T Chakravarty +Duncan Coutts + +with contributions from (alphabetical order) + +Bertram Felgenhauer +Ian Lynagh +André Pang +Jens-Ulrik Petersen +Armin Sander +Sean Seefried +Udo Stenzel +Axel Simon +Michael Weber + +Thanks for comments and suggestions to + +Roman Leshchinskiy +Jan Kort +Seth Kurtzberg +Simon Marlow +Matthias Neubauer +Sven Panne +Simon L. Peyton Jones +Volker Wysk diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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="" +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +import Distribution.Simple + +main = defaultMain diff --git a/language-objc.cabal b/language-objc.cabal new file mode 100644 --- /dev/null +++ b/language-objc.cabal @@ -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 + diff --git a/src/Language/ObjC.hs b/src/Language/ObjC.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC.hs @@ -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 +----------------------------------------------------------------------------- +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) diff --git a/src/Language/ObjC/Analysis.hs b/src/Language/ObjC/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis.hs @@ -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 diff --git a/src/Language/ObjC/Analysis/AstAnalysis.hs b/src/Language/ObjC/Analysis/AstAnalysis.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/AstAnalysis.hs @@ -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) diff --git a/src/Language/ObjC/Analysis/AstAnalysis.hs-boot b/src/Language/ObjC/Analysis/AstAnalysis.hs-boot new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/AstAnalysis.hs-boot @@ -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 diff --git a/src/Language/ObjC/Analysis/Builtins.hs b/src/Language/ObjC/Analysis/Builtins.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/Builtins.hs @@ -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 + ] + ] diff --git a/src/Language/ObjC/Analysis/ConstEval.hs b/src/Language/ObjC/Analysis/ConstEval.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/ConstEval.hs @@ -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 diff --git a/src/Language/ObjC/Analysis/Debug.hs b/src/Language/ObjC/Analysis/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/Debug.hs @@ -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 "" + 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) + diff --git a/src/Language/ObjC/Analysis/DeclAnalysis.hs b/src/Language/ObjC/Analysis/DeclAnalysis.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/DeclAnalysis.hs @@ -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" diff --git a/src/Language/ObjC/Analysis/DefTable.hs b/src/Language/ObjC/Analysis/DefTable.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/DefTable.hs @@ -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 + + 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) + diff --git a/src/Language/ObjC/Analysis/Export.hs b/src/Language/ObjC/Analysis/Export.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/Export.hs @@ -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 diff --git a/src/Language/ObjC/Analysis/NameSpaceMap.hs b/src/Language/ObjC/Analysis/NameSpaceMap.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/NameSpaceMap.hs @@ -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 diff --git a/src/Language/ObjC/Analysis/SemError.hs b/src/Language/ObjC/Analysis/SemError.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/SemError.hs @@ -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) + diff --git a/src/Language/ObjC/Analysis/SemRep.hs b/src/Language/ObjC/Analysis/SemRep.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/SemRep.hs @@ -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 diff --git a/src/Language/ObjC/Analysis/TravMonad.hs b/src/Language/ObjC/Analysis/TravMonad.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/TravMonad.hs @@ -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 diff --git a/src/Language/ObjC/Analysis/TypeCheck.hs b/src/Language/ObjC/Analysis/TypeCheck.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/TypeCheck.hs @@ -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 diff --git a/src/Language/ObjC/Analysis/TypeConversions.hs b/src/Language/ObjC/Analysis/TypeConversions.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/TypeConversions.hs @@ -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) + diff --git a/src/Language/ObjC/Analysis/TypeUtils.hs b/src/Language/ObjC/Analysis/TypeUtils.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Analysis/TypeUtils.hs @@ -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 + diff --git a/src/Language/ObjC/Data.hs b/src/Language/ObjC/Data.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Data.hs @@ -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 diff --git a/src/Language/ObjC/Data/Error.hs b/src/Language/ObjC/Data/Error.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Data/Error.hs @@ -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 +-- +-- > :: (column ) [] +-- > >>> +-- > +-- > ... +-- > +showErrorInfo :: String -> ErrorInfo -> String +showErrorInfo short_msg (ErrorInfo level pos msgs) = + header ++ showMsgLines (if null short_msg then msgs else short_msg:msgs) + where + header = (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 diff --git a/src/Language/ObjC/Data/Ident.hs b/src/Language/ObjC/Data/Ident.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Data/Ident.hs @@ -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) diff --git a/src/Language/ObjC/Data/InputStream.hs b/src/Language/ObjC/Data/InputStream.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Data/InputStream.hs @@ -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 + diff --git a/src/Language/ObjC/Data/Name.hs b/src/Language/ObjC/Data/Name.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Data/Name.hs @@ -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..] diff --git a/src/Language/ObjC/Data/Node.hs b/src/Language/ObjC/Data/Node.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Data/Node.hs @@ -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 + diff --git a/src/Language/ObjC/Data/Position.hs b/src/Language/ObjC/Data/Position.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Data/Position.hs @@ -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 = "" + show BuiltinPosition = "" + show InternalPosition = "" + +{-# DEPRECATED posColumn "column number information is inaccurate in presence of macros - do not rely on it." #-} + +-- | @position absoluteOffset fileName lineNumber columnNumber@ initializes a @Position@ using the given arguments +position :: Int -> String -> Int -> Int -> Position +position = Position + +-- | class of type which aggregate a source code location +class Pos a where + posOf :: a -> Position + +-- | initialize a Position to the start of the translation unit starting in the given file +initPos :: FilePath -> Position +initPos file = Position 0 file 1 1 + +-- | returns @True@ if the given position refers to an actual source file +isSourcePos :: Position -> Bool +isSourcePos (Position _ _ _ _) = True +isSourcePos _ = False + +-- | no position (for unknown position information) +nopos :: Position +nopos = NoPosition + +-- | returns @True@ if the there is no position information available +isNoPos :: Position -> Bool +isNoPos NoPosition = True +isNoPos _ = False + +-- | position attached to built-in objects +-- +builtinPos :: Position +builtinPos = BuiltinPosition + +-- | returns @True@ if the given position refers to a builtin definition +isBuiltinPos :: Position -> Bool +isBuiltinPos BuiltinPosition = True +isBuiltinPos _ = False + +-- | position used for internal errors +internalPos :: Position +internalPos = InternalPosition + +-- | returns @True@ if the given position is internal +isInternalPos :: Position -> Bool +isInternalPos InternalPosition = True +isInternalPos _ = False + +{-# INLINE incPos #-} +-- | advance column +incPos :: Position -> Int -> Position +incPos (Position offs fname row col) n = Position (offs + n) fname row (col + n) +incPos p _ = p + +{-# INLINE retPos #-} +-- | advance to next line +retPos :: Position -> Position +retPos (Position offs fname row _) = Position (offs+1) fname (row + 1) 1 +retPos p = p + +{-# INLINE adjustPos #-} +-- | adjust position: change file and line number, reseting column to 1. This is usually +-- used for #LINE pragmas. The absolute offset is not changed - this can be done +-- by @adjustPos newFile line . incPos (length pragma)@. +adjustPos :: FilePath -> Int -> Position -> Position +adjustPos fname row (Position offs _ _ _) = Position offs fname row 1 +adjustPos _ _ p = p + +{-# INLINE incOffset #-} +-- | advance just the offset +incOffset :: Position -> Int -> Position +incOffset (Position o f r c) n = Position (o + n) f r c +incOffset p _n = p diff --git a/src/Language/ObjC/Data/RList.hs b/src/Language/ObjC/Data/RList.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Data/RList.hs @@ -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) diff --git a/src/Language/ObjC/Parser.hs b/src/Language/ObjC/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Parser.hs @@ -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 diff --git a/src/Language/ObjC/Parser/Builtin.hs b/src/Language/ObjC/Parser/Builtin.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Parser/Builtin.hs @@ -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"] diff --git a/src/Language/ObjC/Parser/Lexer.x b/src/Language/ObjC/Parser/Lexer.x new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Parser/Lexer.x @@ -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: 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 +} diff --git a/src/Language/ObjC/Parser/Parser.y b/src/Language/ObjC/Parser/Parser.y new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Parser/Parser.y @@ -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: +-- +-- +-- +-- GNU extensions are documented in the gcc parser +-- +-- +-- +-- and in: +-- +-- The set of supported extensions is documented in +-- +-- +------------------------------------------------------------------ +{ +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. +-- +-- 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 :- type-qualifier* storage-class+ typename+ "extern unsigned static volatile int f()" +-- type_specifier :- type-qualifier* typename+ "const int f()", "long int f()" +-- declaration_qualifier_list :- type_qualifier* storage-class+ "extern static const f()" +-- type_qualifier_list :- type-qualifier+ "const f()" +-- +-- * GNU extension: +-- __attribute__ annotations +-- +function_definition :: { CFunDef } +function_definition + : function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef [] $1 [] $2) } + + | attrs function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftCAttrs $1) $2 [] $3) } + + | declaration_specifier function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) } + + | type_specifier function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) } + + | declaration_qualifier_list function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef (reverse $1) $2 [] $3) } + + | type_qualifier_list function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 [] $3) } + + | type_qualifier_list attrs function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1 ++ liftCAttrs $2) $3 [] $4) } + + -- old function declarators + + | function_declarator_old declaration_list compound_statement + {% withNodeInfo $1 $ CFunDef [] $1 (reverse $2) $3 } + + | attrs function_declarator_old declaration_list compound_statement + {% withNodeInfo $2 $ CFunDef (liftCAttrs $1) $2 (reverse $3) $4 } + + | declaration_specifier function_declarator_old declaration_list compound_statement + {% withNodeInfo $1 $ CFunDef $1 $2 (reverse $3) $4 } + + | type_specifier function_declarator_old declaration_list compound_statement + {% withNodeInfo $1 $ CFunDef $1 $2 (reverse $3) $4 } + + | declaration_qualifier_list function_declarator_old declaration_list compound_statement + {% withNodeInfo $1 $ CFunDef (reverse $1) $2 (reverse $3) $4 } + + | type_qualifier_list function_declarator_old declaration_list compound_statement + {% withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 (reverse $3) $4 } + + | type_qualifier_list attrs function_declarator_old declaration_list compound_statement + {% withNodeInfo $1 $ CFunDef (liftTypeQuals $1 ++ liftCAttrs $2) $3 (reverse $4) $5 } + +-- Read declarator and put function +function_declarator :: { CDeclr } +function_declarator + : identifier_declarator + {% let declr = reverseDeclr $1 in + enterScope >> doFuncParamDeclIdent declr >> return declr } + + +-- parse C statement (C99 6.8) +-- +-- * GNU extension: ' __asm__ (...); ' statements +-- +statement :: { CStat } +statement + : labeled_statement { $1 } + | compound_statement { $1 } + | expression_statement { $1 } + | selection_statement { $1 } + | iteration_statement { $1 } + | jump_statement { $1 } + | asm_statement {% withNodeInfo $1 (CAsm $1) } + + +-- parse C labeled statement (C99 6.8.1) +-- +-- * GNU extension: case ranges +-- +labeled_statement :: { CStat } +labeled_statement + : identifier ':' attrs_opt statement {% withNodeInfo $1 $ CLabel $1 $4 $3 } + | case constant_expression ':' statement {% withNodeInfo $1 $ CCase $2 $4 } + | default ':' statement {% withNodeInfo $1 $ CDefault $3 } + | case constant_expression "..." constant_expression ':' statement + {% withNodeInfo $1 $ CCases $2 $4 $6 } + + +-- parse C compound statement (C99 6.8.2) +-- +-- * GNU extension: '__label__ ident;' declarations +-- +compound_statement :: { CStat } +compound_statement + : '{' enter_scope block_item_list leave_scope '}' + {% withNodeInfo $1 $ CCompound [] (reverse $3) } + + | '{' enter_scope label_declarations block_item_list leave_scope '}' + {% withNodeInfo $1 $ CCompound (reverse $3) (reverse $4) } + + +-- No syntax for these, just side effecting semantic actions. +-- +enter_scope :: { () } +enter_scope : {% enterScope } +leave_scope :: { () } +leave_scope : {% leaveScope } + + +block_item_list :: { Reversed [CBlockItem] } +block_item_list + : {- empty -} { empty } + | block_item_list block_item { $1 `snoc` $2 } + +block_item :: { CBlockItem } +block_item + : statement { CBlockStmt $1 } + | nested_declaration { $1 } + +nested_declaration :: { CBlockItem } +nested_declaration + : declaration { CBlockDecl $1 } + | nested_function_definition { CNestedFunDef $1 } + | "__extension__" nested_declaration { $2 } + +nested_function_definition :: { CFunDef } +nested_function_definition + : declaration_specifier function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) } + + | type_specifier function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef $1 $2 [] $3) } + + | declaration_qualifier_list function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef (reverse $1) $2 [] $3) } + + | type_qualifier_list function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1) $2 [] $3) } + + | type_qualifier_list attrs function_declarator compound_statement + {% leaveScope >> (withNodeInfo $1 $ CFunDef (liftTypeQuals $1 ++ liftCAttrs $2) $3 [] $4) } + + +label_declarations :: { Reversed [Ident] } +label_declarations + : "__label__" identifier_list ';' { $2 } --TODO + | label_declarations "__label__" identifier_list ';' { $1 `rappendr` $3 } + + +-- parse C expression statement (C99 6.8.3) +-- +expression_statement :: { CStat } +expression_statement + : ';' {% withNodeInfo $1 $ CExpr Nothing } + | expression ';' {% withNodeInfo $1 $ CExpr (Just $1) } + + +-- parse C selection statement (C99 6.8.4) +-- +selection_statement :: { CStat } +selection_statement + : if '(' expression ')' statement + {% withNodeInfo $1 $ CIf $3 $5 Nothing } + + | if '(' expression ')' statement else statement + {% withNodeInfo $1 $ CIf $3 $5 (Just $7) } + + | switch '(' expression ')' statement + {% withNodeInfo $1 $ CSwitch $3 $5 } + + +-- parse C iteration statement (C99 6.8.5) +-- +iteration_statement :: { CStat } +iteration_statement + : while '(' expression ')' statement + {% withNodeInfo $1 $ CWhile $3 $5 False } + + | do statement while '(' expression ')' ';' + {% withNodeInfo $1 $ CWhile $5 $2 True } + + | for '(' expression_opt ';' expression_opt ';' expression_opt ')' statement + {% withNodeInfo $1 $ CFor (Left $3) $5 $7 $9 } + + | for '(' enter_scope declaration expression_opt ';' expression_opt ')' statement leave_scope + {% withNodeInfo $1 $ CFor (Right $4) $5 $7 $9 } + + +-- parse C jump statement (C99 6.8.6) +-- +-- * GNU extension: computed gotos +-- +jump_statement :: { CStat } +jump_statement + : goto identifier ';' {% withNodeInfo $1 $ CGoto $2 } + | goto '*' expression ';' {% withNodeInfo $1 $ CGotoPtr $3 } + | continue ';' {% withNodeInfo $1 $ CCont } + | break ';' {% withNodeInfo $1 $ CBreak } + | return expression_opt ';' {% withNodeInfo $1 $ CReturn $2 } + + +-- parse GNU C __asm__ statement (compatible with C99: J.5.10) +-- +-- asm_stmt :- asm volatile? ( "asm..." : output-operands : input-operands : asm-clobbers ) +-- asm_operand :- [operand-name] "constraint" ( expr ) +-- asm_clobber :- "r1", "r2", ... +-- +asm_statement :: { CAsmStmt } +asm_statement + : asm maybe_type_qualifier '(' string_literal ')' ';' + {% withNodeInfo $1 $ CAsmStmt $2 $4 [] [] [] } + + | asm maybe_type_qualifier '(' string_literal ':' asm_operands ')' ';' + {% withNodeInfo $1 $ CAsmStmt $2 $4 $6 [] [] } + + | asm maybe_type_qualifier '(' string_literal ':' asm_operands ':' asm_operands ')' ';' + {% withNodeInfo $1 $ CAsmStmt $2 $4 $6 $8 [] } + + | asm maybe_type_qualifier '(' string_literal ':' asm_operands ':' asm_operands ':' asm_clobbers ')' ';' + {% withNodeInfo $1 $ CAsmStmt $2 $4 $6 $8 (reverse $10) } + + +maybe_type_qualifier :: { Maybe CTypeQual } +maybe_type_qualifier + : {- empty -} { Nothing } + | type_qualifier { Just $1 } + +asm_operands :: { [CAsmOperand] } +asm_operands + : {- empty -} { [] } + | nonnull_asm_operands { reverse $1 } + +nonnull_asm_operands :: { Reversed [CAsmOperand] } +nonnull_asm_operands + : asm_operand { singleton $1 } + | nonnull_asm_operands ',' asm_operand { $1 `snoc` $3 } + +asm_operand :: { CAsmOperand } +asm_operand + : string_literal '(' expression ')' {% withNodeInfo $1 $ CAsmOperand Nothing $1 $3 } + | '[' ident ']' string_literal '(' expression ')' {% withNodeInfo $1 $ CAsmOperand (Just $2) $4 $6 } + | '[' tyident ']' string_literal '(' expression ')' {% withNodeInfo $1 $ CAsmOperand (Just $2) $4 $6 } + + +asm_clobbers :: { Reversed [CStrLit] } +asm_clobbers + : string_literal { singleton $1 } + | asm_clobbers ',' string_literal { $1 `snoc` $3 } + +{- +--------------------------------------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------------------- +-- Declarations +--------------------------------------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------------------- + +Declarations are the most complicated part of the grammar, and shall be summarized here. +To allow a lightweight notation, we will use the modifier to indicate that the order of the immidieate right-hand +sides doesn't matter. + - a* b+ c === any sequence of a's, b's and c's, which contains exactly 1 'c' and at least one 'b' + +-- storage class and type qualifier +--------------------------------------------------------------------------------------------------------------- +attr :- __attribute__((..)) +storage_class :- typedef | extern | static | auto | register | __thread +type_qualifier :- const | volatile | restrict | inline +type_qualifier_list :- type_qualifier+ + +declaration_qualifier :- storage_class | type_qualifier +declaration_qualifier_list :- type_qualifier* storage_class+ + +qualifiers :- declaration_qualifier_list | type_qualifier_list + := (type_qualifier|storage_class)+ + +-- type names +--------------------------------------------------------------------------------------------------------------- +declaration_specifier :- type_qualifier* storage_class+ (basic_type_name+ | elaborated_type_name | tyident ) +type_specifier :- type_qualifier* (basic_type_name+ | elaborated_type_name | tyident) + +specifiers :- declaration_specifier | type_specifier + := type_qualifier* storage_class* (basic_type_name+ | elaborated_type_name | tyident ) + +-- struct/union/enum declarations +--------------------------------------------------------------------------------------------------------------- +sue_declaration_specifier :- type_qualifier* storage_class+ elaborated_type_name +sue_type_specifier :- type_qualifier* elaborated_type_name + +sue_declaration := sue_declaration_specifier | sue_type_specifier + :- type_qualifier* storage_class* elaborated_type_name + +-- declarators +--------------------------------------------------------------------------------------------------------------- +identifier_declarator :- ( '*' (type_qualifier | attr)* ) * ident [ array_decl | "(" parameter-list ")" ] + plus additional parenthesis' ending ^^ here +typedef_declartor :- +declarator :- identifier_declarator | typedef_declarator + +-- Declaration lists +--------------------------------------------------------------------------------------------------------------- +default_declaring_list :- qualifiers ( identifier_declarator asm*attrs* initializer? )_comma_list + +declaring_list :- specifiers ( declarator asm*attrs* initializer? )_comma_list + +declaration_list := default_declaring_list | declaring_list + +-- Declaration +--------------------------------------------------------------------------------------------------------------- +declaration = sue_declaration | declaration_list + +--------------------------------------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------------------- +-- Attributes +-- (citing http://gcc.gnu.org/onlinedocs/gcc/Attribute-Syntax.html) +--------------------------------------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------------------- + +"Attributes may appear after the colon following a label (expect case and default)" + +labeled_statement :- identifier ':' attrs_opt statement + +"Attributes may go either immediately after the struct/union/enum keyword or after the closing brace" + +struct attrs_opt ... +struct ... { } attrs_opt + +"In general: Attributes appear as part of declarations, either belonging to a declaration or declarator" + +"Any list of specifiers and qualifiers at the start of a declaration may contain attribute specifiers" +"An attribute list may appear immediately before the comma, = or semicolon terminating a declaration of an identifier" + +--------------------------------------------------------------------------------------------------------------- +For the parser, we modified the following rules to be interleaved with attributes: + +default_declaring_list' :- (declaration_qualifier_list' | type_qualifier_list' attr*) + identifier_declarator asm*attr* initializer? + { ',' attr* identifier_declarator asm*attr* initializer? } +declaring_list' :- specifier' declarator asm*attr* initializer? + { ',' attr* declarator asm*attr* initializer? } + + +type_qualifier_list' is like type_qualifier_list, but with preceeding and/or interleaving (but not terminating) __attribute__ annotations. +declaration_qualifier_list', declaration_specifier' and type_specifier' are like their unprimed variants, but with arbitrary preceeding, interleaving and/or terminating __attribute__ annotations. + +"An attribute list may appear immediately before a declarator other than the first in a comma seperated list of declarators" + +"The attribute specifiers may be the only specifiers present (implicit int)" [not supported] + +"Attribute specifiers may be mixed with type qualifiers appearing inside the [] of an parameter array declarator" + +tbc. +-} + + + +-- parse C declaration (C99 6.7) +declaration :: { CDecl } +declaration + : sue_declaration_specifier ';' + {% withNodeInfo $1 $ CDecl (reverse $1) [] } + + | sue_type_specifier ';' + {% withNodeInfo $1 $ CDecl (reverse $1) [] } + + | declaring_list ';' + {% case $1 of CDecl declspecs dies at -> withLength at (CDecl declspecs (List.reverse dies)) } + + | default_declaring_list ';' + {% case $1 of CDecl declspecs dies at -> withLength at (CDecl declspecs (List.reverse dies)) } + + +declaration_list :: { Reversed [CDecl] } +declaration_list + : {- empty -} { empty } + | declaration_list declaration { $1 `snoc` $2 } + + +-- * SUMMARY: default_declaring_list :- qualifier* identifier_declarator asm_attrs initializer? +-- { ',' identifier_declarator asm_attrs initializer? } +-- +-- * GNU extensions +-- __attribute__ annotations imm. before an declarator (see Attribute Syntax, paragraph 11) +-- asm + __attribute__ annotations (end of declarations, see Attribute Syntax, paragraph 12) +-- The assembler annotation is used to specifiy an assembler name for the declarator. +-- +default_declaring_list :: { CDecl } +default_declaring_list + : declaration_qualifier_list identifier_declarator asm_attrs_opt {-{}-} initializer_opt + {% let declspecs = reverse $1 in + do{ declr <- withAsmNameAttrs $3 $2 + ; doDeclIdent declspecs declr + ; withNodeInfo $1 $ + CDecl declspecs [(Just (reverseDeclr declr), $4, Nothing)] }} + + | type_qualifier_list identifier_declarator asm_attrs_opt {-{}-} initializer_opt + {% let declspecs = liftTypeQuals $1 in + do{ declr <- withAsmNameAttrs $3 $2 + ; doDeclIdent declspecs declr + ; withNodeInfo $1 $ CDecl declspecs [(Just (reverseDeclr declr), $4, Nothing)] }} + + | type_qualifier_list attrs identifier_declarator asm_attrs_opt {-{}-} initializer_opt -- FIX 1600 + {% let declspecs = liftTypeQuals $1 in + do{ declr <- withAsmNameAttrs $4 $3 + ; doDeclIdent declspecs declr + ; withNodeInfo $1 $ CDecl (declspecs ++ liftCAttrs $2) [(Just (reverseDeclr declr), $5, Nothing)] }} + + -- GNU extension: __attribute__ as the only qualifier + | attrs identifier_declarator asm_attrs_opt {-{}-} initializer_opt + {% let declspecs = liftCAttrs $1 in + do{ declr <- withAsmNameAttrs $3 $2 + ; doDeclIdent declspecs declr + ; withNodeInfo $1 $ CDecl declspecs [(Just (reverseDeclr declr), $4, Nothing)] }} + + | default_declaring_list ',' attrs_opt identifier_declarator asm_attrs_opt {-{}-} initializer_opt + {% case $1 of + CDecl declspecs dies at -> do + declr <- withAsmNameAttrs (fst $5, snd $5 ++ $3) $4 + doDeclIdent declspecs declr + withLength at $ CDecl declspecs ((Just (reverseDeclr declr), $6, Nothing) : dies) } + +-- assembler, followed by attribute annotation +asm_attrs_opt :: { (Maybe CStrLit, [CAttr]) } +asm_attrs_opt + : asm_opt attrs_opt + { ($1,$2) } + +-- +-- SUMMARY: declaring_list :- specifier* declarator asm_attrs initializer? +-- { ',' declarator asm_attrs initializer? } +-- +-- GNU extensions: +-- __attribute__ annotations imm. before an declarator (see Attribute Syntax, paragraph 11) +-- asm + __attribute__ annotations (end of declarations, see Attribute Syntax, paragraph 12) +-- +declaring_list :: { CDecl } +declaring_list + : declaration_specifier declarator asm_attrs_opt initializer_opt + {% do{ + declr <- withAsmNameAttrs $3 $2; + doDeclIdent $1 declr; + withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr declr), $4, Nothing)] } + } + + | type_specifier declarator asm_attrs_opt initializer_opt + {% do{ + declr <- withAsmNameAttrs $3 $2; + doDeclIdent $1 declr; + withNodeInfo $1 $ CDecl $1 [(Just (reverseDeclr declr), $4, Nothing)] } + } + + | declaring_list ',' attrs_opt declarator asm_attrs_opt initializer_opt + {% case $1 of + CDecl declspecs dies at -> do + declr <- withAsmNameAttrs (fst $5, snd $5 ++ $3) $4 + doDeclIdent declspecs declr + return (CDecl declspecs ((Just (reverseDeclr declr), $6, Nothing) : dies) at) } + + +-- parse C declaration specifiers (C99 6.7) +-- +-- * type_qualifier* storage_class+ (basic_type_name+ | elaborated_type_name | tyident ) +-- +declaration_specifier :: { [CDeclSpec] } +declaration_specifier + : basic_declaration_specifier { reverse $1 } -- Arithmetic or void + | sue_declaration_specifier { reverse $1 } -- Struct/Union/Enum + | typedef_declaration_specifier { reverse $1 } -- Typedef + | 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 :- type_qualifier* storage_class+ +-- +-- GNU extensions +-- * arbitrary interleaved __attribute__ annotations +-- +declaration_qualifier_list :: { Reversed [CDeclSpec] } +declaration_qualifier_list + : storage_class + { singleton (CStorageSpec $1) } + + | attrs storage_class + { reverseList (liftCAttrs $1) `snoc` (CStorageSpec $2) } + + | type_qualifier_list storage_class + { rmap CTypeQual $1 `snoc` CStorageSpec $2 } + + | type_qualifier_list attrs storage_class + { (rmap CTypeQual $1 `rappend` liftCAttrs $2) `snoc` CStorageSpec $3 } + + | declaration_qualifier_list declaration_qualifier + { $1 `snoc` $2 } + + | declaration_qualifier_list attr + { addTrailingAttrs $1 $2 } + +-- +-- declaration_qualifier :- storage_class | type_qualifier +-- +declaration_qualifier :: { CDeclSpec } +declaration_qualifier + : storage_class { CStorageSpec $1 } + | type_qualifier { CTypeQual $1 } -- const or volatile + + +-- parse C storage class specifier (C99 6.7.1) +-- +-- * GNU extensions: '__thread' thread local storage +-- +storage_class :: { CStorageSpec } +storage_class + : typedef {% withNodeInfo $1 $ CTypedef } + | extern {% withNodeInfo $1 $ CExtern } + | static {% withNodeInfo $1 $ CStatic } + | auto {% withNodeInfo $1 $ CAuto } + | register {% withNodeInfo $1 $ CRegister } + | "__thread" {% withNodeInfo $1 $ CThread } + + +-- parse C type specifier (C99 6.7.2) +-- +-- This recignises a whole list of type specifiers rather than just one +-- as in the C99 grammar. +-- +-- type_specifier :- type_qualifier* (basic_type_name+ | elaborated_type_name | g) +-- +type_specifier :: { [CDeclSpec] } +type_specifier + : basic_type_specifier { reverse $1 } -- Arithmetic or void + | sue_type_specifier { reverse $1 } -- Struct/Union/Enum + | typedef_type_specifier { reverse $1 } -- Typedef + | 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 :- type_qualifier* storage_class+ basic_type_name+ +-- +-- GNU extensions +-- arbitrary interleaved __attribute__ annotations +-- +basic_declaration_specifier :: { Reversed [CDeclSpec] } +basic_declaration_specifier + : declaration_qualifier_list basic_type_name + { $1 `snoc` CTypeSpec $2 } + + | basic_type_specifier storage_class + { $1 `snoc` CStorageSpec $2 } + + | basic_declaration_specifier declaration_qualifier + { $1 `snoc` $2 } + + | basic_declaration_specifier basic_type_name + { $1 `snoc` CTypeSpec $2 } + + | basic_declaration_specifier attr + { addTrailingAttrs $1 $2 } + + +-- A mixture of type qualifiers and basic type names in any order, but +-- containing at least one basic type name. +-- +-- basic_type_specifier :- type_qualifier* basic_type_name+ +-- +-- GNU extensions +-- arbitrary interleaved __attribute__ annotations +-- +basic_type_specifier :: { Reversed [CDeclSpec] } +basic_type_specifier + -- Arithmetic or void + : basic_type_name + { singleton (CTypeSpec $1) } + + | attrs basic_type_name + { (reverseList $ liftCAttrs $1) `snoc` (CTypeSpec $2) } + + | type_qualifier_list basic_type_name + { rmap CTypeQual $1 `snoc` CTypeSpec $2 } + + | type_qualifier_list attrs basic_type_name + { rmap CTypeQual $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec $3 } + + | basic_type_specifier type_qualifier + { $1 `snoc` CTypeQual $2 } + + | basic_type_specifier basic_type_name + { $1 `snoc` CTypeSpec $2 } + + | basic_type_specifier attr + { addTrailingAttrs $1 $2 } + + +-- A named or anonymous struct, union or enum type along with at least one +-- storage class and any mix of type qualifiers. +-- +-- * Summary: +-- sue_declaration_specifier :- type_qualifier* storage_class+ elaborated_type_name +-- +sue_declaration_specifier :: { Reversed [CDeclSpec] } +sue_declaration_specifier + : declaration_qualifier_list elaborated_type_name + { $1 `snoc` CTypeSpec $2 } + + | sue_type_specifier storage_class + { $1 `snoc` CStorageSpec $2 } + + | sue_declaration_specifier declaration_qualifier + { $1 `snoc` $2 } + + | sue_declaration_specifier attr + { addTrailingAttrs $1 $2 } + + +-- A struct, union or enum type (named or anonymous) with optional leading and +-- trailing type qualifiers. +-- +-- * Summary: +-- sue_type_specifier :- type_qualifier* elaborated_type_name +-- +-- * GNU Extensions: records __attribute__ annotations +-- +sue_type_specifier :: { Reversed [CDeclSpec] } +sue_type_specifier + -- struct/union/enum + : elaborated_type_name + { singleton (CTypeSpec $1) } + + | attrs elaborated_type_name + { (reverseList $ liftCAttrs $1) `snoc` (CTypeSpec $2) } + + | type_qualifier_list elaborated_type_name + { rmap CTypeQual $1 `snoc` CTypeSpec $2 } + + | type_qualifier_list attrs elaborated_type_name + { rmap CTypeQual $1 `rappend` (liftCAttrs $2) `snoc` CTypeSpec $3 } + + | sue_type_specifier type_qualifier + { $1 `snoc` CTypeQual $2 } + + | sue_type_specifier attr + { addTrailingAttrs $1 $2 } + +-- A typedef'ed type identifier with at least one storage qualifier and any +-- number of type qualifiers +-- +-- * Summary: +-- typedef_declaration_specifier :- type_qualifier* storage_class+ tyident +-- +-- * Note: +-- the tyident can also be a: typeof '(' ... ')' +-- +typedef_declaration_specifier :: { Reversed [CDeclSpec] } +typedef_declaration_specifier + : typedef_type_specifier storage_class + { $1 `snoc` CStorageSpec $2 } + + | declaration_qualifier_list tyident + {% withNodeInfo $2 $ \at -> $1 `snoc` CTypeSpec (CTypeDef $2 at) } + + | declaration_qualifier_list 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 +} diff --git a/src/Language/ObjC/Parser/ParserMonad.hs b/src/Language/ObjC/Parser/ParserMonad.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Parser/ParserMonad.hs @@ -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:) diff --git a/src/Language/ObjC/Parser/Tokens.hs b/src/Language/ObjC/Parser/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Parser/Tokens.hs @@ -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 " " + 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 " " + 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" diff --git a/src/Language/ObjC/Pretty.hs b/src/Language/ObjC/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Pretty.hs @@ -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 "") 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 "" else "a ") +-- single :: Bool -> ( (String -> String -> Doc) -> a ) -> (a, Bool) +-- single isPlural mkDescr = (mkDescr (pluralize isPlural), isPlural) +-- plural :: Bool -> ( (String -> String -> Doc) -> a ) -> (a, Bool) +-- plural isPlural mkDescr = (mkDescr (pluralize isPlural), True) +-- indefArticle isPlural = text$ if isPlural then "" else "a " +-- indefArticle' isPlural = text$ if isPlural then "" else "an " +-- pluralize isPlural s p = text (if isPlural then p else s) +-- prettyList :: (Pretty a) => [a] -> Doc +-- prettyList = hsep . punctuate comma . map pretty +instance Pretty CDeclr where + prettyPrec prec declr = prettyDeclr True prec declr + +prettyDeclr :: Bool -> Int -> CDeclr -> Doc +prettyDeclr show_attrs prec (CDeclr name derived_declrs asmname cattrs _) = + ppDeclr prec (reverse derived_declrs) <+> prettyAsmName asmname <+> ifP show_attrs (attrlistP cattrs) + where + ppDeclr _ [] = maybeP identP name + --'*' __attribute__? qualifiers declarator + ppDeclr p (CPtrDeclr quals _ : declrs) = + parenPrec p 5 $ text "*" <> hsep (map pretty quals) <+> ppDeclr 5 declrs + 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 diff --git a/src/Language/ObjC/Syntax.hs b/src/Language/ObjC/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Syntax.hs @@ -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 diff --git a/src/Language/ObjC/Syntax/AST.hs b/src/Language/ObjC/Syntax/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Syntax/AST.hs @@ -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 and several +-- GNU extensions . +----------------------------------------------------------------------------- +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 ' +-- 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 diff --git a/src/Language/ObjC/Syntax/Builders.hs b/src/Language/ObjC/Syntax/Builders.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Syntax/Builders.hs @@ -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 @ +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 diff --git a/src/Language/ObjC/Syntax/Constants.hs b/src/Language/ObjC/Syntax/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Syntax/Constants.hs @@ -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 diff --git a/src/Language/ObjC/Syntax/Ops.hs b/src/Language/ObjC/Syntax/Ops.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Syntax/Ops.hs @@ -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 ] diff --git a/src/Language/ObjC/Syntax/Utils.hs b/src/Language/ObjC/Syntax/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/Syntax/Utils.hs @@ -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) diff --git a/src/Language/ObjC/System.hs b/src/Language/ObjC/System.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/System.hs @@ -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 diff --git a/src/Language/ObjC/System/GCC.hs b/src/Language/ObjC/System/GCC.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/System/GCC.hs @@ -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 ] + diff --git a/src/Language/ObjC/System/Preprocess.hs b/src/Language/ObjC/System/Preprocess.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjC/System/Preprocess.hs @@ -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`) +