X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=51b77bc13de07af3f9f8123812bd81c0eb8cdf5c;hb=e5b79a6988880d8757634683eefe2f03e45cdfc6;hp=779b67b80c0f01fe3fa47276ed99240bc6309fcf;hpb=432b9c9322181a3644083e3c19b7e240d90659e7;p=ghc-hetmet.git diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 779b67b..51b77bc 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -25,6 +25,7 @@ module RdrHsSyn ( mkImport, -- CallConv -> Safety -- -> (FastString, RdrName, RdrNameHsType) -- -> P RdrNameHsDecl + parseCImport, mkExport, -- CallConv -- -> (FastString, RdrName, RdrNameHsType) -- -> P RdrNameHsDecl @@ -32,7 +33,7 @@ module RdrHsSyn ( mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName mkSimpleConDecl, mkDeprecatedGadtRecordDecl, - + -- Bunch of functions in the parser monad for -- checking and constructing values checkPrecP, -- Int -> P Int @@ -62,20 +63,25 @@ import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo, InlinePragma(..), InlineSpec(..), alwaysInlineSpec, neverInlineSpec ) -import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled ) +import Lexer import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..), CLabelString ) import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) import PrelNames ( forall_tv_RDR ) +import DynFlags import SrcLoc import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable import FastString +import Maybes -import List ( isSuffixOf, nubBy ) +import Control.Applicative ((<$>)) +import Text.ParserCombinators.ReadP as ReadP +import Data.List ( nubBy ) +import Data.Char ( isAscii, isAlphaNum, isAlpha ) #include "HsVersions.h" \end{code} @@ -720,12 +726,14 @@ checkPat loc e args -- OK to let this happen even if bang-patterns checkPat loc (L _ (HsApp f x)) args = do { x <- checkLPat x; checkPat loc f (x:args) } checkPat loc (L _ e) [] - = do { p <- checkAPat loc e; return (L loc p) } + = do { pState <- getPState + ; p <- checkAPat (dflags pState) loc e + ; return (L loc p) } checkPat loc _ _ = patFail loc -checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName) -checkAPat loc e = case e of +checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName) +checkAPat dynflags loc e = case e of EWildPat -> return (WildPat placeHolderType) HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: " ++ showRdrName x) @@ -761,7 +769,7 @@ checkAPat loc e = case e of -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) - | plus == plus_RDR + | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR) -> return (mkNPlusKPat (L nloc n) lit) OpApp l op _fix r -> do l <- checkLPat l @@ -777,8 +785,10 @@ checkAPat loc e = case e of ExplicitPArr _ es -> do ps <- mapM checkLPat es return (PArrPat ps placeHolderType) - ExplicitTuple es b -> do ps <- mapM checkLPat es - return (TuplePat ps b placeHolderType) + ExplicitTuple es b + | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es] + return (TuplePat ps b placeHolderType) + | otherwise -> parseError loc "Illegal tuple section in pattern" RecordCon c _ (HsRecFields fs dd) -> do fs <- mapM checkPatField fs @@ -959,7 +969,6 @@ mkInlineSpec Nothing match_info False = neverInlineSpec match_info -- NOINLINE mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl - ----------------------------------------------------------------------------- -- utilities for foreign declarations @@ -974,68 +983,49 @@ mkImport :: CallConv -> Safety -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkImport (CCall cconv) safety (entity, v, ty) +mkImport (CCall cconv) safety (L loc entity, v, ty) | cconv == PrimCallConv = do - let funcTarget = CFunction (StaticTarget (unLoc entity)) + let funcTarget = CFunction (StaticTarget entity) importSpec = CImport PrimCallConv safety nilFS funcTarget return (ForD (ForeignImport v ty importSpec)) | otherwise = do - importSpec <- parseCImport entity cconv safety v - return (ForD (ForeignImport v ty importSpec)) + case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of + Nothing -> parseError loc "Malformed entity string" + Just importSpec -> return (ForD (ForeignImport v ty importSpec)) mkImport (DNCall ) _ (entity, v, ty) = do spec <- parseDImport entity return $ ForD (ForeignImport v ty (DNImport spec)) --- parse the entity string of a foreign import declaration for the `ccall' or --- `stdcall' calling convention' --- -parseCImport :: Located FastString - -> CCallConv - -> Safety - -> Located RdrName - -> P ForeignImport -parseCImport (L loc entity) cconv safety v - -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak - | entity == fsLit "dynamic" = - return $ CImport cconv safety nilFS (CFunction DynamicTarget) - | entity == fsLit "wrapper" = - return $ CImport cconv safety nilFS CWrapper - | otherwise = parse0 (unpackFS entity) - where - -- using the static keyword? - parse0 (' ': rest) = parse0 rest - parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest - parse0 rest = parse1 rest - -- check for header file name - parse1 "" = parse4 "" nilFS False - parse1 (' ':rest) = parse1 rest - parse1 str@('&':_ ) = parse2 str nilFS - parse1 str - | ".h" `isSuffixOf` first = parse2 rest (mkFastString first) - | otherwise = parse4 str nilFS False - where - (first, rest) = break (\c -> c == ' ' || c == '&') str - -- check for address operator (indicating a label import) - parse2 "" header = parse4 "" header False - parse2 (' ':rest) header = parse2 rest header - parse2 ('&':rest) header = parse3 rest header - parse2 str header = parse4 str header False - -- eat spaces after '&' - parse3 (' ':rest) header = parse3 rest header - parse3 str header = parse4 str header True - -- check for name of C function - parse4 "" header isLbl = build (mkExtName (unLoc v)) header isLbl - parse4 (' ':rest) header isLbl = parse4 rest header isLbl - parse4 str header isLbl - | all (== ' ') rest = build (mkFastString first) header isLbl - | otherwise = parseError loc "Malformed entity string" - where - (first, rest) = break (== ' ') str - -- - build cid header False = return $ - CImport cconv safety header (CFunction (StaticTarget cid)) - build cid header True = return $ - CImport cconv safety header (CLabel cid ) +-- the string "foo" is ambigous: either a header or a C identifier. The +-- C identifier case comes first in the alternatives below, so we pick +-- that one. +parseCImport :: CCallConv -> Safety -> FastString -> String + -> Maybe ForeignImport +parseCImport cconv safety nm str = + listToMaybe $ map fst $ filter (null.snd) $ + readP_to_S parse str + where + parse = choice [ + string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)), + string "wrapper" >> return (mk nilFS CWrapper), + optional (string "static" >> skipSpaces) >> + (mk nilFS <$> cimp nm) +++ + (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm) + ] + + mk = CImport cconv safety + + hdr_char c = isAscii c && (isAlphaNum c || c `elem` "._") + id_char c = isAlphaNum c || c == '_' + + cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) + +++ ((CFunction . StaticTarget) <$> cid) + where + cid = return nm +++ + (do c <- satisfy (\c -> isAlpha c || c == '_') + cs <- many (satisfy id_char) + return (mkFastString (c:cs))) + -- -- Unravel a dotnet spec string.