X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=bd8299b9bb6219476d56f6d1907cbb3865d43ad0;hb=909691a910d99495baf396fca3ab7e82f2e2eb51;hp=187d64d8802f09fb602bf004846fbd2f097140a6;hpb=6c06fdc7ad20682f0f52b5a78e5e3487a2ed047b;p=ghc-hetmet.git diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 187d64d..bd8299b 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -28,7 +28,7 @@ module RdrHsSyn ( -- -> (FastString, RdrName, RdrNameHsType) -- -> P RdrNameHsDecl mkExtName, -- RdrName -> CLabelString - mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName + mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName -- Bunch of functions in the parser monad for -- checking and constructing values @@ -64,7 +64,7 @@ import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo, alwaysInlineSpec, neverInlineSpec ) import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled ) import TysWiredIn ( unitTyCon ) -import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), +import ForeignCall ( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..), CLabelString ) import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) @@ -813,11 +813,19 @@ checkValSig (L l (HsVar v)) ty checkValSig (L l _) _ = parseError l "Invalid type signature" -mkGadtDecl :: Located RdrName +mkGadtDecl :: [Located RdrName] -> LHsType RdrName -- assuming HsType - -> ConDecl RdrName -mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty -mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty + -> [ConDecl RdrName] +-- We allow C,D :: ty +-- and expand it as if it had been +-- C :: ty; D :: ty +-- (Just like type signatures in general.) +mkGadtDecl names ty + = [mk_gadt_con name qvars cxt tau | name <- names] + where + (qvars,cxt,tau) = case ty of + L _ (HsForAllTy _ qvars cxt tau) -> (qvars, cxt, tau) + _ -> ([], noLoc [], ty) mk_gadt_con :: Located RdrName -> [LHsTyVarBndr RdrName] @@ -949,9 +957,14 @@ mkImport :: CallConv -> Safety -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkImport (CCall cconv) safety (entity, v, ty) = do - importSpec <- parseCImport entity cconv safety v +mkImport (CCall cconv) safety (entity, v, ty) + | cconv == PrimCallConv = do + let funcTarget = CFunction (StaticTarget (unLoc 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)) mkImport (DNCall ) _ (entity, v, ty) = do spec <- parseDImport entity return $ ForD (ForeignImport v ty (DNImport spec)) @@ -967,9 +980,9 @@ parseCImport :: Located FastString 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 nilFS (CFunction DynamicTarget) + return $ CImport cconv safety nilFS (CFunction DynamicTarget) | entity == fsLit "wrapper" = - return $ CImport cconv safety nilFS nilFS CWrapper + return $ CImport cconv safety nilFS CWrapper | otherwise = parse0 (unpackFS entity) where -- using the static keyword? @@ -977,41 +990,35 @@ parseCImport (L loc entity) cconv safety v parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest parse0 rest = parse1 rest -- check for header file name - parse1 "" = parse4 "" nilFS False nilFS + parse1 "" = parse4 "" nilFS False parse1 (' ':rest) = parse1 rest parse1 str@('&':_ ) = parse2 str nilFS - parse1 str@('[':_ ) = parse3 str nilFS False parse1 str | ".h" `isSuffixOf` first = parse2 rest (mkFastString first) - | otherwise = parse4 str nilFS False nilFS + | otherwise = parse4 str nilFS False where - (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str + (first, rest) = break (\c -> c == ' ' || c == '&') str -- check for address operator (indicating a label import) - parse2 "" header = parse4 "" header False nilFS + parse2 "" header = parse4 "" header False parse2 (' ':rest) header = parse2 rest header - parse2 ('&':rest) header = parse3 rest header True - parse2 str@('[':_ ) header = parse3 str header False - parse2 str header = parse4 str header False nilFS - -- check for library object name - parse3 (' ':rest) header isLbl = parse3 rest header isLbl - parse3 ('[':rest) header isLbl = - case break (== ']') rest of - (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib) - _ -> parseError loc "Missing ']' in entity" - parse3 str header isLbl = parse4 str header isLbl nilFS + 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 lib = build (mkExtName (unLoc v)) header isLbl lib - parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib - parse4 str header isLbl lib - | all (== ' ') rest = build (mkFastString first) header isLbl lib - | otherwise = parseError loc "Malformed entity string" + 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 lib = return $ - CImport cconv safety header lib (CFunction (StaticTarget cid)) - build cid header True lib = return $ - CImport cconv safety header lib (CLabel cid ) + build cid header False = return $ + CImport cconv safety header (CFunction (StaticTarget cid)) + build cid header True = return $ + CImport cconv safety header (CLabel cid ) -- -- Unravel a dotnet spec string.