diff --git a/itanium-abi.cabal b/itanium-abi.cabal --- a/itanium-abi.cabal +++ b/itanium-abi.cabal @@ -2,12 +2,12 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: itanium-abi -version: 0.1.1.1 +version: 0.1.2 synopsis: An implementation of name mangling/demangling for the Itanium ABI license: BSD3 license-file: LICENSE author: Tristan Ravitch -maintainer: tristan@nochair.net +maintainer: tristan@ravit.ch category: Development build-type: Simple cabal-version: >=1.10 @@ -24,7 +24,8 @@ ghc-options: -Wall build-depends: base >= 4 && < 5, boomerang >= 1.4.5.6 && < 1.5, - text >= 0.11 && < 2, + exceptions >= 0.10 && < 0.11, + text >= 0.11 && < 2.1, transformers, unordered-containers >= 0.2.3.0 && < 0.3 exposed-modules: ABI.Itanium diff --git a/src/ABI/Itanium.hs b/src/ABI/Itanium.hs --- a/src/ABI/Itanium.hs +++ b/src/ABI/Itanium.hs @@ -27,6 +27,7 @@ import Prelude hiding ( (.) ) import Control.Category ( (.) ) +import Data.Char import Text.Boomerang import Text.Boomerang.String import Text.Boomerang.TH @@ -47,6 +48,7 @@ $(makeBoomerangs ''UName) $(makeBoomerangs ''TemplateArg) $(makeBoomerangs ''TemplateParam) +$(makeBoomerangs ''ExprPrimary) -- | Demangle a name into a structured representation (or an error -- string) @@ -72,6 +74,12 @@ rGuardVariable . lit "GV" . name <> rOverrideThunk . lit "T" . callOffset . topLevelEntity <> rOverrideThunkCovariant . lit "Tc" . callOffset . callOffset . topLevelEntity <> + rConstStructData . lit "L" . unqualifiedName <> + + -- The following is a "static" function definition, but c++filt + -- doesn't reproduce the "static" part. + rFunction . lit "L" . name . bareFunctionType <> + rFunction . name . bareFunctionType <> rData . name ) @@ -123,8 +131,11 @@ rFunctionType . lit "F" . bareFunctionType . lit "E" <> rArrayTypeN . lit "A" . rMaybe int . lit "_" . cxxType <> rPtrToMemberType . lit "M" . cxxType . cxxType <> + rSubstitutionType . substitution <> - rClassEnumType . name + rClassEnumType . name <> + rTemplateParamType . templateParam + -- Still need: array-type (E), decltype ) @@ -217,6 +228,7 @@ prefix = ( rDataMemberPrefix . sourceName . lit "M" <> rUnqualifiedPrefix . unqualifiedName <> rSubstitutionPrefix . substitution <> + rSubstitutionPrefix . rSubStdNamespace . lit "St" <> rTemplateParamPrefix . templateParam <> rTemplateArgsPrefix . templateArgs ) @@ -230,8 +242,9 @@ ) substitution :: Boomerang StringError String a (Substitution :- a) -substitution = ( rSubstitution . lit "S" . rMaybe (rList1 (satisfy (/='_'))) . lit "_" <> - rSubStdNamespace . lit "St" <> +substitution = ( + rSubstitution . lit "S" . rMaybe seq_id . lit "_" <> + -- rSubStdNamespace . lit "St" <> -- this one is not standalone, but must be a prefix rSubStdAllocator . lit "Sa" <> rSubBasicString . lit "Sb" <> rSubBasicStringArgs . lit "Ss" <> @@ -240,6 +253,13 @@ rSubBasicIostream . lit "Sd" ) +-- | Reads the sequence ID of a Substitution parameter or Template +-- Argument parameter +seq_id :: Boomerang StringError String a ([Char] :- a) +seq_id = rList1 (satisfy (\c -> and [ c /= '_' + , (isAsciiUpper c || isDigit c) + ])) + unscopedName :: Boomerang StringError String a (UName :- a) unscopedName = ( rUStdName . lit "St" . unqualifiedName <> rUName . unqualifiedName @@ -249,10 +269,16 @@ templateArgs = lit "I" . rList1 templateArg . lit "E" templateArg :: Boomerang StringError String a (TemplateArg :- a) -templateArg = rTypeTemplateArg . cxxType +templateArg = (rTypeTemplateArg . cxxType <> + lit "L" . rExprPrimaryTemplateArg . exprPrimary . lit "E" + ) +exprPrimary :: Boomerang (ParserError MajorMinorPos) String a (ExprPrimary :- a) +exprPrimary = (rExprIntLit . cxxType . abiInt ) + + templateParam :: Boomerang StringError String a (TemplateParam :- a) -templateParam = ( rTemplateParam . lit "T" . rMaybe int . lit "_" ) +templateParam = ( rTemplateParam . lit "T" . rMaybe seq_id . lit "_" ) -- | Parse a length-prefixed string (does not handle newlines) sourceName :: Boomerang (ParserError MajorMinorPos) String a (String :- a) diff --git a/src/ABI/Itanium/Pretty.hs b/src/ABI/Itanium/Pretty.hs --- a/src/ABI/Itanium/Pretty.hs +++ b/src/ABI/Itanium/Pretty.hs @@ -1,77 +1,257 @@ +{-# LANGUAGE LambdaCase #-} + module ABI.Itanium.Pretty ( cxxNameToString, - cxxNameToText + cxxNameToText, + -- * Exceptions thrown + MissingSubstitution, + CtorDtorFallthru, + UnqualCtorDtor, + NonPointerFunctionType, + BarePtrToMember, + EmptyFunctionType ) where +import Control.Monad ( foldM, unless, void ) +import Control.Monad.Catch ( Exception, MonadThrow, throwM ) import Control.Monad.Trans.State.Strict -import Data.Char ( digitToInt ) -import Data.List ( foldl', intersperse ) +import Data.Char ( ord ) +import Data.List ( intersperse ) import Data.HashMap.Strict ( HashMap ) import qualified Data.HashMap.Strict as HM -import Data.Maybe ( fromMaybe ) -import Data.Monoid -import Data.Text.Lazy ( Text, unpack ) +import Data.Maybe ( catMaybes ) +import Data.Text.Lazy ( Text, unpack, unsnoc ) import Data.Text.Lazy.Builder import ABI.Itanium.Types -type Pretty = State (HashMap Int Builder) --- Only record substitutions that were not previously seen -recordSubstitution :: Builder -> Pretty () +-- | The Store maintains the substitution table used for emitting a +-- demangled names. For compression, demangling allows the use of +-- "substitutions" to refer to previously emitted portions of the +-- name. Most portions of the name that are emitted are recorded +-- (with compositional buildup: @foo::bar@ will record both @foo@ and +-- @foo::bar@). The only exceptions to recording are function names +-- and builtin types. As a name is demangled, each portion will be +-- added to this table for use in subsequent substitutions. + +data Store = Store { substitutions :: HashMap Int Builder + , templateArgs :: [Maybe Builder] + } + +emptyStore :: Store +emptyStore = Store mempty mempty + +-- | The Pretty type is used as the main State object for performing +-- conversion to pretty output with the Store as the internal state. + +type Pretty = StateT Store + +---------------------------------------------------------------------- + +-- | Records a substitution component in the current table, skipping +-- any duplications. +-- +-- For convenience, it returns the same item it recorded to allow this +-- to be the last statement for a Pretty Builder operation that should +-- record and return the generated output. +recordSubstitution :: Monad m => Builder -> Pretty m Builder recordSubstitution b = do - s <- get + store <- get + let s = substitutions store case b `elem` HM.elems s of False -> do let n = HM.size s - put $! HM.insert n b s - True -> return () + let store' = store { substitutions = HM.insert n b s } + put $! store' + return b + True -> return b -getSubstitution :: Maybe String -> Pretty Builder +-- | Called for special cases where a substitution should be recorded, +-- even if it is a duplicate of another already-recorded substitution. +recordSubstitutionAlways :: Monad m => Builder -> Pretty m Builder +recordSubstitutionAlways b = do + store <- get + let s = substitutions store + let n = HM.size s + let store' = store { substitutions = HM.insert n b s } + put $! store' + return b + +-- | This is a convenience wrapper for 'recordSubstitution' that will +-- return a void value; this can be used where the results of the +-- recording are not needed and the compiler would warn about an +-- unused return value. +recordSubstitution' :: Monad m => Builder -> Pretty m () +recordSubstitution' = void . recordSubstitution + +-- | Function names are not recorded, but their prefixes are. For example: +-- +-- Input | Records +-- -------------------------------|-------------------------------- +-- @foo(int)@ | (nothing) +-- | +-- @bar::foo(int)@ | @bar@ +-- | +-- @bar::cow::boo::foo(int)@ | @bar@ @bar::cow@ @bar::cow@ +-- | @bar::cow::boo@ +-- +-- To support this, the various parts of the function call are +-- recorded as normal (using recursive, shared pretty printing) and +-- then this function is called to drop the last element recorded, +-- which is the actual function name. +dropLastSubstitution :: Monad m => Pretty m () +dropLastSubstitution = modify $ \store -> + let s = substitutions store + s' = HM.delete ((HM.size s) - 1) s + in store { substitutions = s' } + +-- | Lookup a recorded substitution and return it. A lookup failure +-- means either a malformed mangled name (unlikely) or a logic error +-- below that did not properly record a substitution component. +getSubstitution :: (Monad m, MonadThrow m) => Maybe String -> Pretty m Builder getSubstitution s = do - st <- get + st <- gets substitutions case s of - Nothing -> return $! lookupError 0 st + Nothing -> lookupError 0 st -- This case always adds 1 from the number because the -- Nothing case is index zero Just ix -> - let n = numberValue 36 ix - in return $! lookupError (n+1) st + -- seq ID is base 36 + case numberValue 36 ix of + Just n -> lookupError (n+1) st + Nothing -> errMsg where - errMsg = error ("No substitution found for " ++ show s) - lookupError k m = fromMaybe errMsg (HM.lookup k m) + errMsg = throwM $ MissingSubstitution s + lookupError k m = maybe errMsg return (HM.lookup k m) -cxxNameToText :: DecodedName -> Text -cxxNameToText n = toLazyText $ evalState (dispatchTopLevel n) mempty +-- | The MissingSubstitution exception is thrown when the mangled name +-- requests a substitution that cannot be found. This indicates +-- either an invalid mangled name or else an internal logic error in +-- this Pretty implementation. -cxxNameToString :: DecodedName -> String -cxxNameToString = unpack . cxxNameToText +data MissingSubstitution = MissingSubstitution (Maybe String) +instance Exception MissingSubstitution +instance Show MissingSubstitution where + show (MissingSubstitution s) = "No substitution found for " ++ show s -dispatchTopLevel :: DecodedName -> Pretty Builder + + +---------------------------------------------------------------------- +-- * Template Argument handling +-- +-- Template arguments are different than substitutions in that they +-- are numbered when the template opening character '<' is +-- seen/emitted, but the actual argument itself cannot be stored until +-- the closing character '>' is reached. This means that if the +-- template argument itself contains template arguments, the arguments +-- processed during the recursion must follow the current argument. +-- +-- Example: +-- +-- foo, std::allocator > > +-- ^ ^ ^ ^ ^ +-- | | | `-dup of T1, ignored--' +-- | T1 T2-------------------- T3------------------ +-- T0-------------------------------------------------------------------- +-- +-- Further sophistication is needed to handle the case where +-- duplicates are observed. For example, after T1 above, the '<' +-- following the char_traits reserves another template argument +-- position, but then when the '>' is reached, it can determine that +-- it's a duplicate and doesn't need to be recorded. This is fine if +-- there were no other args recorded after the '<' and before the '>', +-- but consider the case where T0 might be discovered to be a +-- duplicate. To resolve this, the template argument reservation adds +-- a Nothing to the reservation array, but lookups by index ignore +-- Nothing entries. + +newtype ReservedTemplateArgument = RTA Int + +-- | Reserves a template argument location +reserveTemplateArgument :: Monad m => Pretty m ReservedTemplateArgument +reserveTemplateArgument = do + store <- get + let tas = templateArgs store + nta = length tas + put $! store { templateArgs = templateArgs store <> [ Nothing ] } + return $! RTA nta + + +-- | Records a template argument in the current table, skipping any +-- duplications. Returns the input as a convenience pass-through. +recordTemplateArgument :: Monad m + => ReservedTemplateArgument -> Builder -> Pretty m Builder +recordTemplateArgument (RTA i) b = do + store <- get + let tas = templateArgs store + unless (i < length tas) $ + error "INVALID TEMPLATE ARG RESERVATION: CODING ERROR" + let (pre,_:post) = splitAt i tas + if Just b `elem` pre + then return $! b + else do let store' = store { templateArgs = pre <> [ Just b ] <> post } + put $! store' + return $! b + + +-- | Lookup a recorded template argument and return it. A lookup failure +-- means either a malformed mangled name (unlikely) or a logic error +-- below that did not properly record a substitution component. +getTemplateArgument :: (Monad m, MonadThrow m) + => Maybe String -> Pretty m Builder +getTemplateArgument s = do + st <- catMaybes <$> gets templateArgs + case s of + Nothing -> lookupError 0 st + -- This case always adds 1 from the number because the + -- Nothing case is index zero + Just ix -> + -- seq ID is base 36 + case numberValue 36 ix of + Just n -> lookupError (n+1) st + Nothing -> errMsg + where + errMsg = throwM $ MissingTemplateArgument s + lookupError k m = if k < length m + then return $ m !! k + else errMsg + +-- | The MissingTemplateArgument exception is thrown when the mangled name +-- requests a template argument that cannot be found. This indicates +-- either an invalid mangled name or else an internal logic error in +-- this Pretty implementation. + +data MissingTemplateArgument = MissingTemplateArgument (Maybe String) +instance Exception MissingTemplateArgument +instance Show MissingTemplateArgument where + show (MissingTemplateArgument s) = "No template argument found for " ++ show s + + +---------------------------------------------------------------------- + +-- | Primary interface to get the pretty version of a parsed mangled +-- name in Text form. This is a monadic operation to support throwing +-- an exception in that outer monad when there is a pretty-printing +-- conversion error. + +cxxNameToText :: (Monad m, MonadThrow m) => DecodedName -> m Text +cxxNameToText n = toLazyText <$> evalStateT (dispatchTopLevel n) emptyStore + +-- | Primary interface to get the pretty version of a parsed mangled +-- name in String form. + +cxxNameToString :: (Monad m, MonadThrow m) => DecodedName -> m String +cxxNameToString = fmap unpack . cxxNameToText + +dispatchTopLevel :: (Monad m, MonadThrow m) => DecodedName -> Pretty m Builder dispatchTopLevel n = case n of - Function (NestedName qs@(_:_) pfxs uname) argTypes -> do - pn <- showPrefixedName pfxs uname - argBuilders <- case argTypes of - [VoidType] -> return mempty - _ -> mapM showType argTypes - return $! mconcat [ pn - , singleton '(' - , mconcat $ intersperse (fromString ", ") argBuilders - , fromString ") " - , showQualifiers qs - ] - Function fname argTypes -> do - nameBuilder <- showName fname - argBuilders <- case argTypes of - [VoidType] -> return mempty - _ -> mapM showType argTypes - return $! mconcat [ nameBuilder - , singleton '(' - , mconcat $ intersperse (fromString ", ") argBuilders - , singleton ')' - ] - Data varName -> showName varName + Function fname argTypes -> showFunction fname argTypes + ConstStructData varName -> showUnqualifiedName varName + Data varName -> do nm <- showName varName + qual <- showNameQualifiers nm varName + return $! mconcat [nm, qual] VirtualTable t -> do tb <- showType t return $! mconcat [ fromString "vtable for ", tb ] @@ -86,7 +266,8 @@ return $! mconcat [ fromString "typeinfo name for ", tb ] GuardVariable vname -> do vn <- showName vname - return $! mconcat [ fromString "guard variable for ", vn ] + vq <- showNameQualifiers vn vname + return $! mconcat [ fromString "guard variable for ", vn, vq ] OverrideThunk _ target -> do tn <- dispatchTopLevel target return $! mconcat [ fromString "non-virtual thunk to ", tn ] @@ -94,34 +275,86 @@ tn <- dispatchTopLevel target return $! mconcat [ fromString "virtual thunk to ", tn ] -showName :: Name -> Pretty Builder +-- | Show a Function and its arguments. Function representation has +-- several rules: +-- +-- 1. template functions have return types with some exceptions +-- +-- 2. function types which are not part of a function name +-- mangling have return types with some exceptions +-- +-- 3. non-template function names do not have return types +-- +-- The exceptions are that constructors, destructors, and conversion +-- operators do not have return types. +showFunction :: (Monad m, MonadThrow m) + => Name -> [CXXType] -> Pretty m Builder +showFunction fname args = + let (retType:retArgTypes) = args + argTypes = if hasRetType fname then retArgTypes else args + in do nameBuilder <- showName fname + dropLastSubstitution + retSpec <- if hasRetType fname + then do p <- case args of + [] -> return $ fromString "void" + _ -> showType retType + return $! mconcat [ p, singleton ' ' ] + else return $! mempty + argBuilders <- case argTypes of + [VoidType] -> return mempty + _ -> mapM showType argTypes + let argSpec = mconcat + $ intersperse (fromString ", ") argBuilders + quals <- showNameQualifiers mempty fname + return $! mconcat [ retSpec + , nameBuilder + , singleton '(' , argSpec , singleton ')' + , quals + ] + +hasRetType :: Name -> Bool +hasRetType = \case + NestedTemplateName {} -> True + UnscopedTemplateName{} -> True + _ -> False + +-- -- | There is a specific parse rule in older C++ that two +-- -- consecutive template closure brackets have to be separated by a +-- -- space. This was changed in C++14, but the c++filt (i.e. the +-- -- reference standard) still emits the space separators. This +-- -- function adds the brackets around template arguments, adding the +-- -- space separator for compatibility with c++filt and older C++. + +templateBracket :: Builder -> Builder +templateBracket tmpltArgs = + let lastIsTemplateClosure = maybe False (('>' ==) . snd) . unsnoc . toLazyText + in singleton '<' `mappend` + if lastIsTemplateClosure tmpltArgs + then tmpltArgs `mappend` fromString " >" + else tmpltArgs `mappend` singleton '>' + +showName :: (Monad m, MonadThrow m) => Name -> Pretty m Builder showName n = case n of - NestedName qs pfxs uname -> do + NestedName _ pfxs uname -> do pn <- showPrefixedName pfxs uname - case null qs of - False -> return $! mconcat [ pn, singleton ' ', showQualifiers qs ] - True -> return $! pn + recordSubstitution pn UnscopedName uname -> showUName uname - NestedTemplateName [] pfxs targs -> - showPrefixedTArgs pfxs targs - NestedTemplateName qs pfxs targs -> do - pn <- showPrefixedTArgs pfxs targs - return $! mconcat [ pn, singleton ' ', showQualifiers qs ] + NestedTemplateName _ pfxs targs -> do + p <- showPrefixes pfxs + t <- templateBracket <$> showTArgs targs + recordSubstitution $! mappend p t UnscopedTemplateName uname targs -> do un <- showUName uname - recordSubstitution un + recordSubstitution' un tns <- showTArgs targs - return $! mconcat [ un, singleton '<' - , tns - , singleton '>' - ] + recordSubstitution $! un `mappend` templateBracket tns UnscopedTemplateSubstitution s targs -> do ss <- showSubstitution s tns <- showTArgs targs - return $! mconcat [ ss, singleton '<', tns, singleton '>' ] + return $! ss `mappend` templateBracket tns -showUName :: UName -> Pretty Builder +showUName :: (Monad m, MonadThrow m) => UName -> Pretty m Builder showUName u = case u of UName uname -> showUnqualifiedName uname @@ -129,45 +362,56 @@ un <- showUnqualifiedName uname return (fromString "std::" `mappend` un) -showTArgs :: [TemplateArg] -> Pretty Builder +showNameQualifiers :: (Monad m) + => Builder -> Name -> Pretty m Builder +showNameQualifiers pn = \case + NestedName qs@(_:_) _ _ -> + mappend (mconcat [ pn, singleton ' ' ]) <$> showQualifiers pn qs + NestedTemplateName qs@(_:_) _ _ -> + mappend (mconcat [ pn, singleton ' ' ]) <$> showQualifiers pn qs + _ -> return mempty + +showTArgs :: (Monad m, MonadThrow m) => [TemplateArg] -> Pretty m Builder showTArgs targs = do tns <- mapM showTArg targs return $! mconcat $! intersperse (fromString ", ") tns -showPrefixedTArgs :: [Prefix] -> [TemplateArg] -> Pretty Builder -showPrefixedTArgs = go mempty - where - go acc pfxs targs = - case pfxs of - [] -> do - tns <- mapM showTArg targs - return $! mconcat [ acc, singleton '<' - , mconcat $ intersperse (fromString ", ") tns - , singleton '>' ] - pfx : rest -> do - px <- showPrefix pfx - let nextAcc = case acc == mempty of - False -> mconcat [ acc, fromString "::", px ] - True -> px - recordSubstitution nextAcc - go nextAcc rest targs - -showTArg :: TemplateArg -> Pretty Builder +showTArg :: (Monad m, MonadThrow m) => TemplateArg -> Pretty m Builder showTArg ta = case ta of - TypeTemplateArg t -> showType t + TypeTemplateArg t -> do tnum <- reserveTemplateArgument + tt <- showType t + void $ recordTemplateArgument tnum tt + return tt + ExprPrimaryTemplateArg ep -> showExprPrimary ep +showExprPrimary :: (Monad m, MonadThrow m) => ExprPrimary -> Pretty m Builder +showExprPrimary = + let parenShowType ty = do sty <- showType ty + return $ mconcat [singleton '(', sty, singleton ')'] + in \case + ExprIntLit ty intval -> + case ty of + BoolType + | intval == 0 -> return $! fromString "false" + | intval == 1 -> return $! fromString "true" + _ -> do sty <- parenShowType ty + return $! mconcat [ sty + , fromString $ show intval ] + -- pass the current prefix builder down so that it can be added to and -- stored for substitutions -showPrefixedName :: [Prefix] -> UnqualifiedName -> Pretty Builder +showPrefixedName :: (Monad m, MonadThrow m) + => [Prefix] -> UnqualifiedName -> Pretty m Builder showPrefixedName = go mempty where go acc pfxs uname = case (pfxs, uname) of - ([], SourceName n) -> - return $! mconcat [ acc, fromString "::", fromString n ] + ([], SourceName n) -> do + recordSubstitution $! mconcat [ acc, fromString "::", fromString n ] ([], OperatorName op) -> do ob <- showOperator op + recordSubstitution' ob case acc == mempty of False -> return $! mconcat [ acc, fromString "::operator", ob ] True -> return $! mconcat [ fromString "operator", ob ] @@ -185,17 +429,33 @@ False -> fromString "::" True -> fromString "::~" sub = curPfx `mappend` fromString className - recordSubstitution sub + recordSubstitution' sub return $! mconcat [ curPfx, fromString className, inFix, fromString className ] + ([UnqualifiedPrefix (SourceName className), tmplPfx@(TemplateArgsPrefix{})], CtorDtorName cd) -> do + let prevPfx here = case acc == mempty of + True -> here + False -> mconcat [ acc, fromString "::", here ] + nextAcc <- showPrefix (prevPfx $ fromString className) tmplPfx + let inFix = case isDestructor cd of + False -> fromString "::" + True -> fromString "::~" + return $! mconcat [ nextAcc, inFix, fromString className ] (outerPfx : innerPfxs, _) -> do - px <- showPrefix outerPfx - let nextAcc = case acc == mempty of - False -> mconcat [ acc, fromString "::", px ] - True -> px - recordSubstitution nextAcc + nextAcc <- showPrefix acc outerPfx go nextAcc innerPfxs uname - ([], CtorDtorName _) -> error "Illegal fallthrough in constructor/destructor case" + ([], CtorDtorName _) -> throwM CtorDtorFallthru +-- | The CtorDtorFallthru exception is thrown when a Constructor or +-- Destructor is declared without declaring the object type that it is +-- the Constructor or Destructor for. This indicates either an +-- invalid mangled name or else an internal logic error in prefix +-- evaluation. + +data CtorDtorFallthru = CtorDtorFallthru +instance Exception CtorDtorFallthru +instance Show CtorDtorFallthru where + show _ = "Illegal fallthrough in constructor/destructor case" + isDestructor :: CtorDtor -> Bool isDestructor cd = case cd of @@ -204,40 +464,78 @@ D2 -> True _ -> False -showQualifiers :: [CVQualifier] -> Builder -showQualifiers qs = +showQualifiers :: Monad m => Builder -> [CVQualifier] -> Pretty m Builder +showQualifiers qualifies qs = case null qs of - True -> mempty - False -> - let qs' = map showQualifier qs - in mconcat qs' + True -> return mempty + False -> snd <$> foldM showQualifier (qualifies,mempty) qs -showQualifier :: CVQualifier -> Builder -showQualifier q = - case q of - Restrict -> fromString "restrict" - Volatile -> fromString "volatile" - Const -> fromString "const" +showQualifier :: Monad m + => (Builder, Builder) -> CVQualifier + -> Pretty m (Builder, Builder) +showQualifier (accum,res) q = do + -- accum is the accumulated name with the base name, used for + -- recording subtitutions. res is the accumulated name but not + -- including the base name which is previously emitted. res is + -- ultimately returned. + let qual = case q of + Restrict -> fromString "restrict" + Volatile -> fromString "volatile" + Const -> fromString "const" + acc' = mconcat [ accum, singleton ' ', qual ] + res' = case res == mempty of + True -> qual + False -> mconcat [ res, singleton ' ', qual ] + recordSubstitution' acc' + return $! (acc', res') + +showPrefixes :: (Monad m, MonadThrow m) => [Prefix] -> Pretty m Builder +showPrefixes = foldM showPrefix mempty + -- | These are outer namespace/class name qualifiers, so convert them -- to strings followed by :: -showPrefix :: Prefix -> Pretty Builder -showPrefix pfx = - case pfx of - DataMemberPrefix s -> return $! fromString s - UnqualifiedPrefix uname -> showUnqualifiedName uname - SubstitutionPrefix s -> showSubstitution s +showPrefix :: (Monad m, MonadThrow m) => Builder -> Prefix -> Pretty m Builder +showPrefix prior pfx = + let addPrior doRecord toThis = do + let ret = case prior == mempty of + False -> mconcat [ prior, fromString "::", toThis ] + True -> toThis + if doRecord then recordSubstitution ret else return ret + in case pfx of + DataMemberPrefix s -> addPrior True $ fromString s + UnqualifiedPrefix uname -> addPrior True =<< showUnqualifiedName uname + SubstitutionPrefix s -> addPrior False =<< showSubstitution s + TemplateArgsPrefix args -> + case prior == mempty of + True -> (templateBracket <$> showTArgs args) >>= recordSubstitution + False -> do recordSubstitution' prior + targs <- showTArgs args + let this = mconcat [ prior, templateBracket targs ] + recordSubstitution this -showUnqualifiedName :: UnqualifiedName -> Pretty Builder +showUnqualifiedName :: (Monad m, MonadThrow m) + => UnqualifiedName -> Pretty m Builder showUnqualifiedName uname = case uname of OperatorName op -> do ob <- showOperator op return (fromString "operator" `mappend` ob) - CtorDtorName _ -> error "showUnqualifiedName shouldn't reach the ctor/dtor case" - SourceName s -> return (fromString s) + CtorDtorName _ -> throwM UnqualCtorDtor + SourceName s -> return (fromString s) -- KWQ: add Substitution? "C" extern func? -showOperator :: Operator -> Pretty Builder +-- | The UnqualCtorDtor exception is thrown when a attempting to +-- generate a Constructor or Destructor name for an Unqualified name. +-- Although this is allowed by the specification, in this +-- implementation it represents a logic issue since there is no known +-- object to declare the Constructor or Destructor for. + +data UnqualCtorDtor = UnqualCtorDtor +instance Exception UnqualCtorDtor +instance Show UnqualCtorDtor where + show _ = "showUnqualifiedName shouldn't reach the ctor/dtor case?" + +showOperator :: (Monad m, MonadThrow m) => Operator -> Pretty m Builder showOperator op = case op of OpNew -> return $! fromString " new" @@ -296,14 +594,13 @@ return $! singleton ' ' `mappend` tb OpVendor n oper -> return $! fromString ("vendor" ++ show n ++ oper) -- ?? -showType :: CXXType -> Pretty Builder +showType :: (Monad m, MonadThrow m) => CXXType -> Pretty m Builder showType t = case t of QualifiedType qs t' -> do tb <- showType t' - let r = mconcat [ tb, singleton ' ', showQualifiers qs ] - recordSubstitution r - return $! r + quals <- showQualifiers tb qs + return $! mconcat [ tb, singleton ' ' ] `mappend` quals PointerToType (FunctionType ts) -> do -- Since we don't explicitly descend the FunctionType here, we -- need to create a stub entry in the substitution table for it @@ -311,40 +608,40 @@ -- stub will never be referenced because function types aren't -- first-class ts' <- mapM showType ts - recordSubstitution (mconcat ts') + if null ts' + then return() + else recordSubstitution' + $ mconcat [ head ts' + , fromString " (" + , mconcat $ intersperse (fromString ", ") $ tail ts' + , singleton ')' + ] r <- showFunctionType ts - recordSubstitution r - return $! r + recordSubstitution $! r PointerToType t' -> do tb <- showType t' let r = tb `mappend` singleton '*' - recordSubstitution r - return $! r + recordSubstitution $! r ReferenceToType t' -> do tb <- showType t' let r = tb `mappend` singleton '&' - recordSubstitution r - return $! r + recordSubstitution $! r RValueReferenceToType t' -> do tb <- showType t' let r = tb `mappend` fromString "&&" - recordSubstitution r - return $! r + recordSubstitution $! r ComplexPairType t' -> do tb <- showType t' let r = tb `mappend` fromString " complex" - recordSubstitution r return $! r ImaginaryType t' -> do tb <- showType t' let r = tb `mappend` fromString " imaginary" - recordSubstitution r return $! r ParameterPack _ -> undefined VendorTypeQualifier q t' -> do tb <- showType t' let r = mconcat [ fromString q, singleton ' ', tb ] - recordSubstitution r return $! r VoidType -> return $! fromString "void" Wchar_tType -> return $! fromString "wchar_t" @@ -372,33 +669,40 @@ AutoType -> return $! fromString "auto" NullPtrType -> return $! fromString "std::nullptr_t" VendorBuiltinType s -> return $! fromString s - FunctionType _ -> error "Only pointers to function types are supported" + FunctionType _ -> throwM NonPointerFunctionType ExternCFunctionType ts -> do tb <- showFunctionType ts let r = fromString "extern \"C\" " `mappend` tb - recordSubstitution r return $! r ArrayTypeN (Just n) t' -> do tb <- showType t' let r = mconcat [ tb, singleton '[', fromString (show n), singleton ']' ] - recordSubstitution r return $! r ArrayTypeN Nothing t' -> do tb <- showType t' let r = tb `mappend` fromString "[]" - recordSubstitution r return $! r ClassEnumType n -> do r <- showName n - recordSubstitution r - return r + q <- showNameQualifiers r n + recordSubstitution $! mconcat [r, q] PtrToMemberType c m -> do r <- showPtrToMember c m - recordSubstitution r return $! r SubstitutionType s -> showSubstitution s + TemplateParamType tt -> showTemplateParam tt -showSubstitution :: Substitution -> Pretty Builder +-- | The NonPointerFunctionType exception is thrown when attempting to +-- pretty-print a function type that is not a pointer. First-class +-- function types are not supported at this time. This is a logic +-- error in the library? + +data NonPointerFunctionType = NonPointerFunctionType +instance Exception NonPointerFunctionType +instance Show NonPointerFunctionType where + show _ = "Only pointers to function types are supported" + +showSubstitution :: (Monad m, MonadThrow m) => Substitution -> Pretty m Builder showSubstitution s = case s of Substitution ss -> getSubstitution ss @@ -410,21 +714,36 @@ SubBasicOstream -> return $! fromString "std::basic_ostream >" SubBasicIostream -> return $! fromString "std::basic_iostream >" -showPtrToMember :: CXXType -> CXXType -> Pretty Builder +showTemplateParam :: (Monad m, MonadThrow m) => TemplateParam -> Pretty m Builder +showTemplateParam (TemplateParam t) = do r <- getTemplateArgument t + recordSubstitutionAlways r + +showPtrToMember :: (Monad m, MonadThrow m) + => CXXType -> CXXType -> Pretty m Builder showPtrToMember (ClassEnumType n) (FunctionType (rt:argts)) = do rt' <- showType rt argts' <- mapM showType argts nb <- showName n - return $! mconcat [ rt', fromString " (", nb , fromString "::*)(" + q <- showNameQualifiers nb n + return $! mconcat [ rt', fromString " (", nb, q , fromString "::*)(" , mconcat (intersperse (fromString ", ") argts') , singleton ')' ] -showPtrToMember _ _ = error "Expected a ClassEnumType and FunctionType pair for PtrToMemberType" +showPtrToMember _ _ = throwM BarePtrToMember -showFunctionType :: [CXXType] -> Pretty Builder +-- | The BarePtrToMember exception is thrown when there is not enough +-- information to determine what the pointer should point to. This is +-- either a bad mangled name or an internal logic error. + +data BarePtrToMember = BarePtrToMember +instance Exception BarePtrToMember +instance Show BarePtrToMember where + show _ = "Expected a ClassEnumType and FunctionType pair for PtrToMemberType" + +showFunctionType :: (Monad m, MonadThrow m) => [CXXType] -> Pretty m Builder showFunctionType ts = case ts of - [] -> error "Empty type list in function type" + [] -> throwM EmptyFunctionType [rtype, VoidType] -> do rt' <- showType rtype return $! mconcat [ rt', fromString " (*)()" ] @@ -434,9 +753,22 @@ let arglist = mconcat $ intersperse (fromString ", ") rbs return $! mconcat [ tb, fromString " (*)(", arglist, singleton ')' ] +-- | The EmptyFunctionType exception is thrown when there is no +-- argument specification for the function. This is either a bad +-- mangled name or an internal logic error. + +data EmptyFunctionType = EmptyFunctionType +instance Exception EmptyFunctionType +instance Show EmptyFunctionType where + show _ = "Empty type list in function type" + -- Helpers -- Taken from parsec-numbers -numberValue :: Integral i => Int -> String -> i +numberValue :: Integral i => Int -> String -> Maybe i numberValue base = - foldl' (\ x -> ((fromIntegral base * x) +) . fromIntegral . digitToInt) 0 + let seqIdToNum seqId | seqId >= ord 'A' && seqId <= ord 'Z' = Just $ seqId - ord 'A' + 10 + | seqId >= ord '0' && seqId <= ord '9' = Just $ seqId - ord '0' + | otherwise = Nothing + in + foldM (\ x -> fmap (((fromIntegral base * x) +) . fromIntegral) . seqIdToNum . ord) 0 diff --git a/src/ABI/Itanium/Types.hs b/src/ABI/Itanium/Types.hs --- a/src/ABI/Itanium/Types.hs +++ b/src/ABI/Itanium/Types.hs @@ -13,7 +13,8 @@ CallOffset(..), Substitution(..), TemplateArg(..), - TemplateParam(..) + TemplateParam(..), + ExprPrimary(..) ) where import Data.Data @@ -27,6 +28,31 @@ | GuardVariable Name | OverrideThunk CallOffset DecodedName | OverrideThunkCovariant CallOffset CallOffset DecodedName + + | ConstStructData UnqualifiedName + -- ^ Const data that is not a builtin data type (as + -- a ). + -- + -- This construct is not specifically identified in + -- the documentation, but for the following input: + -- + -- struct mystr { int val; }; + -- const struct mystr here = { 9 }; + -- + -- Also works with: + -- + -- class mycls { public: int val; } + -- const class mycls here = { 8 }; + -- + -- When compiled with Clang/LLVM results in Global + -- Variable (apparently always using the + -- length-specified syntax): + -- + -- _ZL4here + -- + -- This is apparently only used for const + -- declarations and only for non-builtin datatypes. + deriving (Eq, Ord, Show, Data, Typeable) data CallOffset = VirtualOffset Int Int @@ -139,10 +165,20 @@ deriving (Eq, Ord, Show, Data, Typeable) data TemplateArg = TypeTemplateArg CXXType + | ExprPrimaryTemplateArg ExprPrimary deriving (Eq, Ord, Show, Data, Typeable) -data TemplateParam = TemplateParam (Maybe Int) +data TemplateParam = TemplateParam (Maybe String) deriving (Eq, Ord, Show, Data, Typeable) + +data ExprPrimary = ExprIntLit CXXType Int + | ExprFloatLit CXXType Float + | ExprStringLit String + | ExprNullPtrLit -- ? + | ExprNullPointerTemplateArg + | ExprComplexFloatLit CXXType Float Float + | ExprExternName DecodedName + deriving (Eq, Ord, Show, Data, Typeable) data UnqualifiedName = OperatorName Operator | CtorDtorName CtorDtor diff --git a/tests/DemangleTests.hs b/tests/DemangleTests.hs --- a/tests/DemangleTests.hs +++ b/tests/DemangleTests.hs @@ -13,9 +13,11 @@ case demangleName sym of Left err -> assertFailure (sym ++ " : " ++ err) Right dname -> - assertEqual sym (normalize expected) (normalize (cxxNameToString dname)) + case cxxNameToString dname of + Left err -> assertFailure (sym ++ " pretty-printing: " ++ show err) + Right s -> assertEqual sym (normalize expected) (normalize s) where - normalize = filter (`notElem` " \n") + normalize = filter (`notElem` "\n") main :: IO () main = do diff --git a/tests/test-cases.txt b/tests/test-cases.txt --- a/tests/test-cases.txt +++ b/tests/test-cases.txt @@ -14020,3 +14020,32 @@ _ZrsR11QDataStreamR9QVector3D _ZrsR11QDataStreamR9QVector4D _ZrsR11QTextStreamR9QSplitter +_ZL13testconstdata +_ZN4uorbIvE9uorb_copyEPK12orb_metadataiPv +_ZN4uorbIvEC2Ei +_ZN3foo4foo1EPiS0_ +_ZN3foo4foo1EiPicS0_ +_ZN3foo4foo1EiPicS0_PFiS0_S0_PdS1_ES3_ +_ZN3fooC2ERKc +_Z16vehicle_gps_stopR3fooPiS1_Oc +_Z16vehicle_gps_stopR3fooPiS1_OcS2_RiS0_S3_ +_Z17vehicle_gps_startRK10gps_statusI16geographical_arcE +_Z16vehicle_gps_townRK10gps_statusI16geographical_arcES3_ +_Z16vehicle_gps_townRK10gps_statusI16geographical_arcEPS2_ +_ZL11hrt_tim_isrPv +_ZN4uORB11PublicationI18vehicle_attitude_sLh1EE7publishERKS1_ +_ZN6matrix10QuaternionIfEC2ERKNS_7Vector3IfEES5_f +_ZNSt3mapINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEES5_St4lessIS5_ESaISt4pairIKS5_S5_EEEixERS9_ +_ZNSt8_Rb_treeINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEESt4pairIKS5_PFiiPPcEESt10_Select1stISC_ESt4lessIS5_ESaISC_EE14_M_insert_nodeEPSt18_Rb_tree_node_baseSK_PSt13_Rb_tree_nodeISC_E +_ZNSt8_Rb_treeINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEESt4pairIKS5_PFiiPPcEESt10_Select1stISC_ESt4lessIS5_ESaISC_EE14_M_insert_nodeEPSt18_Rb_tree_node_baseSK_PSt13_Rb_tree_nodeISC_wS_S0_S1_S2_S3_S4_S5_S6_S7_S8_S9_SA_SB_SC_SD_SE_SF_SG_SH_SI_SJ_SK_E +_ZN3kwq2qqEi +_ZN3kwq3qqqEicPiS_S0_ +_ZN3kwqIcEE +_Z3kwqicPiS_ +_Z16vehicle_gps_townRK10gps_statusI16geographical_arcEPS2_ +_Z16vehicle_gps_townRK10gps_statusI16geographical_arcEPS2_S_S0_S1_S2_ +_ZN9__gnu_cxx12__to_xstringINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEEcEET_PFiPT0_mPKS8_P13__va_list_tagEmSB_z +_ZN9__gnu_cxx12__to_xstringINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEEcEET_PFiPT_mPKS_S1_S2_S3_S4_S5_S6_S7_wS8_bS9_P13__va_list_tagEmSA_bSB_sSC_T0_T_z +_ZN9__gnu_cxx12__to_xstringINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEEcEET_PFiPT0_mPKS_S1_S2_S3_S4_S5_S6_S7_wS8_bS9_P13__va_list_tagEmSA_bSB_sSC_T0_T_z +_Z1fIiEvT_ +_ZNSt3__110moneypunctIcLb0EED0Ev