New syntax for GADT-style record declarations, and associated refactoring

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

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 35f627e..f51000d 100644 (file)
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -108,7 +108,7 @@ tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
        _ -> return ()
     return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
 
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CLabel _))
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
   = ASSERT( null arg_tys )
     do { checkCg checkCOrAsm
        ; checkSafety safety
@@ -116,7 +116,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CLabel _))
        ; 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 safety _ _ CWrapper) = do
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
        -- Foreign wrapper (former f.e.d.)
        -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
        -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
@@ -135,7 +135,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ CWrapper) =
         _ -> addErrTc (illegalForeignTyErr empty sig_ty)
     return idecl
 
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target))
   | isDynamicTarget target = do -- Foreign import dynamic
       checkCg checkCOrAsmOrInterp
       checkCConv cconv
@@ -151,6 +151,18 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction t
           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
           checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
           return idecl
+  | cconv == PrimCallConv = do
+      dflags <- getDOpts
+      check (dopt Opt_GHCForeignImportPrim dflags)
+            (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
+      checkCg (checkCOrAsmOrDotNetOrInterp)
+      checkCTarget target
+      check (playSafe safety)
+            (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
+      checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
+      -- prim import result is more liberal, allows (#,,#)
+      checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty
+      return idecl
   | otherwise = do              -- Normal foreign import
       checkCg (checkCOrAsmOrDotNetOrInterp)
       checkCConv cconv
@@ -348,6 +360,7 @@ checkCConv StdCallConv = return ()
 #else
 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this platform: stdcall")
 #endif
+checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
 \end{code}