[project @ 2001-10-25 02:13:10 by sof]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 1610e32..2e984fe 100644 (file)
--- 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 ->
@@ -273,9 +283,8 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
     in
 
        -- Arguments
-    let n_args = length args
-       tv_idxs | n_args == 0 = []
-               | otherwise   = [1..n_args]
+    let tv_idxs | null args  = []
+               | otherwise  = [1..length args]
     in
     newTyVarTys (length tv_idxs) openTypeKind          `thenNF_Tc` \ arg_tys ->
     tcMonoExprs args arg_tys                           `thenTc`    \ (args', args_lie) ->
@@ -293,7 +302,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}
 
@@ -694,9 +703,12 @@ checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
       (exp_args, _)    = tcSplitFunTys exp_ty''
       (act_args, _)    = tcSplitFunTys act_ty''
 
-      message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
-              | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
-             | otherwise                         = appCtxt fun args
+      len_act_args     = length act_args
+      len_exp_args     = length exp_args
+
+      message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun args
+              | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
+             | otherwise                   = appCtxt fun args
     in
     returnNF_Tc (env2, message)
 
@@ -886,7 +898,7 @@ missingFields rbinds data_con
 
     field_info = zipEqual "missingFields"
                          field_labels
-                         (drop (length ex_theta) (dataConStrictMarks data_con))
+                         (dropList ex_theta (dataConStrictMarks data_con))
        -- The 'drop' is because dataConStrictMarks
        -- includes the existential dictionaries
     (_, _, _, ex_theta, _, _) = dataConSig data_con