+-----------------------------------------------------------------------------
+-- utilities for foreign declarations
+
+-- supported calling conventions
+--
+data CallConv = CCall CCallConv -- ccall or stdcall
+ | DNCall -- .NET
+
+-- construct a foreign import declaration
+--
+mkImport :: CallConv
+ -> Safety
+ -> (FastString, RdrName, RdrNameHsType)
+ -> SrcLoc
+ -> P RdrNameHsDecl
+mkImport (CCall cconv) safety (entity, v, ty) loc =
+ parseCImport entity cconv safety v `thenP` \importSpec ->
+ returnP $ ForD (ForeignImport v ty importSpec False loc)
+mkImport (DNCall ) _ (entity, v, ty) loc =
+ returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
+
+-- parse the entity string of a foreign import declaration for the `ccall' or
+-- `stdcall' calling convention'
+--
+parseCImport :: FastString
+ -> CCallConv
+ -> Safety
+ -> RdrName
+ -> P ForeignImport
+parseCImport entity cconv safety v
+ -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
+ | entity == FSLIT ("dynamic") =
+ returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
+ | entity == FSLIT ("wrapper") =
+ returnP $ CImport cconv safety nilFS 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 nilFS
+ 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
+ where
+ (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
+ -- check for address operator (indicating a label import)
+ parse2 "" header = parse4 "" header False nilFS
+ 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 "Missing ']' in entity"
+ parse3 str header isLbl = parse4 str header isLbl nilFS
+ -- check for name of C function
+ parse4 "" header isLbl lib = build (mkExtName 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 "Malformed entity string"
+ where
+ (first, rest) = break (== ' ') str
+ --
+ build cid header False lib = returnP $
+ CImport cconv safety header lib (CFunction (StaticTarget cid))
+ build cid header True lib = returnP $
+ CImport cconv safety header lib (CLabel cid )
+
+-- construct a foreign export declaration
+--
+mkExport :: CallConv
+ -> (FastString, RdrName, RdrNameHsType)
+ -> SrcLoc
+ -> P RdrNameHsDecl
+mkExport (CCall cconv) (entity, v, ty) loc = returnP $
+ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
+ where
+ entity' | nullFastString entity = mkExtName v
+ | otherwise = entity
+mkExport DNCall (entity, v, ty) loc =
+ parseError "Foreign export is not yet supported for .NET"
+
+-- Supplying the ext_name in a foreign decl is optional; if it