[project @ 2000-12-11 16:56:47 by simonmar]

add ForeignPtr

diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 49aef1d..bed62c4 100644 (file)
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -76,7 +76,7 @@ module TysWiredIn (
        isFFIDynResultTy,   -- :: Type -> Bool
        isFFILabelTy,       -- :: Type -> Bool
        isAddrTy,           -- :: Type -> Bool
-       isForeignObjTy      -- :: Type -> Bool
+       isForeignPtrTy      -- :: Type -> Bool
 
     ) where
 
@@ -374,6 +374,19 @@ isForeignObjTy :: Type -> Bool
 isForeignObjTy = isTyCon foreignObjTyConKey
 \end{code}
 
+\begin{code}
+foreignPtrTyCon
+  = pcNonRecDataTyCon foreignPtrTyConName
+       alpha_tyvar  [(True,False)] [foreignPtrDataCon]
+  where
+    foreignPtrDataCon
+      = pcDataCon foreignPtrDataConName
+           alpha_tyvar [] [foreignObjPrimTy] foreignPtrTyCon
+
+isForeignPtrTy :: Type -> Bool
+isForeignPtrTy = isTyCon foreignPtrTyConKey
+\end{code}
+
 %************************************************************************
 %*                                                                     *
 \subsection[TysWiredIn-Integer]{@Integer@ and its related ``pairing'' types}
@@ -464,8 +477,8 @@ legalIncomingTyCon :: TyCon -> Bool
 -- bytearrays from a _ccall_ / foreign declaration
 -- (or be passed them as arguments in foreign exported functions).
 legalIncomingTyCon tc
-  | getUnique tc `elem` [ foreignObjTyConKey, byteArrayTyConKey, 
-                                              mutableByteArrayTyConKey ] 
+  | getUnique tc `elem` [ foreignObjTyConKey, foreignPtrTyConKey,
+                         byteArrayTyConKey, mutableByteArrayTyConKey ] 
   = False
   -- It's also illegal to make foreign exports that take unboxed
   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
@@ -491,6 +504,7 @@ boxedMarshalableTyCon tc
                         , wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
                         , floatTyConKey, doubleTyConKey
                         , addrTyConKey, charTyConKey, foreignObjTyConKey
+                        , foreignPtrTyConKey
                         , stablePtrTyConKey
                         , byteArrayTyConKey, mutableByteArrayTyConKey
                         , boolTyConKey

diff --git a/ghc/lib/std/PrelForeign.lhs b/ghc/lib/std/PrelForeign.lhs
index d99ca15..f0ea40d 100644 (file)
--- a/ghc/lib/std/PrelForeign.lhs
+++ b/ghc/lib/std/PrelForeign.lhs
@@ -1,5 +1,5 @@
 % ------------------------------------------------------------------------------
-% $Id: PrelForeign.lhs,v 1.15 2000/06/30 13:39:35 simonmar Exp $
+% $Id: PrelForeign.lhs,v 1.16 2000/12/11 16:56:47 simonmar Exp $
 %
 % (c) The University of Glasgow, 1994-2000
 %
@@ -12,9 +12,11 @@
 module PrelForeign (
        module PrelForeign,
 #ifndef __PARALLEL_HASKELL__
+       ForeignPtr(..),
+
+       -- the rest are deprecated
        ForeignObj(..),
        makeForeignObj,
-       -- SUP: deprecated
        mkForeignObj,
        writeForeignObj
 #endif
@@ -26,6 +28,16 @@ import PrelAddr
 import PrelWeak        ( addForeignFinalizer )
 \end{code}
 
+%*********************************************************
+%*                                                     *
+\subsection{ForeignPtr}
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+data ForeignPtr a = ForeignPtr ForeignObj#
+instance CCallable (ForeignPtr a)
+\end{code}
 
 %*********************************************************
 %*                                                     *
@@ -98,3 +110,4 @@ unpackNBytesFO# fo len
        ch = indexCharOffForeignObj# fo i
 #endif
 \end{code}
+