[project @ 1998-12-02 13:17:09 by simonm]

[ghc-hetmet.git] / ghc / lib / misc / SocketPrim.lhs

diff --git a/ghc/lib/misc/SocketPrim.lhs b/ghc/lib/misc/SocketPrim.lhs
index 2cdcc67..b0acd44 100644 (file)
--- a/ghc/lib/misc/SocketPrim.lhs
+++ b/ghc/lib/misc/SocketPrim.lhs
@@ -82,15 +82,17 @@ module SocketPrim (
 import GlaExts
 import ST
 import Ix
+import Weak        ( addForeignFinaliser )
 import PrelIOBase  -- IOError, Handle representation
 import PrelHandle
 import Foreign
 
 import IO
 import IOExts      ( IORef, newIORef, readIORef, writeIORef )
-import PackedString ( unpackNBytesPS, byteArrayToPS, 
+import CString      ( unpackNBytesBAIO,
                      unpackCString, unpackCStringIO,
-                     unpackCStringLenIO
+                     unpackCStringLenIO,
+                     allocChars
                    )
 \end{code}
 
@@ -164,17 +166,27 @@ newtype PortNumber = PNum Int  -- 16-bit value stored in network byte order.
                     deriving ( Eq )
 
 instance Show PortNumber where
-  showsPrec p (PNum pn) = showsPrec p pn_host
-   where
-     pn_host :: Int
-     pn_host = unsafePerformIO  (_casm_ ``%r=(int)ntohs((int)%0); '' pn)
-
+  showsPrec p pn = showsPrec p (ntohs pn)
 
 mkPortNumber :: Int -> PortNumber
 mkPortNumber v = unsafePerformIO $ do
    po <- _casm_ ``%r=(int)htons((int)%0); '' v
    return (PNum po)
 
+ntohs :: PortNumber -> Int
+ntohs (PNum po) = unsafePerformIO (_casm_ ``%r=(int)ntohs((int)%0); '' po)
+
+instance Num PortNumber where
+   fromInt     i = mkPortNumber i
+   fromInteger i = fromInt (fromInteger i)
+    -- for completeness.
+   (+) x y   = mkPortNumber (ntohs x + ntohs y)
+   (-) x y   = mkPortNumber (ntohs x - ntohs y)
+   negate x  = mkPortNumber (-ntohs x)
+   (*) x y   = mkPortNumber (ntohs x * ntohs y)
+   abs n     = mkPortNumber (abs (ntohs n))
+   signum n  = mkPortNumber (signum (ntohs n))
+
 data SockAddr          -- C Names                              
 #ifndef cygwin32_TARGET_OS
   = SockAddrUnix        -- struct sockaddr_un
@@ -430,13 +442,14 @@ readSocket (MkSocket s family stype protocol status) nbytes = do
     fail (userError ("readSocket: can't perform read on socket in status " ++
          show currentStatus))
    else do
-    ptr <- stToIO (newCharArray (1, nbytes))
+    ptr <- allocChars nbytes
     nbytes <- _ccall_ readDescriptor s ptr nbytes
     case nbytes of
       -1 -> constructErrorAndFail "readSocket"
       n  -> do
            barr <- stToIO (unsafeFreezeByteArray ptr)
-            return (unpackNBytesPS (byteArrayToPS barr) n, n)
+           s    <- unpackNBytesBAIO barr n
+            return (s,n)
 
 readSocketAll :: Socket -> IO String
 readSocketAll s =
@@ -460,7 +473,7 @@ recvFrom (MkSocket s family stype protocol status) nbytes = do
     fail (userError ("recvFrom: can't perform read on socket in status " ++
          show currentStatus))
    else do
-    ptr      <- stToIO (newCharArray (0, nbytes))
+    ptr      <- allocChars nbytes 
     (ptr_addr,_) <- allocSockAddr AF_INET
     nbytes   <- _ccall_ recvFrom__ s ptr nbytes ptr_addr
     case nbytes of
@@ -468,7 +481,8 @@ recvFrom (MkSocket s family stype protocol status) nbytes = do
       n  -> do
            barr <- stToIO (unsafeFreezeByteArray ptr)
            addr <- unpackSockAddrInet ptr_addr
-            return (unpackNBytesPS (byteArrayToPS barr) n, n, addr)
+           s    <- unpackNBytesBAIO barr n
+            return (s, n, addr)
 
 \end{code}
 
@@ -878,7 +892,7 @@ unpackFamily family = (range (AF_UNSPEC, AF_MAX))!!family
 
 #endif
 
-#if freebsd_TARGET_OS
+#if freebsd2_TARGET_OS || freebsd3_TARGET_OS
 
 data Family = 
                AF_UNSPEC       -- unspecified 
@@ -923,7 +937,7 @@ unpackFamily family = (range (AF_UNSPEC, AF_MAX))!!family
 -- Alpha running OSF or a SPARC with SunOS, rather than Solaris.
 
 #if osf1_TARGET_OS || osf3_TARGET_OS || sunos4_TARGET_OS || hpux_TARGET_OS || \
-       aix_TARGET_OS || freebsd_TARGET_OS
+       aix_TARGET_OS || freebsd2_TARGET_OS || freebsd3_TARGET_OS
 data SocketType = 
          Stream 
        | Datagram
@@ -1113,13 +1127,13 @@ allocSockAddr :: Family -> IO (MutableByteArray RealWorld Int, Int)
 
 #ifndef cygwin32_TARGET_OS
 allocSockAddr AF_UNIX = do
-    ptr <- stToIO (newCharArray (0,``sizeof(struct sockaddr_un)''))
+    ptr <- allocChars ``sizeof(struct sockaddr_un)''
     let (_,sz) = boundsOfByteArray ptr
     return (ptr, sz)
 #endif
 
 allocSockAddr AF_INET = do
-    ptr <- stToIO (newCharArray (0,``sizeof(struct sockaddr_in)''))
+    ptr <- allocChars ``sizeof(struct sockaddr_in)''
     let (_,sz) = boundsOfByteArray ptr
     return (ptr, sz)
 
@@ -1189,7 +1203,8 @@ socketToHandle :: Socket -> IOMode -> IO Handle
 
 socketToHandle (MkSocket fd family stype protocol status) m = do
     fo <- _ccall_ openFd fd file_mode flush_on_close
-    fo <- makeForeignObj fo (``&freeFileObject'' :: Addr)
+    fo <- makeForeignObj fo
+    addForeignFinaliser fo (freeFileObject fo)
     mkBuffer__ fo 0  -- not buffered
     hndl <- newHandle (Handle__ fo htype NoBuffering socket_str)
     return hndl