From d75105426df54cf78cf5827ed307a64b51a0f428 Mon Sep 17 00:00:00 2001 From: sewardj Date: Fri, 19 Oct 2001 10:04:37 +0000 Subject: [PATCH] [project @ 2001-10-19 10:04:37 by sewardj] merge from stable, rev 1.105.4.1: When not compiling via C, catch Casms in the typecheck and reject them in a civilised way rather than having the various back ends barf. --- ghc/compiler/typecheck/TcExpr.lhs | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 1610e32..cb57efd 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -258,8 +258,18 @@ arg/result types); unify them with the args/result; and store them for later use. \begin{code} -tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty - = -- Get the callable and returnable classes. +tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty + + = getDOptsTc `thenNF_Tc` \ dflags -> + + checkTc (not (is_casm && dopt_HscLang dflags /= HscC)) + (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).", + text "Either compile with -fvia-C, or, better, rewrite your code", + text "to use the foreign function interface. _casm_s are deprecated", + text "and support for them may one day disappear."]) + `thenTc_` + + -- Get the callable and returnable classes. tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> tcLookupClass cReturnableClassName `thenNF_Tc` \ cReturnableClass -> tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon -> @@ -293,7 +303,7 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty -- constraints on the argument and result types. mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s -> newDicts result_origin [mkClassPred cReturnableClass [result_ty]] `thenNF_Tc` \ ccres_dict -> - returnTc (HsCCall lbl args' may_gc is_asm io_result_ty, + returnTc (HsCCall lbl args' may_gc is_casm io_result_ty, mkLIE (ccres_dict ++ concat ccarg_dicts_s) `plusLIE` args_lie) \end{code} -- 1.7.10.4