Use OPTIONS rather than OPTIONS_GHC for pragmas

[ghc-hetmet.git] / compiler / typecheck / TcForeign.lhs

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 4019feb..f01f6a5 100644 (file)
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -1,4 +1,5 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The AQUA Project, Glasgow University, 1998
 %
 \section[TcForeign]{Typechecking \tr{foreign} declarations}
@@ -11,6 +12,13 @@ is restricted to what the outside world understands (read C), and this
 module checks to see if a foreign declaration has got a legal type.
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
 module TcForeign 
        ( 
          tcForeignImports
@@ -22,37 +30,25 @@ module TcForeign
 import HsSyn
 
 import TcRnMonad
-import TcHsType                ( tcHsSigType, UserTypeCtxt(..) )
-import TcExpr          ( tcPolyExpr )                  
+import TcHsType
+import TcExpr
 
-import ForeignCall     ( CCallConv(..) )
-import ErrUtils                ( Message )
-import Id              ( Id, mkLocalId, mkExportedLocalId )
+import ForeignCall
+import ErrUtils
+import Id
 #if alpha_TARGET_ARCH
-import Type            ( typePrimRep )
-import SMRep           ( argMachRep, primRepToCgRep, primRepHint )
+import Type
+import SMRep
+import MachOp
 #endif
-import OccName         ( mkForeignExportOcc )
-import Name            ( Name, NamedThing(..), mkExternalName )
-import TcType          ( Type, tcSplitFunTys, 
-                         tcSplitForAllTys, tcSplitIOType_maybe,
-                         isFFIArgumentTy, isFFIImportResultTy, 
-                         isFFIExportResultTy, isFFILabelTy,
-                         isFFIExternalTy, isFFIDynArgumentTy,
-                         isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy,
-                         toDNType
-                       )
-import ForeignCall     ( CExportSpec(..), CCallTarget(..), 
-                         CLabelString, isCLabelString,
-                         isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) 
-import DynFlags                ( DynFlags(..), HscTarget(..) )
+import Name
+import OccName
+import TcType
+import DynFlags
 import Outputable
-import SrcLoc          ( Located(..), srcSpanStart )
-import Bag             ( consBag )
-
-#if alpha_TARGET_ARCH
-import MachOp          ( machRepByteWidth, MachHint(FloatHint) )
-#endif
+import SrcLoc
+import Bag
+import Unique
 \end{code}
 
 \begin{code}
@@ -227,8 +223,17 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
    newUnique                   `thenM` \ uniq ->
    getModule                   `thenM` \ mod ->
    let
-        gnm  = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) 
-                             (srcSpanStart loc)
+          -- We need to give a name to the new top-level binding that
+          -- is *stable* (i.e. the compiler won't change it later),
+          -- because this name will be referred to by the C code stub.
+          -- Furthermore, the name must be unique (see #1533).  If the
+          -- same function is foreign-exported multiple times, the
+          -- top-level bindings generated must not have the same name.
+          -- Hence we create an External name (doesn't change), and we
+          -- append a Unique to the string right here.
+        uniq_str = showSDoc (pprUnique uniq)
+        occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
+        gnm  = mkExternalName uniq mod (mkForeignExportOcc occ) loc
        id   = mkExportedLocalId gnm sig_ty
        bind = L loc (VarBind id rhs)
    in
@@ -277,7 +282,7 @@ mustBeIO = False
 
 checkForeignRes non_io_result_ok pred_res_ty ty
        -- (IO t) is ok, and so is any newtype wrapping thereof
-  | Just (io, res_ty) <- tcSplitIOType_maybe ty,
+  | Just (io, res_ty, _) <- tcSplitIOType_maybe ty,
     pred_res_ty res_ty
   = returnM ()
  
@@ -320,7 +325,7 @@ checkCg check
        case check target of
         Nothing  -> returnM ()
         Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
-\end{code} 
+\end{code}
                           
 Calling conventions