X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FForeignPtr.hs;h=761e6f19cd184d4cf4fcbcd2420afdff50ef16da;hb=3a8b769484788cb3874e9c695543712eb3330b7f;hp=9868942d7639b83f7c6b65d9cc52e4926804e57d;hpb=18ddadf0b8e35084a51f2560c3fe24ca8a2f3fea;p=ghc-base.git

diff --git a/GHC/ForeignPtr.hs b/GHC/ForeignPtr.hs
index 9868942..761e6f1 100644
--- a/GHC/ForeignPtr.hs
+++ b/GHC/ForeignPtr.hs
@@ -42,10 +42,11 @@ import Data.Typeable
 import GHC.Show
 import GHC.List         ( null )
 import GHC.Base
-import GHC.IOBase
+import GHC.IORef
 import GHC.STRef        ( STRef(..) )
 import GHC.Ptr          ( Ptr(..), FunPtr(..) )
 import GHC.Err
+import GHC.Num          ( fromInteger )
 
 #include "Typeable.h"
 
@@ -149,19 +150,23 @@ mallocForeignPtr :: Storable a => IO (ForeignPtr a)
 -- 
 mallocForeignPtr = doMalloc undefined
   where doMalloc :: Storable b => b -> IO (ForeignPtr b)
-        doMalloc a = do
+        doMalloc a
+          | I# size < 0 = error "mallocForeignPtr: size must be >= 0"
+          | otherwise = do
           r <- newIORef (NoFinalizers, [])
           IO $ \s ->
             case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->
              (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
                                (MallocPtr mbarr# r) #)
             }
-            where (I# size)  = sizeOf a
-                  (I# align) = alignment a
+            where !(I# size)  = sizeOf a
+                  !(I# align) = alignment a
 
 -- | This function is similar to 'mallocForeignPtr', except that the
 -- size of the memory required is given explicitly as a number of bytes.
 mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
+mallocForeignPtrBytes size | size < 0 =
+  error "mallocForeignPtrBytes: size must be >= 0"
 mallocForeignPtrBytes (I# size) = do 
   r <- newIORef (NoFinalizers, [])
   IO $ \s ->
@@ -186,19 +191,23 @@ mallocForeignPtrBytes (I# size) = do
 mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a)
 mallocPlainForeignPtr = doMalloc undefined
   where doMalloc :: Storable b => b -> IO (ForeignPtr b)
-        doMalloc a = IO $ \s ->
+        doMalloc a
+          | I# size < 0 = error "mallocForeignPtr: size must be >= 0"
+          | otherwise = IO $ \s ->
             case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->
              (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
                                (PlainPtr mbarr#) #)
             }
-            where (I# size)  = sizeOf a
-                  (I# align) = alignment a
+            where !(I# size)  = sizeOf a
+                  !(I# align) = alignment a
 
 -- | This function is similar to 'mallocForeignPtrBytes', except that
 -- the internally an optimised ForeignPtr representation with no
 -- finalizer is used. Attempts to add a finalizer will cause an
 -- exception to be thrown.
 mallocPlainForeignPtrBytes :: Int -> IO (ForeignPtr a)
+mallocPlainForeignPtrBytes size | size < 0 =
+  error "mallocPlainForeignPtrBytes: size must be >= 0"
 mallocPlainForeignPtrBytes (I# size) = IO $ \s ->
     case newPinnedByteArray# size s      of { (# s', mbarr# #) ->
        (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
@@ -213,7 +222,7 @@ addForeignPtrFinalizer (FunPtr fp) (ForeignPtr p c) = case c of
   PlainForeignPtr r -> f r >> return ()
   MallocPtr     _ r -> f r >> return ()
   _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"
-  where
+ where
     f r =
       noMixing CFinalizers r $
         IO $ \s ->
@@ -231,7 +240,7 @@ addForeignPtrFinalizerEnv (FunPtr fp) (Ptr ep) (ForeignPtr p c) = case c of
   PlainForeignPtr r -> f r >> return ()
   MallocPtr     _ r -> f r >> return ()
   _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"
-  where
+ where
     f r =
       noMixing CFinalizers r $
         IO $ \s ->
@@ -348,7 +357,7 @@ unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a
 -- To avoid subtle coding errors, hand written marshalling code
 -- should preferably use 'Foreign.ForeignPtr.withForeignPtr' rather
 -- than combinations of 'unsafeForeignPtrToPtr' and
--- 'touchForeignPtr'.  However, the later routines
+-- 'touchForeignPtr'.  However, the latter routines
 -- are occasionally preferred in tool generated marshalling code.
 unsafeForeignPtrToPtr (ForeignPtr fo _) = Ptr fo