- tcHsType hs_ty `thenTc` \ ty ->
- -- Check that the type has the right shape
- -- and that the argument and result types are acceptable.
- let
- -- drop the foralls before inspecting the structure
- -- of the foreign type.
- (_, t_ty) = splitForAllTys ty
- in
- case splitFunTys t_ty of
- (arg_tys, res_ty) ->
- checkForeignImport (isDynamic ext_nm) ty arg_tys res_ty `thenTc_`
- let i = (mkUserId nm ty) in
- returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
+------------ Checking types for foreign import ----------------------
+\begin{code}
+tcCheckFIType _ _ _ (DNImport _)
+ = checkCg checkDotNet
+
+tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ (CLabel _))
+ = checkCg checkCOrAsm `thenM_`
+ check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
+
+tcCheckFIType sig_ty arg_tys res_ty (CImport cconv _ _ _ CWrapper)
+ = -- 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
+ -- as ft -> IO Addr is accepted, too. The use of the latter two forms
+ -- is DEPRECATED, though.
+ checkCg (if cconv == StdCallConv
+ then checkC
+ else checkCOrAsmOrInterp) `thenM_`
+ -- the native code gen can't handle foreign import stdcall "wrapper",
+ -- because it doesn't emit the '@n' suffix on the label of the
+ -- C stub function. Infrastructure changes are required to make this
+ -- happen; MachLabel will need to carry around information about
+ -- the arity of the foreign call.
+ case arg_tys of
+ [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
+ checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`
+ checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_`
+ checkFEDArgs arg1_tys
+ where
+ (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
+ other -> addErrTc (illegalForeignTyErr empty sig_ty)
+
+tcCheckFIType sig_ty arg_tys res_ty (CImport _ safety _ _ (CFunction target))
+ | isDynamicTarget target -- Foreign import dynamic
+ = checkCg checkCOrAsmOrInterp `thenM_`
+ case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
+ [] -> check False (illegalForeignTyErr empty sig_ty)
+ (arg1_ty:arg_tys) -> getDOpts `thenM` \ dflags ->
+ check (isFFIDynArgumentTy arg1_ty)
+ (illegalForeignTyErr argument arg1_ty) `thenM_`
+ checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
+ checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
+
+ | otherwise -- Normal foreign import
+ = checkCg (if isCasmTarget target
+ then checkC else checkCOrAsmOrDotNetOrInterp) `thenM_`
+ checkCTarget target `thenM_`
+ getDOpts `thenM` \ dflags ->
+ checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
+ checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
+
+-- This makes a convenient place to check
+-- that the C identifier is valid for C
+checkCTarget (StaticTarget str)
+ = checkCg checkCOrAsmOrDotNetOrInterp `thenM_`
+ check (isCLabelString str) (badCName str)
+
+checkCTarget (CasmTarget _)
+ = checkCg checkC
+\end{code}