From 2a0cc7c571e351091b58f072ae67ef5caa3ccb05 Mon Sep 17 00:00:00 2001
From: qrczak <unknown>
Date: Thu, 24 Aug 2000 13:32:17 +0000
Subject: [PATCH] [project @ 2000-08-24 13:32:17 by qrczak] Let foreign import
 dynamic accept a newtyped Addr too.

---
 ghc/compiler/prelude/TysWiredIn.lhs  |   22 +++++++++++++++-------
 ghc/compiler/typecheck/TcForeign.lhs |    8 ++++----
 2 files changed, 19 insertions(+), 11 deletions(-)

diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index e132166..d9b7e9d 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -62,13 +62,14 @@ module TysWiredIn (
 	wordTy,
 	wordTyCon,
 
-	isFFIArgumentTy,  -- :: Bool -> Type -> Bool
-	isFFIResultTy,    -- :: Type -> Bool
-	isFFIExternalTy,  -- :: Type -> Bool
- 	isFFIDynResultTy, -- :: Type -> Bool
- 	isFFILabelTy,     -- :: Type -> Bool
-	isAddrTy,	  -- :: Type -> Bool
-	isForeignObjTy    -- :: Type -> Bool
+	isFFIArgumentTy,    -- :: Bool -> Type -> Bool
+	isFFIResultTy,      -- :: Type -> Bool
+	isFFIExternalTy,    -- :: Type -> Bool
+        isFFIDynArgumentTy, -- :: Type -> Bool
+ 	isFFIDynResultTy,   -- :: Type -> Bool
+ 	isFFILabelTy,       -- :: Type -> Bool
+	isAddrTy,	    -- :: Type -> Bool
+	isForeignObjTy      -- :: Type -> Bool
 
     ) where
 
@@ -361,10 +362,17 @@ isFFIResultTy :: Type -> Bool
 -- But we allow () as well
 isFFIResultTy ty = checkRepTyCon (\tc -> tc == unitTyCon || legalIncomingTyCon tc) ty
 
+isFFIDynArgumentTy :: Type -> Bool
+-- The argument type of a foreign import dynamic must be either Addr, or
+-- a newtype of Addr.
+isFFIDynArgumentTy = checkRepTyCon (== addrTyCon)
+
+isFFIDynResultTy :: Type -> Bool
 -- The result type of a foreign export dynamic must be either Addr, or
 -- a newtype of Addr.
 isFFIDynResultTy = checkRepTyCon (== addrTyCon)
 
+isFFILabelTy :: Type -> Bool
 -- The type of a foreign label must be either Addr, or
 -- a newtype of Addr.
 isFFILabelTy = checkRepTyCon (== addrTyCon)
diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index c84c3c8..4c00838 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -42,8 +42,8 @@ import Type		( splitFunTys
 			, splitForAllTys
 			)
 import TysWiredIn	( isFFIArgumentTy, isFFIResultTy, 
-			  isFFIExternalTy, isAddrTy,
-			  isFFIDynResultTy, isFFILabelTy
+			  isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy,
+			  isFFILabelTy
 			)
 import Type             ( Type )
 import Unique
@@ -168,7 +168,7 @@ checkForeignImport is_dynamic is_safe ty args res
    case args of
      []     -> check False (illegalForeignTyErr True{-Arg-} ty)
      (x:xs) ->
-        check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
+        check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
         mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs	`thenTc_`
 	checkForeignRes True {-NonIO ok-} isFFIResultTy res
  | otherwise =
@@ -180,7 +180,7 @@ checkForeignExport is_dynamic ty args res
  | is_dynamic = 
     -- * the first (and only!) arg has got to be a function type
     --   and it must return IO t
-    -- * result type is an Addr or IO Addr
+    -- * result type is IO Addr
    case args of
      [arg]  ->
 	case splitFunTys arg of
-- 
1.7.10.4