[project @ 2001-10-19 10:04:37 by sewardj]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 810ea72..cb57efd 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -15,8 +15,7 @@ import RnHsSyn                ( RenamedHsExpr, RenamedRecordBinds )
 import TcHsSyn         ( TcExpr, TcRecordBinds, mkHsLet )
 
 import TcMonad
-import BasicTypes      ( RecFlag(..) )
-
+import BasicTypes      ( RecFlag(..),  isMarkedStrict )
 import Inst            ( InstOrigin(..), 
                          LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
                          newOverloadedLit, newMethod, newIPDict,
@@ -26,10 +25,10 @@ import Inst         ( InstOrigin(..),
 import TcBinds         ( tcBindsAndThen )
 import TcEnv           ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
                          tcLookupTyCon, tcLookupDataCon, tcLookupId,
-                         tcExtendGlobalTyVars, tcLookupSyntaxName
+                         tcExtendGlobalTyVars
                        )
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcStmts )
-import TcMonoType      ( tcHsSigType, checkSigTyVars, sigCtxt )
+import TcMonoType      ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars, sigCtxt )
 import TcPat           ( badFieldCon, simpleHsLitTy )
 import TcSimplify      ( tcSimplifyCheck, tcSimplifyIPs )
 import TcMType         ( tcInstTyVars, tcInstType, 
@@ -50,7 +49,6 @@ import Id             ( idType, recordSelectorFieldLabel, isRecordSelector )
 import DataCon         ( dataConFieldLabels, dataConSig, 
                          dataConStrictMarks
                        )
-import Demand          ( isMarkedStrict )
 import Name            ( Name )
 import TyCon           ( TyCon, tyConTyVars, isAlgTyCon, tyConDataCons )
 import Subst           ( mkTopTyVarSubst, substTheta, substTy )
@@ -58,7 +56,7 @@ import VarSet         ( elemVarSet )
 import TysWiredIn      ( boolTy, mkListTy, listTyCon )
 import PrelNames       ( cCallableClassName, 
                          cReturnableClassName, 
-                         enumFromName, enumFromThenName, negateName,
+                         enumFromName, enumFromThenName, 
                          enumFromToName, enumFromThenToName,
                          thenMName, failMName, returnMName, ioTyConName
                        )
@@ -195,9 +193,8 @@ tcMonoExpr (HsLit lit)     res_ty = tcLit lit res_ty
 tcMonoExpr (HsOverLit lit) res_ty = newOverloadedLit (LiteralOrigin lit) lit res_ty
 tcMonoExpr (HsPar expr)    res_ty = tcMonoExpr expr res_ty
 
-tcMonoExpr (NegApp expr) res_ty
-  = tcLookupSyntaxName negateName      `thenNF_Tc` \ neg ->
-    tcMonoExpr (HsApp (HsVar neg) expr) res_ty
+tcMonoExpr (NegApp expr neg_name) res_ty
+  = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty
 
 tcMonoExpr (HsLam match) res_ty
   = tcMatchLambda match res_ty                 `thenTc` \ (match',lie) ->
@@ -261,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 ->
@@ -296,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}
 
@@ -596,9 +603,9 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 
 \begin{code}
 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
- = tcAddErrCtxt (exprSigCtxt in_expr)  $
-   tcHsSigType  poly_ty                `thenTc` \ sig_tc_ty ->
+ = tcHsSigType ExprSigCtxt poly_ty     `thenTc` \ sig_tc_ty ->
 
+   tcAddErrCtxt (exprSigCtxt in_expr)  $
    if not (isQualifiedTy sig_tc_ty) then
        -- Easy case
        unifyTauTy sig_tc_ty res_ty     `thenTc_`