[project @ 2001-06-13 15:50:57 by rrt]

Add an ext_name string to foreign dotnet types.

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 28778b7..ebf82a7 100644 (file)
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -43,6 +43,7 @@ import Class          ( FunDep, DefMeth(..) )
 import CStrings                ( CLabelString )
 import Outputable      
 import SrcLoc          ( SrcLoc )
+import FastString
 \end{code}
 
 
@@ -261,9 +262,10 @@ data TyClDecl name pat
                tcdLoc :: SrcLoc
     }
 
-  | ForeignType { tcdName   :: name,           -- See remarks about IfaceSig above
-                 tcdFoType :: FoType,
-                 tcdLoc    :: SrcLoc }
+  | ForeignType { tcdName    :: name,          -- See remarks about IfaceSig above
+                 tcdExtName :: Maybe FastString,
+                 tcdFoType  :: FoType,
+                 tcdLoc     :: SrcLoc }
 
   | TyData {   tcdND     :: NewOrData,
                tcdCtxt   :: HsContext name,     -- context

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 872257f..9269c59 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.67 2001/06/11 12:21:17 simonpj Exp $
+$Id: Parser.y,v 1.68 2001/06/13 15:50:57 rrt Exp $
 
 Haskell grammar.
 
@@ -402,8 +402,8 @@ fordecl : srcloc 'label' ext_name varid '::' sigtype
        | srcloc 'import' 'dotnet' ext_name varid '::' sigtype
                { ForD (ForeignImport $5 $7 (DNImport (DNCallSpec ($4 `orElse` mkExtName $5))) $1) }
 
-       | srcloc 'import' 'dotnet' 'type' tycon
-               { TyClD (ForeignType $5 DNType $1) }
+       | srcloc 'import' 'dotnet' 'type' ext_name tycon
+               { TyClD (ForeignType $6 $5 DNType $1) }
 
 decls  :: { [RdrBinding] }
        : decls ';' decl                { $3 : $1 }

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 47fda3a..9254ef2 100644 (file)
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -352,7 +352,7 @@ decl    : src_loc qvar_name '::' type maybe_idinfo
        | src_loc 'type' qtc_name tv_bndrs '=' type                    
                        { TySynonym $3 $4 $6 $1 }
        | src_loc 'foreign' 'type' qtc_name                    
-                       { ForeignType $4 DNType $1 }
+                       { ForeignType $4 Nothing DNType $1 }
        | src_loc 'data' opt_decl_context qtc_name tv_bndrs constrs            
                        { mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1 }
        | src_loc 'newtype' opt_decl_context qtc_name tv_bndrs newtype_constr

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index c89a88b..e7add89 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -916,7 +916,7 @@ precParseErr op1 op2
 sectionPrecErr op arg_op section
  = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
         nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
-        nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
+        nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
 
 nonStdGuardErr guard
   = hang (ptext

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 9fa3806..0044d67 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -329,8 +329,8 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
                                 | otherwise                      -> DataTyCon
 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
-                  (ForeignType {tcdName = tycon_name})
-  = ATyCon (mkForeignTyCon tycon_name liftedTypeKind 0 [])
+                  (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
+  = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
                   (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,

diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 015d0b3..4fc0348 100644 (file)
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -64,6 +64,7 @@ import Name           ( Name, nameUnique, NamedThing(getName) )
 import PrelNames       ( Unique, Uniquable(..), anyBoxConKey )
 import PrimRep         ( PrimRep(..), isFollowableRep )
 import Outputable
+import FastString
 \end{code}
 
 %************************************************************************
@@ -135,8 +136,9 @@ data TyCon
        primTyConRep :: PrimRep,        -- Many primitive tycons are unboxed, but some are
                                        -- boxed (represented by pointers). The PrimRep tells.
 
-       isUnLifted   :: Bool    -- Most primitive tycons are unlifted, 
+       isUnLifted   :: Bool,   -- Most primitive tycons are unlifted, 
                                -- but foreign-imported ones may not be
+       tyConExtName :: Maybe FastString
     }
 
   | TupleTyCon {
@@ -297,9 +299,11 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info
     }
 
 -- Foreign-imported (.NET) type constructors are represented
--- as primitive, but *lifted*, TyCons for now.  
--- They  have PtrRep
-mkForeignTyCon name kind arity arg_vrcs
+-- as primitive, but *lifted*, TyCons for now. They are lifted
+-- because the Haskell type T representing the (foreign) .NET
+-- type T is actually implemented (in ILX) as a thunk<T>
+-- They have PtrRep
+mkForeignTyCon name ext_name kind arity arg_vrcs
   = PrimTyCon {
        tyConName    = name,
        tyConUnique  = nameUnique name,
@@ -307,7 +311,8 @@ mkForeignTyCon name kind arity arg_vrcs
        tyConArity   = arity,
         tyConArgVrcs = arg_vrcs,
        primTyConRep = PtrRep,
-       isUnLifted   = False
+       isUnLifted   = False,
+       tyConExtName = ext_name
     }
 
 
@@ -319,7 +324,8 @@ mkPrimTyCon name kind arity arg_vrcs rep
        tyConArity   = arity,
         tyConArgVrcs = arg_vrcs,
        primTyConRep = rep,
-       isUnLifted   = True
+       isUnLifted   = True,
+       tyConExtName = Nothing
     }
 
 mkSynTyCon name kind arity tyvars rhs argvrcs