X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcForeign.lhs;h=185e592417379e00c1278889fe392ef5eb931681;hb=389cca214f33a29646e08d57e3dca862140007b2;hp=23f959bba7afa4343751025da233021f028088f5;hpb=d95ce839533391e7118257537044f01cbb1d6694;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 23f959b..185e592 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -69,22 +69,22 @@ tcForeignImports decls
 
 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
- = addErrCtxt (foreignDeclCtxt fo)  $ do
-   sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
-   let 
-      -- drop the foralls before inspecting the structure
-      -- of the foreign type.
-	(_, t_ty)	  = tcSplitForAllTys sig_ty
-	(arg_tys, res_ty) = tcSplitFunTys t_ty
-	id		  = mkLocalId nm sig_ty
+ = addErrCtxt (foreignDeclCtxt fo)  $ 
+   do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+      ; let 
+          -- Drop the foralls before inspecting the
+          -- structure of the foreign type.
+	    (_, t_ty)	      = tcSplitForAllTys sig_ty
+	    (arg_tys, res_ty) = tcSplitFunTys t_ty
+	    id  	      = mkLocalId nm sig_ty
  		-- Use a LocalId to obey the invariant that locally-defined 
 		-- things are LocalIds.  However, it does not need zonking,
 		-- (so TcHsSyn.zonkForeignExports ignores it).
    
-   imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
-   -- can't use sig_ty here because it :: Type and we need HsType Id
-   -- hence the undefined
-   return (id, ForeignImport (L loc id) undefined imp_decl')
+      ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
+         -- Can't use sig_ty here because sig_ty :: Type and 
+	 -- we need HsType Id hence the undefined
+      ; return (id, ForeignImport (L loc id) undefined imp_decl') }
 tcFImport d = pprPanic "tcFImport" (ppr d)
 \end{code}
 
@@ -96,7 +96,7 @@ tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
     checkCg checkDotnet
     dflags <- getDOpts
     checkForeignArgs (isFFIDotnetTy dflags) arg_tys
-    checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty
+    checkForeignRes nonIOok (isFFIDotnetTy dflags) res_ty
     let (DNCallSpec isStatic kind _ _ _ _) = spec
     case kind of
        DNMethod | not isStatic ->
@@ -108,10 +108,12 @@ tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
        _ -> return ()
     return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
 
-tcCheckFIType sig_ty _ _ idecl@(CImport _ _ _ _ (CLabel _)) = do
-    checkCg checkCOrAsm
-    check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
-    return idecl
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) 
+  = ASSERT( null arg_tys )
+    do { checkCg checkCOrAsm
+       ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
+       ; return idecl }	     -- NB check res_ty not sig_ty!
+       	 	      	     --    In case sig_ty is (forall a. ForeignPtr a)
 
 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
    	-- Foreign wrapper (former f.e.d.)
@@ -233,7 +235,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
    -- is *stable* (i.e. the compiler won't change it later),
    -- because this name will be referred to by the C code stub.
    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
-   return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
+   return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec)
 tcFExport d = pprPanic "tcFExport" (ppr d)
 \end{code}