GHC bits for new library organisation.
\begin{code}
sub setupBuildFlags {
-
# PROFILING stuff after argv mangling:
if ( ! $PROFing ) {
# add -auto sccs even if not profiling !
close(CCOUT) || &tidy_up_and_die(1,"$Pgm: failed closing `$Tmp_prefix.ccout'\n");
}
+ local($signal_num) = $? & 127;
+ local($dumped_core) = $? & 128;
+
if ($return_val != 0) {
if ($Using_dump_file) {
print STDERR "Compilation Errors dumped in $Specific_dump_file\n";
}
&tidy_up_and_die($return_val, '');
}
+
+ if ($signal_num != 0) {
+ print STDERR "Phase $tidy_name received signal $signal_num";
+ if ($dumped_core != 0) {
+ print STDERR " (core dumped)";
+ }
+ print STDERR "\n";
+ }
$Using_dump_file = 0;
}
\end{code}
# Lifting this out of this sub brings it out of scope - why??
%Supported_syslibs =
- ( exts,
+ ( lang,
[ # where to slurp interface files from
( $INSTALLING
- ? "$InstLibDirGhc/imports/exts"
- : "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/exts"
+ ? "$InstLibDirGhc/imports/lang"
+ : "$TopPwd/hslibs/lang"
)
, # where to find the archive to use when linking
( $INSTALLING
? "$InstLibDirGhc"
- : "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/exts"
+ : "$TopPwd/hslibs/lang"
+ )
+ , # where to find the cbits archive to use when linking
+ ( $INSTALLING
+ ? "$InstLibDirGhc"
+ : "$TopPwd/hslibs/lang/cbits"
)
- , '' # no cbits
, '' # Syslib dependencies
, '' # extra ghc opts
, '' # extra cc opts
, '' # extra ld opts
],
- misc,
+ concurrent,
[ # where to slurp interface files from
( $INSTALLING
- ? "$InstLibDirGhc/imports/misc"
- : "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/misc"
+ ? "$InstLibDirGhc/imports/concurrent"
+ : "$TopPwd/hslibs/concurrent"
)
, # where to find the archive to use when linking
( $INSTALLING
? "$InstLibDirGhc"
- : "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/misc"
+ : "$TopPwd/hslibs/concurrent"
)
- , # where to find the cbits archive to use when linking
+ , '' # where to find the cbits archive to use when linking
+ , '' # Syslib dependencies
+ , '' # extra ghc opts
+ , '' # extra cc opts
+ , '' # extra ld opts
+ ],
+
+ data,
+ [ # where to slurp interface files from
+ ( $INSTALLING
+ ? "$InstLibDirGhc/imports/data"
+ : "$TopPwd/hslibs/data:$TopPwd/hslibs/data/edison:$TopPwd/hslibs/data/edison/Assoc:$TopPwd/hslibs/data/edison/Coll:$TopPwd/hslibs/data/edison/Seq"
+ )
+ , # where to find the archive to use when linking
( $INSTALLING
? "$InstLibDirGhc"
- : "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/misc/cbits"
+ : "$TopPwd/hslibs/data"
)
- , 'exts concurrent' # Syslib dependencies
- , '' # extra ghc opts
- , '' # extra cc opts
- , ( $TargetPlatform =~ /-solaris2$/ ? '-lnsl -lsocket' : '')
+ , '' # where to find the cbits archive to use when linking
+ , '' # Syslib dependencies
+ , '' # extra ghc opts
+ , '' # extra cc opts
+ , '' # extra ld opts
],
- hbc,
+
+ net,
[ # where to slurp interface files from
( $INSTALLING
- ? "$InstLibDirGhc/imports/hbc"
- : "$TopPwd/CONTRIB/libraries/hbc/src"
+ ? "$InstLibDirGhc/imports/net"
+ : "$TopPwd/hslibs/net"
)
, # where to find the archive to use when linking
( $INSTALLING
? "$InstLibDirGhc"
- : "$TopPwd/CONTRIB/libraries/src/hbc"
+ : "$TopPwd/hslibs/net"
)
, # where to find the cbits archive to use when linking
( $INSTALLING
? "$InstLibDirGhc"
- : "$TopPwd/CONTRIB/libraries/hbc/cbits"
+ : "$TopPwd/hslibs/net/cbits"
)
- , 'exts' # Syslib dependencies
- , '' # extra ghc opts
- , '' # extra cc opts
- , ''
+ , 'lang text' # Syslib dependencies
+ , '' # extra ghc opts
+ , '' # extra cc opts
+ , ( $TargetPlatform =~ /-solaris2$/ ? '-lnsl -lsocket' : '')
],
+
posix,
[ # where to slurp interface files from
( $INSTALLING
? "$InstLibDirGhc/imports/posix"
- : "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/posix"
+ : "$TopPwd/hslibs/posix"
)
, # where to find the archive to use when linking
( $INSTALLING
? "$InstLibDirGhc"
- : "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/posix"
+ : "$TopPwd/hslibs/posix"
)
, # where to find the cbits archive to use when linking
( $INSTALLING
? "$InstLibDirGhc"
- : "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/posix/cbits"
+ : "$TopPwd/hslibs/posix/cbits"
)
- , 'misc' # Syslib dependencies
+ , 'lang' # Syslib dependencies
, '' # extra ghc opts
, '' # extra cc opts
, '' # extra ld opts
],
- concurrent,
+
+ text,
[ # where to slurp interface files from
( $INSTALLING
- ? "$InstLibDirGhc/imports/concurrent"
- : "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/concurrent"
+ ? "$InstLibDirGhc/imports/text"
+ : "$TopPwd/hslibs/text:$TopPwd/hslibs/text/html"
)
, # where to find the archive to use when linking
( $INSTALLING
? "$InstLibDirGhc"
- : "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/concurrent"
+ : "$TopPwd/hslibs/text"
)
- , '' # where to find the cbits archive to use when linking
- , '' # Syslib dependencies
+ , # where to find the cbits archive to use when linking
+ ( $INSTALLING
+ ? "$InstLibDirGhc"
+ : "$TopPwd/hslibs/text/cbits"
+ )
+ , 'lang' # Syslib dependencies
, '' # extra ghc opts
, '' # extra cc opts
, '' # extra ld opts
],
+
+ util,
+ [ # where to slurp interface files from
+ ( $INSTALLING
+ ? "$InstLibDirGhc/imports/util"
+ : "$TopPwd/hslibs/util"
+ )
+ , # where to find the archive to use when linking
+ ( $INSTALLING
+ ? "$InstLibDirGhc"
+ : "$TopPwd/hslibs/util"
+ )
+ , # where to find the cbits archive to use when linking
+ ( $INSTALLING
+ ? "$InstLibDirGhc"
+ : "$TopPwd/hslibs/util/cbits"
+ )
+ , 'lang concurrent' # Syslib dependencies
+ , '' # extra ghc opts
+ , '' # extra cc opts
+ , '' # extra ld opts
+ ],
+
win32,
[ # where to slurp interface files from
( $INSTALLING
: "$TopPwd/hslibs/win32/src"
)
, ''
- , 'exts' # Syslib dependencies
+ , 'lang' # Syslib dependencies
, '' # extra ghc opts
, '' # extra cc opts
, '-luser32 -lgdi32' # extra ld opts
],
+
com,
[ # where to slurp interface files from
( $INSTALLING
: "$TopPwd/hdirect/lib"
)
, ''
- , 'exts' # Syslib dependencies
+ , 'lang' # Syslib dependencies
, '' # extra ghc opts
, '' # extra cc opts
, '-luser32 -lole32 -loleaut32 -ladvapi32'
# This check is here to avoid syslib loops from
# spoiling the party. A side-effect of it is that
# it disallows multiple mentions of a syslib on a command-line,
- # explicit *and* implicit ones (i.e., "-syslib exts -syslib misc"
- # is not equal to "-syslib exts -syslib misc -syslib exts",
+ # explicit *and* implicit ones (i.e., "-syslib lang -syslib misc"
+ # is not equal to "-syslib lang -syslib misc -syslib lang",
# which it needs to be)
#
# Since our current collection of syslibs don't have any
$Syslibs_added{$syslib} = 1;
- local ($hi_dir, $lib_dir, $lib_cbits_dir,
+ local ($hi_dirs, $lib_dir, $lib_cbits_dir,
$syslib_deps, $syslib_ghc_opts,
$syslib_cc_opts, $syslib_ld_opts) = @{ $Supported_syslibs{$syslib} };
-
- unshift(@SysImport_dir, $hi_dir);
+ foreach(split(':',$hi_dirs)) {
+ unshift(@SysImport_dir, $_);
+ }
push(@SysLibrary_dir, $lib_dir);
push(@SysLibrary_dir, $lib_cbits_dir) if ( $lib_cbits_dir ne '');
/^-fglasgow-exts$/
&& do { push(@HsC_flags, $_);
- # -fglasgow-exts implies -syslib exts
- &add_syslib('exts');
+ # -fglasgow-exts implies -syslib lang
+ &add_syslib('lang');
next arg; };
-#################################################################################
-#
-# ghc/lib/Makefile
-#
-# Makefile for building the GHC Prelude libraries umpteen ways
-#
-#
-#################################################################################
+# -----------------------------------------------------------------------------
+# $Id: Makefile,v 1.33 1999/11/26 16:29:12 simonmar Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
-# posix must be before misc.
-
-ifeq "$(GhcWithHscBuiltViaC)" "YES"
-SUBDIRS = std exts
-else
-ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
-SUBDIRS = std exts concurrent posix misc
-else
-SUBDIRS = std exts concurrent misc
-endif
-endif
+SUBDIRS = std
include $(TOP)/mk/target.mk
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-97
-%
-\section[Channel]{Unbounded Channels}
-
-Standard, unbounded channel abstraction.
-
-\begin{code}
-module Channel
- (
- {- abstract type defined -}
- Chan,
-
- {- creator -}
- newChan, -- :: IO (Chan a)
-
- {- operators -}
- writeChan, -- :: Chan a -> a -> IO ()
- readChan, -- :: Chan a -> IO a
- dupChan, -- :: Chan a -> IO (Chan a)
- unGetChan, -- :: Chan a -> a -> IO ()
-
- isEmptyChan, -- :: Chan a -> IO Bool
-
- {- stream interface -}
- getChanContents, -- :: Chan a -> IO [a]
- writeList2Chan -- :: Chan a -> [a] -> IO ()
-
- ) where
-
-import Prelude
-import PrelConc
-import PrelST
-import PrelIOBase ( unsafeInterleaveIO )
-\end{code}
-
-A channel is represented by two @MVar@s keeping track of the two ends
-of the channel contents,i.e., the read- and write ends. Empty @MVar@s
-are used to handle consumers trying to read from an empty channel.
-
-\begin{code}
-data Chan a
- = Chan (MVar (Stream a))
- (MVar (Stream a))
-
-type Stream a = MVar (ChItem a)
-
-data ChItem a = ChItem a (Stream a)
-\end{code}
-
-See the Concurrent Haskell paper for a diagram explaining the
-how the different channel operations proceed.
-
-@newChan@ sets up the read and write end of a channel by initialising
-these two @MVar@s with an empty @MVar@.
-
-\begin{code}
-newChan :: IO (Chan a)
-newChan = do
- hole <- newEmptyMVar
- read <- newMVar hole
- write <- newMVar hole
- return (Chan read write)
-\end{code}
-
-To put an element on a channel, a new hole at the write end is created.
-What was previously the empty @MVar@ at the back of the channel is then
-filled in with a new stream element holding the entered value and the
-new hole.
-
-\begin{code}
-writeChan :: Chan a -> a -> IO ()
-writeChan (Chan _read write) val = do
- new_hole <- newEmptyMVar
- old_hole <- takeMVar write
- putMVar write new_hole
- putMVar old_hole (ChItem val new_hole)
-
-readChan :: Chan a -> IO a
-readChan (Chan read _write) = do
- read_end <- takeMVar read
- (ChItem val new_read_end) <- takeMVar read_end
- putMVar read new_read_end
- return val
-
-
-dupChan :: Chan a -> IO (Chan a)
-dupChan (Chan _read write) = do
- new_read <- newEmptyMVar
- hole <- readMVar write
- putMVar new_read hole
- return (Chan new_read write)
-
-unGetChan :: Chan a -> a -> IO ()
-unGetChan (Chan read _write) val = do
- new_read_end <- newEmptyMVar
- read_end <- takeMVar read
- putMVar new_read_end (ChItem val read_end)
- putMVar read new_read_end
-
-isEmptyChan :: Chan a -> IO Bool
-isEmptyChan (Chan read write) = do
- r <- takeMVar read
- w <- readMVar write
- let eq = r == w
- eq `seq` putMVar read r
- return eq
-
-\end{code}
-
-Operators for interfacing with functional streams.
-
-\begin{code}
-getChanContents :: Chan a -> IO [a]
-getChanContents ch
- = unsafeInterleaveIO (do
- x <- readChan ch
- xs <- getChanContents ch
- return (x:xs)
- )
-
--------------
-writeList2Chan :: Chan a -> [a] -> IO ()
-writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[ChannelVar]{Channel variables}
-
-Channel variables, are one-element channels described in the Concurrent
-Haskell paper (available from @ftp://ftp.dcs.gla.ac.uk/pub/glasgow-fp/drafts@)
-
-\begin{code}
-module ChannelVar
- (
- {- abstract -}
- CVar,
- newCVar, -- :: IO (CVar a)
- writeCVar, -- :: CVar a -> a -> IO ()
- readCVar, -- :: CVar a -> IO a
- MVar
-
- ) where
-
-import Prelude
-import PrelConc
-\end{code}
-
-@MVars@ provide the basic mechanisms for synchronising access to a shared
-resource. @CVars@, or channel variables, provide an abstraction that guarantee
-that the producer is not allowed to run riot, but enforces the interleaved
-access to the channel variable,i.e., a producer is forced to wait up for
-a consumer to remove the previous value before it can deposit a new one in the @CVar@.
-
-\begin{code}
-
-data CVar a
- = CVar (MVar a) -- prod -> cons
- (MVar ()) -- cons -> prod
-
-newCVar :: IO (CVar a)
-writeCVar :: CVar a -> a -> IO ()
-readCVar :: CVar a -> IO a
-
-newCVar
- = newEmptyMVar >>= \ datum ->
- newMVar () >>= \ ack ->
- return (CVar datum ack)
-
-writeCVar (CVar datum ack) val
- = takeMVar ack >>
- putMVar datum val >>
- return ()
-
-readCVar (CVar datum ack)
- = takeMVar datum >>= \ val ->
- putMVar ack () >>
- return val
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1996
-%
-
-\section[Concurrent]{Concurrent Haskell constructs}
-
-A common interface to a collection of useful concurrency abstractions.
-Currently, the collection only contains the abstractions found in the
-{\em Concurrent Haskell} paper (presented at the Haskell Workshop
-1995, draft available via \tr{ftp} from
-\tr{ftp.dcs.gla.ac.uk/pub/glasgow-fp/drafts}.) plus a couple of
-others. See the paper and the individual files containing the module
-definitions for explanation on what they do.
-
-\begin{code}
-module Concurrent (
- module ChannelVar,
- module Channel,
- module Semaphore,
- module SampleVar
-
- , ThreadId
-
- -- Forking and suchlike
- , forkIO -- :: IO () -> IO ThreadId
- , myThreadId -- :: IO ThreadId
- , killThread -- :: ThreadId -> IO ()
- , raiseInThread -- :: ThreadId -> Exception -> IO ()
- , par -- :: a -> b -> b
- , seq -- :: a -> b -> b
- , fork -- :: a -> b -> b
- , yield -- :: IO ()
-
- , threadDelay -- :: Int -> IO ()
- , threadWaitRead -- :: Int -> IO ()
- , threadWaitWrite -- :: Int -> IO ()
-
- -- MVars
- , MVar -- abstract
- , newMVar -- :: a -> IO (MVar a)
- , newEmptyMVar -- :: IO (MVar a)
- , takeMVar -- :: MVar a -> IO a
- , putMVar -- :: MVar a -> a -> IO ()
- , readMVar -- :: MVar a -> IO a
- , swapMVar -- :: MVar a -> a -> IO a
- , isEmptyMVar -- :: MVar a -> IO Bool
-
- -- merging of streams
- , mergeIO -- :: [a] -> [a] -> IO [a]
- , nmergeIO -- :: [[a]] -> IO [a]
- ) where
-
-import Parallel
-import ChannelVar
-import Channel
-import Semaphore
-import SampleVar
-import PrelConc
-import PrelHandle ( topHandler )
-import PrelException
-import PrelIOBase ( IO(..) )
-import IO
-import PrelAddr ( Addr )
-import PrelArr ( ByteArray )
-import PrelPack ( packString )
-import PrelIOBase ( unsafePerformIO , unsafeInterleaveIO )
-import PrelBase ( fork# )
-import PrelGHC ( Addr#, unsafeCoerce# )
-
-infixr 0 `fork`
-\end{code}
-
-Thread Ids, specifically the instances of Eq and Ord for these things.
-The ThreadId type itself is defined in std/PrelConc.lhs.
-
-Rather than define a new primitve, we use a little helper function
-cmp_thread in the RTS.
-
-\begin{code}
-foreign import ccall "cmp_thread" unsafe cmp_thread :: Addr# -> Addr# -> Int
--- Returns -1, 0, 1
-
-cmpThread :: ThreadId -> ThreadId -> Ordering
-cmpThread (ThreadId t1) (ThreadId t2) =
- case cmp_thread (unsafeCoerce# t1) (unsafeCoerce# t2) of
- -1 -> LT
- 0 -> EQ
- 1 -> GT
-
-instance Eq ThreadId where
- t1 == t2 =
- case t1 `cmpThread` t2 of
- EQ -> True
- _ -> False
-
-instance Ord ThreadId where
- compare = cmpThread
-\end{code}
-
-\begin{code}
-forkIO :: IO () -> IO ThreadId
-forkIO action = IO $ \ s ->
- case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
- where
- action_plus =
- catchException action
- (topHandler False{-don't quit on exception raised-})
-
-{-# INLINE fork #-}
-fork :: a -> b -> b
-fork x y = unsafePerformIO (forkIO (x `seq` return ())) `seq` y
-\end{code}
-
-
-\begin{code}
-max_buff_size :: Int
-max_buff_size = 1
-
-mergeIO :: [a] -> [a] -> IO [a]
-nmergeIO :: [[a]] -> IO [a]
-
-mergeIO ls rs
- = newEmptyMVar >>= \ tail_node ->
- newMVar tail_node >>= \ tail_list ->
- newQSem max_buff_size >>= \ e ->
- newMVar 2 >>= \ branches_running ->
- let
- buff = (tail_list,e)
- in
- forkIO (suckIO branches_running buff ls) >>
- forkIO (suckIO branches_running buff rs) >>
- takeMVar tail_node >>= \ val ->
- signalQSem e >>
- return val
-
-type Buffer a
- = (MVar (MVar [a]), QSem)
-
-suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
-
-suckIO branches_running buff@(tail_list,e) vs
- = case vs of
- [] -> takeMVar branches_running >>= \ val ->
- if val == 1 then
- takeMVar tail_list >>= \ node ->
- putMVar node [] >>
- putMVar tail_list node
- else
- putMVar branches_running (val-1)
- (x:xs) ->
- waitQSem e >>
- takeMVar tail_list >>= \ node ->
- newEmptyMVar >>= \ next_node ->
- unsafeInterleaveIO (
- takeMVar next_node >>= \ x ->
- signalQSem e >>
- return x) >>= \ next_node_val ->
- putMVar node (x:next_node_val) >>
- putMVar tail_list next_node >>
- suckIO branches_running buff xs
-
-nmergeIO lss
- = let
- len = length lss
- in
- newEmptyMVar >>= \ tail_node ->
- newMVar tail_node >>= \ tail_list ->
- newQSem max_buff_size >>= \ e ->
- newMVar len >>= \ branches_running ->
- let
- buff = (tail_list,e)
- in
- mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
- takeMVar tail_node >>= \ val ->
- signalQSem e >>
- return val
- where
- mapIO f xs = sequence (map f xs)
-\end{code}
+++ /dev/null
-# $Id: Makefile,v 1.9 1999/10/29 13:55:40 sof Exp $
-#
-# Makefile for concurrent libraries.
-#
-
-TOP = ../..
-include $(TOP)/mk/boilerplate.mk
-
-WAYS=$(GhcLibWays)
-
-HC = $(GHC)
-
-#-----------------------------------------------------------------------------
-# Setting the standard variables
-#
-
-LIBRARY = libHSconcurrent$(_way).a
-HS_SRCS = $(wildcard *.lhs)
-HS_OBJS = $(HS_SRCS:.lhs=.$(way_)o)
-LIBOBJS = $(HS_OBJS)
-HS_IFACES= $(HS_SRCS:.lhs=.$(way_)hi)
-
-
-#-----------------------------------------------------------------------------
-# Setting the GHC compile options
-
-SRC_HC_OPTS += -recomp -cpp -fglasgow-exts -fvia-C -Rghc-timing $(GhcLibHcOpts)
-SRC_MKDEPENDHS_OPTS += -optdep--include-prelude
-
-#
-# Profiling options
-WAY_p_HC_OPTS += -GPrelude
-WAY_mr_HC_OPTS += -GPrelude
-
-#
-# Object and interface files have suffixes tagged with their ways
-#
-ifneq "$(way)" ""
-SRC_HC_OPTS += -hisuf $(way_)hi
-endif
-
-Parallel_HC_OPTS += -fglasgow-exts
-
-#-----------------------------------------------------------------------------
-# Dependency generation
-
-SRC_MKDEPENDHS_OPTS += -I$(GHC_INCLUDE_DIR)
-
-DLL_NAME = HSconc.dll
-DLL_IMPLIB_NAME = libHSconcurrent_imp.a
-SRC_BLD_DLL_OPTS += --export-all --output-def=HSconc.def DllVersionInfo.o
-SRC_BLD_DLL_OPTS += -lwinmm -lHSrts_imp -lHScbits_imp -lHS_imp -lgmp -L. -L../../rts/gmp -L../../rts -L../std -L../std/cbits
-
-ifeq "$(way)" "dll"
-all :: DllVersionInfo.o
-endif
-
-#-----------------------------------------------------------------------------
-# Installation; need to install .hi files as well as libraries
-#
-# The interface files are put inside the $(libdir), since they
-# might (potentially) be platform specific..
-#
-# override is used here because for binary distributions, datadir is
-# set on the command line. sigh.
-#
-override datadir:=$(libdir)/imports/concurrent
-
-#
-# Files to install from here
-#
-INSTALL_LIBS += $(LIBRARY)
-INSTALL_DATAS += $(HS_IFACES)
-ifeq "$(EnableWin32DLLs)" "YES"
-INSTALL_PROGS += $(DLL_NAME)
-INSTALL_LIBS += $(patsubst %.a, %_imp.a, $(LIBRARY))
-INSTALL_DATAS += dLL_ifs.hi
-endif
-
-include $(TOP)/mk/target.mk
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[Merge]{Mergeing streams}
-
-Avoiding the loss of ref. transparency by attaching the merge to the
-IO monad.
-
-(The ops. are now defined in Concurrent to avoid module loop trouble).
-
-\begin{code}
-module Merge
- (
- mergeIO
- , nmergeIO
- ) where
-
-import Concurrent
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
-%
-\section[Parallel]{Parallel Constructs}
-
-\begin{code}
-module Parallel (par, seq -- re-exported
-#if defined(__GRANSIM__)
- , parGlobal, parLocal, parAt, parAtAbs, parAtRel, parAtForNow
-#endif
- ) where
-
-import PrelConc ( par )
-
-#if defined(__GRANSIM__)
-import PrelBase
-import PrelErr ( parError )
-import PrelGHC ( parGlobal#, parLocal#, parAt#, parAtAbs#, parAtRel#, parAtForNow# )
-
-{-# INLINE parGlobal #-}
-{-# INLINE parLocal #-}
-{-# INLINE parAt #-}
-{-# INLINE parAtAbs #-}
-{-# INLINE parAtRel #-}
-{-# INLINE parAtForNow #-}
-parGlobal :: Int -> Int -> Int -> Int -> a -> b -> b
-parLocal :: Int -> Int -> Int -> Int -> a -> b -> b
-parAt :: Int -> Int -> Int -> Int -> a -> b -> c -> c
-parAtAbs :: Int -> Int -> Int -> Int -> Int -> a -> b -> b
-parAtRel :: Int -> Int -> Int -> Int -> Int -> a -> b -> b
-parAtForNow :: Int -> Int -> Int -> Int -> a -> b -> c -> c
-
-parGlobal (I# w) (I# g) (I# s) (I# p) x y = case (parGlobal# x w g s p y) of { 0# -> parError; _ -> y }
-parLocal (I# w) (I# g) (I# s) (I# p) x y = case (parLocal# x w g s p y) of { 0# -> parError; _ -> y }
-
-parAt (I# w) (I# g) (I# s) (I# p) v x y = case (parAt# x v w g s p y) of { 0# -> parError; _ -> y }
-parAtAbs (I# w) (I# g) (I# s) (I# p) (I# q) x y = case (parAtAbs# x q w g s p y) of { 0# -> parError; _ -> y }
-parAtRel (I# w) (I# g) (I# s) (I# p) (I# q) x y = case (parAtRel# x q w g s p y) of { 0# -> parError; _ -> y }
-parAtForNow (I# w) (I# g) (I# s) (I# p) v x y = case (parAtForNow# x v w g s p y) of { 0# -> parError; _ -> y }
-
-#endif
-
--- Maybe parIO and the like could be added here later.
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[SampleVar]{Sample variables}
-
-Sample variables are slightly different from a normal @MVar@:
-
-\begin{itemize}
-\item Reading an empty @SampleVar@ causes the reader to block.
- (same as @takeMVar@ on empty @MVar@)
-\item Reading a filled @SampleVar@ empties it and returns value.
- (same as @takeMVar@)
-\item Writing to an empty @SampleVar@ fills it with a value, and
-potentially, wakes up a blocked reader (same as for @putMVar@ on empty @MVar@).
-\item Writing to a filled @SampleVar@ overwrites the current value.
- (different from @putMVar@ on full @MVar@.)
-\end{itemize}
-
-\begin{code}
-module SampleVar
- (
- SampleVar, -- :: type _ =
-
- newEmptySampleVar, -- :: IO (SampleVar a)
- newSampleVar, -- :: a -> IO (SampleVar a)
- emptySampleVar, -- :: SampleVar a -> IO ()
- readSampleVar, -- :: SampleVar a -> IO a
- writeSampleVar -- :: SampleVar a -> a -> IO ()
-
- ) where
-
-import PrelConc
-
-
-type SampleVar a
- = MVar (Int, -- 1 == full
- -- 0 == empty
- -- <0 no of readers blocked
- MVar a)
-
--- Initally, a @SampleVar@ is empty/unfilled.
-
-newEmptySampleVar :: IO (SampleVar a)
-newEmptySampleVar = do
- v <- newEmptyMVar
- newMVar (0,v)
-
-newSampleVar :: a -> IO (SampleVar a)
-newSampleVar a = do
- v <- newEmptyMVar
- putMVar v a
- newMVar (1,v)
-
-emptySampleVar :: SampleVar a -> IO ()
-emptySampleVar v = do
- (readers, var) <- takeMVar v
- if readers >= 0 then
- putMVar v (0,var)
- else
- putMVar v (readers,var)
-
---
--- filled => make empty and grab sample
--- not filled => try to grab value, empty when read val.
---
-readSampleVar :: SampleVar a -> IO a
-readSampleVar svar = do
- (readers,val) <- takeMVar svar
- putMVar svar (readers-1,val)
- takeMVar val
-
---
--- filled => overwrite
--- not filled => fill, write val
---
-writeSampleVar :: SampleVar a -> a -> IO ()
-writeSampleVar svar v = do
- (readers,val) <- takeMVar svar
- case readers of
- 1 ->
- swapMVar val v >>
- putMVar svar (1,val)
- _ ->
- putMVar val v >>
- putMVar svar (min 1 (readers+1), val)
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[Semaphore]{Quantity semaphores}
-
-General/quantity semaphores
-
-\begin{code}
-module Semaphore
- (
- {- abstract -}
- QSem,
-
- newQSem, -- :: Int -> IO QSem
- waitQSem, -- :: QSem -> IO ()
- signalQSem, -- :: QSem -> IO ()
-
- {- abstract -}
- QSemN,
- newQSemN, -- :: Int -> IO QSemN
- waitQSemN, -- :: QSemN -> Int -> IO ()
- signalQSemN -- :: QSemN -> Int -> IO ()
-
- ) where
-
-import PrelConc
-\end{code}
-
-General semaphores are also implemented readily in terms of shared
-@MVar@s, only have to catch the case when the semaphore is tried
-waited on when it is empty (==0). Implement this in the same way as
-shared variables are implemented - maintaining a list of @MVar@s
-representing threads currently waiting. The counter is a shared
-variable, ensuring the mutual exclusion on its access.
-
-\begin{code}
-newtype QSem = QSem (MVar (Int, [MVar ()]))
-
-newQSem :: Int -> IO QSem
-newQSem init = do
- sem <- newMVar (init,[])
- return (QSem sem)
-
-waitQSem :: QSem -> IO ()
-waitQSem (QSem sem) = do
- (avail,blocked) <- takeMVar sem -- gain ex. access
- if avail > 0 then
- putMVar sem (avail-1,[])
- else do
- block <- newEmptyMVar
- {-
- Stuff the reader at the back of the queue,
- so as to preserve waiting order. A signalling
- process then only have to pick the MVar at the
- front of the blocked list.
-
- The version of waitQSem given in the paper could
- lead to starvation.
- -}
- putMVar sem (0, blocked++[block])
- takeMVar block
-
-signalQSem :: QSem -> IO ()
-signalQSem (QSem sem) = do
- (avail,blocked) <- takeMVar sem
- case blocked of
- [] -> putMVar sem (avail+1,[])
-
- (block:blocked') -> do
- putMVar sem (0,blocked')
- putMVar block ()
-
-\end{code}
-
-
-\begin{code}
-newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))
-
-newQSemN :: Int -> IO QSemN
-newQSemN init = do
- sem <- newMVar (init,[])
- return (QSemN sem)
-
-waitQSemN :: QSemN -> Int -> IO ()
-waitQSemN (QSemN sem) sz = do
- (avail,blocked) <- takeMVar sem -- gain ex. access
- if (avail - sz) > 0 then
- -- discharging 'sz' still leaves the semaphore
- -- in an 'unblocked' state.
- putMVar sem (avail-sz,[])
- else do
- block <- newEmptyMVar
- putMVar sem (avail, blocked++[(sz,block)])
- takeMVar block
-
-signalQSemN :: QSemN -> Int -> IO ()
-signalQSemN (QSemN sem) n = do
- (avail,blocked) <- takeMVar sem
- (avail',blocked') <- free (avail+n) blocked
- putMVar sem (avail',blocked')
- where
- free avail [] = return (avail,[])
- free avail ((req,block):blocked)
- | avail >= req = do
- putMVar block ()
- free (avail-req) blocked
- | otherwise = do
- (avail',blocked') <- free avail blocked
- return (avail',(req,block):blocked')
-
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1996
-%
-
-\section[Addr]{Module @Addr@}
-
-\begin{code}
-#include "MachDeps.h"
-
-module Addr
- ( Addr
-
- , module Addr
-#ifndef __HUGS__
- , module Word
- , module Int
- , module PrelAddr
-#endif
-
- -- (non-standard) coercions
- , addrToInt -- :: Addr -> Int
- , intToAddr -- :: Int -> Addr
-
- ) where
-
-import NumExts
-#ifndef __HUGS__
-import PrelAddr
-import PrelForeign
-import PrelStable
-import PrelBase
-import PrelIOBase ( IO(..) )
-import Word ( indexWord8OffAddr, indexWord16OffAddr
- , indexWord32OffAddr, indexWord64OffAddr
- , readWord8OffAddr, readWord16OffAddr
- , readWord32OffAddr, readWord64OffAddr
- , writeWord8OffAddr, writeWord16OffAddr
- , writeWord32OffAddr, writeWord64OffAddr
- )
-
-import Int ( indexInt8OffAddr, indexInt16OffAddr
- , indexInt32OffAddr, indexInt64OffAddr
- , readInt8OffAddr, readInt16OffAddr
- , readInt32OffAddr, readInt64OffAddr
- , writeInt8OffAddr, writeInt16OffAddr
- , writeInt32OffAddr, writeInt64OffAddr
- )
-#endif
-
-\end{code}
-
-\begin{code}
-#ifdef __HUGS__
-instance Show Addr where
- showsPrec p addr rs = pad_out (showHex int "") rs
- where
- -- want 0s prefixed to pad it out to a fixed length.
- pad_out ('0':'x':ls) rs =
- '0':'x':(replicate (2*ADDR_SIZE_IN_BYTES - length ls) '0')
- ++ ls ++ rs
- int = primAddrToInt addr
-#else
-instance Show Addr where
- showsPrec p (A# a) rs = pad_out (showHex int "") rs
- where
- -- want 0s prefixed to pad it out to a fixed length.
- pad_out ('0':'x':ls) rs =
- '0':'x':(replicate (2*ADDR_SIZE_IN_BYTES - length ls) '0') ++ ls ++ rs
-
- int =
- case word2Integer# (int2Word# (addr2Int# a)) of
- (# s, d #) -> J# s d
-#endif
-\end{code}
-
-
-Coercing between machine ints and words
-
-\begin{code}
-addrToInt :: Addr -> Int
-intToAddr :: Int -> Addr
-
-#ifdef __HUGS__
-addrToInt = primAddrToInt
-intToAddr = primIntToAddr
-#else
-addrToInt (A# a#) = I# (addr2Int# a#)
-intToAddr (I# i#) = A# (int2Addr# i#)
-#endif
-\end{code}
-
-Indexing immutable memory:
-
-\begin{code}
-indexCharOffAddr :: Addr -> Int -> Char
-indexIntOffAddr :: Addr -> Int -> Int
-indexWordOffAddr :: Addr -> Int -> Word
---in PrelAddr: indexAddrOffAddr :: Addr -> Int -> Addr
-indexFloatOffAddr :: Addr -> Int -> Float
-indexDoubleOffAddr :: Addr -> Int -> Double
-indexStablePtrOffAddr :: Addr -> Int -> StablePtr a
-
-#ifdef __HUGS__
-indexCharOffAddr = error "TODO: indexCharOffAddr "
-indexIntOffAddr = error "TODO: indexIntOffAddr "
-indexWordOffAddr = error "TODO: indexWordOffAddr "
-indexAddrOffAddr = error "TODO: indexAddrOffAddr "
-indexFloatOffAddr = error "TODO: indexFloatOffAddr "
-indexDoubleOffAddr = error "TODO: indexDoubleOffAddr"
-indexStablePtrOffAddr = error "TODO: indexStablePtrOffAddr"
-#else
-indexCharOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexCharOffAddr# addr# n# of { r# ->
- (C# r#)}}
-
-indexIntOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexIntOffAddr# addr# n# of { r# ->
- (I# r#)}}
-
-indexWordOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexWordOffAddr# addr# n# of { r# ->
- (W# r#)}}
-
-indexFloatOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexFloatOffAddr# addr# n# of { r# ->
- (F# r#)}}
-
-indexDoubleOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexDoubleOffAddr# addr# n# of { r# ->
- (D# r#)}}
-
-indexStablePtrOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexStablePtrOffAddr# addr# n# of { r# ->
- (StablePtr r#)}}
-#endif
-\end{code}
-
-Indexing mutable memory:
-
-\begin{code}
-readCharOffAddr :: Addr -> Int -> IO Char
-readIntOffAddr :: Addr -> Int -> IO Int
-readWordOffAddr :: Addr -> Int -> IO Word
-readAddrOffAddr :: Addr -> Int -> IO Addr
-readFloatOffAddr :: Addr -> Int -> IO Float
-readDoubleOffAddr :: Addr -> Int -> IO Double
-readStablePtrOffAddr :: Addr -> Int -> IO (StablePtr a)
-
-#ifdef __HUGS__
-readCharOffAddr = error "TODO: readCharOffAddr "
-readIntOffAddr = error "TODO: readIntOffAddr "
-readWordOffAddr = error "TODO: readWordOffAddr "
-readAddrOffAddr = error "TODO: readAddrOffAddr "
-readFloatOffAddr = error "TODO: readFloatOffAddr "
-readDoubleOffAddr = error "TODO: readDoubleOffAddr "
-readStablePtrOffAddr = error "TODO: readStablePtrOffAddr"
-#else
-readCharOffAddr a i = case indexCharOffAddr a i of { C# o# -> return (C# o#) }
-readIntOffAddr a i = case indexIntOffAddr a i of { I# o# -> return (I# o#) }
-readWordOffAddr a i = case indexWordOffAddr a i of { W# o# -> return (W# o#) }
-readAddrOffAddr a i = case indexAddrOffAddr a i of { A# o# -> return (A# o#) }
-readFloatOffAddr a i = case indexFloatOffAddr a i of { F# o# -> return (F# o#) }
-readDoubleOffAddr a i = case indexDoubleOffAddr a i of { D# o# -> return (D# o#) }
-readStablePtrOffAddr a i = case indexStablePtrOffAddr a i of { StablePtr x -> return (StablePtr x) }
-#endif
-\end{code}
-
-
-\begin{code}
-writeCharOffAddr :: Addr -> Int -> Char -> IO ()
-writeIntOffAddr :: Addr -> Int -> Int -> IO ()
-writeWordOffAddr :: Addr -> Int -> Word -> IO ()
-writeAddrOffAddr :: Addr -> Int -> Addr -> IO ()
-writeFloatOffAddr :: Addr -> Int -> Float -> IO ()
-writeDoubleOffAddr :: Addr -> Int -> Double -> IO ()
-
-#ifdef __HUGS__
-writeCharOffAddr = error "TODO: writeCharOffAddr "
-writeIntOffAddr = error "TODO: writeIntOffAddr "
-writeWordOffAddr = error "TODO: writeWordOffAddr "
-writeAddrOffAddr = error "TODO: writeAddrOffAddr "
-writeFloatOffAddr = error "TODO: writeFloatOffAddr "
-writeDoubleOffAddr = error "TODO: writeDoubleOffAddr "
-#else
-writeCharOffAddr (A# a#) (I# i#) (C# c#) = IO $ \ s# ->
- case (writeCharOffAddr# a# i# c# s#) of s2# -> (# s2#, () #)
-
-writeIntOffAddr (A# a#) (I# i#) (I# e#) = IO $ \ s# ->
- case (writeIntOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
-
-writeWordOffAddr (A# a#) (I# i#) (W# e#) = IO $ \ s# ->
- case (writeWordOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
-
-writeAddrOffAddr (A# a#) (I# i#) (A# e#) = IO $ \ s# ->
- case (writeAddrOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
-
-writeFloatOffAddr (A# a#) (I# i#) (F# e#) = IO $ \ s# ->
- case (writeFloatOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
-
-writeDoubleOffAddr (A# a#) (I# i#) (D# e#) = IO $ \ s# ->
- case (writeDoubleOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
-
-#ifndef __PARALLEL_HASKELL__
-writeForeignObjOffAddr :: Addr -> Int -> ForeignObj -> IO ()
-writeForeignObjOffAddr (A# a#) (I# i#) (ForeignObj e#) = IO $ \ s# ->
- case (writeForeignObjOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
-#endif
-
-writeStablePtrOffAddr :: Addr -> Int -> StablePtr a -> IO ()
-writeStablePtrOffAddr (A# a#) (I# i#) (StablePtr e#) = IO $ \ s# ->
- case (writeStablePtrOffAddr# a# i# e# s#) of s2# -> (# s2# , () #)
-
-#endif
-\end{code}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $Id: AxiomTesting.lhs,v 1.1 1999/10/25 05:19:22 andy Exp $
-%
-% (c) The Hugs/GHC Team 1999
-%
-
-This is a testing framework for using axiomatic like specifications
-of equalities.
-
-\begin{code}
-module AxiomTesting (
- TestM, -- abstract
- (&&&),
- (|||),
- funVar,
- displayVars,
- testRules,
- var,
- vars,
- ALPHA, BETA, GAMMA,
- EqALPHA, OrdALPHA,
- testAssoc,
- -- advanced user functions below
- Example(..),
- testComplete,
- testFail,
- bottom,
- bottomExample,
- ) where
-
-import Monad
-import IO
-import List
-import IOExts
-import Exception (tryAll)
-import IOExts (unsafePtrEq)
-
-infix 4 <==>
-infixl 3 &&&
-infixl 2 |||
-
-------------------------------------------------------------------------------
-
-newtype TestM a = TestM { runTestM :: TestMState -> IO (TestMResult a) }
-
-data TestMState = TestMState {
- uniqIds :: IORef Int,
- bindingPairs :: [(String,String)]
- }
-
-initTestMState ref = TestMState {
- uniqIds = ref,
- bindingPairs = []
- }
-
-data TestMResult a
- = TestMComplete !Int
- | TestMFail TestMState
- | TestMOk [(a,TestMState)]
-
-runTestsM :: (a -> TestM b) -> [(a,TestMState)]
- -> [(b,TestMState)] -> Int -> IO (TestMResult b)
-runTestsM f [] [] n = return (TestMComplete n)
-runTestsM f [] xs n = return (TestMOk xs)
-runTestsM f ((a,s):as) ys n =
- do r <- runTestM (f a) s
- case r of
- (TestMFail _) -> return r
- (TestMComplete m) -> runTestsM f as ys (n+m)
- (TestMOk xs) -> runTestsM f as (xs++ys) n
-
-instance Monad TestM where
- return v = TestM (\ b -> return (TestMOk [(v,b)]))
- p >>= f = TestM (\ b ->
- do res <- runTestM p b
- case res of
- (TestMComplete m) -> return (TestMComplete m)
- (TestMFail f) -> return (TestMFail f)
- -- The following pattern is an optimization
- TestMOk [(x,s)] -> runTestM (f x) s
- TestMOk xs -> runTestsM f xs [] 0)
-
-runIOTestM :: IO a -> TestM a
-runIOTestM m = TestM (\ b -> do { r <- m ; return (TestMOk [(r,b)]) })
-
-testComplete = TestM (\ b -> return (TestMComplete 1))
-testFail = TestM (\ b -> return (TestMFail b))
-
-
-oneTest :: TestM () -> TestM ()
-oneTest p =
- TestM (\ b -> do r <- runTestM p b
- case r of
- (TestMComplete n) -> return (TestMComplete 1)
- other -> return other)
-
-{-
- - This also has the nice effect of stoping the bindings
- - of vars escaping for each side of the test.
- - This is why (>>=) does not have this semantics.
- -
- -}
-
-(&&&) :: TestM () -> TestM () -> TestM ()
-(&&&) p q =
- TestM (\ b -> do r <- runTestM p b
- case r of
- (TestMComplete n) ->
- do r2 <- runTestM q b
- case r2 of
- (TestMComplete m) -> return (TestMComplete (n+m))
- other -> return other
- (TestMFail _) -> return r
- _ -> return (error "&&& failed"))
-
-
-(|||) :: TestM () -> TestM () -> TestM ()
-(|||) p q =
- TestM (\ b -> do r <- runTestM p b
- case r of
- (TestMComplete n) -> return r
- (TestMFail _) -> runTestM q b
- _ -> return (error "||| failed"))
-
-pairUp :: String -> [(a,String)] -> TestM a
-pairUp name pairs =
- TestM (\ b ->
- do return (TestMOk [
- (a,b { bindingPairs = (name,r) : bindingPairs b })
- | (a,r) <- pairs ]))
-
-funVar :: String -> String -> TestM ()
-funVar name r = pairUp name [((),r)]
-
-uniqId :: TestM Int
-uniqId = TestM (\ s ->
- do v <- readIORef (uniqIds s)
- let v' = v + 1
- writeIORef (uniqIds s) v'
- return (TestMOk [(v',s)]))
-{-
- - For debugging, you can make the monad display each binding
- - it is using.
- -}
-displayVars :: TestM ()
-displayVars = TestM (\ s ->
- do putStr "\n"
- sequence_ [putStr (" ** " ++ k ++ " = " ++ v ++ "\n")
- | (k,v) <- reverse (bindingPairs s) ]
- return (TestMOk [((),s)]))
-
-------------------------------------------------------------------------------
-{-
- - This function lets you test a list of rules
- - about a specific function.
- -}
-
-testRules :: String -> [TestM ()] -> IO ()
-testRules name actions =
- do putStr (rjustify 25 name ++ " : ")
- f <- tr 1 actions [] 0
- mapM fa f
- return ()
- where
- rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s
-
- tr n [] [] c = do {
- putStr (rjustify (45 - n) (" (" ++ show c ++ ")\n")) ;
- return [] }
- tr n [] xs c = do { putStr ("\n") ; return xs }
- tr n (action:actions) others c =
- do ref <- newIORef 0
- r <- runTestM action (initTestMState ref)
- case r of
- (TestMComplete m)
- -> do { putStr "." ;
- tr (n+1) actions others (c+m) }
- TestMFail f -> do { putStr "#" ;
- tr (n+1) actions ((n,f):others) c}
- _ -> do { putStr "?" ; tr (n+1) actions others c}
-
-
- fa (n,f) =
- do putStr "\n"
- putStr (" ** test "
- ++ show n
- ++ " of "
- ++ name
- ++ " failed with the binding(s)\n")
- sequence_ [putStr (" ** " ++ k ++ " = " ++ v ++ "\n")
- | (k,v) <- reverse (bindingPairs f) ]
- putStr "\n"
-
-var :: (Example a) => String -> TestM a
-var name =
- do pairs <- getVars
- pairUp name pairs
-
-vars :: (Example a,Show a) => String -> [a] -> TestM a
-vars name as =
- do pairUp name [(a,show a) | a <- as ]
-
-------------------------------------------------------------------------------
-
-class Example a where
- -- A list of examples of values at this type.
- getVars :: TestM [(a,String)]
-
- -- A version of equality, where _|_ == _|_ ==> True, not _|_
-
- (<==>) :: a -> a -> TestM ()
- (<==>) a b =
- do r <- runIOTestM (magicTest a b)
- case r of
- Same -> testComplete
- PerhapsSame -> oneTest (a `equ` b)
- Different -> testFail
-
- isFinite :: a -> TestM ()
- isFinite a =
- do r <- runIOTestM (magicTest a bottom)
- case r of
- -- If this is _|_, then this check
- -- is over, because this guard is not met.
- -- but we return success, because the
- -- overall problem was ok.
- -- returning "return ()" whould
- -- continue the test.
- -- (A bit like F => ? ==> T)
- Same -> testComplete
- _ -> isFiniteSpine a
-
- -- protected, use only for defintions of things.
- equ :: a -> a -> TestM ()
- equ _ _ = testFail
-
- isFiniteSpine :: a -> TestM ()
- isFiniteSpine _ = return ()
-
-data BotCmp = Same | PerhapsSame | Different
-
-------------------------------------------------------------------------------
--- All the compile specific parts are captured inside
--- the function magicTest.
-
-#if __HUGS__
-
--- Old, Classic Hugs version
-primitive catchError :: a -> Maybe a
-
-magicTest :: a -> a -> IO BotCmp
-magicTest a b =
- if unsafePtrEq a b then return Same
- else case (catchError a,catchError b) of
- (Nothing,Nothing) -> return Same
- (Just a,Just b) -> return PerhapsSame
- _ -> return Different
-
-
-#else
-
-magicTest :: a -> a -> IO BotCmp
-magicTest a b =
- if unsafePtrEq a b then return Same
- else do a' <- tryAll a
- b' <- tryAll b
- case (a',b') of
- (Left _,Left _) -> return Same
- (Right _,Right _) -> return PerhapsSame
- _ -> return Different
-
-#endif
-------------------------------------------------------------------------------
-
-bottom = error "bottom"
-bottomExample = [(bottom,"_|_")]
-
-cmp a b = if (a == b) then testComplete else testFail
-
-render :: (Show a) => [a] -> [(a,String)]
-render as = [ (a,show a) | a <- as ]
-
-instance Example Char where
- getVars = return (render ['a','z'] ++ bottomExample)
- equ a b = cmp a b
-
-instance Example Float where
- getVars = return (render [0.0,1.0,999.0] ++ bottomExample)
- equ a b = cmp a b
-
-instance Example Double where
- getVars = return (render [0.0,1.0,999.0] ++ bottomExample)
- equ a b = cmp a b
-
-instance Example Integer where
- getVars = return (render [-1,1,1] ++ bottomExample)
- equ a b = cmp a b
-
-instance Example () where
- getVars = return (render [()] ++ bottomExample)
- equ a b = cmp a b
-
-instance Example Int where
- getVars = return (render [0,1,2,minBound,maxBound] ++ bottomExample)
- equ a b = cmp a b
-
-instance Example Bool where
- getVars = return (render [True,False] ++ bottomExample)
- equ a b = cmp a b
-
-instance Example a => Example [a] where
- getVars =
- do e1 <- getVars
- e2 <- getVars
- return (
- concat [ [ ([e],"[" ++ t ++ "]"),
- (e:bottom,t ++ ":_|_") ]
- | (e,t) <- e1 ]
- ++ [ ([e1,e2],
- "[" ++ t1 ++ "," ++ t2 ++ "]")
- | (e1,t1) <- e1, (e2,t2) <- e2 ]
- ++ [ ([e1,e2,e1],
- "[" ++ t1 ++ "," ++ t2 ++ "," ++ t1 ++ "]")
- | (e1,t1) <- e1, (e2,t2) <- e2 ]
- ++ [ ([],"[]")]
- ++ bottomExample)
-
- equ [] [] = testComplete
- equ (a:as) (b:bs) = (a <==> b) &&& (as <==> bs)
- equ _ _ = testFail
-
- isFiniteSpine [] = return ()
- isFiniteSpine (_:xs) = isFinite xs
-
-instance Example a => Example (Maybe a) where
- getVars =
- do e1 <- getVars
- return (
- [ (Just e,"Just " ++ t)
- | (e,t) <- e1 ]
- ++ [ (Nothing,"Nothing")]
- ++ bottomExample)
-
- equ Nothing Nothing = testComplete
- equ (Just a) (Just b) = a <==> b
- equ _ _ = testFail
-
- isFiniteSpine Nothing = return ()
- isFiniteSpine (Just _) = return ()
-
-------------------------------------------------------------------------------
-
-{- We pick something isomorphic to ints because of the
- - shape of the domain.
- -
- - ... -1 0 1 ...
- - \ | /
- - \ /
- - _|_
- -}
-
-class PolyExample a where
- mkPoly :: Int -> a
- unPoly :: a -> Int
- namePoly :: a -> String
-
- equPoly :: a -> a -> TestM ()
- equPoly a b = (unPoly a) <==> (unPoly b)
-
- getPolyVars :: TestM [(a,String)]
- getPolyVars =
- do n <- uniqId
- return ([mkPair (mkPoly 0) 0,
- mkPair (mkPoly n) n] ++ bottomExample)
- where
- mkPair a n = (a,namePoly a ++ "_" ++ show n)
-
-------------------------------------------------------------------------------
-
-newtype ALPHA = ALPHA { unALPHA :: Int }
-
-instance PolyExample ALPHA where
- mkPoly = ALPHA
- unPoly = unALPHA
- namePoly = const "a"
-
-instance Example ALPHA where { equ = equPoly ; getVars = getPolyVars }
-
-newtype BETA = BETA { unBETA :: Int }
-
-instance PolyExample BETA where
- mkPoly = BETA
- unPoly = unBETA
- namePoly = const "b"
-
-instance Example BETA where { equ = equPoly ; getVars = getPolyVars }
-
-newtype GAMMA = GAMMA { unGAMMA :: Int }
-
-instance PolyExample GAMMA where
- mkPoly = GAMMA
- unPoly = unGAMMA
- namePoly = const "c"
-
-instance Example GAMMA where { equ = equPoly ; getVars = getPolyVars }
-
-newtype EqALPHA = EqALPHA { unEqALPHA :: Int }
- deriving (Eq)
-
-instance PolyExample EqALPHA where
- mkPoly = EqALPHA
- unPoly = unEqALPHA
- namePoly = const "a"
-
-instance Example EqALPHA where { equ = equPoly ; getVars = getPolyVars }
-
-newtype OrdALPHA = OrdALPHA { unOrdALPHA :: Int }
- deriving (Eq,Ord)
-
-instance PolyExample OrdALPHA where
- mkPoly = OrdALPHA
- unPoly = unOrdALPHA
- namePoly = const "b"
-
-instance Example OrdALPHA where { equ = equPoly ; getVars = getPolyVars }
-
-------------------------------------------------------------------------------
--- More Utilities
-
-testAssoc :: (Example a) => (a -> a -> a) -> TestM ()
-testAssoc fn =
- do x <- var "x"
- y <- var "y"
- z <- var "z"
- ((x `fn` (y `fn` z)) <==> ((x `fn` y) `fn` z))
-
-------------------------------------------------------------------------------
-\end{code}
-
-Example specifications. They all have type IO ().
-
-test_concat = testRules "concat" [
- do (xss :: [[ALPHA]]) <- var "xss"
- concat xss <==> foldr (++) [] xss
- ]
-
-test_head = testRules "head" [
- let def_head (x:_) = x
- def_head [] = error ""
- in do (xs :: [ALPHA]) <- var "xs"
- head xs <==> def_head xs
- ]
-
-test_sort = testRules "sort" [
- do (xs :: [OrdALPHA]) <- var "xs"
- sort xs <==> sortBy compare xs,
- do (xs :: [OrdALPHA]) <- var "xs"
- head (sort xs) <==> minimum xs,
- do (xs :: [OrdALPHA]) <- var "xs"
- last (sort xs) <==> maximum xs,
- do (xs :: [OrdALPHA]) <- var "xs"
- (ys :: [OrdALPHA]) <- var "ys"
- (null xs <==> True)
- ||| (null ys <==> True)
- ||| (head (sort (xs ++ ys)) <==> min (minimum xs) (minimum ys)),
- do (xs :: [OrdALPHA]) <- var "xs"
- (ys :: [OrdALPHA]) <- var "ys"
- (null xs <==> True)
- ||| (null ys <==> True)
- ||| (last (sort (xs ++ ys)) <==> max (maximum xs) (maximum ys))
- ]
-
-test_map = testRules "map" [
- let def_map f [] = []
- def_map f (x:xs) = f x : def_map f xs
- test f fn =
- do funVar "f" fn
- xs <- var "xs"
- map f xs <==> def_map f xs
- in
- test (id :: ALPHA -> ALPHA)
- "id"
- &&& test ((\ a -> a + 1) :: Int -> Int)
- "\\ a -> a + 1"
- &&& test ((\ a -> bottom) :: Int -> Int)
- "\\ a -> _|_",
- do (xs :: [ALPHA]) <- var "xs"
- xs <==> map id xs
- ]
-
-test_int_plus = testRules "(+)::Int->Int->Int" [
- testAssoc ((+) :: Int -> Int -> Int)
- ]
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\section[Bits]{The @Bits@ interface}
-
-Defines the @Bits@ class containing bit-based operations.
-See library document for details on the semantics of the
-individual operations.
-
-\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-
-module Bits where
-
-#ifndef __HUGS__
-import PrelBase
-#endif
-
---ADR: The fixity for .|. conflicts with that for .|. in Fran.
--- Removing all fixities is a fairly safe fix; fixing the "one fixity
--- per symbol per program" limitation in Hugs would take a lot longer.
-#ifndef __HUGS__
-infixl 8 `shift`, `rotate`
-infixl 7 .&.
-infixl 6 `xor`
-infixl 5 .|.
-#endif
-
-class Bits a where
- (.&.), (.|.), xor :: a -> a -> a
- complement :: a -> a
- shift :: a -> Int -> a
- rotate :: a -> Int -> a
- bit :: Int -> a
- setBit :: a -> Int -> a
- clearBit :: a -> Int -> a
- complementBit :: a -> Int -> a
- testBit :: a -> Int -> Bool
- bitSize :: a -> Int
- isSigned :: a -> Bool
-
-shiftL, shiftR :: Bits a => a -> Int -> a
-rotateL, rotateR :: Bits a => a -> Int -> a
-shiftL a i = shift a i
-shiftR a i = shift a (-i)
-rotateL a i = rotate a i
-rotateR a i = rotate a (-i)
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1997
-%
-\section[ByteArray]{The @ByteArray@ interface}
-
-Immutable, read-only chunks of bytes, the @ByteArray@ collects
-together the definitions in @ArrBase@ and exports them as one.
-
-\begin{code}
-module ByteArray
- (
- ByteArray(..), -- not abstract, for now. Instance of : CCallable, Eq.
- Ix,
-
- newByteArray, -- :: Ix ix => (ix,ix) -> ST s (ByteArray ix)
-
- --Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
- indexCharArray, -- :: Ix ix => ByteArray ix -> ix -> Char
- indexIntArray, -- :: Ix ix => ByteArray ix -> ix -> Int
- indexWordArray, -- :: Ix ix => ByteArray ix -> ix -> Word
- indexAddrArray, -- :: Ix ix => ByteArray ix -> ix -> Addr
- indexFloatArray, -- :: Ix ix => ByteArray ix -> ix -> Float
- indexDoubleArray, -- :: Ix ix => ByteArray ix -> ix -> Double
- indexStablePtrArray, -- :: Ix ix => ByteArray ix -> ix -> (StablePtr a)
-
- sizeofByteArray, -- :: Ix ix => ByteArray ix -> Int
- boundsOfByteArray -- :: Ix ix => ByteArray ix -> (ix, ix)
-
- ) where
-
-import PrelArr
-import PrelBase
-import PrelStable( StablePtr(..) )
-import PrelST
-import Ix
-\end{code}
-
-\begin{code}
-indexStablePtrArray :: Ix ix => ByteArray ix -> ix -> (StablePtr a)
-indexStablePtrArray (ByteArray l u barr#) n
- = case (index (l,u) n) of { I# n# ->
- case indexStablePtrArray# barr# n# of { r# ->
- (StablePtr r#)}}
-\end{code}
-
-The size returned is in bytes.
-
-\begin{code}
-sizeofByteArray :: Ix ix => ByteArray ix -> Int
-sizeofByteArray (ByteArray _ _ arr#) =
- case (sizeofByteArray# arr#) of
- i# -> (I# i#)
-
-boundsOfByteArray :: Ix ix => ByteArray ix -> (ix, ix)
-boundsOfByteArray (ByteArray l u _) = (l,u)
-\end{code}
-
-\begin{code}
-newByteArray :: Ix ix => (ix,ix) -> ST s (ByteArray ix)
-newByteArray ixs = do
- m_arr <- newCharArray ixs
- unsafeFreezeByteArray m_arr
-\end{code}
-
-If it should turn out to be an issue, could probably be speeded
-up quite a bit.
-
-\begin{code}
-instance Ix ix => Eq (ByteArray ix) where
- b1 == b2 = eqByteArray b1 b2
-
-eqByteArray :: Ix ix => ByteArray ix -> ByteArray ix -> Bool
-eqByteArray b1 b2 =
- sizeofByteArray b1 == sizeofByteArray b2 &&
- all (\ x -> indexCharArray b1 x == indexCharArray b2 x) (range (boundsOfByteArray b1))
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1996
-%
-
-\section[CCall]{Module @CCall@}
-
-\begin{code}
-module CCall ( module PrelCCall ) where
-
-import PrelCCall
-\end{code}
+++ /dev/null
-%
-% (c) AQUA Project, Glasgow University, 1998
-%
-
-Cheap and cheerful dynamic types.
-
-The Dynamic interface is part of the Hugs/GHC standard
-libraries, providing basic support for dynamic types.
-
-Operations for injecting values of arbitrary type into
-a dynamically typed value, Dynamic, are provided, together
-with operations for converting dynamic values into a concrete
-(monomorphic) type.
-
-The Dynamic implementation provided is closely based on code
-contained in Hugs library of the same name.
-
-NOTE: test code at the end, but commented out.
-
-\begin{code}
-module Dynamic
- (
- -- dynamic type
- Dynamic -- abstract, instance of: Show (?)
- , toDyn -- :: Typeable a => a -> Dynamic
- , fromDyn -- :: Typeable a => Dynamic -> a -> a
- , fromDynamic -- :: Typeable a => Dynamic -> Maybe a
-
- -- type representation
-
- , Typeable(typeOf)
- -- class Typeable a where { typeOf :: a -> TypeRep }
-
- -- Dynamic defines Typeable instances for the following
- -- Prelude types: Char, Int, Float, Double, Bool
- -- (), Maybe a, (a->b), [a]
- -- (a,b) (a,b,c) (a,b,c,d) (a,b,c,d,e)
-
- , TypeRep -- abstract, instance of: Eq, Show
- , TyCon -- abstract, instance of: Eq, Show
-
- -- type representation constructors/operators:
- , mkTyCon -- :: String -> TyCon
- , mkAppTy -- :: TyCon -> [TypeRep] -> TypeRep
- , mkFunTy -- :: TypeRep -> TypeRep -> TypeRep
- , applyTy -- :: TypeRep -> TypeRep -> Maybe TypeRep
-
- --
- -- let iTy = mkTyCon "Int" in show (mkAppTy (mkTyCon ",,")
- -- [iTy,iTy,iTy])
- --
- -- returns "(Int,Int,Int)"
- --
- -- The TypeRep Show instance promises to print tuple types
- -- correctly. Tuple type constructors are specified by a
- -- sequence of commas, e.g., (mkTyCon ",,,,,,") returns
- -- the 7-tuple tycon.
- ) where
-
-{- BEGIN_FOR_GHC
-import GlaExts
-import PrelDynamic
- END_FOR_GHC -}
-
-import IOExts
- ( unsafePerformIO,
- IORef, newIORef, readIORef, writeIORef
- )
-
-{- BEGIN_FOR_HUGS -}
-import
- PreludeBuiltin
-
-unsafeCoerce = primUnsafeCoerce
-{- END_FOR_HUGS -}
-
-{- BEGIN_FOR_GHC
-unsafeCoerce :: a -> b
-unsafeCoerce = unsafeCoerce#
- END_FOR_GHC -}
-\end{code}
-
-The dynamic type is represented by Dynamic, carrying
-the dynamic value along with its type representation:
-
-\begin{code}
--- the instance just prints the type representation.
-instance Show Dynamic where
- showsPrec _ (Dynamic t _) =
- showString "<<" .
- showsPrec 0 t .
- showString ">>"
-\end{code}
-
-Operations for going to and from Dynamic:
-
-\begin{code}
-toDyn :: Typeable a => a -> Dynamic
-toDyn v = Dynamic (typeOf v) (unsafeCoerce v)
-
-fromDyn :: Typeable a => Dynamic -> a -> a
-fromDyn (Dynamic t v) def
- | typeOf def == t = unsafeCoerce v
- | otherwise = def
-
-fromDynamic :: Typeable a => Dynamic -> Maybe a
-fromDynamic (Dynamic t v) =
- case unsafeCoerce v of
- r | t == typeOf r -> Just r
- | otherwise -> Nothing
-\end{code}
-
-(Abstract) universal datatype:
-
-\begin{code}
-instance Show TypeRep where
- showsPrec p (App tycon tys) =
- case tys of
- [] -> showsPrec p tycon
- [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
- xs
- | isTupleTyCon tycon -> showTuple tycon xs
- | otherwise ->
- showParen (p > 9) $
- showsPrec p tycon .
- showChar ' ' .
- showArgs tys
-
- showsPrec p (Fun f a) =
- showParen (p > 8) $
- showsPrec 9 f . showString " -> " . showsPrec 8 a
-\end{code}
-
-To make it possible to convert values with user-defined types
-into type Dynamic, we need a systematic way of getting
-the type representation of an arbitrary type. A type
-class provides just the ticket,
-
-\begin{code}
-class Typeable a where
- typeOf :: a -> TypeRep
-\end{code}
-
-NOTE: The argument to the overloaded `typeOf' is only
-used to carry type information, and Typeable instances
-should *never* *ever* look at its value.
-
-\begin{code}
-isTupleTyCon :: TyCon -> Bool
-isTupleTyCon (TyCon _ (',':_)) = True
-isTupleTyCon _ = False
-
-instance Show TyCon where
- showsPrec _ (TyCon _ s) = showString s
-
-\end{code}
-
-If we enforce the restriction that there is only one
-@TyCon@ for a type & it is shared among all its uses,
-we can map them onto Ints very simply. The benefit is,
-of course, that @TyCon@s can then be compared efficiently.
-
-Provided the implementor of other @Typeable@ instances
-takes care of making all the @TyCon@s CAFs (toplevel constants),
-this will work.
-
-If this constraint does turn out to be a sore thumb, changing
-the Eq instance for TyCons is trivial.
-
-\begin{code}
-mkTyCon :: String -> TyCon
-mkTyCon str = unsafePerformIO $ do
- v <- readIORef uni
- writeIORef uni (v+1)
- return (TyCon v str)
-
-uni :: IORef Int
-uni = unsafePerformIO ( newIORef 0 )
-\end{code}
-
-Some (Show.TypeRep) helpers:
-
-\begin{code}
-showArgs :: Show a => [a] -> ShowS
-showArgs [] = id
-showArgs [a] = showsPrec 10 a
-showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
-
-showTuple :: TyCon -> [TypeRep] -> ShowS
-showTuple (TyCon _ str) args = showChar '(' . go str args
- where
- go [] [a] = showsPrec 10 a . showChar ')'
- go _ [] = showChar ')' -- a failure condition, really.
- go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
- go _ _ = showChar ')'
-\end{code}
-
-\begin{code}
-mkAppTy :: TyCon -> [TypeRep] -> TypeRep
-mkAppTy tyc args = App tyc args
-
-mkFunTy :: TypeRep -> TypeRep -> TypeRep
-mkFunTy f a = Fun f a
-\end{code}
-
-Auxillary functions
-
-\begin{code}
--- (f::(a->b)) `dynApply` (x::a) = (f a)::b
-dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
-dynApply (Dynamic t1 f) (Dynamic t2 x) =
- case applyTy t1 t2 of
- Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))
- Nothing -> Nothing
-
-dynApp :: Dynamic -> Dynamic -> Dynamic
-dynApp f x = case dynApply f x of
- Just r -> r
- Nothing -> error ("Type error in dynamic application.\n" ++
- "Can't apply function " ++ show f ++
- " to argument " ++ show x)
-
-applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
-applyTy (Fun t1 t2) t3
- | t1 == t3 = Just t2
-applyTy _ _ = Nothing
-
-\end{code}
-
-\begin{code}
-instance Typeable Int where
- typeOf _ = mkAppTy intTc []
-
-instance Typeable Char where
- typeOf _ = mkAppTy charTc []
-
-instance Typeable Bool where
- typeOf _ = mkAppTy boolTc []
-
-instance Typeable Float where
- typeOf _ = mkAppTy floatTc []
-
-instance Typeable Double where
- typeOf _ = mkAppTy doubleTc []
-
-instance Typeable Integer where
- typeOf _ = mkAppTy integerTc []
-
-instance Typeable a => Typeable (IO a) where
- typeOf action = mkAppTy ioTc [typeOf (doIO action)]
- where
- doIO :: IO a -> a
- doIO = undefined
-
-instance Typeable a => Typeable [a] where
- typeOf ls = mkAppTy listTc [typeOf (hd ls)]
- where
- hd :: [a] -> a
- hd = undefined
-
-instance Typeable a => Typeable (Maybe a) where
- typeOf mb = mkAppTy maybeTc [typeOf (getJ mb)]
- where
- getJ :: Maybe a -> a
- getJ = undefined
-
-instance (Typeable a, Typeable b) => Typeable (Either a b) where
- typeOf ei = mkAppTy eitherTc [typeOf (getL ei), typeOf (getR ei)]
- where
- getL :: Either a b -> a
- getL = undefined
- getR :: Either a b -> b
- getR = undefined
-
-instance (Typeable a, Typeable b) => Typeable (a -> b) where
- typeOf f = mkFunTy (typeOf (arg f)) (typeOf (res f))
- where
- arg :: (a -> b) -> a
- arg = undefined
-
- res :: (a -> b) -> b
- res = undefined
-
-instance Typeable () where
- typeOf _ = mkAppTy unitTc []
-
-instance Typeable TypeRep where
- typeOf _ = mkAppTy typeRepTc []
-
-instance Typeable TyCon where
- typeOf _ = mkAppTy tyConTc []
-
-instance Typeable Dynamic where
- typeOf _ = mkAppTy dynamicTc []
-
-instance Typeable Ordering where
- typeOf _ = mkAppTy orderingTc []
-
-instance (Typeable a, Typeable b) => Typeable (a,b) where
- typeOf tu = mkAppTy tup2Tc [typeOf (fst tu), typeOf (snd tu)]
- where
- fst :: (a,b) -> a
- fst = undefined
- snd :: (a,b) -> b
- snd = undefined
-
-instance ( Typeable a
- , Typeable b
- , Typeable c) => Typeable (a,b,c) where
- typeOf tu = mkAppTy tup3Tc [ typeOf (fst tu)
- , typeOf (snd tu)
- , typeOf (thd tu)
- ]
- where
- fst :: (a,b,c) -> a
- fst = undefined
- snd :: (a,b,c) -> b
- snd = undefined
- thd :: (a,b,c) -> c
- thd = undefined
-
-instance ( Typeable a
- , Typeable b
- , Typeable c
- , Typeable d) => Typeable (a,b,c,d) where
- typeOf tu = mkAppTy tup4Tc [ typeOf (fst tu)
- , typeOf (snd tu)
- , typeOf (thd tu)
- , typeOf (fth tu)
- ]
- where
- fst :: (a,b,c,d) -> a
- fst = undefined
- snd :: (a,b,c,d) -> b
- snd = undefined
- thd :: (a,b,c,d) -> c
- thd = undefined
- fth :: (a,b,c,d) -> d
- fth = undefined
-
-instance ( Typeable a
- , Typeable b
- , Typeable c
- , Typeable d
- , Typeable e) => Typeable (a,b,c,d,e) where
- typeOf tu = mkAppTy tup5Tc [ typeOf (fst tu)
- , typeOf (snd tu)
- , typeOf (thd tu)
- , typeOf (fth tu)
- , typeOf (ffth tu)
- ]
- where
- fst :: (a,b,c,d,e) -> a
- fst = undefined
- snd :: (a,b,c,d,e) -> b
- snd = undefined
- thd :: (a,b,c,d,e) -> c
- thd = undefined
- fth :: (a,b,c,d,e) -> d
- fth = undefined
- ffth :: (a,b,c,d,e) -> e
- ffth = undefined
-
-\end{code}
-
-@TyCon@s are provided for the following:
-
-\begin{code}
--- prelude types:
-intTc, charTc, boolTc :: TyCon
-intTc = mkTyCon "Int"
-charTc = mkTyCon "Char"
-boolTc = mkTyCon "Bool"
-
-tup2Tc, tup3Tc, tup4Tc, tup5Tc :: TyCon
-tup2Tc = mkTyCon ","
-tup3Tc = mkTyCon ",,"
-tup4Tc = mkTyCon ",,,"
-tup5Tc = mkTyCon ",,,,"
-
-floatTc, doubleTc, integerTc :: TyCon
-floatTc = mkTyCon "Float"
-doubleTc = mkTyCon "Double"
-integerTc = mkTyCon "Integer"
-
-ioTc, maybeTc, eitherTc, listTc :: TyCon
-ioTc = mkTyCon "IO"
-maybeTc = mkTyCon "Maybe"
-eitherTc = mkTyCon "Either"
-listTc = mkTyCon "[]"
-
-unitTc, orderingTc, arrayTc, complexTc, handleTc :: TyCon
-unitTc = mkTyCon "()"
-orderingTc = mkTyCon "Ordering"
-arrayTc = mkTyCon "Array"
-complexTc = mkTyCon "Complex"
-handleTc = mkTyCon "Handle"
-
--- Hugs/GHC extension lib types:
-addrTc, stablePtrTc, mvarTc :: TyCon
-addrTc = mkTyCon "Addr"
-stablePtrTc = mkTyCon "StablePtr"
-mvarTc = mkTyCon "MVar"
-
-foreignObjTc, stTc :: TyCon
-foreignObjTc = mkTyCon "ForeignObj"
-stTc = mkTyCon "ST"
-
-int8Tc, int16Tc, int32Tc, int64Tc :: TyCon
-int8Tc = mkTyCon "Int8"
-int16Tc = mkTyCon "Int16"
-int32Tc = mkTyCon "Int32"
-int64Tc = mkTyCon "Int64"
-
-word8Tc, word16Tc, word32Tc, word64Tc :: TyCon
-word8Tc = mkTyCon "Word8"
-word16Tc = mkTyCon "Word16"
-word32Tc = mkTyCon "Word32"
-word64Tc = mkTyCon "Word64"
-
-tyConTc, typeRepTc, dynamicTc :: TyCon
-tyConTc = mkTyCon "TyCon"
-typeRepTc = mkTyCon "Type"
-dynamicTc = mkTyCon "Dynamic"
-
--- GHC specific:
-{- BEGIN_FOR_GHC
-byteArrayTc, mutablebyteArrayTc, wordTc :: TyCon
-byteArrayTc = mkTyCon "ByteArray"
-mutablebyteArrayTc = mkTyCon "MutableByteArray"
-wordTc = mkTyCon "Word"
- END_FOR_GHC -}
-
-\end{code}
-
-begin{code}
-test1,test2, test3, test4 :: Dynamic
-
-test1 = toDyn (1::Int)
-test2 = toDyn ((+) :: Int -> Int -> Int)
-test3 = dynApp test2 test1
-test4 = dynApp test3 test1
-
-test5, test6,test7 :: Int
-test5 = fromDyn test4 0
-test6 = fromDyn test1 0
-test7 = fromDyn test2 0
-
-test8 :: Dynamic
-test8 = toDyn (mkAppTy listTc)
-
-test9 :: Float
-test9 = fromDyn test8 0
-
-printf :: String -> [Dynamic] -> IO ()
-printf str args = putStr (decode str args)
- where
- decode [] [] = []
- decode ('%':'n':cs) (d:ds) =
- (\ v -> show v++decode cs ds) (fromDyn d (0::Int))
- decode ('%':'c':cs) (d:ds) =
- (\ v -> show v++decode cs ds) (fromDyn d ('\0'))
- decode ('%':'b':cs) (d:ds) =
- (\ v -> show v++decode cs ds) (fromDyn d (False::Bool))
- decode (x:xs) ds = x:decode xs ds
-
-test10 :: IO ()
-test10 = printf "%n = %c, that much is %b\n" [toDyn (3::Int),toDyn 'a', toDyn False]
-end{code}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $Id: Exception.lhs,v 1.7 1999/03/26 19:43:43 sof Exp $
-%
-% (c) The GRAP/AQUA Project, Glasgow University, 1998
-%
-
-The External API for exceptions. The functions provided in this
-module allow catching of exceptions in the IO monad.
-
-\begin{code}
-module Exception (
-
- Exception(..), -- instance Show
- ArithException(..), -- instance Show
- AsyncException(..), -- instance Show
-
- tryAll, -- :: a -> IO (Either Exception a)
- tryAllIO, -- :: IO a -> IO (Either Exception a)
- try, -- :: (Exception -> Maybe b) -> a -> IO (Either b a)
- tryIO, -- :: (Exception -> Maybe b) -> IO a -> IO (Either b a)
-
- catchAll, -- :: a -> (Exception -> IO a) -> IO a
- catchAllIO,-- :: IO a -> (Exception -> IO a) -> IO a
- catch, -- :: (Exception -> Maybe b) -> a -> (b -> IO a) -> IO a
- catchIO, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
-
- -- Exception predicates
-
- justIoErrors, -- :: Exception -> Maybe IOError
- justArithExceptions, -- :: Exception -> Maybe ArithException
- justErrors, -- :: Exception -> Maybe String
- justDynExceptions, -- :: Exception -> Maybe Dynamic
- justAssertions, -- :: Exception -> Maybe String
- justAsyncExceptions, -- :: Exception -> Maybe AsyncException
-
- -- Throwing exceptions
-
- throw, -- :: Exception -> a
- raiseInThread, -- :: ThreadId -> Exception -> a
-
- -- Dynamic exceptions
-
- throwDyn, -- :: Typeable ex => ex -> b
- catchDyn, -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
-
- -- Assertions
-
- assert, -- :: Bool -> a -> a
-
- -- Utilities
-
- finally, -- :: IO a -> IO b -> IO b
-
- bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()
- bracket_, -- :: IO a -> IO b -> IO c -> IO ()
-
- ) where
-
-#ifdef __HUGS__
-import PreludeBuiltin hiding (catch)
-import Prelude hiding (catch)
-#else
-import Prelude hiding (catch)
-import PrelGHC (catch#, assert)
-import PrelException hiding (catch)
-import PrelConc ( raiseInThread )
-#endif
-
-import Dynamic
-\end{code}
-
------------------------------------------------------------------------------
-Catching exceptions
-
-PrelException defines 'catchException' for us.
-
-\begin{code}
-catchAll :: a -> (Exception -> IO a) -> IO a
-#ifdef __HUGS__
-catchAll a handler = primCatch' (case primForce a of () -> return a) handler
-#else
-catchAll a handler = catch# (a `seq` return a) handler
-#endif
-
-catchAllIO :: IO a -> (Exception -> IO a) -> IO a
-catchAllIO = catchException
-
-catch :: (Exception -> Maybe b) -> a -> (b -> IO a) -> IO a
-catch p a handler = catchAll a handler'
- where handler' e = case p e of
- Nothing -> throw e
- Just b -> handler b
-
-catchIO :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
-catchIO p a handler = catchAllIO a handler'
- where handler' e = case p e of
- Nothing -> throw e
- Just b -> handler b
-\end{code}
-
------------------------------------------------------------------------------
-'try' and variations.
-
-\begin{code}
-tryAll :: a -> IO (Either Exception a)
-#ifdef __HUGS__
-tryAll a = primCatch' (case primForce a of { () -> return Nothing})
- (\e -> return (Just e))
-#else
-tryAll a = catch# (a `seq` return (Right a)) (\e -> return (Left e))
-#endif
-
-tryAllIO :: IO a -> IO (Either Exception a)
-tryAllIO a = catchAllIO (a >>= \ v -> return (Right v))
- (\e -> return (Left e))
-
-try :: (Exception -> Maybe b) -> a -> IO (Either b a)
-try p a = do
- r <- tryAll a
- case r of
- Right v -> return (Right v)
- Left e -> case p e of
- Nothing -> throw e
- Just b -> return (Left b)
-
-tryIO :: (Exception -> Maybe b) -> IO a -> IO (Either b a)
-tryIO p a = do
- r <- tryAllIO a
- case r of
- Right v -> return (Right v)
- Left e -> case p e of
- Nothing -> throw e
- Just b -> return (Left b)
-\end{code}
-
------------------------------------------------------------------------------
-Dynamic exception types. Since one of the possible kinds of exception
-is a dynamically typed value, we can effectively have polymorphic
-exceptions.
-
-throwDyn will raise any value as an exception, provided it is in the
-Typeable class (see Dynamic.lhs).
-
-catchDyn will catch any exception of a given type (determined by the
-handler function). Any raised exceptions that don't match are
-re-raised.
-
-\begin{code}
-throwDyn :: Typeable exception => exception -> b
-throwDyn exception = throw (DynException (toDyn exception))
-
-catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a
-catchDyn m k = catchException m handle
- where handle ex = case ex of
- (DynException dyn) ->
- case fromDynamic dyn of
- Just exception -> k exception
- Nothing -> throw ex
- _ -> throw ex
-\end{code}
-
------------------------------------------------------------------------------
-Exception Predicates
-
-\begin{code}
-justIoErrors :: Exception -> Maybe IOError
-justArithExceptions :: Exception -> Maybe ArithException
-justErrors :: Exception -> Maybe String
-justDynExceptions :: Exception -> Maybe Dynamic
-justAssertions :: Exception -> Maybe String
-justAsyncExceptions :: Exception -> Maybe AsyncException
-
-justIoErrors (IOException e) = Just e
-justIoErrors _ = Nothing
-
-justArithExceptions (ArithException e) = Just e
-justArithExceptions _ = Nothing
-
-justErrors (ErrorCall e) = Just e
-justErrors _ = Nothing
-
-justAssertions (AssertionFailed e) = Just e
-justAssertions _ = Nothing
-
-justDynExceptions (DynException e) = Just e
-justDynExceptions _ = Nothing
-
-justAsyncExceptions (AsyncException e) = Just e
-justAsyncExceptions _ = Nothing
-\end{code}
-
------------------------------------------------------------------------------
-Some Useful Functions
-
-\begin{code}
-finally :: IO a -> IO b -> IO b
-a `finally` sequel = do
- tryAllIO a
- sequel
-
-bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
-bracket before after thing = do
- a <- before
- c <- tryAllIO (thing a)
- after a
- case c of
- Right r -> return r
- Left e -> throw e
-
-bracket_ :: IO a -> IO b -> IO c -> IO c
-bracket_ before after thing = do
- before
- c <- tryAllIO thing
- after
- case c of
- Right r -> return r
- Left e -> throw e
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1998
-%
-
-\section[Foreign]{Module @Foreign@}
-
-\begin{code}
-module Foreign
- (
- ForeignObj -- abstract, instance of: Eq
- , makeForeignObj -- :: Addr{-obj-} -> Addr{-finaliser-} -> IO ForeignObj
- , mkForeignObj -- :: Addr -> IO ForeignObj
- , writeForeignObj -- :: ForeignObj -> Addr{-new obj-} -> IO ()
- , addForeignFinalizer -- :: ForeignObj -> IO () -> IO ()
-
- -- the coercion from a foreign obj to an addr is unsafe,
- -- and should not be used unless absolutely necessary.
- , foreignObjToAddr -- :: ForeignObj -> IO Addr
-
- , StablePtr {-a-} -- abstract.
- , makeStablePtr -- :: a -> IO (StablePtr a)
- , deRefStablePtr -- :: StablePtr a -> IO a
- , freeStablePtr -- :: StablePtr a -> IO ()
-
- , indexCharOffForeignObj -- :: ForeignObj -> Int -> Char
-
- , indexIntOffForeignObj -- :: ForeignObj -> Int -> Int
- , indexInt8OffForeignObj -- :: ForeignObj -> Int -> Int8
- , indexInt16OffForeignObj -- :: ForeignObj -> Int -> Int16
- , indexInt32OffForeignObj -- :: ForeignObj -> Int -> Int32
- , indexInt64OffForeignObj -- :: ForeignObj -> Int -> Int64
-
- , indexWord8OffForeignObj -- :: ForeignObj -> Int -> Word
- , indexWord8OffForeignObj -- :: ForeignObj -> Int -> Word8
- , indexWord16OffForeignObj -- :: ForeignObj -> Int -> Word16
- , indexWord32OffForeignObj -- :: ForeignObj -> Int -> Word32
- , indexWord64OffForeignObj -- :: ForeignObj -> Int -> Word64
-
- , indexAddrOffForeignObj -- :: ForeignObj -> Int -> Addr
- , indexFloatOffForeignObj -- :: ForeignObj -> Int -> Float
- , indexDoubleOffForeignObj -- :: ForeignObj -> Int -> Double
-
- , readCharOffForeignObj -- :: ForeignObj -> Int -> IO Char
- , readIntOffForeignObj -- :: ForeignObj -> Int -> IO Int
- , readInt8OffForeignObj -- :: ForeignObj -> Int -> IO Int8
- , readInt16OffForeignObj -- :: ForeignObj -> Int -> IO Int16
- , readInt32OffForeignObj -- :: ForeignObj -> Int -> IO Int32
- , readInt64OffForeignObj -- :: ForeignObj -> Int -> IO Int64
-
- , readWordOffForeignObj -- :: ForeignObj -> Int -> IO Word
- , readWord8OffForeignObj -- :: ForeignObj -> Int -> IO Word8
- , readWord16OffForeignObj -- :: ForeignObj -> Int -> IO Word16
- , readWord32OffForeignObj -- :: ForeignObj -> Int -> IO Word32
- , readWord64OffForeignObj -- :: ForeignObj -> Int -> IO Word64
-
- , readAddrOffForeignObj -- :: ForeignObj -> Int -> IO Addr
- , readFloatOffForeignObj -- :: ForeignObj -> Int -> IO Float
- , readDoubleOffForeignObj -- :: ForeignObj -> Int -> IO Double
-
- , writeCharOffForeignObj -- :: ForeignObj -> Int -> Char -> IO ()
- , writeIntOffForeignObj -- :: ForeignObj -> Int -> Int -> IO ()
- , writeInt8OffForeignObj -- :: ForeignObj -> Int -> Int8 -> IO ()
- , writeInt16OffForeignObj -- :: ForeignObj -> Int -> Int16 -> IO ()
- , writeInt32OffForeignObj -- :: ForeignObj -> Int -> Int32 -> IO ()
- , writeInt64OffForeignObj -- :: ForeignObj -> Int -> Int64 -> IO ()
-
- , writeWordOffForeignObj -- :: ForeignObj -> Int -> Word -> IO ()
- , writeWord8OffForeignObj -- :: ForeignObj -> Int -> Word8 -> IO ()
- , writeWord16OffForeignObj -- :: ForeignObj -> Int -> Word16 -> IO ()
- , writeWord32OffForeignObj -- :: ForeignObj -> Int -> Word32 -> IO ()
- , writeWord64OffForeignObj -- :: ForeignObj -> Int -> Word64 -> IO ()
-
- , writeAddrOffForeignObj -- :: ForeignObj -> Int -> Addr -> IO ()
- , writeFloatOffForeignObj -- :: ForeignObj -> Int -> Float -> IO ()
- , writeDoubleOffForeignObj -- :: ForeignObj -> Int -> Double -> IO ()
-
- ) where
-
-import PrelForeign hiding ( makeForeignObj )
-import PrelStable
-import qualified PrelForeign as PF ( makeForeignObj )
-import PrelBase ( Int(..), Double(..), Float(..), Char(..) )
-import PrelGHC ( indexCharOffForeignObj#, indexIntOffForeignObj#,
- indexAddrOffForeignObj#, indexFloatOffForeignObj#,
- indexDoubleOffForeignObj#, indexWordOffForeignObj#
- )
-import PrelAddr ( Addr(..), Word(..) )
-import PrelWeak ( addForeignFinalizer )
-import Word
- (
- indexWord8OffForeignObj
- , indexWord16OffForeignObj
- , indexWord32OffForeignObj
- , indexWord64OffForeignObj
- , readWord8OffForeignObj
- , readWord16OffForeignObj
- , readWord32OffForeignObj
- , readWord64OffForeignObj
- , writeWord8OffForeignObj
- , writeWord16OffForeignObj
- , writeWord32OffForeignObj
- , writeWord64OffForeignObj
- )
-
-import Int
- (
- indexInt8OffForeignObj
- , indexInt16OffForeignObj
- , indexInt32OffForeignObj
- , indexInt64OffForeignObj
- , readInt8OffForeignObj
- , readInt16OffForeignObj
- , readInt32OffForeignObj
- , readInt64OffForeignObj
- , writeInt8OffForeignObj
- , writeInt16OffForeignObj
- , writeInt32OffForeignObj
- , writeInt64OffForeignObj
- )
-import PrelIOBase ( IO(..) )
-\end{code}
-
-\begin{code}
-foreignObjToAddr :: ForeignObj -> IO Addr
-foreignObjToAddr fo = _casm_ `` %r=(StgAddr)%0; '' fo
-\end{code}
-
-\begin{code}
-makeForeignObj :: Addr -> Addr -> IO ForeignObj
-makeForeignObj obj finalizer = do
- fobj <- PF.makeForeignObj obj
- addForeignFinalizer fobj (app0 finalizer fobj)
- return fobj
-
-mkForeignObj :: Addr -> IO ForeignObj
-mkForeignObj = PF.makeForeignObj
-
-foreign import dynamic unsafe app0 :: Addr -> (ForeignObj -> IO ())
-\end{code}
-
-
-
-\begin{code}
-indexCharOffForeignObj :: ForeignObj -> Int -> Char
-indexCharOffForeignObj (ForeignObj fo#) (I# i#) = C# (indexCharOffForeignObj# fo# i#)
-
-indexIntOffForeignObj :: ForeignObj -> Int -> Int
-indexIntOffForeignObj (ForeignObj fo#) (I# i#) = I# (indexIntOffForeignObj# fo# i#)
-
-indexWordOffForeignObj :: ForeignObj -> Int -> Word
-indexWordOffForeignObj (ForeignObj fo#) (I# i#) = W# (indexWordOffForeignObj# fo# i#)
-
-indexAddrOffForeignObj :: ForeignObj -> Int -> Addr
-indexAddrOffForeignObj (ForeignObj fo#) (I# i#) = A# (indexAddrOffForeignObj# fo# i#)
-
-indexFloatOffForeignObj :: ForeignObj -> Int -> Float
-indexFloatOffForeignObj (ForeignObj fo#) (I# i#) = F# (indexFloatOffForeignObj# fo# i#)
-
-indexDoubleOffForeignObj :: ForeignObj -> Int -> Double
-indexDoubleOffForeignObj (ForeignObj fo#) (I# i#) = D# (indexDoubleOffForeignObj# fo# i#)
-
--- read value out of mutable memory
-readCharOffForeignObj :: ForeignObj -> Int -> IO Char
-readCharOffForeignObj fo i = _casm_ `` %r=(StgChar)(((StgChar*)%0)[(StgInt)%1]); '' fo i
-
-readIntOffForeignObj :: ForeignObj -> Int -> IO Int
-readIntOffForeignObj fo i = _casm_ `` %r=(StgInt)(((StgInt*)%0)[(StgInt)%1]); '' fo i
-
-readWordOffForeignObj :: ForeignObj -> Int -> IO Word
-readWordOffForeignObj fo i = _casm_ `` %r=(StgWord)(((StgWord*)%0)[(StgInt)%1]); '' fo i
-
-readAddrOffForeignObj :: ForeignObj -> Int -> IO Addr
-readAddrOffForeignObj fo i = _casm_ `` %r=(StgAddr)(((StgAddr*)%0)[(StgInt)%1]); '' fo i
-
-readFloatOffForeignObj :: ForeignObj -> Int -> IO Float
-readFloatOffForeignObj fo i = _casm_ `` %r=(StgFloat)(((StgFloat*)%0)[(StgInt)%1]); '' fo i
-
-readDoubleOffForeignObj :: ForeignObj -> Int -> IO Double
-readDoubleOffForeignObj fo i = _casm_ `` %r=(StgDouble)(((StgDouble*)%0)[(StgInt)%1]); '' fo i
-\end{code}
-
-\begin{code}
-writeCharOffForeignObj :: ForeignObj -> Int -> Char -> IO ()
-writeCharOffForeignObj fo i e = _casm_ `` (((StgChar*)%0)[(StgInt)%1])=(StgChar)%2; '' fo i e
-
-writeIntOffForeignObj :: ForeignObj -> Int -> Int -> IO ()
-writeIntOffForeignObj fo i e = _casm_ `` (((StgInt*)%0)[(StgInt)%1])=(StgInt)%2; '' fo i e
-
-writeWordOffForeignObj :: ForeignObj -> Int -> Word -> IO ()
-writeWordOffForeignObj fo i e = _casm_ `` (((StgWord*)%0)[(StgInt)%1])=(StgWord)%2; '' fo i e
-
-writeAddrOffForeignObj :: ForeignObj -> Int -> Addr -> IO ()
-writeAddrOffForeignObj fo i e = _casm_ `` (((StgAddr*)%0)[(StgInt)%1])=(StgAddr)%2; ''fo i e
-
-writeFloatOffForeignObj :: ForeignObj -> Int -> Float -> IO ()
-writeFloatOffForeignObj fo i e = _casm_ `` (((StgFloat*)%0)[(StgInt)%1])=(StgFloat)%2; '' fo i e
-
-writeDoubleOffForeignObj :: ForeignObj -> Int -> Double -> IO ()
-writeDoubleOffForeignObj fo i e = _casm_ `` (((StgDouble*)%0)[(StgInt)%1])=(StgDouble)%2; '' fo i e
-
-\end{code}
+++ /dev/null
-A Haskell port of GNU's getopt library
-
-Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
-changes Dec. 1997)
-
-Two rather obscure features are missing: The Bash 2.0 non-option hack
-(if you don't already know it, you probably don't want to hear about
-it...) and the recognition of long options with a single dash
-(e.g. '-help' is recognised as '--help', as long as there is no short
-option 'h').
-
-Other differences between GNU's getopt and this implementation: * To
-enforce a coherent description of options and arguments, there are
-explanation fields in the option/argument descriptor. * Error
-messages are now more informative, but no longer POSIX
-compliant... :-( And a final Haskell advertisement: The GNU C
-implementation uses well over 1100 lines, we need only 195 here,
-including a 46 line example! :-)
-
-\begin{code}
-module GetOpt (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) where
-
-import List(isPrefixOf)
-
-data ArgOrder a -- what to do with options following non-options:
- = RequireOrder -- no option processing after first non-option
- | Permute -- freely intersperse options and non-options
- | ReturnInOrder (String -> a) -- wrap non-options into options
-
-data OptDescr a = -- description of a single options:
- Option [Char] -- list of short option characters
- [String] -- list of long option strings (without "--")
- (ArgDescr a) -- argument descriptor
- String -- explanation of option for user
-
-data ArgDescr a -- description of an argument option:
- = NoArg a -- no argument expected
- | ReqArg (String -> a) String -- option requires argument
- | OptArg (Maybe String -> a) String -- optional argument
-
-data OptKind a -- kind of cmd line arg (internal use only):
- = Opt a -- an option
- | NonOpt String -- a non-option
- | EndOfOpts -- end-of-options marker (i.e. "--")
- | OptErr String -- something went wrong...
-
-usageInfo :: String -- header
- -> [OptDescr a] -- option descriptors
- -> String -- nicely formatted decription of options
-usageInfo header optDescr = unlines (header:table)
- where (ss,ls,ds) = (unzip3 . map fmtOpt) optDescr
- table = zipWith3 paste (sameLen ss) (sameLen ls) (sameLen ds)
- paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z
- sameLen xs = flushLeft ((maximum . map length) xs) xs
- flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]
-
-fmtOpt :: OptDescr a -> (String,String,String)
-fmtOpt (Option sos los ad descr) = (sepBy ',' (map (fmtShort ad) sos),
- sepBy ',' (map (fmtLong ad) los),
- descr)
- where sepBy _ [] = ""
- sepBy _ [x] = x
- sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs
-
-fmtShort :: ArgDescr a -> Char -> String
-fmtShort (NoArg _ ) so = "-" ++ [so]
-fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad
-fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"
-
-fmtLong :: ArgDescr a -> String -> String
-fmtLong (NoArg _ ) lo = "--" ++ lo
-fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
-fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
-
-getOpt :: ArgOrder a -- non-option handling
- -> [OptDescr a] -- option descriptors
- -> [String] -- the commandline arguments
- -> ([a],[String],[String]) -- (options,non-options,error messages)
-getOpt _ _ [] = ([],[],[])
-getOpt ordering optDescr (arg:args) = procNextOpt opt ordering
- where procNextOpt (Opt o) _ = (o:os,xs,es)
- procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[])
- procNextOpt (NonOpt x) Permute = (os,x:xs,es)
- procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es)
- procNextOpt EndOfOpts RequireOrder = ([],rest,[])
- procNextOpt EndOfOpts Permute = ([],rest,[])
- procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[])
- procNextOpt (OptErr e) _ = (os,xs,e:es)
-
- (opt,rest) = getNext arg args optDescr
- (os,xs,es) = getOpt ordering optDescr rest
-
--- take a look at the next cmd line arg and decide what to do with it
-getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
-getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
-getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
-getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
-getNext a rest _ = (NonOpt a,rest)
-
--- handle long option
-longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
-longOpt ls rs optDescr = long ads arg rs
- where (opt,arg) = break (=='=') ls
- options = [ o | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `isPrefixOf` l ]
- ads = [ ad | Option _ _ ad _ <- options ]
- optStr = ("--"++opt)
-
- long (_:_:_) _ rest = (errAmbig options optStr,rest)
- long [NoArg a ] [] rest = (Opt a,rest)
- long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)
- long [ReqArg _ d] [] [] = (errReq d optStr,[])
- long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)
- long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)
- long [OptArg f _] [] rest = (Opt (f Nothing),rest)
- long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)
- long _ _ rest = (errUnrec optStr,rest)
-
--- handle short option
-shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
-shortOpt x xs rest optDescr = short ads xs rest
- where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]
- ads = [ ad | Option _ _ ad _ <- options ]
- optStr = '-':[x]
-
- short (_:_:_) _ rest = (errAmbig options optStr,rest)
- short (NoArg a :_) [] rest = (Opt a,rest)
- short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)
- short (ReqArg _ d:_) [] [] = (errReq d optStr,[])
- short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
- short (ReqArg f _:_) xs rest = (Opt (f xs),rest)
- short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)
- short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)
- short [] [] rest = (errUnrec optStr,rest)
- short [] xs rest = (errUnrec optStr,('-':xs):rest)
-
--- miscellaneous error formatting
-
-errAmbig :: [OptDescr a] -> String -> OptKind a
-errAmbig ods optStr = OptErr (usageInfo header ods)
- where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
-
-errReq :: String -> String -> OptKind a
-errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
-
-errUnrec :: String -> OptKind a
-errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n")
-
-errNoArg :: String -> OptKind a
-errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
-
-{-
------------------------------------------------------------------------------------------
--- and here a small and hopefully enlightening example:
-
-data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show
-
-options :: [OptDescr Flag]
-options =
- [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files",
- Option ['V','?'] ["version","release"] (NoArg Version) "show version info",
- Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump",
- Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"]
-
-out :: Maybe String -> Flag
-out Nothing = Output "stdout"
-out (Just o) = Output o
-
-test :: ArgOrder Flag -> [String] -> String
-test order cmdline = case getOpt order options cmdline of
- (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n"
- (_,_,errs) -> concat errs ++ usageInfo header options
- where header = "Usage: foobar [OPTION...] files..."
-
--- example runs:
--- putStr (test RequireOrder ["foo","-v"])
--- ==> options=[] args=["foo", "-v"]
--- putStr (test Permute ["foo","-v"])
--- ==> options=[Verbose] args=["foo"]
--- putStr (test (ReturnInOrder Arg) ["foo","-v"])
--- ==> options=[Arg "foo", Verbose] args=[]
--- putStr (test Permute ["foo","--","-v"])
--- ==> options=[] args=["foo", "-v"]
--- putStr (test Permute ["-?o","--name","bar","--na=baz"])
--- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[]
--- putStr (test Permute ["--ver","foo"])
--- ==> option `--ver' is ambiguous; could be one of:
--- -v --verbose verbosely list files
--- -V, -? --version, --release show version info
--- Usage: foobar [OPTION...] files...
--- -v --verbose verbosely list files
--- -V, -? --version, --release show version info
--- -o[FILE] --output[=FILE] use FILE for dump
--- -n USER --name=USER only dump USER's files
------------------------------------------------------------------------------------------
--}
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1996
-%
-\section[GlaExts]{The @GlaExts@ interface}
-
-Compatibility cruft: Deprecated! Don't use! This rug will
-dissappear from underneath your feet very soon.
-
-This module will eventually be the interface to GHC-ONLY extensions:
-i.e. unboxery and primitive operations over unboxed values.
-
-OLD:
-The @GlaExts@ packages up various Glasgow extensions and
-exports them all through one interface. The Idea being that
-a Haskell program using a Glasgow extension doesn't have to
-selective import of obscure/likely-to-move (believe me, we
-really like to move functions around for the prelude bits!)
-GHC interfaces - instead import the GlaExts rag bag and you should be away!
-
-\begin{code}
-module GlaExts
-
- (
- ST, RealWorld,
-
- unsafePerformIO,
- unsafeInterleaveIO,
-
- -- operations for interfacing IO and ST
- --
- stToIO, -- :: ST RealWorld a -> IO a
- ioToST, -- :: IO a -> ST RealWorld a
-
- -- compatibility cruft
- PrimIO,
- ioToPrimIO,
- primIOToIO,
- unsafePerformPrimIO,
- thenPrimIO, thenIO_Prim,
- seqPrimIO, returnPrimIO,
-
- seqST, thenST, returnST,
-
- -- Everything from module ByteArray:
- module ByteArray,
-
- -- Same for Mutable(Byte)Array interface:
- module MutableArray,
-
- -- the representation of some basic types:
- Int(..),Addr(..),Word(..),Float(..),Double(..),Integer(..),Char(..),
-
- -- The non-standard fromInt and toInt methods
- Num( fromInt ), Integral( toInt ),
-
- -- Fusion
- build, augment,
-
- -- misc bits
- trace,
-
- -- and finally, all the unboxed primops of PrelGHC!
- module PrelGHC
-
- ) where
-
-import PrelGHC
-import PrelBase
-import PrelNum ( Num(..), Integral(..) ) -- To get fromInt/toInt
-import PrelAddr ( Addr(..), Word(..) )
-import PrelST
-import IOExts
-import PrelIOBase
-import ByteArray
-import MutableArray
-import Monad
-
-type PrimIO a = IO a
-
-primIOToIO :: PrimIO a -> IO a
-primIOToIO io = io
-
-ioToPrimIO :: IO a -> PrimIO a
-ioToPrimIO io = io
-
-unsafePerformPrimIO :: PrimIO a -> a
-unsafePerformPrimIO = unsafePerformIO
-
-thenPrimIO :: PrimIO a -> (a -> PrimIO b) -> PrimIO b
-thenPrimIO = (>>=)
-
-seqPrimIO :: PrimIO a -> PrimIO b -> PrimIO b
-seqPrimIO = (>>)
-
-returnPrimIO :: a -> PrimIO a
-returnPrimIO = return
-
-thenIO_Prim :: PrimIO a -> (a -> IO b) -> IO b
-thenIO_Prim = (>>=)
-
--- ST compatibility stubs.
-thenST :: ST s a -> ( a -> ST s b) -> ST s b
-thenST = (>>=)
-
-seqST :: ST s a -> ST s b -> ST s b
-seqST = (>>)
-
-returnST :: a -> ST s a
-returnST = return
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1996
-%
-\section[IOExts]{Module @IOExts@}
-
-@IOExts@ provides useful functionality that fall outside the
-standard Haskell IO interface. Expect the contents of IOExts
-to be the same for Hugs and GHC (same goes for any other
-Hugs/GHC extension libraries, unless a function/type is
-explicitly flagged as being implementation specific
-extension.)
-
-\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-
-module IOExts
- ( fixIO
- , unsafePerformIO
- , unsafeInterleaveIO
-
- , IORef -- instance of: Eq
- , newIORef
- , readIORef
- , writeIORef
- , updateIORef
-
- , mkWeakIORef
-
- , IOArray -- instance of: Eq
- , newIOArray
- , boundsIOArray
- , readIOArray
- , writeIOArray
- , freezeIOArray
- , thawIOArray
-#ifndef __HUGS__
- , unsafeFreezeIOArray
- , unsafeThawIOArray
-#endif
-
-#ifdef __HUGS__
-#else
- , openFileEx
- , IOModeEx(..)
-
- , hSetEcho
- , hGetEcho
- , hIsTerminalDevice
- , hConnectTo
- , withHandleFor
- , withStdout
- , withStdin
- , withStderr
-#endif
- , trace
-#ifdef __HUGS__
-#else
- , performGC
-#endif
-
- , unsafePtrEq
-
- , freeHaskellFunctionPtr
-
- , HandlePosition
- , HandlePosn(..)
- , hTell -- :: Handle -> IO HandlePosition
-
- , hSetBinaryMode -- :: Handle -> Bool -> IO Bool
-
- ) where
-
-\end{code}
-
-\begin{code}
-#ifdef __HUGS__
-import PreludeBuiltin
-import ST
-#else
-import PrelBase
-import PrelIOBase
-import IO
-import PrelHandle ( openFileEx, IOModeEx(..),
- hSetEcho, hGetEcho, getHandleFd
- )
-import PrelST
-import PrelArr
-import PrelWeak
-import PrelGHC
-import PrelHandle
-import PrelErr
-import IO ( hPutStr, hPutChar )
-import PrelAddr ( Addr )
-#endif
-import Ix
-
-unsafePtrEq :: a -> a -> Bool
-
-#ifdef __HUGS__
-unsafePtrEq = primReallyUnsafePtrEquality
-#else
-unsafePtrEq a b =
- case reallyUnsafePtrEquality# a b of
- 0# -> False
- _ -> True
-#endif
-\end{code}
-
-\begin{code}
-newIORef :: a -> IO (IORef a)
-readIORef :: IORef a -> IO a
-writeIORef :: IORef a -> a -> IO ()
-
-#ifdef __HUGS__
-type IORef a = STRef RealWorld a
-newIORef = newSTRef
-readIORef = readSTRef
-writeIORef = writeSTRef
-#else
-newtype IORef a = IORef (MutableVar RealWorld a)
- deriving Eq
-
-newIORef v = stToIO (newVar v) >>= \ var -> return (IORef var)
-readIORef (IORef var) = stToIO (readVar var)
-writeIORef (IORef var) v = stToIO (writeVar var v)
-#endif
-
-updateIORef :: IORef a -> (a -> a) -> IO ()
-updateIORef ref f = do
- x <- readIORef ref
- let x' = f x
- writeIORef ref x'
- -- or should we return new value ? (or old?)
-
-mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a))
-mkWeakIORef r@(IORef (MutableVar r#)) f = IO $ \s ->
- case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #)
-\end{code}
-
-\begin{code}
-newIOArray :: Ix ix => (ix,ix) -> elt -> IO (IOArray ix elt)
-boundsIOArray :: Ix ix => IOArray ix elt -> (ix, ix)
-readIOArray :: Ix ix => IOArray ix elt -> ix -> IO elt
-writeIOArray :: Ix ix => IOArray ix elt -> ix -> elt -> IO ()
-freezeIOArray :: Ix ix => IOArray ix elt -> IO (Array ix elt)
-thawIOArray :: Ix ix => Array ix elt -> IO (IOArray ix elt)
-#ifndef __HUGS__
-unsafeFreezeIOArray :: Ix ix => IOArray ix elt -> IO (Array ix elt)
-unsafeThawIOArray :: Ix ix => Array ix elt -> IO (IOArray ix elt)
-#endif
-
-#ifdef __HUGS__
-type IOArray ix elt = STArray RealWorld ix elt
-newIOArray = newSTArray
-boundsIOArray = boundsSTArray
-readIOArray = readSTArray
-writeIOArray = writeSTArray
-freezeIOArray = freezeSTArray
-thawIOArray = thawSTArray
-#else
-newtype IOArray ix elt = IOArray (MutableArray RealWorld ix elt)
- deriving Eq
-
-newIOArray ixs elt =
- stToIO (newArray ixs elt) >>= \arr ->
- return (IOArray arr)
-
-boundsIOArray (IOArray arr) = boundsOfArray arr
-
-readIOArray (IOArray arr) ix = stToIO (readArray arr ix)
-
-writeIOArray (IOArray arr) ix elt = stToIO (writeArray arr ix elt)
-
-freezeIOArray (IOArray arr) = stToIO (freezeArray arr)
-
-thawIOArray arr = do
- marr <- stToIO (thawArray arr)
- return (IOArray marr)
-
-unsafeFreezeIOArray (IOArray arr) = stToIO (unsafeFreezeArray arr)
-unsafeThawIOArray arr = do
- marr <- stToIO (unsafeThawArray arr)
- return (IOArray marr)
-#endif
-\end{code}
-
-\begin{code}
-{-# NOINLINE trace #-}
-trace :: String -> a -> a
-#ifdef __HUGS__
-trace string expr = unsafePerformIO $ do
- putStrLn string
- return expr
-#else
-trace string expr = unsafePerformIO $ do
- fd <- getHandleFd stderr
- hPutStr stderr string
- hPutChar stderr '\n'
- postTraceHook fd
- return expr
-
-foreign import "PostTraceHook" postTraceHook :: Int -> IO ()
-#endif
-
-\end{code}
-
-Not something you want to call normally, but useful
-in the cases where you do want to flush stuff out of
-the heap or make sure you've got room enough
-
-\begin{code}
-#ifndef __HUGS__
-foreign import "performGC" performGC :: IO ()
-#endif
-\end{code}
-
-When using 'foreign export dynamic' to dress up a Haskell
-IO action to look like a C function pointer, a little bit
-of memory is allocated (along with a stable pointer to
-the Haskell IO action). When done with the C function
-pointer, you'll need to call @freeHaskellFunctionPtr()@ to
-let go of these resources - here's the Haskell wrapper for
-that RTS entry point, should you want to free it from
-within Haskell.
-
-\begin{code}
-foreign import ccall "freeHaskellFunctionPtr"
- freeHaskellFunctionPtr :: Addr -> IO ()
-
-\end{code}
-
-(Experimental)
-
-Support for redirecting I/O on a handle to another for the
-duration of an IO action. To re-route a handle, it is first
-flushed, followed by replacing its innards (i.e., FILE_OBJECT)
-with that of the other. This happens before and after the
-action is executed.
-
-If the action raises an exception, the handle is replaced back
-to its old contents, but without flushing it first - as this
-may provoke exceptions. Notice that the action may perform
-I/O on either Handle, with the result that the I/O is interleaved.
-(Why you would want to do this, is a completely different matter.)
-
-ToDo: probably want to restrict what kind of handles can be
-replaced with another - i.e., don't want to be able to replace
-a writeable handle with a readable one.
-
-\begin{code}
-withHandleFor :: Handle
- -> Handle
- -> IO a
- -> IO a
-withHandleFor h1 h2 act = do
- h1_fo <- getFO h1
- plugIn h1_fo
- where
- plugIn h1_fo = do
- hFlush h2
- h2_fo <- withHandle h2 $ \ h2_ -> return (h2_{haFO__=h1_fo}, haFO__ h2_)
- catch (act >>= \ x -> hFlush h2 >> setFO h2 h2_fo >> return x)
- (\ err -> setFO h2 h2_fo >> ioError err)
-
- setFO h fo =
- withHandle h $ \ h_ -> return (h_{haFO__=fo}, ())
-
- getFO h =
- wantRWHandle "withHandleFor" h $ \ h_ ->
- return (haFO__ h_)
-
-\end{code}
-
-Derived @withHandleFor@ combinators and, at the moment, these
-are exported from @IOExts@ and not @withHandleFor@ itself.
-
-\begin{code}
-withStdin h a = withHandleFor h stdin a
-withStdout h a = withHandleFor h stdout a
-withStderr h a = withHandleFor h stderr a
-\end{code}
-
-@hTell@ is the lower-level version of @hGetPosn@ - return the
-position, without bundling it together with the handle itself:
-
-\begin{code}
-hTell :: Handle -> IO HandlePosition
-hTell h = do
- (HandlePosn _ x) <- hGetPosn h
- return x
-\end{code}
-
-@hSetBinaryMode@ lets you change the translation mode for a handle.
-On some platforms (e.g., Win32) a distinction is made between being in
-'text mode' or 'binary mode', with the former terminating lines
-by \r\n rather than just \n.
-
-Debating the Winnitude or otherwise of such a scheme is less than
-interesting -- it's there, so we have to cope.
-
-A side-effect of calling @hSetBinaryMode@ is that the output buffer
-(if any) is flushed prior to changing the translation mode.
-
-\begin{code}
-hSetBinaryMode :: Handle -> Bool -> IO Bool
-hSetBinaryMode handle is_binary = do
- -- is_binary = True => set translation mode to binary.
- wantRWHandle "hSetBinaryMode" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- setBinaryMode fo flg
- if rc >= 0 then
- return (int2Bool rc)
- else
- constructErrorAndFail "hSetBinaryMode"
- where
- flg | is_binary = 1
- | otherwise = 0
-
- int2Bool 0 = False
- int2Bool _ = True
-
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1997-1999
-%
-
-\section[Int]{Module @Int@}
-
-This code is largely copied from the Hugs library of the same name,
-suitably hammered to use unboxed types.
-
-\begin{code}
-#include "MachDeps.h"
-
-module Int
- ( Int8
- , Int16
- , Int32
- , Int64
-
- , int8ToInt16 -- :: Int8 -> Int16
- , int8ToInt32 -- :: Int8 -> Int32
- , int8ToInt64 -- :: Int8 -> Int64
-
- , int16ToInt8 -- :: Int16 -> Int8
- , int16ToInt32 -- :: Int16 -> Int32
- , int16ToInt64 -- :: Int16 -> Int64
-
- , int32ToInt8 -- :: Int32 -> Int8
- , int32ToInt16 -- :: Int32 -> Int16
- , int32ToInt64 -- :: Int32 -> Int64
-
- , int64ToInt8 -- :: Int64 -> Int8
- , int64ToInt16 -- :: Int64 -> Int16
- , int64ToInt32 -- :: Int64 -> Int32
-
- , int8ToInt -- :: Int8 -> Int
- , int16ToInt -- :: Int16 -> Int
- , int32ToInt -- :: Int32 -> Int
- , int64ToInt -- :: Int32 -> Int
-
- , intToInt8 -- :: Int -> Int8
- , intToInt16 -- :: Int -> Int16
- , intToInt32 -- :: Int -> Int32
- , intToInt64 -- :: Int -> Int32
-
- , integerToInt8 -- :: Integer -> Int8
- , integerToInt16 -- :: Integer -> Int16
- , integerToInt32 -- :: Integer -> Int32
- , integerToInt64 -- :: Integer -> Int64
-
- , int8ToInteger -- :: Int8 -> Integer
- , int16ToInteger -- :: Int16 -> Integer
- , int32ToInteger -- :: Int32 -> Integer
- , int64ToInteger -- :: Int64 -> Integer
-
- -- plus Eq, Ord, Num, Bounded, Real, Integral, Ix, Enum, Read,
- -- Show and Bits instances for each of Int8, Int16, Int32 and Int64
-
-#ifndef __HUGS__
- -- The "official" place to get these from is Addr, importing
- -- them from Int is a non-standard thing to do.
- , indexInt8OffAddr
- , indexInt16OffAddr
- , indexInt32OffAddr
- , indexInt64OffAddr
-
- , readInt8OffAddr
- , readInt16OffAddr
- , readInt32OffAddr
- , readInt64OffAddr
-
- , writeInt8OffAddr
- , writeInt16OffAddr
- , writeInt32OffAddr
- , writeInt64OffAddr
-
-#endif
-
- , sizeofInt8
- , sizeofInt16
- , sizeofInt32
- , sizeofInt64
-
- -- The "official" place to get these from is Foreign
-#ifndef __PARALLEL_HASKELL__
-#ifndef __HUGS__
- , indexInt8OffForeignObj
- , indexInt16OffForeignObj
- , indexInt32OffForeignObj
- , indexInt64OffForeignObj
-
- , readInt8OffForeignObj
- , readInt16OffForeignObj
- , readInt32OffForeignObj
- , readInt64OffForeignObj
-
- , writeInt8OffForeignObj
- , writeInt16OffForeignObj
- , writeInt32OffForeignObj
- , writeInt64OffForeignObj
-#endif
-#endif
-
- -- The non-standard fromInt and toInt methods
- , Num( fromInt ), Integral( toInt )
-
- -- non-standard, GHC specific
- , intToWord
-
-#ifndef __HUGS__
- -- Internal, do not use.
- , int8ToInt#
- , int16ToInt#
- , int32ToInt#
-#endif
-
- ) where
-
-#ifndef __HUGS__
-import PrelBase
-import CCall
-import PrelForeign
-import PrelIOBase
-import PrelAddr ( Int64(..), Word64(..), Addr(..), Word(..) )
-import PrelNum ( Num(..), Integral(..) ) -- To get fromInt/toInt
-#else
-import Word
-#endif
-import Ix
-import Bits
-import Ratio ( (%) )
-import Numeric ( readDec )
-import Word ( Word32 )
-\end{code}
-
-#ifndef __HUGS__
-
-\begin{code}
------------------------------------------------------------------------------
--- The "official" coercion functions
------------------------------------------------------------------------------
-
-int8ToInt :: Int8 -> Int
-int16ToInt :: Int16 -> Int
-int32ToInt :: Int32 -> Int
-
-int8ToInt# :: Int8 -> Int#
-int16ToInt# :: Int16 -> Int#
-int32ToInt# :: Int32 -> Int#
-
-intToInt8 :: Int -> Int8
-intToInt16 :: Int -> Int16
-intToInt32 :: Int -> Int32
-
-int8ToInt16 :: Int8 -> Int16
-int8ToInt32 :: Int8 -> Int32
-
-int16ToInt8 :: Int16 -> Int8
-int16ToInt32 :: Int16 -> Int32
-
-int32ToInt8 :: Int32 -> Int8
-int32ToInt16 :: Int32 -> Int16
-
-int8ToInt16 (I8# x) = I16# x
-int8ToInt32 (I8# x) = I32# x
-int8ToInt64 = int32ToInt64 . int8ToInt32
-
-int16ToInt8 (I16# x) = I8# x
-int16ToInt32 (I16# x) = I32# x
-int16ToInt64 = int32ToInt64 . int16ToInt32
-
-int32ToInt8 (I32# x) = I8# x
-int32ToInt16 (I32# x) = I16# x
-
---GHC specific
-intToWord :: Int -> Word
-intToWord (I# i#) = W# (int2Word# i#)
-\end{code}
-
-\subsection[Int8]{The @Int8@ interface}
-
-\begin{code}
-data Int8 = I8# Int#
-instance CCallable Int8
-instance CReturnable Int8
-
-int8ToInt (I8# x) = I# (i8ToInt# x)
-int8ToInt# (I8# x) = i8ToInt# x
-
-i8ToInt# :: Int# -> Int#
-i8ToInt# x = if x' <=# 0x7f# then x' else x' -# 0x100#
- where x' = word2Int# (int2Word# x `and#` int2Word# 0xff#)
-
---
--- This doesn't perform any bounds checking
--- on the value it is passed, nor its sign.
--- i.e., show (intToInt8 511) => "-1"
---
-intToInt8 (I# x) = I8# (intToInt8# x)
-
-intToInt8# :: Int# -> Int#
-intToInt8# i# = word2Int# ((int2Word# i#) `and#` int2Word# 0xff#)
-
-instance Eq Int8 where
- (I8# x#) == (I8# y#) = x# ==# y#
- (I8# x#) /= (I8# y#) = x# /=# y#
-
-instance Ord Int8 where
- compare (I8# x#) (I8# y#) = compareInt# (i8ToInt# x#) (i8ToInt# y#)
-
-compareInt# :: Int# -> Int# -> Ordering
-compareInt# x# y#
- | x# <# y# = LT
- | x# ==# y# = EQ
- | otherwise = GT
-
-instance Num Int8 where
- (I8# x#) + (I8# y#) = I8# (intToInt8# (x# +# y#))
- (I8# x#) - (I8# y#) = I8# (intToInt8# (x# -# y#))
- (I8# x#) * (I8# y#) = I8# (intToInt8# (x# *# y#))
- negate i@(I8# x#) =
- if x# ==# 0#
- then i
- else I8# (0x100# -# x#)
-
- abs = absReal
- signum = signumReal
- fromInteger (S# i#) = I8# (intToInt8# i#)
- fromInteger (J# s# d#) = I8# (intToInt8# (integer2Int# s# d#))
- fromInt = intToInt8
-
-instance Bounded Int8 where
- minBound = 0x80
- maxBound = 0x7f
-
-instance Real Int8 where
- toRational x = toInteger x % 1
-
-instance Integral Int8 where
- div x y
- | x > 0 && y < 0 = quotInt8 (x-y-1) y
- | x < 0 && y > 0 = quotInt8 (x-y+1) y
- | otherwise = quotInt8 x y
-
- quot x@(I8# _) y@(I8# y#)
- | y# /=# 0# = x `quotInt8` y
- | otherwise = divZeroError "quot{Int8}" x
- rem x@(I8# _) y@(I8# y#)
- | y# /=# 0# = x `remInt8` y
- | otherwise = divZeroError "rem{Int8}" x
- mod x y
- | x > 0 && y < 0 || x < 0 && y > 0 = if r/=0 then r+y else 0
- | otherwise = r
- where r = remInt8 x y
-
- a@(I8# _) `quotRem` b@(I8# _) = (a `quotInt8` b, a `remInt8` b)
- toInteger i8 = toInteger (int8ToInt i8)
- toInt i8 = int8ToInt i8
-
-remInt8, quotInt8 :: Int8 -> Int8 -> Int8
-remInt8 (I8# x) (I8# y) = I8# (intToInt8# ((i8ToInt# x) `remInt#` (i8ToInt# y)))
-quotInt8 (I8# x) (I8# y) = I8# (intToInt8# ((i8ToInt# x) `quotInt#` (i8ToInt# y)))
-
-instance Ix Int8 where
- range (m,n) = [m..n]
- index b@(m,_) i
- | inRange b i = int8ToInt (i - m)
- | otherwise = indexError i b "Int8"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int8 where
- succ i
- | i == maxBound = succError "Int8"
- | otherwise = i+1
- pred i
- | i == minBound = predError "Int8"
- | otherwise = i-1
-
- toEnum x
- | x >= toInt (minBound::Int8) && x <= toInt (maxBound::Int8)
- = intToInt8 x
- | otherwise
- = toEnumError "Int8" x (minBound::Int8,maxBound::Int8)
-
- fromEnum = int8ToInt
- enumFrom e1 = map toEnum [fromEnum e1 .. fromEnum (maxBound::Int8)]
- enumFromThen e1 e2 =
- map toEnum [fromEnum e1, fromEnum e2 .. fromEnum (last::Int8)]
- where
- last
- | e2 < e1 = minBound
- | otherwise = maxBound
-
-instance Read Int8 where
- readsPrec p s = [ (intToInt8 x,r) | (x,r) <- readsPrec p s ]
-
-instance Show Int8 where
- showsPrec p i8 = showsPrec p (int8ToInt i8)
-
-binop8 :: (Int32 -> Int32 -> a) -> (Int8 -> Int8 -> a)
-binop8 op x y = int8ToInt32 x `op` int8ToInt32 y
-
-instance Bits Int8 where
- (I8# x) .&. (I8# y) = I8# (word2Int# ((int2Word# x) `and#` (int2Word# y)))
- (I8# x) .|. (I8# y) = I8# (word2Int# ((int2Word# x) `or#` (int2Word# y)))
- (I8# x) `xor` (I8# y) = I8# (word2Int# ((int2Word# x) `xor#` (int2Word# y)))
- complement (I8# x) = I8# (word2Int# ((int2Word# x) `xor#` (int2Word# 0xff#)))
- shift (I8# x) i@(I# i#)
- | i > 0 = I8# (intToInt8# (iShiftL# (i8ToInt# x) i#))
- | otherwise = I8# (intToInt8# (iShiftRA# (i8ToInt# x) (negateInt# i#)))
- i8@(I8# x) `rotate` (I# i)
- | i ==# 0# = i8
- | i ># 0# =
- I8# (intToInt8# ( word2Int# (
- (int2Word# (iShiftL# (i8ToInt# x) i'))
- `or#`
- (int2Word# (iShiftRA# (word2Int# (
- (int2Word# x) `and#`
- (int2Word# (0x100# -# pow2# i2))))
- i2)))))
- | otherwise = rotate i8 (I# (8# +# i))
- where
- i' = word2Int# (int2Word# i `and#` int2Word# 7#)
- i2 = 8# -# i'
- bit i = shift 1 i
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
- testBit x i = (x .&. bit i) /= 0
- bitSize _ = 8
- isSigned _ = True
-
-pow2# :: Int# -> Int#
-pow2# x# = iShiftL# 1# x#
-
-pow2_64# :: Int# -> Int64#
-pow2_64# x# = word64ToInt64# (shiftL64# (wordToWord64# (int2Word# 1#)) x#)
-
-sizeofInt8 :: Word32
-sizeofInt8 = 1
-\end{code}
-
-\subsection[Int16]{The @Int16@ interface}
-
-\begin{code}
-data Int16 = I16# Int#
-instance CCallable Int16
-instance CReturnable Int16
-
-int16ToInt (I16# x) = I# (i16ToInt# x)
-int16ToInt# (I16# x) = i16ToInt# x
-
-i16ToInt# :: Int# -> Int#
-i16ToInt# x = if x' <=# 0x7fff# then x' else x' -# 0x10000#
- where x' = word2Int# (int2Word# x `and#` int2Word# 0xffff#)
-
-intToInt16 (I# x) = I16# (intToInt16# x)
-
-intToInt16# :: Int# -> Int#
-intToInt16# i# = word2Int# ((int2Word# i#) `and#` int2Word# 0xffff#)
-
-instance Eq Int16 where
- (I16# x#) == (I16# y#) = x# ==# y#
- (I16# x#) /= (I16# y#) = x# /=# y#
-
-instance Ord Int16 where
- compare (I16# x#) (I16# y#) = compareInt# (i16ToInt# x#) (i16ToInt# y#)
-
-instance Num Int16 where
- (I16# x#) + (I16# y#) = I16# (intToInt16# (x# +# y#))
- (I16# x#) - (I16# y#) = I16# (intToInt16# (x# -# y#))
- (I16# x#) * (I16# y#) = I16# (intToInt16# (x# *# y#))
- negate i@(I16# x#) =
- if x# ==# 0#
- then i
- else I16# (0x10000# -# x#)
- abs = absReal
- signum = signumReal
- fromInteger (S# i#) = I16# (intToInt16# i#)
- fromInteger (J# s# d#) = I16# (intToInt16# (integer2Int# s# d#))
- fromInt = intToInt16
-
-instance Bounded Int16 where
- minBound = 0x8000
- maxBound = 0x7fff
-
-instance Real Int16 where
- toRational x = toInteger x % 1
-
-instance Integral Int16 where
- div x y
- | x > 0 && y < 0 = quotInt16 (x-y-1) y
- | x < 0 && y > 0 = quotInt16 (x-y+1) y
- | otherwise = quotInt16 x y
-
- quot x@(I16# _) y@(I16# y#)
- | y# /=# 0# = x `quotInt16` y
- | otherwise = divZeroError "quot{Int16}" x
- rem x@(I16# _) y@(I16# y#)
- | y# /=# 0# = x `remInt16` y
- | otherwise = divZeroError "rem{Int16}" x
- mod x y
- | x > 0 && y < 0 || x < 0 && y > 0 = if r/=0 then r+y else 0
- | otherwise = r
- where r = remInt16 x y
-
- a@(I16# _) `quotRem` b@(I16# _) = (a `quotInt16` b, a `remInt16` b)
- toInteger i16 = toInteger (int16ToInt i16)
- toInt i16 = int16ToInt i16
-
-remInt16, quotInt16 :: Int16 -> Int16 -> Int16
-remInt16 (I16# x) (I16# y) = I16# (intToInt16# ((i16ToInt# x) `remInt#` (i16ToInt# y)))
-quotInt16 (I16# x) (I16# y) = I16# (intToInt16# ((i16ToInt# x) `quotInt#` (i16ToInt# y)))
-
-instance Ix Int16 where
- range (m,n) = [m..n]
- index b@(m,_) i
- | inRange b i = int16ToInt (i - m)
- | otherwise = indexError i b "Int16"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int16 where
- succ i
- | i == maxBound = succError "Int16"
- | otherwise = i+1
-
- pred i
- | i == minBound = predError "Int16"
- | otherwise = i-1
-
- toEnum x
- | x >= toInt (minBound::Int16) && x <= toInt (maxBound::Int16)
- = intToInt16 x
- | otherwise
- = toEnumError "Int16" x (minBound::Int16, maxBound::Int16)
-
- fromEnum = int16ToInt
-
- enumFrom e1 = map toEnum [fromEnum e1 .. fromEnum (maxBound::Int16)]
- enumFromThen e1 e2 = map toEnum [fromEnum e1, fromEnum e2 .. fromEnum (last::Int16)]
- where last
- | e2 < e1 = minBound
- | otherwise = maxBound
-
-instance Read Int16 where
- readsPrec p s = [ (intToInt16 x,r) | (x,r) <- readsPrec p s ]
-
-instance Show Int16 where
- showsPrec p i16 = showsPrec p (int16ToInt i16)
-
-binop16 :: (Int32 -> Int32 -> a) -> (Int16 -> Int16 -> a)
-binop16 op x y = int16ToInt32 x `op` int16ToInt32 y
-
-instance Bits Int16 where
- (I16# x) .&. (I16# y) = I16# (word2Int# ((int2Word# x) `and#` (int2Word# y)))
- (I16# x) .|. (I16# y) = I16# (word2Int# ((int2Word# x) `or#` (int2Word# y)))
- (I16# x) `xor` (I16# y) = I16# (word2Int# ((int2Word# x) `xor#` (int2Word# y)))
- complement (I16# x) = I16# (word2Int# ((int2Word# x) `xor#` (int2Word# 0xffff#)))
- shift (I16# x) i@(I# i#)
- | i > 0 = I16# (intToInt16# (iShiftL# (i16ToInt# x) i#))
- | otherwise = I16# (intToInt16# (iShiftRA# (i16ToInt# x) (negateInt# i#)))
- i16@(I16# x) `rotate` (I# i)
- | i ==# 0# = i16
- | i ># 0# =
- I16# (intToInt16# (word2Int# (
- (int2Word# (iShiftL# (i16ToInt# x) i'))
- `or#`
- (int2Word# (iShiftRA# ( word2Int# (
- (int2Word# x) `and#` (int2Word# (0x100# -# pow2# i2))))
- i2)))))
- | otherwise = rotate i16 (I# (16# +# i))
- where
- i' = word2Int# (int2Word# i `and#` int2Word# 15#)
- i2 = 16# -# i'
- bit i = shift 1 i
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
- testBit x i = (x .&. bit i) /= 0
- bitSize _ = 16
- isSigned _ = True
-
-sizeofInt16 :: Word32
-sizeofInt16 = 2
-\end{code}
-
-%
-%
-\subsection[Int32]{The @Int32@ interface}
-%
-%
-
-\begin{code}
-data Int32 = I32# Int#
-instance CCallable Int32
-instance CReturnable Int32
-
-int32ToInt (I32# x) = I# (i32ToInt# x)
-int32ToInt# (I32# x) = i32ToInt# x
-
-i32ToInt# :: Int# -> Int#
-#if WORD_SIZE_IN_BYTES > 4
-i32ToInt# x = if x' <=# 0x7fffffff# then x' else x' -# 0x100000000#
- where x' = word2Int# (int2Word# x `and#` int2Word# 0xffffffff#)
-#else
-i32ToInt# x = x
-#endif
-
-intToInt32 (I# x) = I32# (intToInt32# x)
-intToInt32# :: Int# -> Int#
-#if WORD_SIZE_IN_BYTES > 4
-intToInt32# i# = word2Int# ((int2Word# i#) `and#` int2Word# 0xffffffff#)
-#else
-intToInt32# i# = i#
-#endif
-
-instance Eq Int32 where
- (I32# x#) == (I32# y#) = x# ==# y#
- (I32# x#) /= (I32# y#) = x# /=# y#
-
-instance Ord Int32 where
- compare (I32# x#) (I32# y#) = compareInt# (i32ToInt# x#) (i32ToInt# y#)
-
-instance Num Int32 where
- (I32# x#) + (I32# y#) = I32# (intToInt32# (x# +# y#))
- (I32# x#) - (I32# y#) = I32# (intToInt32# (x# -# y#))
- (I32# x#) * (I32# y#) = I32# (intToInt32# (x# *# y#))
-#if WORD_SIZE_IN_BYTES > 4
- negate i@(I32# x) =
- if x ==# 0#
- then i
- else I32# (intToInt32# (0x100000000# -# x'))
-#else
- negate (I32# x) = I32# (negateInt# x)
-#endif
- abs = absReal
- signum = signumReal
- fromInteger (S# i#) = I32# (intToInt32# i#)
- fromInteger (J# s# d#) = I32# (intToInt32# (integer2Int# s# d#))
- fromInt = intToInt32
-
-instance Bounded Int32 where
- minBound = fromInt minBound
- maxBound = fromInt maxBound
-
-instance Real Int32 where
- toRational x = toInteger x % 1
-
-instance Integral Int32 where
- div x y
- | x > 0 && y < 0 = quotInt32 (x-y-1) y
- | x < 0 && y > 0 = quotInt32 (x-y+1) y
- | otherwise = quotInt32 x y
- quot x@(I32# _) y@(I32# y#)
- | y# /=# 0# = x `quotInt32` y
- | otherwise = divZeroError "quot{Int32}" x
- rem x@(I32# _) y@(I32# y#)
- | y# /=# 0# = x `remInt32` y
- | otherwise = divZeroError "rem{Int32}" x
- mod x y
- | x > 0 && y < 0 || x < 0 && y > 0 = if r/=0 then r+y else 0
- | otherwise = r
- where r = remInt32 x y
-
- a@(I32# _) `quotRem` b@(I32# _) = (a `quotInt32` b, a `remInt32` b)
- toInteger i32 = toInteger (int32ToInt i32)
- toInt i32 = int32ToInt i32
-
-remInt32, quotInt32 :: Int32 -> Int32 -> Int32
-remInt32 (I32# x) (I32# y) = I32# (intToInt32# ((i32ToInt# x) `remInt#` (i32ToInt# y)))
-quotInt32 (I32# x) (I32# y) = I32# (intToInt32# ((i32ToInt# x) `quotInt#` (i32ToInt# y)))
-
-instance Ix Int32 where
- range (m,n) = [m..n]
- index b@(m,_) i
- | inRange b i = int32ToInt (i - m)
- | otherwise = indexError i b "Int32"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int32 where
- succ i
- | i == maxBound = succError "Int32"
- | otherwise = i+1
-
- pred i
- | i == minBound = predError "Int32"
- | otherwise = i-1
-
- toEnum x
- -- with Int having the same range as Int32, the following test
- -- shouldn't fail. However, having it here
- | x >= toInt (minBound::Int32) && x <= toInt (maxBound::Int32)
- = intToInt32 x
- | otherwise
- = toEnumError "Int32" x (minBound::Int32, maxBound::Int32)
-
- fromEnum = int32ToInt
-
- enumFrom e1 = map toEnum [fromEnum e1 .. fromEnum (maxBound::Int32)]
- enumFromThen e1 e2 = map toEnum [fromEnum e1, fromEnum e2 .. fromEnum (last::Int32)]
- where
- last
- | e2 < e1 = minBound
- | otherwise = maxBound
-
-instance Read Int32 where
- readsPrec p s = [ (intToInt32 x,r) | (x,r) <- readsPrec p s ]
-
-instance Show Int32 where
- showsPrec p i32 = showsPrec p (int32ToInt i32)
-
-instance Bits Int32 where
- (I32# x) .&. (I32# y) = I32# (word2Int# ((int2Word# x) `and#` (int2Word# y)))
- (I32# x) .|. (I32# y) = I32# (word2Int# ((int2Word# x) `or#` (int2Word# y)))
- (I32# x) `xor` (I32# y) = I32# (word2Int# ((int2Word# x) `xor#` (int2Word# y)))
-#if WORD_SIZE_IN_BYTES > 4
- complement (I32# x) = I32# (word2Int# ((int2Word# x) `xor#` (int2Word# 0xffffffff#)))
-#else
- complement (I32# x) = I32# (word2Int# ((int2Word# x) `xor#` (int2Word# (negateInt# 1#))))
-#endif
- shift (I32# x) i@(I# i#)
- | i > 0 = I32# (intToInt32# (iShiftL# (i32ToInt# x) i#))
- | otherwise = I32# (intToInt32# (iShiftRA# (i32ToInt# x) (negateInt# i#)))
- i32@(I32# x) `rotate` (I# i)
- | i ==# 0# = i32
- | i ># 0# =
- -- ( (x<<i') | ((x&(0x100000000-2^i2))>>i2)
- I32# (intToInt32# ( word2Int# (
- (int2Word# (iShiftL# (i32ToInt# x) i'))
- `or#`
- (int2Word# (iShiftRA# (word2Int# (
- (int2Word# x)
- `and#`
- (int2Word# (maxBound# -# pow2# i2 +# 1#))))
- i2)))))
- | otherwise = rotate i32 (I# (32# +# i))
- where
- i' = word2Int# (int2Word# i `and#` int2Word# 31#)
- i2 = 32# -# i'
- (I32# maxBound#) = maxBound
- bit i = shift 1 i
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
- testBit x i = (x .&. bit i) /= 0
- bitSize _ = 32
- isSigned _ = True
-
-sizeofInt32 :: Word32
-sizeofInt32 = 4
-\end{code}
-
-\subsection[Int64]{The @Int64@ interface}
-
-
-\begin{code}
-#if WORD_SIZE_IN_BYTES == 8
---data Int64 = I64# Int#
-
-int32ToInt64 :: Int32 -> Int64
-int32ToInt64 (I32# i#) = I64# i#
-
-intToInt32# :: Int# -> Int#
-intToInt32# i# = word2Int# ((int2Word# i#) `and#` (case (maxBound::Word32) of W# x# -> x#))
-
-int64ToInt32 :: Int64 -> Int32
-int64ToInt32 (I64# i#) = I32# (intToInt32# w#)
-
-instance Eq Int64 where
- (I64# x) == (I64# y) = x `eqInt#` y
- (I64# x) /= (I64# y) = x `neInt#` y
-
-instance Ord Int32 where
- compare (I64# x#) (I64# y#) = compareInt# x# y#
-
-instance Num Int64 where
- (I64# x) + (I64# y) = I64# (x +# y)
- (I64# x) - (I64# y) = I64# (x -# y)
- (I64# x) * (I64# y) = I64# (x *# y)
- negate w@(I64# x) = I64# (negateInt# x)
- abs x = absReal
- signum = signumReal
- fromInteger (S# i#) = I64# i#
- fromInteger (J# s# d#) = I64# (integer2Int# s# d#)
- fromInt = intToInt64
-
-instance Bounded Int64 where
- minBound = integerToInt64 (-0x8000000000000000)
- maxBound = integerToInt64 0x7fffffffffffffff
-
-instance Integral Int64 where
- div x y
- | x > 0 && y < 0 = quotInt64 (x-y-1) y
- | x < 0 && y > 0 = quotInt64 (x-y+1) y
- | otherwise = quotInt64 x y
-
- quot x@(I64# _) y@(I64# y#)
- | y# /=# 0# = x `quotInt64` y
- | otherwise = divZeroError "quot{Int64}" x
-
- rem x@(I64# _) y@(I64# y#)
- | y# /=# 0# = x `remInt64` y
- | otherwise = divZeroError "rem{Int64}" x
-
- mod x y
- | x > 0 && y < 0 || x < 0 && y > 0 = if r/=0 then r+y else 0
- | otherwise = r
- where r = remInt64 x y
-
- a@(I64# _) `quotRem` b@(I64# _) = (a `quotInt64` b, a `remInt64` b)
- toInteger (I64# i#) = toInteger (I# i#)
- toInt (I64# i#) = I# i#
-
-instance Bits Int64 where
- (I64# x) .&. (I64# y) = I64# (word2Int# ((int2Word# x) `and#` (int2Word# y)))
- (I64# x) .|. (I64# y) = I64# (word2Int# ((int2Word# x) `or#` (int2Word# y)))
- (I64# x) `xor` (I64# y) = I64# (word2Int# ((int2Word# x) `xor#` (int2Word# y)))
- complement (I64# x) = I64# (negateInt# x)
- shift (I64# x) i@(I# i#)
- | i > 0 = I64# (iShiftL# x i#)
- | otherwise = I64# (iShiftRA# x (negateInt# i#))
- i64@(I64# x) `rotate` (I# i)
- | i ==# 0# = i64
- | i ># 0# =
- -- ( (x<<i') | ((x&(0x10000000000000000-2^i2))>>i2) )
- I64# (word2Int# (
- (int2Word# (iShiftL# x i'))
- `or#`
- (int2Word# (iShiftRA# (word2Int# (
- (int2Word# x)
- `and#`
- (int2Word# (maxBound# -# pow2# i2 +# 1#))))
- i2))))
- | otherwise = rotate i64 (I# (64# +# i))
- where
- i' = word2Int# (int2Word# i `and#` int2Word# 63#)
- i2 = 64# -# i'
- (I64# maxBound#) = maxBound
- bit i = shift 1 i
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
- testBit x i = (x .&. bit i) /= 0
- bitSize _ = 64
- isSigned _ = True
-
-
-
-remInt64 (I64# x) (I64# y) = I64# (x `remInt#` y)
-quotInt64 (I64# x) (I64# y) = I64# (x `quotInt#` y)
-
-int64ToInteger :: Int64 -> Integer
-int64ToInteger (I64# i#) = toInteger (I# i#)
-
-integerToInt64 :: Integer -> Int64
-integerToInt64 i = case fromInteger i of { I# i# -> I64# i# }
-
-intToInt64 :: Int -> Int64
-intToInt64 (I# i#) = I64# i#
-
-int64ToInt :: Int64 -> Int
-int64ToInt (I64# i#) = I# i#
-
-#else
---assume: support for long-longs
---data Int64 = I64 Int64# deriving (Eq, Ord, Bounded)
-
-int32ToInt64 :: Int32 -> Int64
-int32ToInt64 (I32# i#) = I64# (intToInt64# i#)
-
-int64ToInt32 :: Int64 -> Int32
-int64ToInt32 (I64# i#) = I32# (int64ToInt# i#)
-
-int64ToInteger :: Int64 -> Integer
-int64ToInteger (I64# x#) =
- case int64ToInteger# x# of
- (# s#, p# #) -> J# s# p#
-
-integerToInt64 :: Integer -> Int64
-integerToInt64 (S# i#) = I64# (intToInt64# i#)
-integerToInt64 (J# s# d#) = I64# (integerToInt64# s# d#)
-
-instance Eq Int64 where
- (I64# x) == (I64# y) = x `eqInt64#` y
- (I64# x) /= (I64# y) = x `neInt64#` y
-
-instance Ord Int64 where
- compare (I64# x) (I64# y) = compareInt64# x y
- (<) (I64# x) (I64# y) = x `ltInt64#` y
- (<=) (I64# x) (I64# y) = x `leInt64#` y
- (>=) (I64# x) (I64# y) = x `geInt64#` y
- (>) (I64# x) (I64# y) = x `gtInt64#` y
- max x@(I64# x#) y@(I64# y#) =
- case (compareInt64# x# y#) of { LT -> y ; EQ -> x ; GT -> x }
- min x@(I64# x#) y@(I64# y#) =
- case (compareInt64# x# y#) of { LT -> x ; EQ -> x ; GT -> y }
-
-instance Num Int64 where
- (I64# x) + (I64# y) = I64# (x `plusInt64#` y)
- (I64# x) - (I64# y) = I64# (x `minusInt64#` y)
- (I64# x) * (I64# y) = I64# (x `timesInt64#` y)
- negate (I64# x) = I64# (negateInt64# x)
- abs x = absReal x
- signum = signumReal
- fromInteger i = integerToInt64 i
- fromInt i = intToInt64 i
-
-compareInt64# :: Int64# -> Int64# -> Ordering
-compareInt64# i# j#
- | i# `ltInt64#` j# = LT
- | i# `eqInt64#` j# = EQ
- | otherwise = GT
-
-instance Bounded Int64 where
- minBound = integerToInt64 (-0x8000000000000000)
- maxBound = integerToInt64 0x7fffffffffffffff
-
-instance Integral Int64 where
- div x y
- | x > 0 && y < 0 = quotInt64 (x-y-1) y
- | x < 0 && y > 0 = quotInt64 (x-y+1) y
- | otherwise = quotInt64 x y
-
- quot x@(I64# _) y@(I64# y#)
- | y# `neInt64#` (intToInt64# 0#) = x `quotInt64` y
- | otherwise = divZeroError "quot{Int64}" x
-
- rem x@(I64# _) y@(I64# y#)
- | y# `neInt64#` (intToInt64# 0#) = x `remInt64` y
- | otherwise = divZeroError "rem{Int64}" x
-
- mod x y
- | x > 0 && y < 0 || x < 0 && y > 0 = if r/=0 then r+y else 0
- | otherwise = r
- where r = remInt64 x y
-
- a@(I64# _) `quotRem` b@(I64# _) = (a `quotInt64` b, a `remInt64` b)
- toInteger i = int64ToInteger i
- toInt i = int64ToInt i
-
-instance Bits Int64 where
- (I64# x) .&. (I64# y) = I64# (word64ToInt64# ((int64ToWord64# x) `and64#` (int64ToWord64# y)))
- (I64# x) .|. (I64# y) = I64# (word64ToInt64# ((int64ToWord64# x) `or64#` (int64ToWord64# y)))
- (I64# x) `xor` (I64# y) = I64# (word64ToInt64# ((int64ToWord64# x) `xor64#` (int64ToWord64# y)))
- complement (I64# x) = I64# (negateInt64# x)
- shift (I64# x) i@(I# i#)
- | i > 0 = I64# (iShiftL64# x i#)
- | otherwise = I64# (iShiftRA64# x (negateInt# i#))
- i64@(I64# x) `rotate` (I# i)
- | i ==# 0# = i64
- | i ># 0# =
- -- ( (x<<i') | ((x&(0x10000000000000000-2^i2))>>i2) )
- I64# (word64ToInt64# (
- (int64ToWord64# (iShiftL64# x i')) `or64#`
- (int64ToWord64# (iShiftRA64# (word64ToInt64# ((int64ToWord64# x) `and64#`
- (int64ToWord64# (maxBound# `minusInt64#` (pow2_64# i2 `plusInt64#` (intToInt64# 1#))))))
- i2))))
- | otherwise = rotate i64 (I# (64# +# i))
- where
- i' = word2Int# (int2Word# i `and#` int2Word# 63#)
- i2 = 64# -# i'
- (I64# maxBound#) = maxBound
- bit i = shift 1 i
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
- testBit x i = (x .&. bit i) /= 0
- bitSize _ = 64
- isSigned _ = True
-
-remInt64, quotInt64 :: Int64 -> Int64 -> Int64
-remInt64 (I64# x) (I64# y) = I64# (x `remInt64#` y)
-quotInt64 (I64# x) (I64# y) = I64# (x `quotInt64#` y)
-
-intToInt64 :: Int -> Int64
-intToInt64 (I# i#) = I64# (intToInt64# i#)
-
-int64ToInt :: Int64 -> Int
-int64ToInt (I64# i#) = I# (int64ToInt# i#)
-
--- Word64# primop wrappers:
-
-ltInt64# :: Int64# -> Int64# -> Bool
-ltInt64# x# y# =
- case stg_ltInt64 x# y# of
- 0 -> False
- _ -> True
-
-leInt64# :: Int64# -> Int64# -> Bool
-leInt64# x# y# =
- case stg_leInt64 x# y# of
- 0 -> False
- _ -> True
-
-eqInt64# :: Int64# -> Int64# -> Bool
-eqInt64# x# y# =
- case stg_eqInt64 x# y# of
- 0 -> False
- _ -> True
-
-neInt64# :: Int64# -> Int64# -> Bool
-neInt64# x# y# =
- case stg_neInt64 x# y# of
- 0 -> False
- _ -> True
-
-geInt64# :: Int64# -> Int64# -> Bool
-geInt64# x# y# =
- case stg_geInt64 x# y# of
- 0 -> False
- _ -> True
-
-gtInt64# :: Int64# -> Int64# -> Bool
-gtInt64# x# y# =
- case stg_gtInt64 x# y# of
- 0 -> False
- _ -> True
-
-plusInt64# :: Int64# -> Int64# -> Int64#
-plusInt64# a# b# =
- case stg_plusInt64 a# b# of
- I64# i# -> i#
-
-minusInt64# :: Int64# -> Int64# -> Int64#
-minusInt64# a# b# =
- case stg_minusInt64 a# b# of
- I64# i# -> i#
-
-timesInt64# :: Int64# -> Int64# -> Int64#
-timesInt64# a# b# =
- case stg_timesInt64 a# b# of
- I64# i# -> i#
-
-quotInt64# :: Int64# -> Int64# -> Int64#
-quotInt64# a# b# =
- case stg_quotInt64 a# b# of
- I64# i# -> i#
-
-remInt64# :: Int64# -> Int64# -> Int64#
-remInt64# a# b# =
- case stg_remInt64 a# b# of
- I64# i# -> i#
-
-negateInt64# :: Int64# -> Int64#
-negateInt64# a# =
- case stg_negateInt64 a# of
- I64# i# -> i#
-
-and64# :: Word64# -> Word64# -> Word64#
-and64# a# b# =
- case stg_and64 a# b# of
- W64# w# -> w#
-
-or64# :: Word64# -> Word64# -> Word64#
-or64# a# b# =
- case stg_or64 a# b# of
- W64# w# -> w#
-
-xor64# :: Word64# -> Word64# -> Word64#
-xor64# a# b# =
- case stg_xor64 a# b# of
- W64# w# -> w#
-
-not64# :: Word64# -> Word64#
-not64# a# =
- case stg_not64 a# of
- W64# w# -> w#
-
-shiftL64# :: Word64# -> Int# -> Word64#
-shiftL64# a# b# =
- case stg_shiftL64 a# b# of
- W64# w# -> w#
-
-iShiftL64# :: Int64# -> Int# -> Int64#
-iShiftL64# a# b# =
- case stg_iShiftL64 a# b# of
- I64# i# -> i#
-
-iShiftRL64# :: Int64# -> Int# -> Int64#
-iShiftRL64# a# b# =
- case stg_iShiftRL64 a# b# of
- I64# i# -> i#
-
-iShiftRA64# :: Int64# -> Int# -> Int64#
-iShiftRA64# a# b# =
- case stg_iShiftRA64 a# b# of
- I64# i# -> i#
-
-shiftRL64# :: Word64# -> Int# -> Word64#
-shiftRL64# a# b# =
- case stg_shiftRL64 a# b# of
- W64# w# -> w#
-
-int64ToInt# :: Int64# -> Int#
-int64ToInt# i64# =
- case stg_int64ToInt i64# of
- I# i# -> i#
-
-wordToWord64# :: Word# -> Word64#
-wordToWord64# w# =
- case stg_wordToWord64 w# of
- W64# w64# -> w64#
-
-word64ToInt64# :: Word64# -> Int64#
-word64ToInt64# w# =
- case stg_word64ToInt64 w# of
- I64# i# -> i#
-
-int64ToWord64# :: Int64# -> Word64#
-int64ToWord64# i# =
- case stg_int64ToWord64 i# of
- W64# w# -> w#
-
-intToInt64# :: Int# -> Int64#
-intToInt64# i# =
- case stg_intToInt64 i# of
- I64# i64# -> i64#
-
-foreign import "stg_intToInt64" stg_intToInt64 :: Int# -> Int64
-foreign import "stg_int64ToWord64" stg_int64ToWord64 :: Int64# -> Word64
-foreign import "stg_word64ToInt64" stg_word64ToInt64 :: Word64# -> Int64
-foreign import "stg_wordToWord64" stg_wordToWord64 :: Word# -> Word64
-foreign import "stg_int64ToInt" stg_int64ToInt :: Int64# -> Int
-foreign import "stg_shiftRL64" stg_shiftRL64 :: Word64# -> Int# -> Word64
-foreign import "stg_iShiftRA64" stg_iShiftRA64 :: Int64# -> Int# -> Int64
-foreign import "stg_iShiftRL64" stg_iShiftRL64 :: Int64# -> Int# -> Int64
-foreign import "stg_iShiftL64" stg_iShiftL64 :: Int64# -> Int# -> Int64
-foreign import "stg_shiftL64" stg_shiftL64 :: Word64# -> Int# -> Word64
-foreign import "stg_not64" stg_not64 :: Word64# -> Word64
-foreign import "stg_xor64" stg_xor64 :: Word64# -> Word64# -> Word64
-foreign import "stg_or64" stg_or64 :: Word64# -> Word64# -> Word64
-foreign import "stg_and64" stg_and64 :: Word64# -> Word64# -> Word64
-foreign import "stg_negateInt64" stg_negateInt64 :: Int64# -> Int64
-foreign import "stg_remInt64" stg_remInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_quotInt64" stg_quotInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_timesInt64" stg_timesInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_minusInt64" stg_minusInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_plusInt64" stg_plusInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_gtInt64" stg_gtInt64 :: Int64# -> Int64# -> Int
-foreign import "stg_geInt64" stg_geInt64 :: Int64# -> Int64# -> Int
-foreign import "stg_neInt64" stg_neInt64 :: Int64# -> Int64# -> Int
-foreign import "stg_eqInt64" stg_eqInt64 :: Int64# -> Int64# -> Int
-foreign import "stg_leInt64" stg_leInt64 :: Int64# -> Int64# -> Int
-foreign import "stg_ltInt64" stg_ltInt64 :: Int64# -> Int64# -> Int
-
-#endif
-
---
--- Code that's independent of Int64 rep.
---
-instance Enum Int64 where
- succ i
- | i == maxBound = succError "Int64"
- | otherwise = i+1
-
- pred i
- | i == minBound = predError "Int64"
- | otherwise = i-1
-
- toEnum i = intToInt64 i
- fromEnum x
- | x >= intToInt64 (minBound::Int) && x <= intToInt64 (maxBound::Int)
- = int64ToInt x
- | otherwise
- = fromEnumError "Int64" x
-
- enumFrom e1 = map integerToInt64 [int64ToInteger e1 .. int64ToInteger (maxBound::Int64)]
- enumFromTo e1 e2 = map integerToInt64 [int64ToInteger e1 .. int64ToInteger e2]
- enumFromThen e1 e2 = map integerToInt64 [int64ToInteger e1, int64ToInteger e2 .. int64ToInteger last]
- where
- last :: Int64
- last
- | e2 < e1 = minBound
- | otherwise = maxBound
-
- enumFromThenTo e1 e2 e3 = map integerToInt64 [int64ToInteger e1, int64ToInteger e2 .. int64ToInteger e3]
-
-
-instance Show Int64 where
- showsPrec p i64 = showsPrec p (int64ToInteger i64)
-
-instance Read Int64 where
- readsPrec _ s = [ (integerToInt64 x,r) | (x,r) <- readDec s ]
-
-
-instance Ix Int64 where
- range (m,n) = [m..n]
- index b@(m,_) i
- | inRange b i = int64ToInt (i-m)
- | otherwise = indexError i b "Int64"
- inRange (m,n) i = m <= i && i <= n
-
-instance Real Int64 where
- toRational x = toInteger x % 1
-
-
-sizeofInt64 :: Word32
-sizeofInt64 = 8
-
-int8ToInteger :: Int8 -> Integer
-int8ToInteger i = toInteger i
-
-int16ToInteger :: Int16 -> Integer
-int16ToInteger i = toInteger i
-
-int32ToInteger :: Int32 -> Integer
-int32ToInteger i = toInteger i
-
-int64ToInt8 :: Int64 -> Int8
-int64ToInt8 = int32ToInt8 . int64ToInt32
-
-int64ToInt16 :: Int64 -> Int16
-int64ToInt16 = int32ToInt16 . int64ToInt32
-
-integerToInt8 :: Integer -> Int8
-integerToInt8 = fromInteger
-
-integerToInt16 :: Integer -> Int16
-integerToInt16 = fromInteger
-
-integerToInt32 :: Integer -> Int32
-integerToInt32 = fromInteger
-
-\end{code}
-
-%
-%
-\subsection[Int Utils]{Miscellaneous utilities}
-%
-%
-
-Code copied from the Prelude
-
-\begin{code}
-absReal :: (Ord a, Num a) => a -> a
-absReal x | x >= 0 = x
- | otherwise = -x
-
-signumReal :: (Ord a, Num a) => a -> a
-signumReal x | x == 0 = 0
- | x > 0 = 1
- | otherwise = -1
-\end{code}
-
-\begin{code}
-indexInt8OffAddr :: Addr -> Int -> Int8
-indexInt8OffAddr (A# a#) (I# i#) = intToInt8 (I# (ord# (indexCharOffAddr# a# i#)))
-
-indexInt16OffAddr :: Addr -> Int -> Int16
-indexInt16OffAddr a i =
-#ifdef WORDS_BIGENDIAN
- intToInt16 ( int8ToInt l + (int8ToInt maxBound) * int8ToInt h)
-#else
- intToInt16 ( int8ToInt h + (int8ToInt maxBound) * int8ToInt l)
-#endif
- where
- byte_idx = i * 2
- l = indexInt8OffAddr a byte_idx
- h = indexInt8OffAddr a (byte_idx+1)
-
-indexInt32OffAddr :: Addr -> Int -> Int32
-indexInt32OffAddr (A# a#) i = intToInt32 (I# (indexIntOffAddr# a# i'#))
- where
- -- adjust index to be in Int units, not Int32 ones.
- (I# i'#)
-#if WORD_SIZE_IN_BYTES==8
- = i `div` 2
-#else
- = i
-#endif
-
-indexInt64OffAddr :: Addr -> Int -> Int64
-indexInt64OffAddr (A# a#) (I# i#)
-#if WORD_SIZE_IN_BYTES==8
- = I64# (indexIntOffAddr# a# i#)
-#else
- = I64# (indexInt64OffAddr# a# i#)
-#endif
-
-#ifndef __PARALLEL_HASKELL__
-
-indexInt8OffForeignObj :: ForeignObj -> Int -> Int8
-indexInt8OffForeignObj (ForeignObj fo#) (I# i#) = intToInt8 (I# (ord# (indexCharOffForeignObj# fo# i#)))
-
-indexInt16OffForeignObj :: ForeignObj -> Int -> Int16
-indexInt16OffForeignObj fo i =
-# ifdef WORDS_BIGENDIAN
- intToInt16 ( int8ToInt l + (int8ToInt maxBound) * int8ToInt h)
-# else
- intToInt16 ( int8ToInt h + (int8ToInt maxBound) * int8ToInt l)
-# endif
- where
- byte_idx = i * 2
- l = indexInt8OffForeignObj fo byte_idx
- h = indexInt8OffForeignObj fo (byte_idx+1)
-
-indexInt32OffForeignObj :: ForeignObj -> Int -> Int32
-indexInt32OffForeignObj (ForeignObj fo#) i = intToInt32 (I# (indexIntOffForeignObj# fo# i'#))
- where
- -- adjust index to be in Int units, not Int32 ones.
- (I# i'#)
-# if WORD_SIZE_IN_BYTES==8
- = i `div` 2
-# else
- = i
-# endif
-
-indexInt64OffForeignObj :: ForeignObj -> Int -> Int64
-indexInt64OffForeignObj (ForeignObj fo#) (I# i#)
-# if WORD_SIZE_IN_BYTES==8
- = I64# (indexIntOffForeignObj# fo# i#)
-# else
- = I64# (indexInt64OffForeignObj# fo# i#)
-# endif
-
-#endif /* __PARALLEL_HASKELL__ */
-\end{code}
-
-Read words out of mutable memory:
-
-\begin{code}
-readInt8OffAddr :: Addr -> Int -> IO Int8
-readInt8OffAddr a i = _casm_ `` %r=(StgInt8)(((StgInt8*)%0)[(StgInt)%1]); '' a i
-
-readInt16OffAddr :: Addr -> Int -> IO Int16
-readInt16OffAddr a i = _casm_ `` %r=(StgInt16)(((StgInt16*)%0)[(StgInt)%1]); '' a i
-
-readInt32OffAddr :: Addr -> Int -> IO Int32
-readInt32OffAddr a i = _casm_ `` %r=(StgInt32)(((StgInt32*)%0)[(StgInt)%1]); '' a i
-
-readInt64OffAddr :: Addr -> Int -> IO Int64
-#if WORD_SIZE_IN_BYTES==8
-readInt64OffAddr a i = _casm_ `` %r=(StgInt)(((StgInt*)%0)[(StgInt)%1]); '' a i
-#else
-readInt64OffAddr a i = _casm_ `` %r=(StgInt64)(((StgInt64*)%0)[(StgInt)%1]); '' a i
-#endif
-
-#ifndef __PARALLEL_HASKELL__
-
-readInt8OffForeignObj :: ForeignObj -> Int -> IO Int8
-readInt8OffForeignObj fo i = _casm_ `` %r=(StgInt8)(((StgInt8*)%0)[(StgInt)%1]); '' fo i
-
-readInt16OffForeignObj :: ForeignObj -> Int -> IO Int16
-readInt16OffForeignObj fo i = _casm_ `` %r=(StgInt16)(((StgInt16*)%0)[(StgInt)%1]); '' fo i
-
-readInt32OffForeignObj :: ForeignObj -> Int -> IO Int32
-readInt32OffForeignObj fo i = _casm_ `` %r=(StgInt32)(((StgInt32*)%0)[(StgInt)%1]); '' fo i
-
-readInt64OffForeignObj :: ForeignObj -> Int -> IO Int64
-# if WORD_SIZE_IN_BYTES==8
-readInt64OffForeignObj fo i = _casm_ `` %r=(StgInt)(((StgInt*)%0)[(StgInt)%1]); '' fo i
-# else
-readInt64OffForeignObj fo i = _casm_ `` %r=(StgInt64)(((StgInt64*)%0)[(StgInt)%1]); '' fo i
-# endif
-
-#endif /* __PARALLEL_HASKELL__ */
-\end{code}
-
-\begin{code}
-writeInt8OffAddr :: Addr -> Int -> Int8 -> IO ()
-writeInt8OffAddr a i e = _casm_ `` (((StgInt8*)%0)[(StgInt)%1])=(StgInt8)%2; '' a i e
-
-writeInt16OffAddr :: Addr -> Int -> Int16 -> IO ()
-writeInt16OffAddr a i e = _casm_ `` (((StgInt16*)%0)[(StgInt)%1])=(StgInt16)%2; '' a i e
-
-writeInt32OffAddr :: Addr -> Int -> Int32 -> IO ()
-writeInt32OffAddr a i e = _casm_ `` (((StgInt32*)%0)[(StgInt)%1])=(StgInt32)%2; '' a i e
-
-writeInt64OffAddr :: Addr -> Int -> Int64 -> IO ()
-#if WORD_SIZE_IN_BYTES==8
-writeInt64OffAddr a i e = _casm_ `` (((StgInt*)%0)[(StgInt)%1])=(StgInt)%2; '' a i e
-#else
-writeInt64OffAddr a i e = _casm_ `` (((StgInt64*)%0)[(StgInt)%1])=(StgInt64)%2; '' a i e
-#endif
-
-#ifndef __PARALLEL_HASKELL__
-
-writeInt8OffForeignObj :: ForeignObj -> Int -> Int8 -> IO ()
-writeInt8OffForeignObj fo i e = _casm_ `` (((StgInt8*)%0)[(StgInt)%1])=(StgInt8)%2; '' fo i e
-
-writeInt16OffForeignObj :: ForeignObj -> Int -> Int16 -> IO ()
-writeInt16OffForeignObj fo i e = _casm_ `` (((StgInt16*)%0)[(StgInt)%1])=(StgInt16)%2; '' fo i e
-
-writeInt32OffForeignObj :: ForeignObj -> Int -> Int32 -> IO ()
-writeInt32OffForeignObj fo i e = _casm_ `` (((StgInt32*)%0)[(StgInt)%1])=(StgInt32)%2; '' fo i e
-
-writeInt64OffForeignObj :: ForeignObj -> Int -> Int64 -> IO ()
-# if WORD_SIZE_IN_BYTES==8
-writeInt64OffForeignObj fo i e = _casm_ `` (((StgInt*)%0)[(StgInt)%1])=(StgInt)%2; '' fo i e
-# else
-writeInt64OffForeignObj fo i e = _casm_ `` (((StgInt64*)%0)[(StgInt)%1])=(StgInt64)%2; '' fo i e
-# endif
-
-#endif /* __PARALLEL_HASKELL__ */
-
-\end{code}
-
-
-C&P'ed from Ix.lhs
-
-\begin{code}
-{-# NOINLINE indexError #-}
-indexError :: Show a => a -> (a,a) -> String -> b
-indexError i rng tp
- = error (showString "Ix{" . showString tp . showString "}.index: Index " .
- showParen True (showsPrec 0 i) .
- showString " out of range " $
- showParen True (showsPrec 0 rng) "")
-
-
-toEnumError :: (Show a,Show b) => String -> a -> (b,b) -> c
-toEnumError inst_ty tag bnds
- = error ("Enum.toEnum{" ++ inst_ty ++ "}: tag " ++
- (showParen True (showsPrec 0 tag) $
- " is outside of bounds " ++
- show bnds))
-
-fromEnumError :: (Show a,Show b) => String -> a -> b
-fromEnumError inst_ty tag
- = error ("Enum.fromEnum{" ++ inst_ty ++ "}: value " ++
- (showParen True (showsPrec 0 tag) $
- " is outside of Int's bounds " ++
- show (minBound::Int,maxBound::Int)))
-
-succError :: String -> a
-succError inst_ty
- = error ("Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound")
-
-predError :: String -> a
-predError inst_ty
- = error ("Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound")
-
-divZeroError :: (Show a) => String -> a -> b
-divZeroError meth v
- = error ("Integral." ++ meth ++ ": divide by 0 (" ++ show v ++ " / 0)")
-
-\end{code}
-
-#else
-\begin{code}
------------------------------------------------------------------------------
--- The "official" coercion functions
------------------------------------------------------------------------------
-
-int8ToInt :: Int8 -> Int
-intToInt8 :: Int -> Int8
-int16ToInt :: Int16 -> Int
-intToInt16 :: Int -> Int16
-int32ToInt :: Int32 -> Int
-intToInt32 :: Int -> Int32
-
--- And some non-exported ones
-
-int8ToInt16 :: Int8 -> Int16
-int8ToInt32 :: Int8 -> Int32
-int16ToInt8 :: Int16 -> Int8
-int16ToInt32 :: Int16 -> Int32
-int32ToInt8 :: Int32 -> Int8
-int32ToInt16 :: Int32 -> Int16
-
-int8ToInt16 = I16 . int8ToInt
-int8ToInt32 = I32 . int8ToInt
-int16ToInt8 = I8 . int16ToInt
-int16ToInt32 = I32 . int16ToInt
-int32ToInt8 = I8 . int32ToInt
-int32ToInt16 = I16 . int32ToInt
-
------------------------------------------------------------------------------
--- Int8
------------------------------------------------------------------------------
-
-newtype Int8 = I8 Int
-
-int8ToInt (I8 x) = if x' <= 0x7f then x' else x' - 0x100
- where x' = x `primAndInt` 0xff
-intToInt8 = I8
-
-instance Eq Int8 where (==) = binop (==)
-instance Ord Int8 where compare = binop compare
-
-instance Num Int8 where
- x + y = to (binop (+) x y)
- x - y = to (binop (-) x y)
- negate = to . negate . from
- x * y = to (binop (*) x y)
- abs = absReal
- signum = signumReal
- fromInteger = to . fromInteger
- fromInt = to
-
-instance Bounded Int8 where
- minBound = 0x80
- maxBound = 0x7f
-
-instance Real Int8 where
- toRational x = toInteger x % 1
-
-instance Integral Int8 where
- x `div` y = to (binop div x y)
- x `quot` y = to (binop quot x y)
- x `rem` y = to (binop rem x y)
- x `mod` y = to (binop mod x y)
- x `quotRem` y = to2 (binop quotRem x y)
- even = even . from
- toInteger = toInteger . from
- toInt = toInt . from
-
-instance Ix Int8 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = from (i - m)
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int8 where
- toEnum = to
- fromEnum = from
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Int8)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int8)]
- where last = if d < c then minBound else maxBound
-
-instance Read Int8 where
- readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
-
-instance Show Int8 where
- showsPrec p = showsPrec p . from
-
-binop8 :: (Int32 -> Int32 -> a) -> (Int8 -> Int8 -> a)
-binop8 op x y = int8ToInt32 x `op` int8ToInt32 y
-
-instance Bits Int8 where
- x .&. y = int32ToInt8 (binop8 (.&.) x y)
- x .|. y = int32ToInt8 (binop8 (.|.) x y)
- x `xor` y = int32ToInt8 (binop8 xor x y)
- complement = int32ToInt8 . complement . int8ToInt32
- x `shift` i = int32ToInt8 (int8ToInt32 x `shift` i)
--- rotate
- bit = int32ToInt8 . bit
- setBit x i = int32ToInt8 (setBit (int8ToInt32 x) i)
- clearBit x i = int32ToInt8 (clearBit (int8ToInt32 x) i)
- complementBit x i = int32ToInt8 (complementBit (int8ToInt32 x) i)
- testBit x i = testBit (int8ToInt32 x) i
- bitSize _ = 8
- isSigned _ = True
-
-int8ToInteger = error "TODO: int8ToInteger"
-integerToInt8 = error "TODO: integerToInt8"
-
---intToInt8 = fromInt
---int8ToInt = toInt
-
-sizeofInt8 :: Word32
-sizeofInt8 = 1
-
------------------------------------------------------------------------------
--- Int16
------------------------------------------------------------------------------
-
-newtype Int16 = I16 Int
-
-int16ToInt (I16 x) = if x' <= 0x7fff then x' else x' - 0x10000
- where x' = x `primAndInt` 0xffff
-intToInt16 = I16
-
-instance Eq Int16 where (==) = binop (==)
-instance Ord Int16 where compare = binop compare
-
-instance Num Int16 where
- x + y = to (binop (+) x y)
- x - y = to (binop (-) x y)
- negate = to . negate . from
- x * y = to (binop (*) x y)
- abs = absReal
- signum = signumReal
- fromInteger = to . fromInteger
- fromInt = to
-
-instance Bounded Int16 where
- minBound = 0x8000
- maxBound = 0x7fff
-
-instance Real Int16 where
- toRational x = toInteger x % 1
-
-instance Integral Int16 where
- x `div` y = to (binop div x y)
- x `quot` y = to (binop quot x y)
- x `rem` y = to (binop rem x y)
- x `mod` y = to (binop mod x y)
- x `quotRem` y = to2 (binop quotRem x y)
- even = even . from
- toInteger = toInteger . from
- toInt = toInt . from
-
-instance Ix Int16 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = from (i - m)
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int16 where
- toEnum = to
- fromEnum = from
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Int16)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int16)]
- where last = if d < c then minBound else maxBound
-
-instance Read Int16 where
- readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
-
-instance Show Int16 where
- showsPrec p = showsPrec p . from
-
-binop16 :: (Int32 -> Int32 -> a) -> (Int16 -> Int16 -> a)
-binop16 op x y = int16ToInt32 x `op` int16ToInt32 y
-
-instance Bits Int16 where
- x .&. y = int32ToInt16 (binop16 (.&.) x y)
- x .|. y = int32ToInt16 (binop16 (.|.) x y)
- x `xor` y = int32ToInt16 (binop16 xor x y)
- complement = int32ToInt16 . complement . int16ToInt32
- x `shift` i = int32ToInt16 (int16ToInt32 x `shift` i)
--- rotate
- bit = int32ToInt16 . bit
- setBit x i = int32ToInt16 (setBit (int16ToInt32 x) i)
- clearBit x i = int32ToInt16 (clearBit (int16ToInt32 x) i)
- complementBit x i = int32ToInt16 (complementBit (int16ToInt32 x) i)
- testBit x i = testBit (int16ToInt32 x) i
- bitSize _ = 16
- isSigned _ = True
-
-int16ToInteger = error "TODO: int16ToInteger"
-integerToInt16 = error "TODO: integerToInt16"
-
---intToInt16 = fromInt
---int16ToInt = toInt
-
-sizeofInt16 :: Word32
-sizeofInt16 = 2
-
------------------------------------------------------------------------------
--- Int32
------------------------------------------------------------------------------
-
-newtype Int32 = I32 Int
-
-int32ToInt (I32 x) = x
-intToInt32 = I32
-
-instance Eq Int32 where (==) = binop (==)
-instance Ord Int32 where compare = binop compare
-
-instance Num Int32 where
- x + y = to (binop (+) x y)
- x - y = to (binop (-) x y)
- negate = to . negate . from
- x * y = to (binop (*) x y)
- abs = absReal
- signum = signumReal
- fromInteger = to . fromInteger
- fromInt = to
-
-instance Bounded Int32 where
- minBound = to minBound
- maxBound = to maxBound
-
-instance Real Int32 where
- toRational x = toInteger x % 1
-
-instance Integral Int32 where
- x `div` y = to (binop div x y)
- x `quot` y = to (binop quot x y)
- x `rem` y = to (binop rem x y)
- x `mod` y = to (binop mod x y)
- x `quotRem` y = to2 (binop quotRem x y)
- even = even . from
- toInteger = toInteger . from
- toInt = toInt . from
-
-instance Ix Int32 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = from (i - m)
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int32 where
- toEnum = to
- fromEnum = from
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Int32)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int32)]
- where last = if d < c then minBound else maxBound
-
-instance Read Int32 where
- readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
-
-instance Show Int32 where
- showsPrec p = showsPrec p . from
-
-instance Bits Int32 where
- (.&.) x y = to (binop primAndInt x y)
- (.|.) x y = to (binop primOrInt x y)
- xor x y = to (binop primXorInt x y)
-
- complement = xor ((-1) :: Int32)
- x `shift` i | i == 0 = x
- | i > 0 = to (primShiftLInt (from x) i)
- | i < 0 = to (primShiftRAInt (from x) (-i))
--- rotate
- bit = shift 0x1
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
-
- testBit x i = (0x1 .&. shift x i) == (0x1 :: Int32)
- bitSize _ = 32
- isSigned _ = True
-
-
-int32ToInteger = error "TODO: int32ToInteger"
-integerToInt32 = error "TODO: integerToInt32"
-
-sizeofInt32 :: Word32
-sizeofInt32 = 4
-
------------------------------------------------------------------------------
--- Int64
---
--- This is not ideal, but does have the advantage that you can
--- now typecheck generated code that include Int64 statements.
---
------------------------------------------------------------------------------
-
-type Int64 = Integer
-
-int64ToInteger = error "TODO: int64ToInteger"
-
-integerToInt64 = error "TODO: integerToInt64"
-
-int64ToInt32 = error "TODO: int64ToInt32"
-int64ToInt16 = error "TODO: int64ToInt16"
-int64ToInt8 = error "TODO: int64ToInt8"
-
-int32ToInt64 = error "TODO: int32ToInt64"
-int16ToInt64 = error "TODO: int16ToInt64"
-int8ToInt64 = error "TODO: int8ToInt64"
-
-intToInt64 = fromInt
-int64ToInt = toInt
-
-sizeofInt64 :: Word32
-sizeofInt64 = 8
-
------------------------------------------------------------------------------
--- End of exported definitions
---
--- The remainder of this file consists of definitions which are only
--- used in the implementation.
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
--- Coercions - used to make the instance declarations more uniform
------------------------------------------------------------------------------
-
-class Coerce a where
- to :: Int -> a
- from :: a -> Int
-
-instance Coerce Int32 where
- from = int32ToInt
- to = intToInt32
-
-instance Coerce Int8 where
- from = int8ToInt
- to = intToInt8
-
-instance Coerce Int16 where
- from = int16ToInt
- to = intToInt16
-
-binop :: Coerce int => (Int -> Int -> a) -> (int -> int -> a)
-binop op x y = from x `op` from y
-
-to2 :: Coerce int => (Int, Int) -> (int, int)
-to2 (x,y) = (to x, to y)
-
------------------------------------------------------------------------------
--- Extra primitives
------------------------------------------------------------------------------
-
---primitive primAnd "primAndInt" :: Int -> Int -> Int
-
---primitive primAndInt :: Int32 -> Int32 -> Int32
---primitive primOrInt :: Int32 -> Int32 -> Int32
---primitive primXorInt :: Int32 -> Int32 -> Int32
---primitive primComplementInt :: Int32 -> Int32
---primitive primShiftInt :: Int32 -> Int -> Int32
---primitive primBitInt :: Int -> Int32
---primitive primTestInt :: Int32 -> Int -> Bool
-
------------------------------------------------------------------------------
--- Code copied from the Prelude
------------------------------------------------------------------------------
-
-absReal x | x >= 0 = x
- | otherwise = -x
-
-signumReal x | x == 0 = 0
- | x > 0 = 1
- | otherwise = -1
-
------------------------------------------------------------------------------
--- End
------------------------------------------------------------------------------
-
-intToWord :: Int -> Word
-intToWord i = primIntToWord i
-
-\end{code}
-#endif
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1997
-%
-
-\section[LazyST]{The Lazy State Transformer Monad, @LazyST@}
-
-This module presents an identical interface to ST, but the underlying
-implementation of the state thread is lazy.
-
-\begin{code}
-module LazyST (
-
- ST,
-
- runST,
- unsafeInterleaveST,
-
- ST.STRef,
- newSTRef, readSTRef, writeSTRef,
-
- STArray,
- newSTArray, readSTArray, writeSTArray, boundsSTArray,
- thawSTArray, freezeSTArray, unsafeFreezeSTArray,
- unsafeThawSTArray,
-
- ST.unsafeIOToST, ST.stToIO,
-
- strictToLazyST, lazyToStrictST
- ) where
-
-import qualified ST
-import qualified PrelST
-import PrelArr
-import PrelBase ( Eq(..), Int, Bool, ($), ()(..) )
-import Monad
-import Ix
-import PrelGHC
-
-newtype ST s a = ST (State s -> (a, State s))
-
-data State s = S# (State# s)
-
-instance Functor (ST s) where
- fmap f m = ST $ \ s ->
- let
- ST m_a = m
- (r,new_s) = m_a s
- in
- (f r,new_s)
-
-instance Monad (ST s) where
-
- return a = ST $ \ s -> (a,s)
- m >> k = m >>= \ _ -> k
- fail s = error s
-
- (ST m) >>= k
- = ST $ \ s ->
- let
- (r,new_s) = m s
- ST k_a = k r
- in
- k_a new_s
-
-{-# NOINLINE runST #-}
-runST :: (forall s. ST s a) -> a
-runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Variables}
-%* *
-%*********************************************************
-
-\begin{code}
-newSTRef :: a -> ST s (ST.STRef s a)
-readSTRef :: ST.STRef s a -> ST s a
-writeSTRef :: ST.STRef s a -> a -> ST s ()
-
-newSTRef = strictToLazyST . ST.newSTRef
-readSTRef = strictToLazyST . ST.readSTRef
-writeSTRef r a = strictToLazyST (ST.writeSTRef r a)
-
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Arrays}
-%* *
-%*********************************************************
-
-\begin{code}
-newtype STArray s ix elt = STArray (MutableArray s ix elt)
-
-newSTArray :: Ix ix => (ix,ix) -> elt -> ST s (STArray s ix elt)
-readSTArray :: Ix ix => STArray s ix elt -> ix -> ST s elt
-writeSTArray :: Ix ix => STArray s ix elt -> ix -> elt -> ST s ()
-boundsSTArray :: Ix ix => STArray s ix elt -> (ix, ix)
-thawSTArray :: Ix ix => Array ix elt -> ST s (STArray s ix elt)
-freezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
-unsafeFreezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
-
-newSTArray ixs init =
- strictToLazyST (newArray ixs init) >>= \arr ->
- return (STArray arr)
-
-readSTArray (STArray arr) ix = strictToLazyST (readArray arr ix)
-writeSTArray (STArray arr) ix v = strictToLazyST (writeArray arr ix v)
-boundsSTArray (STArray arr) = boundsOfArray arr
-thawSTArray arr =
- strictToLazyST (thawArray arr) >>= \ marr ->
- return (STArray marr)
-
-freezeSTArray (STArray arr) = strictToLazyST (freezeArray arr)
-unsafeFreezeSTArray (STArray arr) = strictToLazyST (unsafeFreezeArray arr)
-unsafeThawSTArray arr =
- strictToLazyST (unsafeThawArray arr) >>= \ marr ->
- return (STArray marr)
-
-strictToLazyST :: PrelST.ST s a -> ST s a
-strictToLazyST m = ST $ \s ->
- let
- pr = case s of { S# s# -> PrelST.liftST m s# }
- r = case pr of { PrelST.STret _ v -> v }
- s' = case pr of { PrelST.STret s2# _ -> S# s2# }
- in
- (r, s')
-
-lazyToStrictST :: ST s a -> PrelST.ST s a
-lazyToStrictST (ST m) = PrelST.ST $ \s ->
- case (m (S# s)) of (a, S# s') -> (# s', a #)
-
-unsafeInterleaveST :: ST s a -> ST s a
-unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST
-
-\end{code}
+++ /dev/null
-#################################################################################
-#
-# ghc/lib/Makefile
-#
-# Makefile for building the GHC Prelude libraries umpteen ways
-#
-#
-#################################################################################
-
-TOP = ../..
-include $(TOP)/mk/boilerplate.mk
-
-WAYS=$(GhcLibWays)
-
-HC = $(GHC)
-
-#-----------------------------------------------------------------------------
-# Setting the standard variables
-#
-
-LIBRARY = libHSexts$(_way).a
-HS_SRCS = $(wildcard *.lhs)
-HS_OBJS = $(HS_SRCS:.lhs=.$(way_)o)
-LIBOBJS = $(HS_OBJS)
-HS_IFACES= $(HS_SRCS:.lhs=.$(way_)hi)
-
-#-----------------------------------------------------------------------------
-# Setting the GHC compile options
-
-SRC_HC_OPTS += -recomp -cpp -fglasgow-exts -fvia-C -Rghc-timing $(GhcLibHcOpts)
-
-ifneq "$(way)" "dll"
-SRC_HC_OPTS += -static
-endif
-
-#
-# Profiling options
-WAY_p_HC_OPTS += -GPrelude
-WAY_mr_HC_OPTS += -GPrelude
-
-#
-# Object and interface files have suffixes tagged with their ways
-#
-ifneq "$(way)" ""
-SRC_HC_OPTS += -hisuf $(way_)hi
-endif
-
-Int_HC_OPTS += -H20m -fno-prune-tydecls -monly-3-regs
-Word_HC_OPTS += -H20m -monly-3-regs
-Foreign_HC_OPTS += -fno-prune-tydecls
-NativeInfo_HC_OPTS += -fno-prune-tydecls
-Dynamic_HC_OPTS += $(MAGIC_HSCPP_OPTS)
-
-MAGIC_HSCPP_OPTS=-DBEGIN_FOR_GHC='-}' -DEND_FOR_GHC='{-' -DBEGIN_FOR_HUGS='{-' -DEND_FOR_HUGS='-}'
-
-#-----------------------------------------------------------------------------
-# Dependency generation
-
-SRC_MKDEPENDHS_OPTS += -I$(GHC_INCLUDE_DIR) -optdep--include-prelude -optdep-w $(MAGIC_HSCPP_OPTS)
-
-#-----------------------------------------------------------------------------
-# Win32 DLL setup
-
-DLL_NAME = HSexts.dll
-DLL_IMPLIB_NAME = libHSexts_imp.a
-SRC_BLD_DLL_OPTS += --export-all --output-def=HSexts.def DllVersionInfo.o
-SRC_BLD_DLL_OPTS += -lwinmm -lHSrts_imp -lHScbits_imp -lHS_imp -lgmp -L. -L../../rts/gmp -L../../rts -L../std -L../std/cbits
-
-ifeq "$(way)" "dll"
-all :: DllVersionInfo.o
-endif
-
-#-----------------------------------------------------------------------------
-# Installation; need to install .hi files as well as libraries
-#
-# The interface files are put inside the $(libdir), since they
-# might (potentially) be platform specific..
-#
-# override is used here because for binary distributions, datadir is
-# set on the command line. sigh.
-#
-override datadir:=$(libdir)/imports/exts
-
-#
-# Files to install from here
-#
-INSTALL_LIBS += $(LIBRARY)
-INSTALL_DATAS += $(HS_IFACES)
-
-ifeq "$(EnableWin32DLLs)" "YES"
-INSTALL_PROGS += $(DLL_NAME)
-INSTALL_LIBS += $(patsubst %.a, %_imp.a, $(LIBRARY))
-INSTALL_DATAS += dLL_ifs.hi
-endif
-
-include $(TOP)/mk/target.mk
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1997
-%
-\section[MutableArray]{The @MutableArray@ interface}
-
-Mutable (byte)arrays interface, re-exports type types and operations
-over them from @ArrBase@. Have to be used in conjunction with
-@ST@.
-
-\begin{code}
-module MutableArray
- (
- MutableArray(..), -- not abstract
- MutableByteArray(..),
-
- ST,
- Ix,
-
- -- Creators:
- newArray, -- :: Ix ix => (ix,ix) -> elt -> ST s (MutableArray s ix elt)
- newCharArray,
- newAddrArray,
- newIntArray,
- newFloatArray,
- newDoubleArray,
- newStablePtrArray, -- :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
-
- boundsOfArray, -- :: Ix ix => MutableArray s ix elt -> (ix, ix)
- boundsOfMutableByteArray, -- :: Ix ix => MutableByteArray s ix -> (ix, ix)
-
- readArray, -- :: Ix ix => MutableArray s ix elt -> ix -> ST s elt
-
- readCharArray, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Char
- readIntArray, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Int
- readAddrArray, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Addr
- readFloatArray, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Float
- readDoubleArray, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Double
- readStablePtrArray, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s (StablePtr a)
-
- writeArray, -- :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s ()
- writeCharArray, -- :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s ()
- writeIntArray, -- :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s ()
- writeAddrArray, -- :: Ix ix => MutableByteArray s ix -> ix -> Addr -> ST s ()
- writeFloatArray, -- :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s ()
- writeDoubleArray, -- :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s ()
- writeStablePtrArray, -- :: Ix ix => MutableByteArray s ix -> ix -> StablePtr a -> ST s ()
-
- freezeArray, -- :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt)
- freezeCharArray, -- :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
- freezeIntArray, -- :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
- freezeAddrArray, -- :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
- freezeFloatArray, -- :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
- freezeDoubleArray, -- :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
- freezeStablePtrArray, -- :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
-
- unsafeFreezeArray, -- :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt)
- unsafeFreezeByteArray, -- :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
-
- thawArray, -- :: Ix ix => Array ix elt -> ST s (MutableArray s ix)
- thawByteArray, -- :: Ix ix => ByteArray ix -> ST s (MutableByteArray s ix)
- unsafeThawArray, -- :: Ix ix => Array ix elt -> ST s (MutableArray s ix)
- unsafeThawByteArray, -- :: Ix ix => ByteArray ix -> ST s (MutableByteArray s ix)
-
- -- the sizes are reported back are *in bytes*.
- sizeofMutableByteArray, -- :: Ix ix => MutableByteArray s ix -> Int
-
- readWord8Array, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Word8
- readWord16Array, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Word16
- readWord32Array, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Word32
- readWord64Array, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Word64
-
- writeWord8Array, -- :: Ix ix => MutableByteArray s ix -> ix -> Word8 -> ST s ()
- writeWord16Array, -- :: Ix ix => MutableByteArray s ix -> ix -> Word16 -> ST s ()
- writeWord32Array, -- :: Ix ix => MutableByteArray s ix -> ix -> Word32 -> ST s ()
- writeWord64Array, -- :: Ix ix => MutableByteArray s ix -> ix -> Word64 -> ST s ()
-
- readInt8Array, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Int8
- readInt16Array, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Int16
- readInt32Array, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Int32
- readInt64Array, -- :: Ix ix => MutableByteArray s ix -> ix -> ST s Int64
-
- writeInt8Array, -- :: Ix ix => MutableByteArray s ix -> ix -> Int8 -> ST s ()
- writeInt16Array, -- :: Ix ix => MutableByteArray s ix -> ix -> Int16 -> ST s ()
- writeInt32Array, -- :: Ix ix => MutableByteArray s ix -> ix -> Int32 -> ST s ()
- writeInt64Array -- :: Ix ix => MutableByteArray s ix -> ix -> Int64 -> ST s ()
-
- ) where
-
-import PrelIOBase
-import PrelBase
-import PrelArr
-import PrelAddr
-import PrelArrExtra
-import PrelForeign
-import PrelStable
-import PrelST
-import ST
-import Ix
-import Word
-import Int
-
-\end{code}
-
-Note: the absence of operations to read/write ForeignObjs to a mutable
-array is not accidental; storing foreign objs in a mutable array is
-not supported.
-
-\begin{code}
-sizeofMutableByteArray :: Ix ix => MutableByteArray s ix -> Int
-sizeofMutableByteArray (MutableByteArray _ _ arr#) =
- case (sizeofMutableByteArray# arr#) of
- i# -> (I# i#)
-
-\end{code}
-
-\begin{code}
-newStablePtrArray :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
-newStablePtrArray ixs@(l,u) = ST $ \ s# ->
- case rangeSize ixs of { I# n# ->
- case (newStablePtrArray# n# s#) of { (# s2#, barr# #) ->
- (# s2#, (MutableByteArray l u barr#) #) }}
-
-readStablePtrArray :: Ix ix => MutableByteArray s ix -> ix -> ST s (StablePtr a)
-readStablePtrArray (MutableByteArray l u barr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readStablePtrArray# barr# n# s# of { (# s2#, r# #) ->
- (# s2# , (StablePtr r#) #) }}
-
-writeStablePtrArray :: Ix ix => MutableByteArray s ix -> ix -> StablePtr a -> ST s ()
-writeStablePtrArray (MutableByteArray l u barr#) n (StablePtr sp#) = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case writeStablePtrArray# barr# n# sp# s# of { s2# ->
- (# s2# , () #) }}
-
-freezeStablePtrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
-freezeStablePtrArray (MutableByteArray l u arr#) = ST $ \ s# ->
- case rangeSize (l,u) of { I# n# ->
- case freeze arr# n# s# of { (# s2# , frozen# #) ->
- (# s2# , ByteArray l u frozen# #) }}
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> (# State# s, ByteArray# #)
-
- freeze arr1# n# s#
- = case (newStablePtrArray# n# s#) of { (# s2# , newarr1# #) ->
- case copy 0# n# arr1# newarr1# s2# of { (# s3# , newarr2# #) ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int# -> Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> (# State# s , MutableByteArray# s #)
-
- copy cur# end# from# to# st#
- | cur# ==# end#
- = (# st# , to# #)
- | otherwise
- = case (readStablePtrArray# from# cur# st#) of { (# s1# , ele #) ->
- case (writeStablePtrArray# to# cur# ele s1#) of { s2# ->
- copy (cur# +# 1#) end# from# to# s2#
- }}
-
-\end{code}
-
-
-Reminder: indexing an array at some base type is done in units
-of the size of the type being; *not* in bytes.
-
-\begin{code}
-readWord8Array :: (Ix ix) => MutableByteArray s ix -> ix -> ST s Word8
-readWord16Array :: (Ix ix) => MutableByteArray s ix -> ix -> ST s Word16
-readWord32Array :: (Ix ix) => MutableByteArray s ix -> ix -> ST s Word32
-
-readWord8Array (MutableByteArray l u arr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readCharArray# arr# n# s# of { (# s2# , r# #) ->
- (# s2# , intToWord8 (I# (ord# r#)) #) }}
-
-
-readWord16Array (MutableByteArray l u arr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readWordArray# arr# (n# `quotInt#` 2#) s# of { (# s2# , w# #) ->
- case n# `remInt#` 2# of
- 0# -> (# s2# , wordToWord16 (W# w#) #)
- -- the double byte hides in the lower half of the wrd.
- 1# -> (# s2# , wordToWord16 (W# (shiftRL# w# 16#)) #)
- -- take the upper 16 bits.
- }}
-
-readWord32Array (MutableByteArray l u arr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readWordArray# arr# n# s# of { (# s2# , w# #) ->
- (# s2# , wordToWord32 (W# w#) #) }}
-
-
- -- FIXME, Num shouldn't be required, but it makes my life easier.
-readWord64Array :: (Num ix, Ix ix) => MutableByteArray s ix -> ix -> ST s Word64
-readWord64Array mb n = do
- l <- readWord32Array mb (2*n)
- h <- readWord32Array mb (2*n + 1)
-#ifdef WORDS_BIGENDIAN
- return ( word32ToWord64 h + word32ToWord64 l * word32ToWord64 (maxBound::Word32))
-#else
- return ( word32ToWord64 l + word32ToWord64 h * word32ToWord64 (maxBound::Word32))
-#endif
-
-writeWord8Array :: (Ix ix) => MutableByteArray s ix -> ix -> Word8 -> ST s ()
-writeWord16Array :: (Ix ix) => MutableByteArray s ix -> ix -> Word16 -> ST s ()
-writeWord32Array :: (Ix ix) => MutableByteArray s ix -> ix -> Word32 -> ST s ()
-
-writeWord8Array (MutableByteArray l u arr#) n w = ST $ \ s# ->
- case (index (l,u) n) of
- I# n# -> case writeCharArray# arr# n# (chr# (word2Int# (word8ToWord# w))) s# of
- s2# -> (# s2# , () #)
-
-writeWord16Array (MutableByteArray l u arr#) n w = ST $ \ s# ->
- case (index (l,u) n) of
- I# n# ->
- let
- w# =
- let w' = word16ToWord# w in
- case n# `remInt#` 2# of
- 0# -> w'
- 1# -> shiftL# w' 16#
-
- mask =
- case n# `remInt#` 2# of
- 0# -> case ``0xffff0000'' of W# x -> x -- writing to the lower half of the word.
- 1# -> int2Word# 0x0000ffff#
- in
- case readWordArray# arr# (n# `quotInt#` 2#) s# of
- (# s2# , v# #) ->
- case writeWordArray# arr# (n# `quotInt#` 2#) (w# `or#` (v# `and#` mask )) s2# of
- s3# -> (# s3# , () #)
-
-writeWord32Array (MutableByteArray l u arr#) n w = ST $ \ s# ->
- case (index (l,u) n) of
- I# n# ->
- case writeWordArray# arr# n# w# s# of
- s2# -> (# s2# , () #)
- where
- w# = word32ToWord# w
-
- -- FIXME, Num shouldn't be required, but it makes my life easier.
-writeWord64Array :: (Num ix, Ix ix) => MutableByteArray s ix -> ix -> Word64 -> ST s ()
-writeWord64Array mb n w = do
-#ifdef WORDS_BIGENDIAN
- writeWord32Array mb (n*2) h
- writeWord32Array mb (n*2+1) l
-#else
- writeWord32Array mb (n*2) l
- writeWord32Array mb (n*2+1) h
-#endif
- where
- h = word64ToWord32 h'
- l = word64ToWord32 l'
- (h',l') = w `divMod` (word32ToWord64 (maxBound::Word32) + 1)
-
-
-\end{code}
-
-\begin{code}
-readInt8Array :: (Ix ix) => MutableByteArray s ix -> ix -> ST s Int8
-readInt16Array :: (Ix ix) => MutableByteArray s ix -> ix -> ST s Int16
-readInt32Array :: (Ix ix) => MutableByteArray s ix -> ix -> ST s Int32
-
-readInt8Array (MutableByteArray l u arr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readCharArray# arr# n# s# of { (# s2# , r# #) ->
- (# s2# , intToInt8 (I# (ord# r#)) #) }}
-
-readInt16Array (MutableByteArray l u arr#) n = ST $ \ s# ->
- case (index (l,u) n) of
- I# n# ->
- case readIntArray# arr# (n# `quotInt#` 2#) s# of
- (# s2# , i# #) ->
- case n# `remInt#` 2# of
- 0# -> (# s2# , intToInt16 (I# i#) #)
- 1# -> (# s2# , intToInt16 (I# (word2Int# (shiftRL# (int2Word# i#) 16# ))) #)
-
-readInt32Array (MutableByteArray l u arr#) n = ST $ \ s# ->
- case (index (l,u) n) of
- I# n# -> case readIntArray# arr# n# s# of
- (# s2# , i# #) -> (# s2# , intToInt32 (I# i#) #)
-
-readInt64Array :: (Num ix, Ix ix) => MutableByteArray s ix -> ix -> ST s Int64
-readInt64Array mb n = do
- l <- readInt32Array mb (2*n)
- h <- readInt32Array mb (2*n + 1)
-#ifdef WORDS_BIGENDIAN
- return ( int32ToInt64 h + int32ToInt64 l * int32ToInt64 (maxBound::Int32))
-#else
- return ( int32ToInt64 l + int32ToInt64 h * int32ToInt64 (maxBound::Int32))
-#endif
-
-writeInt8Array :: (Ix ix) => MutableByteArray s ix -> ix -> Int8 -> ST s ()
-writeInt16Array :: (Ix ix) => MutableByteArray s ix -> ix -> Int16 -> ST s ()
-writeInt32Array :: (Ix ix) => MutableByteArray s ix -> ix -> Int32 -> ST s ()
-
-writeInt8Array (MutableByteArray l u arr#) n i = ST $ \ s# ->
- case (index (l,u) n) of
- I# n# ->
- case writeCharArray# arr# n# ch s# of
- s2# -> (# s2# , () #)
- where
- ch = chr# (int8ToInt# i)
-
-writeInt16Array (MutableByteArray l u arr#) n i = ST $ \ s# ->
- case (index (l,u) n) of
- I# n# ->
- let
- i# =
- let i' = int16ToInt# i in
- case n# `remInt#` 2# of
- 0# -> i'
- 1# -> iShiftL# i' 16#
-
- mask =
- case n# `remInt#` 2# of
- 0# -> case ``0xffff0000'' of W# x -> x -- writing to the lower half of the word.
- 1# -> int2Word# 0x0000ffff#
- in
- case readIntArray# arr# (n# `quotInt#` 2#) s# of
- (# s2# , v# #) ->
- let w' = word2Int# (int2Word# i# `or#` (int2Word# v# `and#` mask))
- in
- case writeIntArray# arr# (n# `quotInt#` 2#) w' s2# of
- s2# -> (# s2# , () #)
-
-writeInt32Array (MutableByteArray l u arr#) n i = ST $ \ s# ->
- case (index (l,u) n) of
- I# n# ->
- case writeIntArray# arr# n# i# s# of
- s2# -> (# s2# , () #)
- where
- i# = int32ToInt# i
-
-writeInt64Array :: (Num ix, Ix ix) => MutableByteArray s ix -> ix -> Int64 -> ST s ()
-writeInt64Array mb n w = do
-#ifdef WORDS_BIGENDIAN
- writeInt32Array mb (n*2) h
- writeInt32Array mb (n*2+1) l
-#else
- writeInt32Array mb (n*2) l
- writeInt32Array mb (n*2+1) h
-#endif
- where
- h = int64ToInt32 h'
- l = int64ToInt32 l'
- (h',l') = w `divMod` (int32ToInt64 (maxBound::Int32) * 2 - 1)
-
-\end{code}
-
-\begin{code}
-{-# SPECIALIZE boundsOfMutableByteArray :: MutableByteArray s Int -> IPr #-}
-boundsOfMutableByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix)
-boundsOfMutableByteArray (MutableByteArray l u _) = (l,u)
-
-\end{code}
-
-\begin{code}
-thawByteArray :: Ix ix => ByteArray ix -> ST s (MutableByteArray s ix)
-thawByteArray (ByteArray l u barr#) =
- {-
- The implementation is made more complex by the
- fact that the indexes are in units of whatever
- base types that's stored in the byte array.
- -}
- case (sizeofByteArray# barr#) of
- i# -> do
- marr <- newCharArray (0,I# i#)
- mapM_ (\ idx@(I# idx#) ->
- writeCharArray marr idx (C# (indexCharArray# barr# idx#)))
- [0..]
- let (MutableByteArray _ _ arr#) = marr
- return (MutableByteArray l u arr#)
-
-{-
- in-place conversion of immutable arrays to mutable ones places
- a proof obligation on the user: no other parts of your code can
- have a reference to the array at the point where you unsafely
- thaw it (and, subsequently mutate it, I suspect.)
--}
-unsafeThawByteArray :: Ix ix => ByteArray ix -> ST s (MutableByteArray s ix)
-unsafeThawByteArray (ByteArray l u barr#) = ST $ \ s# ->
- case unsafeThawByteArray# barr# s# of
- (# s2#, arr# #) -> (# s2#, MutableByteArray l u arr# #)
-
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1998
-%
-\section[NativeInfo]{Module @NativeInfo@}
-
-Misc information about the characteristics of the host
-architecture/machine lucky enough to run your program.
-
-\begin{code}
-#include "MachDeps.h"
-
-module NativeInfo
- (
- isBigEndian -- :: Bool
-
- , os -- :: String
- , arch -- :: String
-
- , sizeofAddr -- :: Word32
- , sizeofDouble -- :: ""
- , sizeofFloat
- , sizeofChar
-
- , sizeofWord
- , sizeofWord8
- , sizeofWord16
- , sizeofWord32
- , sizeofWord64
-
- , sizeofInt
- , sizeofInt8
- , sizeofInt16
- , sizeofInt32
- , sizeofInt64
-
- ) where
-
-import Word
-import Addr
-import Int
-
-\end{code}
-
-Byte-ordering:
-
-\begin{code}
-isBigEndian :: Bool
-isBigEndian =
-#ifdef WORDS_BIGENDIAN
- True
-#else
- False
-#endif
-\end{code}
-
-Host architecture and OS info:
-
-\begin{code}
-arch :: String
-arch = HOST_ARCH
-
-os :: String
-os = HOST_OS
-\end{code}
-
-@sizeofX@ returns the size of the (basic) type X (in 8-bit byte units.)
-
-(Do not provide a type class for this, since writing out sizeofX is shorter
-(and more consise) than using an overloaded function that returns the sizeof
-at a particular type.)
-
-\begin{code}
-sizeofAddr :: Word32
-sizeofAddr = ADDR_SIZE_IN_BYTES
-
-sizeofDouble :: Word32
-sizeofDouble = DOUBLE_SIZE_IN_BYTES
-
-sizeofFloat :: Word32
-sizeofFloat = FLOAT_SIZE_IN_BYTES
-
-sizeofInt :: Word32
-sizeofInt = INT_SIZE_IN_BYTES
-
-sizeofWord :: Word32
-sizeofWord = WORD_SIZE_IN_BYTES
-
-sizeofChar :: Word32
-sizeofChar = CHAR_SIZE_IN_BYTES
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1998
-%
-
-\section[NumExts]{Misc numeric bits}
-
-\begin{code}
-module NumExts
-
- (
- doubleToFloat -- :: Double -> Float
- , floatToDouble -- :: Double -> Float
-
- , showHex -- :: Integral a => a -> ShowS
- , showOct -- :: Integral a => a -> ShowS
- , showBin -- :: Integral a => a -> ShowS
-
- -- general purpose number->string converter.
- , showIntAtBase -- :: Integral a
- -- => a -- base
- -- -> (a -> Char) -- digit to char
- -- -> a -- number to show.
- -- -> ShowS
- , showListWith -- :: (a -> ShowS)
- -- -> [a]
- -- -> ShowS
- ) where
-
-import Char (ord, chr)
-#ifdef __HUGS__
-ord_0 = ord '0'
-#else
-import PrelNum ( ord_0 )
-import PrelShow( showList__ )
-import GlaExts
-#endif
-\end{code}
-
-\begin{code}
-doubleToFloat :: Double -> Float
-floatToDouble :: Float -> Double
-
-#ifdef __HUGS__
-doubleToFloat = primDoubleToFloat
-floatToDouble = primFloatToDouble
-#else
-doubleToFloat (D# d#) = F# (double2Float# d#)
-floatToDouble (F# f#) = D# (float2Double# f#)
-#endif
-
-#ifdef __HUGS__
-showIntAtBase :: Integral a => a -> (a -> Char) -> a -> ShowS
-showIntAtBase base toChr n r
- | n < 0 = error ("NumExts.showIntAtBase: applied to negative number " ++ show n)
- | otherwise =
- case quotRem n base of { (n', d) ->
- let c = toChr d in
- seq c $ -- stricter than necessary
- let
- r' = c : r
- in
- if n' == 0 then r' else showIntAtBase base toChr n' r'
- }
-#else
-showIntAtBase :: Integral a => a -> (a -> Char) -> a -> ShowS
-showIntAtBase base toChr n r
- | n < 0 = error ("NumExts.showIntAtBase: applied to negative number " ++ show n)
- | otherwise =
- case quotRem n base of { (n', d) ->
- case toChr d of { C# c# -> -- stricter than necessary
- let
- r' = C# c# : r
- in
- if n' == 0 then r' else showIntAtBase base toChr n' r'
- }}
-#endif
-
-showHex :: Integral a => a -> ShowS
-showHex n r =
- showString "0x" $
- showIntAtBase 16 (toChrHex) n r
- where
- toChrHex d
- | d < 10 = chr (ord_0 + fromIntegral d)
- | otherwise = chr (ord 'a' + fromIntegral (d - 10))
-
-showOct :: Integral a => a -> ShowS
-showOct n r =
- showString "0o" $
- showIntAtBase 8 (toChrOct) n r
- where toChrOct d = chr (ord_0 + fromIntegral d)
-
-showBin :: Integral a => a -> ShowS
-showBin n r =
- showString "0b" $
- showIntAtBase 2 (toChrOct) n r
- where toChrOct d = chr (ord_0 + fromIntegral d)
-\end{code}
-
-Easy enough to define by the user, but since it's
-occasionally useful (when, say, printing out a
-list of hex values), we define and export it
-from @NumExts@.
-
-\begin{code}
-showListWith :: (a -> ShowS) -> [a] -> ShowS
-showListWith = showList__
-#ifdef __HUGS__
-showList__ :: (a -> ShowS) -> [a] -> ShowS
-showList__ _ [] s = "[]" ++ s
-showList__ showx (x:xs) s = '[' : showx x (showl xs)
- where
- showl [] = ']' : s
- showl (y:ys) = ',' : showx y (showl ys)
-#endif
-\end{code}
-
+++ /dev/null
-*********************************************************************************
-* *
-* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators *
-* *
-* based on "The Design of a Pretty-printing Library" *
-* in Advanced Functional Programming, *
-* Johan Jeuring and Erik Meijer (eds), LNCS 925 *
-* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps *
-* *
-* Heavily modified by Simon Peyton Jones, Dec 96 *
-* *
-*********************************************************************************
-
-Version 3.0 28 May 1997
- * Cured massive performance bug. If you write
-
- foldl <> empty (map (text.show) [1..10000])
-
- you get quadratic behaviour with V2.0. Why? For just the same reason as you get
- quadratic behaviour with left-associated (++) chains.
-
- This is really bad news. One thing a pretty-printer abstraction should
- certainly guarantee is insensivity to associativity. It matters: suddenly
- GHC's compilation times went up by a factor of 100 when I switched to the
- new pretty printer.
-
- I fixed it with a bit of a hack (because I wanted to get GHC back on the
- road). I added two new constructors to the Doc type, Above and Beside:
-
- <> = Beside
- $$ = Above
-
- Then, where I need to get to a "TextBeside" or "NilAbove" form I "force"
- the Doc to squeeze out these suspended calls to Beside and Above; but in so
- doing I re-associate. It's quite simple, but I'm not satisfied that I've done
- the best possible job. I'll send you the code if you are interested.
-
- * Added new exports:
- punctuate, hang
- int, integer, float, double, rational,
- lparen, rparen, lbrack, rbrack, lbrace, rbrace,
-
- * fullRender's type signature has changed. Rather than producing a string it
- now takes an extra couple of arguments that tells it how to glue fragments
- of output together:
-
- fullRender :: Mode
- -> Int -- Line length
- -> Float -- Ribbons per line
- -> (TextDetails -> a -> a) -- What to do with text
- -> a -- What to do at the end
- -> Doc
- -> a -- Result
-
- The "fragments" are encapsulated in the TextDetails data type:
- data TextDetails = Chr Char
- | Str String
- | PStr FAST_STRING
-
- The Chr and Str constructors are obvious enough. The PStr constructor has a packed
- string (FAST_STRING) inside it. It's generated by using the new "ptext" export.
-
- An advantage of this new setup is that you can get the renderer to do output
- directly (by passing in a function of type (TextDetails -> IO () -> IO ()),
- rather than producing a string that you then print.
-
-
-Version 2.0 24 April 1997
- * Made empty into a left unit for <> as well as a right unit;
- it is also now true that
- nest k empty = empty
- which wasn't true before.
-
- * Fixed an obscure bug in sep that occassionally gave very wierd behaviour
-
- * Added $+$
-
- * Corrected and tidied up the laws and invariants
-
-======================================================================
-Relative to John's original paper, there are the following new features:
-
-1. There's an empty document, "empty". It's a left and right unit for
- both <> and $$, and anywhere in the argument list for
- sep, hcat, hsep, vcat, fcat etc.
-
- It is Really Useful in practice.
-
-2. There is a paragraph-fill combinator, fsep, that's much like sep,
- only it keeps fitting things on one line until itc can't fit any more.
-
-3. Some random useful extra combinators are provided.
- <+> puts its arguments beside each other with a space between them,
- unless either argument is empty in which case it returns the other
-
-
- hcat is a list version of <>
- hsep is a list version of <+>
- vcat is a list version of $$
-
- sep (separate) is either like hsep or like vcat, depending on what fits
-
- cat is behaves like sep, but it uses <> for horizontal conposition
- fcat is behaves like fsep, but it uses <> for horizontal conposition
-
- These new ones do the obvious things:
- char, semi, comma, colon, space,
- parens, brackets, braces,
- quotes, doubleQuotes
-
-4. The "above" combinator, $$, now overlaps its two arguments if the
- last line of the top argument stops before the first line of the second begins.
- For example: text "hi" $$ nest 5 "there"
- lays out as
- hi there
- rather than
- hi
- there
-
- There are two places this is really useful
-
- a) When making labelled blocks, like this:
- Left -> code for left
- Right -> code for right
- LongLongLongLabel ->
- code for longlonglonglabel
- The block is on the same line as the label if the label is
- short, but on the next line otherwise.
-
- b) When laying out lists like this:
- [ first
- , second
- , third
- ]
- which some people like. But if the list fits on one line
- you want [first, second, third]. You can't do this with
- John's original combinators, but it's quite easy with the
- new $$.
-
- The combinator $+$ gives the original "never-overlap" behaviour.
-
-5. Several different renderers are provided:
- * a standard one
- * one that uses cut-marks to avoid deeply-nested documents
- simply piling up in the right-hand margin
- * one that ignores indentation (fewer chars output; good for machines)
- * one that ignores indentation and newlines (ditto, only more so)
-
-6. Numerous implementation tidy-ups
- Use of unboxed data types to speed up the implementation
-
-
-
-\begin{code}
-module Pretty (
- Doc, -- Abstract
- Mode(..), TextDetails(..),
-
- empty, isEmpty, nest,
-
- text, char, ptext,
- int, integer, float, double, rational,
- parens, brackets, braces, quotes, doubleQuotes,
- semi, comma, colon, space, equals,
- lparen, rparen, lbrack, rbrack, lbrace, rbrace,
-
- (<>), (<+>), hcat, hsep,
- ($$), ($+$), vcat,
- sep, cat,
- fsep, fcat,
-
- hang, punctuate,
-
--- renderStyle, -- Haskell 1.3 only
- render, fullRender
- ) where
-
--- Don't import Util( assertPanic ) because it makes a loop in the module structure
-
-infixl 6 <>
-infixl 6 <+>
-infixl 5 $$, $+$
-\end{code}
-
-
-
-*********************************************************
-* *
-\subsection{CPP magic so that we can compile with both GHC and Hugs}
-* *
-*********************************************************
-
-The library uses unboxed types to get a bit more speed, but these CPP macros
-allow you to use either GHC or Hugs. To get GHC, just set the CPP variable
- __GLASGOW_HASKELL__
-
-
-*********************************************************
-* *
-\subsection{The interface}
-* *
-*********************************************************
-
-The primitive @Doc@ values
-
-\begin{code}
-empty :: Doc
-isEmpty :: Doc -> Bool
-text :: String -> Doc
-char :: Char -> Doc
-
-semi, comma, colon, space, equals :: Doc
-lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
-
-parens, brackets, braces :: Doc -> Doc
-quotes, doubleQuotes :: Doc -> Doc
-
-int :: Int -> Doc
-integer :: Integer -> Doc
-float :: Float -> Doc
-double :: Double -> Doc
-rational :: Rational -> Doc
-\end{code}
-
-Combining @Doc@ values
-
-\begin{code}
-(<>) :: Doc -> Doc -> Doc -- Beside
-hcat :: [Doc] -> Doc -- List version of <>
-(<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
-hsep :: [Doc] -> Doc -- List version of <+>
-
-($$) :: Doc -> Doc -> Doc -- Above; if there is no
- -- overlap it "dovetails" the two
-vcat :: [Doc] -> Doc -- List version of $$
-
-cat :: [Doc] -> Doc -- Either hcat or vcat
-sep :: [Doc] -> Doc -- Either hsep or vcat
-fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
-fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
-
-nest :: Int -> Doc -> Doc -- Nested
-\end{code}
-
-GHC-specific ones.
-
-\begin{code}
-hang :: Doc -> Int -> Doc -> Doc
-punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
-\end{code}
-
-Displaying @Doc@ values.
-
-\begin{code}
-instance Show Doc where
- showsPrec prec doc cont = showDoc doc cont
-
-render :: Doc -> String -- Uses default style
-fullRender :: Mode
- -> Int -- Line length
- -> Float -- Ribbons per line
- -> (TextDetails -> a -> a) -- What to do with text
- -> a -- What to do at the end
- -> Doc
- -> a -- Result
-
-{- When we start using 1.3
-renderStyle :: Style -> Doc -> String
-data Style = Style { lineLength :: Int, -- In chars
- ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
- mode :: Mode
- }
-style :: Style -- The default style
-style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
--}
-
-data Mode = PageMode -- Normal
- | ZigZagMode -- With zig-zag cuts
- | LeftMode -- No indentation, infinitely long lines
- | OneLineMode -- All on one line
-
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{The @Doc@ calculus}
-* *
-*********************************************************
-
-The @Doc@ combinators satisfy the following laws:
-\begin{verbatim}
-Laws for $$
-~~~~~~~~~~~
-<a1> (x $$ y) $$ z = x $$ (y $$ z)
-<a2> empty $$ x = x
-<a3> x $$ empty = x
-
- ...ditto $+$...
-
-Laws for <>
-~~~~~~~~~~~
-<b1> (x <> y) <> z = x <> (y <> z)
-<b2> empty <> x = empty
-<b3> x <> empty = x
-
- ...ditto <+>...
-
-Laws for text
-~~~~~~~~~~~~~
-<t1> text s <> text t = text (s++t)
-<t2> text "" <> x = x, if x non-empty
-
-Laws for nest
-~~~~~~~~~~~~~
-<n1> nest 0 x = x
-<n2> nest k (nest k' x) = nest (k+k') x
-<n3> nest k (x <> y) = nest k z <> nest k y
-<n4> nest k (x $$ y) = nest k x $$ nest k y
-<n5> nest k empty = empty
-<n6> x <> nest k y = x <> y, if x non-empty
-
-** Note the side condition on <n6>! It is this that
-** makes it OK for empty to be a left unit for <>.
-
-Miscellaneous
-~~~~~~~~~~~~~
-<m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
- nest (-length s) y)
-
-<m2> (x $$ y) <> z = x $$ (y <> z)
- if y non-empty
-
-
-Laws for list versions
-~~~~~~~~~~~~~~~~~~~~~~
-<l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
- ...ditto hsep, hcat, vcat, fill...
-
-<l2> nest k (sep ps) = sep (map (nest k) ps)
- ...ditto hsep, hcat, vcat, fill...
-
-Laws for oneLiner
-~~~~~~~~~~~~~~~~~
-<o1> oneLiner (nest k p) = nest k (oneLiner p)
-<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
-\end{verbatim}
-
-
-You might think that the following verion of <m1> would
-be neater:
-\begin{verbatim}
-<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
- nest (-length s) y)
-\end{verbatim}
-But it doesn't work, for if x=empty, we would have
-\begin{verbatim}
- text s $$ y = text s <> (empty $$ nest (-length s) y)
- = text s <> nest (-length s) y
-\end{verbatim}
-
-
-
-*********************************************************
-* *
-\subsection{Simple derived definitions}
-* *
-*********************************************************
-
-\begin{code}
-semi = char ';'
-colon = char ':'
-comma = char ','
-space = char ' '
-equals = char '='
-lparen = char '('
-rparen = char ')'
-lbrack = char '['
-rbrack = char ']'
-lbrace = char '{'
-rbrace = char '}'
-
-int n = text (show n)
-integer n = text (show n)
-float n = text (show n)
-double n = text (show n)
-rational n = text (show n)
--- SIGBJORN wrote instead:
--- rational n = text (show (fromRationalX n))
-
-quotes p = char '`' <> p <> char '\''
-doubleQuotes p = char '"' <> p <> char '"'
-parens p = char '(' <> p <> char ')'
-brackets p = char '[' <> p <> char ']'
-braces p = char '{' <> p <> char '}'
-
-
-hcat = foldr (<>) empty
-hsep = foldr (<+>) empty
-vcat = foldr ($$) empty
-
-hang d1 n d2 = sep [d1, nest n d2]
-
-punctuate p [] = []
-punctuate p (d:ds) = go d ds
- where
- go d [] = [d]
- go d (e:es) = (d <> p) : go e es
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{The @Doc@ data type}
-* *
-*********************************************************
-
-A @Doc@ represents a {\em set} of layouts. A @Doc@ with
-no occurrences of @Union@ or @NoDoc@ represents just one layout.
-\begin{code}
-data Doc
- = Empty -- empty
- | NilAbove Doc -- text "" $$ x
- | TextBeside TextDetails Int Doc -- text s <> x
- | Nest Int Doc -- nest k x
- | Union Doc Doc -- ul `union` ur
- | NoDoc -- The empty set of documents
- | Beside Doc Bool Doc -- True <=> space between
- | Above Doc Bool Doc -- True <=> never overlap
-
-type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
-
-
-reduceDoc :: Doc -> RDoc
-reduceDoc (Beside p g q) = beside p g (reduceDoc q)
-reduceDoc (Above p g q) = above p g (reduceDoc q)
-reduceDoc p = p
-
-
-data TextDetails = Chr Char
- | Str String
- | PStr String
-space_text = Chr ' '
-nl_text = Chr '\n'
-\end{code}
-
-Here are the invariants:
-\begin{itemize}
-\item
-The argument of @NilAbove@ is never @Empty@. Therefore
-a @NilAbove@ occupies at least two lines.
-
-\item
-The arugment of @TextBeside@ is never @Nest@.
-
-\item
-The layouts of the two arguments of @Union@ both flatten to the same string.
-
-\item
-The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
-
-\item
-The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
-If the left argument of a union is equivalent to the empty set (@NoDoc@),
-then the @NoDoc@ appears in the first line.
-
-\item
-An empty document is always represented by @Empty@.
-It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
-
-\item
-The first line of every layout in the left argument of @Union@
-is longer than the first line of any layout in the right argument.
-(1) ensures that the left argument has a first line. In view of (3),
-this invariant means that the right argument must have at least two
-lines.
-\end{itemize}
-
-\begin{code}
- -- Arg of a NilAbove is always an RDoc
-nilAbove_ p = NilAbove p
-
- -- Arg of a TextBeside is always an RDoc
-textBeside_ s sl p = TextBeside s sl p
-
- -- Arg of Nest is always an RDoc
-nest_ k p = Nest k p
-
- -- Args of union are always RDocs
-union_ p q = Union p q
-
-\end{code}
-
-
-Notice the difference between
- * NoDoc (no documents)
- * Empty (one empty document; no height and no width)
- * text "" (a document containing the empty string;
- one line high, but has no width)
-
-
-
-*********************************************************
-* *
-\subsection{@empty@, @text@, @nest@, @union@}
-* *
-*********************************************************
-
-\begin{code}
-empty = Empty
-
-isEmpty Empty = True
-isEmpty _ = False
-
-char c = textBeside_ (Chr c) 1 Empty
-text s = case length s of {sl -> textBeside_ (Str s) sl Empty}
-ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
-
-nest k p = mkNest k (reduceDoc p) -- Externally callable version
-
--- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
-mkNest k (Nest k1 p) = mkNest (k + k1) p
-mkNest k NoDoc = NoDoc
-mkNest k Empty = Empty
-mkNest 0 p = p -- Worth a try!
-mkNest k p = nest_ k p
-
--- mkUnion checks for an empty document
-mkUnion Empty q = Empty
-mkUnion p q = p `union_` q
-\end{code}
-
-*********************************************************
-* *
-\subsection{Vertical composition @$$@}
-* *
-*********************************************************
-
-
-\begin{code}
-p $$ q = Above p False q
-p $+$ q = Above p True q
-
-above :: Doc -> Bool -> RDoc -> RDoc
-above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
-above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
-above p g q = aboveNest p g 0 (reduceDoc q)
-
-aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
--- Specfication: aboveNest p g k q = p $g$ (nest k q)
-
-aboveNest NoDoc g k q = NoDoc
-aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
- aboveNest p2 g k q
-
-aboveNest Empty g k q = mkNest k q
-aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
- -- p can't be Empty, so no need for mkNest
-
-aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
-aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
- where
- k1 = k - sl
- rest = case p of
- Empty -> nilAboveNest g k1 q
- other -> aboveNest p g k1 q
-\end{code}
-
-\begin{code}
-nilAboveNest :: Bool -> Int -> RDoc -> RDoc
--- Specification: text s <> nilaboveNest g k q
--- = text s <> (text "" $g$ nest k q)
-
-nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
-nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
-
-nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap
- = textBeside_ (Str (spaces k)) k q
- | otherwise -- Put them really above
- = nilAbove_ (mkNest k q)
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{Horizontal composition @<>@}
-* *
-*********************************************************
-
-\begin{code}
-p <> q = Beside p False q
-p <+> q = Beside p True q
-
-beside :: Doc -> Bool -> RDoc -> RDoc
--- Specification: beside g p q = p <g> q
-
-beside NoDoc g q = NoDoc
-beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
-beside Empty g q = q
-beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty
-beside p@(Beside p1 g1 q1) g2 q2
- {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
- [ && (op1 == <> || op1 == <+>) ] -}
- | g1 == g2 = beside p1 g1 (beside q1 g2 q2)
- | otherwise = beside (reduceDoc p) g2 q2
-beside p@(Above _ _ _) g q = beside (reduceDoc p) g q
-beside (NilAbove p) g q = nilAbove_ (beside p g q)
-beside (TextBeside s sl p) g q = textBeside_ s sl rest
- where
- rest = case p of
- Empty -> nilBeside g q
- other -> beside p g q
-\end{code}
-
-\begin{code}
-nilBeside :: Bool -> RDoc -> RDoc
--- Specification: text "" <> nilBeside g p
--- = text "" <g> p
-
-nilBeside g Empty = Empty -- Hence the text "" in the spec
-nilBeside g (Nest _ p) = nilBeside g p
-nilBeside g p | g = textBeside_ space_text 1 p
- | otherwise = p
-\end{code}
-
-*********************************************************
-* *
-\subsection{Separate, @sep@, Hughes version}
-* *
-*********************************************************
-
-\begin{code}
--- Specification: sep ps = oneLiner (hsep ps)
--- `union`
--- vcat ps
-
-sep = sepX True -- Separate with spaces
-cat = sepX False -- Don't
-
-sepX x [] = empty
-sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
-
-
--- Specification: sep1 g k ys = sep (x : map (nest k) ys)
--- = oneLiner (x <g> nest k (hsep ys))
--- `union` x $$ nest k (vcat ys)
-
-sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
-sep1 g _ k ys | k == 0 && False = undefined
-sep1 g NoDoc k ys = NoDoc
-sep1 g (p `Union` q) k ys = sep1 g p k ys
- `union_`
- (aboveNest q False k (reduceDoc (vcat ys)))
-
-sep1 g Empty k ys = mkNest k (sepX g ys)
-sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
-
-sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
-sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
-
--- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
--- Called when we have already found some text in the first item
--- We have to eat up nests
-
-sepNB g (Nest _ p) k ys = sepNB g p k ys
-
-sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
- `mkUnion`
- nilAboveNest False k (reduceDoc (vcat ys))
- where
- rest | g = hsep ys
- | otherwise = hcat ys
-
-sepNB g p k ys = sep1 g p k ys
-\end{code}
-
-*********************************************************
-* *
-\subsection{@fill@}
-* *
-*********************************************************
-
-\begin{code}
-fsep = fill True
-fcat = fill False
-
--- Specification:
--- fill [] = empty
--- fill [p] = p
--- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
--- (fill (oneLiner p2 : ps))
--- `union`
--- p1 $$ fill ps
-
-fill g [] = empty
-fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
-
-
-fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
-fill1 g _ k ys | k == 0 && False = undefined
-fill1 g NoDoc k ys = NoDoc
-fill1 g (p `Union` q) k ys = fill1 g p k ys
- `union_`
- (aboveNest q False k (fill g ys))
-
-fill1 g Empty k ys = mkNest k (fill g ys)
-fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
-
-fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
-fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
-
-fillNB g _ k ys | k == 0 && False = undefined
-fillNB g (Nest _ p) k ys = fillNB g p k ys
-fillNB g Empty k [] = Empty
-fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
- `mkUnion`
- nilAboveNest False k (fill g (y:ys))
- where
- k1 | g = k - 1
- | otherwise = k
-
-fillNB g p k ys = fill1 g p k ys
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{Selecting the best layout}
-* *
-*********************************************************
-
-\begin{code}
-best :: Mode
- -> Int -- Line length
- -> Int -- Ribbon length
- -> RDoc
- -> RDoc -- No unions in here!
-
-best OneLineMode w r p
- = get p
- where
- get Empty = Empty
- get NoDoc = NoDoc
- get (NilAbove p) = nilAbove_ (get p)
- get (TextBeside s sl p) = textBeside_ s sl (get p)
- get (Nest k p) = get p -- Elide nest
- get (p `Union` q) = first (get p) (get q)
-
-best mode w r p
- = get w p
- where
- get :: Int -- (Remaining) width of line
- -> Doc -> Doc
- get w _ | w==0 && False = undefined
- get w Empty = Empty
- get w NoDoc = NoDoc
- get w (NilAbove p) = nilAbove_ (get w p)
- get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
- get w (Nest k p) = nest_ k (get (w - k) p)
- get w (p `Union` q) = nicest w r (get w p) (get w q)
-
- get1 :: Int -- (Remaining) width of line
- -> Int -- Amount of first line already eaten up
- -> Doc -- This is an argument to TextBeside => eat Nests
- -> Doc -- No unions in here!
-
- get1 w _ _ | w==0 && False = undefined
- get1 w sl Empty = Empty
- get1 w sl NoDoc = NoDoc
- get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
- get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
- get1 w sl (Nest k p) = get1 w sl p
- get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
- (get1 w sl q)
-
-nicest w r p q = nicest1 w r 0 p q
-nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
- | otherwise = q
-
-fits :: Int -- Space available
- -> Doc
- -> Bool -- True if *first line* of Doc fits in space available
-
-fits n p | n < 0 = False
-fits n NoDoc = False
-fits n Empty = True
-fits n (NilAbove _) = True
-fits n (TextBeside _ sl p) = (fits $! (n - sl)) p
-
-minn x y | x < y = x
- | otherwise = y
-\end{code}
-
-@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
-@first@ returns its first argument if it is non-empty, otherwise its second.
-
-\begin{code}
-first p q | nonEmptySet p = p
- | otherwise = q
-
-nonEmptySet NoDoc = False
-nonEmptySet (p `Union` q) = True
-nonEmptySet Empty = True
-nonEmptySet (NilAbove p) = True -- NoDoc always in first line
-nonEmptySet (TextBeside _ _ p) = nonEmptySet p
-nonEmptySet (Nest _ p) = nonEmptySet p
-\end{code}
-
-@oneLiner@ returns the one-line members of the given set of @Doc@s.
-
-\begin{code}
-oneLiner :: Doc -> Doc
-oneLiner NoDoc = NoDoc
-oneLiner Empty = Empty
-oneLiner (NilAbove p) = NoDoc
-oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
-oneLiner (Nest k p) = nest_ k (oneLiner p)
-oneLiner (p `Union` q) = oneLiner p
-\end{code}
-
-
-
-*********************************************************
-* *
-\subsection{Displaying the best layout}
-* *
-*********************************************************
-
-
-\begin{code}
-{-
-renderStyle Style{mode, lineLength, ribbonsPerLine} doc
- = fullRender mode lineLength ribbonsPerLine doc ""
--}
-
-render doc = showDoc doc ""
-showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
-
-string_txt (Chr c) s = c:s
-string_txt (Str s1) s2 = s1 ++ s2
-string_txt (PStr s1) s2 = s1 ++ s2
-\end{code}
-
-\begin{code}
-
-fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
-fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)
-
-fullRender mode line_length ribbons_per_line txt end doc
- = display mode line_length ribbon_length txt end best_doc
- where
- best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
-
- hacked_line_length, ribbon_length :: Int
- ribbon_length = round (fromIntegral line_length / ribbons_per_line)
- hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
-
-display mode page_width ribbon_width txt end doc
- = case page_width - ribbon_width of { gap_width ->
- case gap_width `quot` 2 of { shift ->
- let
- lay k (Nest k1 p) = lay (k + k1) p
- lay k Empty = end
-
- lay k (NilAbove p) = nl_text `txt` lay k p
-
- lay k (TextBeside s sl p)
- = case mode of
- ZigZagMode | k >= gap_width
- -> nl_text `txt` (
- Str (multi_ch shift '/') `txt` (
- nl_text `txt` (
- lay1 (k - shift) s sl p)))
-
- | k < 0
- -> nl_text `txt` (
- Str (multi_ch shift '\\') `txt` (
- nl_text `txt` (
- lay1 (k + shift) s sl p )))
-
- other -> lay1 k s sl p
-
- lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
-
- lay2 k (NilAbove p) = nl_text `txt` lay k p
- lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
- lay2 k (Nest _ p) = lay2 k p
- lay2 k Empty = end
- in
- lay 0 doc
- }}
-
-cant_fail = error "easy_display: NoDoc"
-easy_display nl_text txt end doc
- = lay doc cant_fail
- where
- lay NoDoc no_doc = no_doc
- lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc
- lay (Nest k p) no_doc = lay p no_doc
- lay Empty no_doc = end
- lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line
- lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
-
-indent n | n >= 8 = '\t' : indent (n - 8)
- | otherwise = spaces n
-
-multi_ch 0 ch = ""
-multi_ch n ch = ch : multi_ch (n - 1) ch
-
-spaces 0 = ""
-spaces n = ' ' : spaces (n - 1)
-\end{code}
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[module_ST]{The State Transformer Monad, @ST@}
-
-\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-
-module ST
- (
- ST -- abstract, instance of Functor, Monad.
- , runST -- :: (forall s. ST s a) -> a
- , fixST -- :: (a -> ST s a) -> ST s a
- , unsafeInterleaveST -- :: ST s a -> ST s a
-
- , STRef
- , newSTRef
- , readSTRef
- , writeSTRef
-
- , unsafeIOToST
- , stToIO
-
- , STArray
- , newSTArray
- , readSTArray
- , writeSTArray
- , boundsSTArray
- , thawSTArray
- , freezeSTArray
- , unsafeFreezeSTArray
-#ifndef __HUGS__
--- no 'good' reason, just doesn't support it right now.
- , unsafeThawSTArray
-#endif
-
- ) where
-
-#ifdef __HUGS__
-import PreludeBuiltin
-#define MutableVar Ref
-#define readVar primReadRef
-#define writeVar primWriteRef
-#define newVar primNewRef
-#else
-import PrelArr
-import PrelST
-import PrelBase ( Eq(..), Int, Bool, ($), ()(..), unsafeCoerce# )
-import PrelIOBase ( IO(..), stToIO )
-#endif
-import Monad
-import Ix
-
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Variables}
-%* *
-%*********************************************************
-
-\begin{code}
-newtype STRef s a = STRef (MutableVar s a)
- deriving Eq
-
-newSTRef :: a -> ST s (STRef s a)
-newSTRef v = newVar v >>= \ var -> return (STRef var)
-
-readSTRef :: STRef s a -> ST s a
-readSTRef (STRef var) = readVar var
-
-writeSTRef :: STRef s a -> a -> ST s ()
-writeSTRef (STRef var) v = writeVar var v
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Arrays}
-%* *
-%*********************************************************
-
-\begin{code}
-newSTArray :: Ix ix => (ix,ix) -> elt -> ST s (STArray s ix elt)
-writeSTArray :: Ix ix => STArray s ix elt -> ix -> elt -> ST s ()
-readSTArray :: Ix ix => STArray s ix elt -> ix -> ST s elt
-boundsSTArray :: Ix ix => STArray s ix elt -> (ix, ix)
-thawSTArray :: Ix ix => Array ix elt -> ST s (STArray s ix elt)
-freezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
-unsafeFreezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
-
-#ifndef __HUGS__
--- see export list comment..
-unsafeThawSTArray :: Ix ix => Array ix elt -> ST s (STArray s ix elt)
-#endif
-
-#ifdef __HUGS__
-data STArray s ix elt = STArray (ix,ix) (PrimMutableArray s elt)
- deriving Eq
-
-newSTArray ixs elt = do
- { arr <- primNewArray (rangeSize ixs) elt
- ; return (STArray ixs arr)
- }
-
-boundsSTArray (STArray ixs arr) = ixs
-readSTArray (STArray ixs arr) ix = primReadArray arr (index ixs ix)
-writeSTArray (STArray ixs arr) ix elt = primWriteArray arr (index ixs ix) elt
-freezeSTArray (STArray ixs arr) = do
- { arr' <- primFreezeArray arr
- ; return (Array ixs arr')
- }
-
-unsafeFreezeSTArray (STArray ixs arr) = do
- { arr' <- primUnsafeFreezeArray arr
- ; return (Array ixs arr')
- }
-
-thawSTArray (Array ixs arr) = do
- { arr' <- primThawArray arr
- ; return (STArray ixs arr')
- }
-
-primFreezeArray :: PrimMutableArray s a -> ST s (PrimArray a)
-primFreezeArray arr = do
- { let n = primSizeMutableArray arr
- ; arr' <- primNewArray n arrEleBottom
- ; mapM_ (copy arr arr') [0..n-1]
- ; primUnsafeFreezeArray arr'
- }
- where
- copy arr arr' i = do { x <- primReadArray arr i; primWriteArray arr' i x }
- arrEleBottom = error "primFreezeArray: panic"
-
-primThawArray :: PrimArray a -> ST s (PrimMutableArray s a)
-primThawArray arr = do
- { let n = primSizeArray arr
- ; arr' <- primNewArray n arrEleBottom
- ; mapM_ (copy arr arr') [0..n-1]
- ; return arr'
- }
- where
- copy arr arr' i = primWriteArray arr' i (primIndexArray arr i)
- arrEleBottom = error "primFreezeArray: panic"
-#else
-newtype STArray s ix elt = STArray (MutableArray s ix elt)
- deriving Eq
-
-newSTArray ixs elt =
- newArray ixs elt >>= \arr ->
- return (STArray arr)
-
-boundsSTArray (STArray arr) = boundsOfArray arr
-
-readSTArray (STArray arr) ix = readArray arr ix
-
-writeSTArray (STArray arr) ix elt = writeArray arr ix elt
-
-thawSTArray arr = thawArray arr >>= \starr -> return (STArray starr)
-
-freezeSTArray (STArray arr) = freezeArray arr
-
-unsafeFreezeSTArray (STArray arr) = unsafeFreezeArray arr
-unsafeThawSTArray arr = unsafeThawArray arr >>= \ marr -> return (STArray marr)
-
-#endif
-\end{code}
-
-
-\begin{code}
-unsafeIOToST :: IO a -> ST s a
-#ifdef __HUGS__
-unsafeIOToST = primUnsafeCoerce
-#else
-unsafeIOToST (IO io) = ST $ \ s ->
- case ((unsafeCoerce# io) s) of
- (# new_s, a #) -> unsafeCoerce# (STret new_s a)
--- IOfail new_s e -> error ("I/O Error (unsafeIOToST): " ++ showsPrec 0 e "\n")
-#endif
-\end{code}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $Id: Stable.lhs,v 1.1 1999/01/26 12:24:58 simonm Exp $
-%
-% (c) The GHC Team, 1999
-%
-
-\section[Stable]{Module @Stable@}
-
-\begin{code}
-module Stable
-
- ( StableName {-a-} -- abstract.
- , makeStableName -- :: a -> IO (StableName a)
- , hashStableName -- :: StableName a -> Int
-
- , StablePtr {-a-} -- abstract.
- , makeStablePtr -- :: a -> IO (StablePtr a)
- , deRefStablePtr -- :: StablePtr a -> IO a
- , freeStablePtr -- :: StablePtr a -> IO ()
- )
-
- where
-
-import PrelBase
-import PrelIOBase
-import PrelStable
-
------------------------------------------------------------------------------
--- Stable Names
-
-data StableName a = StableName (StableName# a)
-
-makeStableName :: a -> IO (StableName a)
-hashStableName :: StableName a -> Int
-
-makeStableName a = IO $ \ s ->
- case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #)
-
-hashStableName (StableName sn) = I# (stableNameToInt# sn)
-
-instance Eq (StableName a) where
- (StableName sn1) == (StableName sn2) =
- case eqStableName# sn1 sn2 of
- 0# -> False
- _ -> True
-
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1998
-%
-
-\section[Weak]{Module @Weak@}
-
-\begin{code}
-module Weak (
- Weak, -- abstract
- -- instance Eq (Weak v)
-
- mkWeak, -- :: k -> v -> Maybe (IO ()) -> IO (Weak v)
- deRefWeak, -- :: Weak v -> IO (Maybe v)
- finalize, -- :: Weak v -> IO ()
- -- replaceFinaliser -- :: Weak v -> IO () -> IO ()
-
- mkWeakPtr, -- :: k -> Maybe (IO ()) -> IO (Weak k)
- mkWeakPair, -- :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))
- addFinalizer, -- :: key -> IO () -> IO ()
- addForeignFinalizer -- :: ForeignObj -> IO () -> IO ()
- ) where
-
-import PrelBase
-import PrelIOBase
-import PrelWeak
-import Foreign
-
-deRefWeak :: Weak v -> IO (Maybe v)
-deRefWeak (Weak w) = IO $ \s ->
- case deRefWeak# w s of
- (# s1, flag, p #) -> case flag of
- 0# -> (# s1, Nothing #)
- _ -> (# s1, Just p #)
-
-mkWeakPair :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))
-mkWeakPair key val finalizer = mkWeak key (key,val) finalizer
-
-finalize :: Weak v -> IO ()
-finalize (Weak w) = IO $ \s ->
- case finalizeWeak# w s of
- (# s1, 0#, _ #) -> (# s1, () #) -- already dead, or no finaliser
- (# s1, _, f #) -> f s1
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1997
-%
-\section[Word]{Module @Word@}
-
-GHC implementation of the standard Hugs/GHC @Word@
-interface, types and operations over unsigned, sized
-quantities.
-
-\begin{code}
-#include "MachDeps.h"
-
-module Word
- ( Word8 -- all abstract.
- , Word16 -- instances: Eq, Ord
- , Word32 -- Num, Bounded, Real,
- , Word64 -- Integral, Ix, Enum,
- -- Read, Show, Bits,
- -- CCallable, CReturnable
- -- (last two are GHC specific.)
-
-
- , word8ToWord16 -- :: Word8 -> Word16
- , word8ToWord32 -- :: Word8 -> Word32
- , word8ToWord64 -- :: Word8 -> Word64
-
- , word16ToWord8 -- :: Word16 -> Word32
- , word16ToWord32 -- :: Word16 -> Word32
- , word16ToWord64 -- :: Word8 -> Word64
-
- , word32ToWord8 -- :: Word32 -> Word8
- , word32ToWord16 -- :: Word32 -> Word16
- , word32ToWord64 -- :: Word32 -> Word64
-
- , word64ToWord8 -- :: Word64 -> Word8
- , word64ToWord16 -- :: Word64 -> Word16
- , word64ToWord32 -- :: Word64 -> Word32
-
- , word8ToInt -- :: Word8 -> Int
- , word16ToInt -- :: Word16 -> Int
- , word32ToInt -- :: Word32 -> Int
- , word64ToInt -- :: Word64 -> Int
-
- , intToWord8 -- :: Int -> Word8
- , intToWord16 -- :: Int -> Word16
- , intToWord32 -- :: Int -> Word32
- , intToWord64 -- :: Int -> Word64
-
- , word8ToInteger -- :: Word8 -> Integer
- , word16ToInteger -- :: Word16 -> Integer
- , word32ToInteger -- :: Word32 -> Integer
- , word64ToInteger -- :: Word64 -> Integer
-
- , integerToWord8 -- :: Integer -> Word8
- , integerToWord16 -- :: Integer -> Word16
- , integerToWord32 -- :: Integer -> Word32
- , integerToWord64 -- :: Integer -> Word64
-
-#ifndef __HUGS__
- -- NB! GHC SPECIFIC:
- , wordToWord8 -- :: Word -> Word8
- , wordToWord16 -- :: Word -> Word16
- , wordToWord32 -- :: Word -> Word32
- , wordToWord64 -- :: Word -> Word64
-
- , word8ToWord -- :: Word8 -> Word
- , word16ToWord -- :: Word16 -> Word
- , word32ToWord -- :: Word32 -> Word
- , word64ToWord -- :: Word64 -> Word
-#endif
-
- -- The "official" place to get these from is Addr.
- , indexWord8OffAddr
- , indexWord16OffAddr
- , indexWord32OffAddr
- , indexWord64OffAddr
-
- , readWord8OffAddr
- , readWord16OffAddr
- , readWord32OffAddr
- , readWord64OffAddr
-
- , writeWord8OffAddr
- , writeWord16OffAddr
- , writeWord32OffAddr
- , writeWord64OffAddr
-
- , sizeofWord8
- , sizeofWord16
- , sizeofWord32
- , sizeofWord64
-
- -- The "official" place to get these from is Foreign
-#ifndef __PARALLEL_HASKELL__
-#ifndef __HUGS__
- , indexWord8OffForeignObj
- , indexWord16OffForeignObj
- , indexWord32OffForeignObj
- , indexWord64OffForeignObj
-
- , readWord8OffForeignObj
- , readWord16OffForeignObj
- , readWord32OffForeignObj
- , readWord64OffForeignObj
-
- , writeWord8OffForeignObj
- , writeWord16OffForeignObj
- , writeWord32OffForeignObj
- , writeWord64OffForeignObj
-#endif
-#endif
-
- -- non-standard, GHC specific
- , wordToInt
-
-#ifndef __HUGS__
- -- Internal, do not use.
- , word8ToWord#
- , word16ToWord#
- , word32ToWord#
-#endif
-
- ) where
-
-#ifndef __HUGS__
-import PrelBase
-import CCall
-import PrelForeign
-import PrelIOBase
-import PrelAddr
-import PrelNum ( Num(..), Integral(..) ) -- To get fromInt/toInt
-#endif
-import Ix
-import Bits
-import Ratio
-import Numeric (readDec, showInt)
-
-#ifndef __HUGS__
-
------------------------------------------------------------------------------
--- The "official" coercion functions
------------------------------------------------------------------------------
-
-word8ToWord32 :: Word8 -> Word32
-word16ToWord32 :: Word16 -> Word32
-word32ToWord8 :: Word32 -> Word8
-word32ToWord16 :: Word32 -> Word16
-
-word8ToInt :: Word8 -> Int
-word16ToInt :: Word16 -> Int
-intToWord8 :: Int -> Word8
-intToWord16 :: Int -> Word16
-
-integerToWord8 :: Integer -> Word8
-integerToWord16 :: Integer -> Word16
-
-word8ToInt = word32ToInt . word8ToWord32
-intToWord8 = word32ToWord8 . intToWord32
-word16ToInt = word32ToInt . word16ToWord32
-intToWord16 = word32ToWord16 . intToWord32
-word8ToInteger = word32ToInteger . word8ToWord32
-word16ToInteger = word32ToInteger . word16ToWord32
-integerToWord8 = fromInteger
-integerToWord16 = fromInteger
-
-intToWord32 :: Int -> Word32
-intToWord32 (I# x) = W32# ((int2Word# x) `and#` (case (maxBound::Word32) of W32# x# -> x#))
---intToWord32 (I# x) = W32# (int2Word# x)
-
-word32ToInt :: Word32 -> Int
-word32ToInt (W32# x) = I# (word2Int# x)
-
-word32ToInteger :: Word32 -> Integer
-word32ToInteger (W32# x) = word2Integer x
-
-integerToWord32 :: Integer -> Word32
-integerToWord32 = fromInteger
-
-\end{code}
-
-\subsection[Word8]{The @Word8@ interface}
-
-The byte type @Word8@ is represented in the Haskell
-heap by boxing up a 32-bit quantity, @Word#@. An invariant
-for this representation is that the higher 24 bits are
-*always* zeroed out. A consequence of this is that
-operations that could possibly overflow have to mask
-out the top three bytes before building the resulting @Word8@.
-
-\begin{code}
-data Word8 = W8# Word#
-
-instance CCallable Word8
-instance CReturnable Word8
-
-word8ToWord32 (W8# x) = W32# x
-word8ToWord16 (W8# x) = W16# x
-word32ToWord8 (W32# x) = W8# (wordToWord8# x)
-
--- mask out upper three bytes.
-intToWord8# :: Int# -> Word#
-intToWord8# i# = (int2Word# i#) `and#` (int2Word# 0xff#)
-
-wordToWord8# :: Word# -> Word#
-wordToWord8# w# = w# `and#` (int2Word# 0xff#)
-
-instance Eq Word8 where
- (W8# x) == (W8# y) = x `eqWord#` y
- (W8# x) /= (W8# y) = x `neWord#` y
-
-instance Ord Word8 where
- compare (W8# x#) (W8# y#) = compareWord# x# y#
- (<) (W8# x) (W8# y) = x `ltWord#` y
- (<=) (W8# x) (W8# y) = x `leWord#` y
- (>=) (W8# x) (W8# y) = x `geWord#` y
- (>) (W8# x) (W8# y) = x `gtWord#` y
- max x@(W8# x#) y@(W8# y#) =
- case (compareWord# x# y#) of { LT -> y ; EQ -> x ; GT -> x }
- min x@(W8# x#) y@(W8# y#) =
- case (compareWord# x# y#) of { LT -> x ; EQ -> x ; GT -> y }
-
--- Helper function, used by Ord Word* instances.
-compareWord# :: Word# -> Word# -> Ordering
-compareWord# x# y#
- | x# `ltWord#` y# = LT
- | x# `eqWord#` y# = EQ
- | otherwise = GT
-
-instance Num Word8 where
- (W8# x) + (W8# y) =
- W8# (intToWord8# (word2Int# x +# word2Int# y))
- (W8# x) - (W8# y) =
- W8# (intToWord8# (word2Int# x -# word2Int# y))
- (W8# x) * (W8# y) =
- W8# (intToWord8# (word2Int# x *# word2Int# y))
- negate w@(W8# x) =
- if x' ==# 0#
- then w
- else W8# (int2Word# (0x100# -# x'))
- where
- x' = word2Int# x
- abs x = x
- signum = signumReal
- fromInteger (S# i#) = W8# (wordToWord8# (int2Word# i#))
- fromInteger (J# s# d#) = W8# (wordToWord8# (integer2Word# s# d#))
- fromInt = intToWord8
-
-instance Bounded Word8 where
- minBound = 0
- maxBound = 0xff
-
-instance Real Word8 where
- toRational x = toInteger x % 1
-
--- Note: no need to mask results here
--- as they cannot overflow.
-instance Integral Word8 where
- div x@(W8# x#) (W8# y#)
- | y# `neWord#` (int2Word# 0#) = W8# (x# `quotWord#` y#)
- | otherwise = divZeroError "div{Word8}" x
-
- quot x@(W8# x#) (W8# y#)
- | y# `neWord#` (int2Word# 0#) = W8# (x# `quotWord#` y#)
- | otherwise = divZeroError "quot{Word8}" x
-
- rem x@(W8# x#) (W8# y#)
- | y# `neWord#` (int2Word# 0#) = W8# (x# `remWord#` y#)
- | otherwise = divZeroError "rem{Word8}" x
-
- mod x@(W8# x#) (W8# y#)
- | y# `neWord#` (int2Word# 0#) = W8# (x# `remWord#` y#)
- | otherwise = divZeroError "mod{Word8}" x
-
- quotRem (W8# x) (W8# y) = (W8# (x `quotWord#` y), W8# (x `remWord#` y))
- divMod (W8# x) (W8# y) = (W8# (x `quotWord#` y), W8# (x `remWord#` y))
-
- toInteger (W8# x) = word2Integer x
- toInt x = word8ToInt x
-
-instance Ix Word8 where
- range (m,n) = [m..n]
- index b@(m,_) i
- | inRange b i = word8ToInt (i-m)
- | otherwise = indexError i b "Word8"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Word8 where
- succ w
- | w == maxBound = succError "Word8"
- | otherwise = w+1
- pred w
- | w == minBound = predError "Word8"
- | otherwise = w-1
-
- toEnum i@(I# i#)
- | i >= toInt (minBound::Word8) && i <= toInt (maxBound::Word8)
- = W8# (intToWord8# i#)
- | otherwise
- = toEnumError "Word8" i (minBound::Word8,maxBound::Word8)
-
- fromEnum (W8# w) = I# (word2Int# w)
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Word8)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum last]
- where
- last :: Word8
- last
- | d < c = minBound
- | otherwise = maxBound
-
-instance Read Word8 where
- readsPrec _ = readDec
-
-instance Show Word8 where
- showsPrec _ = showInt
-
---
--- Word8s are represented by an (unboxed) 32-bit Word.
--- The invariant is that the upper 24 bits are always zeroed out.
---
-instance Bits Word8 where
- (W8# x) .&. (W8# y) = W8# (x `and#` y)
- (W8# x) .|. (W8# y) = W8# (x `or#` y)
- (W8# x) `xor` (W8# y) = W8# (x `xor#` y)
- complement (W8# x) = W8# (x `xor#` int2Word# 0xff#)
- shift (W8# x#) i@(I# i#)
- | i > 0 = W8# (wordToWord8# (shiftL# x# i#))
- | otherwise = W8# (wordToWord8# (shiftRL# x# (negateInt# i#)))
- w@(W8# x) `rotate` (I# i)
- | i ==# 0# = w
- | i ># 0# = W8# ((wordToWord8# (shiftL# x i')) `or#`
- (shiftRL# (x `and#`
- (int2Word# (0x100# -# pow2# i2)))
- i2))
- | otherwise = rotate w (I# (8# +# i))
- where
- i' = word2Int# (int2Word# i `and#` int2Word# 7#)
- i2 = 8# -# i'
-
- bit (I# i#)
- | i# >=# 0# && i# <=# 7# = W8# (wordToWord8# (shiftL# (int2Word# 1#) i#))
- | otherwise = 0 -- We'll be overbearing, for now..
-
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
-
- testBit (W8# x#) (I# i#)
- | i# <# 8# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0#
- | otherwise = False -- for now, this is really an error.
-
- bitSize _ = 8
- isSigned _ = False
-
-pow2# :: Int# -> Int#
-pow2# x# = word2Int# (shiftL# (int2Word# 1#) x#)
-
-word2Integer :: Word# -> Integer
-word2Integer w = case word2Integer# w of
- (# s, d #) -> J# s d
-
-pow2_64# :: Int# -> Int64#
-pow2_64# x# = word64ToInt64# (shiftL64# (wordToWord64# (int2Word# 1#)) x#)
-
-sizeofWord8 :: Word32
-sizeofWord8 = 1
-
-\end{code}
-
-\subsection[Word16]{The @Word16@ interface}
-
-The double byte type @Word16@ is represented in the Haskell
-heap by boxing up a machine word, @Word#@. An invariant
-for this representation is that only the lower 16 bits are
-`active', any bits above are {\em always} zeroed out.
-A consequence of this is that operations that could possibly
-overflow have to mask out anything above the lower two bytes
-before putting together the resulting @Word16@.
-
-\begin{code}
-data Word16 = W16# Word#
-instance CCallable Word16
-instance CReturnable Word16
-
-word16ToWord32 (W16# x) = W32# x
-word16ToWord8 (W16# x) = W8# (wordToWord8# x)
-word32ToWord16 (W32# x) = W16# (wordToWord16# x)
-
--- mask out upper 16 bits.
-intToWord16# :: Int# -> Word#
-intToWord16# i# = ((int2Word# i#) `and#` (int2Word# 0xffff#))
-
-wordToWord16# :: Word# -> Word#
-wordToWord16# w# = w# `and#` (int2Word# 0xffff#)
-
-instance Eq Word16 where
- (W16# x) == (W16# y) = x `eqWord#` y
- (W16# x) /= (W16# y) = x `neWord#` y
-
-instance Ord Word16 where
- compare (W16# x#) (W16# y#) = compareWord# x# y#
- (<) (W16# x) (W16# y) = x `ltWord#` y
- (<=) (W16# x) (W16# y) = x `leWord#` y
- (>=) (W16# x) (W16# y) = x `geWord#` y
- (>) (W16# x) (W16# y) = x `gtWord#` y
- max x@(W16# x#) y@(W16# y#) =
- case (compareWord# x# y#) of { LT -> y ; EQ -> x ; GT -> x }
- min x@(W16# x#) y@(W16# y#) =
- case (compareWord# x# y#) of { LT -> x ; EQ -> x ; GT -> y }
-
-instance Num Word16 where
- (W16# x) + (W16# y) =
- W16# (intToWord16# (word2Int# x +# word2Int# y))
- (W16# x) - (W16# y) =
- W16# (intToWord16# (word2Int# x -# word2Int# y))
- (W16# x) * (W16# y) =
- W16# (intToWord16# (word2Int# x *# word2Int# y))
- negate w@(W16# x) =
- if x' ==# 0#
- then w
- else W16# (int2Word# (0x10000# -# x'))
- where
- x' = word2Int# x
- abs x = x
- signum = signumReal
- fromInteger (S# i#) = W16# (wordToWord16# (int2Word# i#))
- fromInteger (J# s# d#) = W16# (wordToWord16# (integer2Word# s# d#))
- fromInt = intToWord16
-
-instance Bounded Word16 where
- minBound = 0
- maxBound = 0xffff
-
-instance Real Word16 where
- toRational x = toInteger x % 1
-
-instance Integral Word16 where
- div x@(W16# x#) (W16# y#)
- | y# `neWord#` (int2Word# 0#) = W16# (x# `quotWord#` y#)
- | otherwise = divZeroError "div{Word16}" x
-
- quot x@(W16# x#) (W16# y#)
- | y# `neWord#`(int2Word# 0#) = W16# (x# `quotWord#` y#)
- | otherwise = divZeroError "quot{Word16}" x
-
- rem x@(W16# x#) (W16# y#)
- | y# `neWord#` (int2Word# 0#) = W16# (x# `remWord#` y#)
- | otherwise = divZeroError "rem{Word16}" x
-
- mod x@(W16# x#) (W16# y#)
- | y# `neWord#` (int2Word# 0#) = W16# (x# `remWord#` y#)
- | otherwise = divZeroError "mod{Word16}" x
-
- quotRem (W16# x) (W16# y) = (W16# (x `quotWord#` y), W16# (x `remWord#` y))
- divMod (W16# x) (W16# y) = (W16# (x `quotWord#` y), W16# (x `remWord#` y))
-
- toInteger (W16# x) = word2Integer x
- toInt x = word16ToInt x
-
-instance Ix Word16 where
- range (m,n) = [m..n]
- index b@(m,_) i
- | inRange b i = word16ToInt (i - m)
- | otherwise = indexError i b "Word16"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Word16 where
- succ w
- | w == maxBound = succError "Word16"
- | otherwise = w+1
- pred w
- | w == minBound = predError "Word16"
- | otherwise = w-1
-
- toEnum i@(I# i#)
- | i >= toInt (minBound::Word16) && i <= toInt (maxBound::Word16)
- = W16# (intToWord16# i#)
- | otherwise
- = toEnumError "Word16" i (minBound::Word16,maxBound::Word16)
-
- fromEnum (W16# w) = I# (word2Int# w)
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Word16)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum last]
- where
- last :: Word16
- last
- | d < c = minBound
- | otherwise = maxBound
-
-instance Read Word16 where
- readsPrec _ = readDec
-
-instance Show Word16 where
- showsPrec _ = showInt
-
-instance Bits Word16 where
- (W16# x) .&. (W16# y) = W16# (x `and#` y)
- (W16# x) .|. (W16# y) = W16# (x `or#` y)
- (W16# x) `xor` (W16# y) = W16# (x `xor#` y)
- complement (W16# x) = W16# (x `xor#` int2Word# 0xffff#)
- shift (W16# x#) i@(I# i#)
- | i > 0 = W16# (wordToWord16# (shiftL# x# i#))
- | otherwise = W16# (shiftRL# x# (negateInt# i#))
- w@(W16# x) `rotate` (I# i)
- | i ==# 0# = w
- | i ># 0# = W16# ((wordToWord16# (shiftL# x i')) `or#`
- (shiftRL# (x `and#`
- (int2Word# (0x10000# -# pow2# i2)))
- i2))
- | otherwise = rotate w (I# (16# +# i'))
- where
- i' = word2Int# (int2Word# i `and#` int2Word# 15#)
- i2 = 16# -# i'
- bit (I# i#)
- | i# >=# 0# && i# <=# 15# = W16# (shiftL# (int2Word# 1#) i#)
- | otherwise = 0 -- We'll be overbearing, for now..
-
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
-
- testBit (W16# x#) (I# i#)
- | i# <# 16# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0#
- | otherwise = False -- for now, this is really an error.
-
- bitSize _ = 16
- isSigned _ = False
-
-
-sizeofWord16 :: Word32
-sizeofWord16 = 2
-
-\end{code}
-
-\subsection[Word32]{The @Word32@ interface}
-
-The quad byte type @Word32@ is represented in the Haskell
-heap by boxing up a machine word, @Word#@. An invariant
-for this representation is that any bits above the lower
-32 are {\em always} zeroed out. A consequence of this is that
-operations that could possibly overflow have to mask
-the result before building the resulting @Word16@.
-
-\begin{code}
-data Word32 = W32# Word#
-
-instance CCallable Word32
-instance CReturnable Word32
-
-instance Eq Word32 where
- (W32# x) == (W32# y) = x `eqWord#` y
- (W32# x) /= (W32# y) = x `neWord#` y
-
-instance Ord Word32 where
- compare (W32# x#) (W32# y#) = compareWord# x# y#
- (<) (W32# x) (W32# y) = x `ltWord#` y
- (<=) (W32# x) (W32# y) = x `leWord#` y
- (>=) (W32# x) (W32# y) = x `geWord#` y
- (>) (W32# x) (W32# y) = x `gtWord#` y
- max x@(W32# x#) y@(W32# y#) =
- case (compareWord# x# y#) of { LT -> y ; EQ -> x ; GT -> x }
- min x@(W32# x#) y@(W32# y#) =
- case (compareWord# x# y#) of { LT -> x ; EQ -> x ; GT -> y }
-
-instance Num Word32 where
- (W32# x) + (W32# y) =
- W32# (intToWord32# (word2Int# x +# word2Int# y))
- (W32# x) - (W32# y) =
- W32# (intToWord32# (word2Int# x -# word2Int# y))
- (W32# x) * (W32# y) =
- W32# (intToWord32# (word2Int# x *# word2Int# y))
-#if WORD_SIZE_IN_BYTES == 8
- negate w@(W32# x) =
- if x' ==# 0#
- then w
- else W32# (intToWord32# (0x100000000# -# x'))
- where
- x' = word2Int# x
-#else
- negate (W32# x) = W32# (intToWord32# (negateInt# (word2Int# x)))
-#endif
- abs x = x
- signum = signumReal
- fromInteger (S# i#) = W32# (intToWord32# i#)
- fromInteger (J# s# d#) = W32# (wordToWord32# (integer2Word# s# d#))
- fromInt (I# x) = W32# (intToWord32# x)
- -- ToDo: restrict fromInt{eger} range.
-
-intToWord32# :: Int# -> Word#
-wordToWord32# :: Word# -> Word#
-
-#if WORD_SIZE_IN_BYTES == 8
-intToWord32# i# = (int2Word# i#) `and#` (int2Word# 0xffffffff#)
-wordToWord32# w# = w# `and#` (int2Word# 0xffffffff#)
-wordToWord64# w# = w#
-#else
-intToWord32# i# = int2Word# i#
-wordToWord32# w# = w#
-
-#endif
-
-instance Bounded Word32 where
- minBound = 0
-#if WORD_SIZE_IN_BYTES == 8
- maxBound = 0xffffffff
-#else
- maxBound = minBound - 1
-#endif
-
-instance Real Word32 where
- toRational x = toInteger x % 1
-
-instance Integral Word32 where
- div x y
- | y /= 0 = quotWord32 x y
- | otherwise = divZeroError "div{Word32}" x
-
- quot x y
- | y /= 0 = quotWord32 x y
- | otherwise = divZeroError "quot{Word32}" x
-
- rem x y
- | y /= 0 = remWord32 x y
- | otherwise = divZeroError "rem{Word32}" x
-
- mod x y
- | y /= 0 = remWord32 x y
- | otherwise = divZeroError "mod{Word32}" x
-
- quotRem a b = (a `quotWord32` b, a `remWord32` b)
- divMod x y = quotRem x y
-
- toInteger (W32# x) = word2Integer x
- toInt (W32# x) = I# (word2Int# x)
-
-{-# INLINE quotWord32 #-}
-{-# INLINE remWord32 #-}
-remWord32, quotWord32 :: Word32 -> Word32 -> Word32
-(W32# x) `quotWord32` (W32# y) = W32# (x `quotWord#` y)
-(W32# x) `remWord32` (W32# y) = W32# (x `remWord#` y)
-
-instance Ix Word32 where
- range (m,n) = [m..n]
- index b@(m,_) i
- | inRange b i = word32ToInt (i - m)
- | otherwise = indexError i b "Word32"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Word32 where
- succ w
- | w == maxBound = succError "Word32"
- | otherwise = w+1
- pred w
- | w == minBound = predError "Word32"
- | otherwise = w-1
-
- -- the toEnum/fromEnum will fail if the mapping isn't legal,
- -- use the intTo* & *ToInt coercion functions to 'bypass' these range checks.
- toEnum x
- | x >= 0 = intToWord32 x
- | otherwise
- = toEnumError "Word32" x (minBound::Word32,maxBound::Word32)
-
- fromEnum x
- | x <= intToWord32 (maxBound::Int)
- = word32ToInt x
- | otherwise
- = fromEnumError "Word32" x
-
- enumFrom w = [w .. maxBound]
- enumFromTo w1 w2
- | w1 <= w2 = eftt32 True{-increasing-} w1 diff_f last
- | otherwise = []
- where
- last = (> w2)
- diff_f x = x + 1
-
- enumFromThen w1 w2 = [w1,w2 .. last]
- where
- last :: Word32
- last
- | w1 <=w2 = maxBound
- | otherwise = minBound
-
- enumFromThenTo w1 w2 wend = eftt32 increasing w1 step_f last
- where
- increasing = w1 <= w2
- diff1 = w2 - w1
- diff2 = w1 - w2
-
- last
- | increasing = (> wend)
- | otherwise = (< wend)
-
- step_f
- | increasing = \ x -> x + diff1
- | otherwise = \ x -> x - diff2
-
-
-eftt32 :: Bool -> Word32 -> (Word32 -> Word32) -> (Word32-> Bool) -> [Word32]
-eftt32 increasing init stepper done = go init
- where
- go now
- | done now = []
- | increasing && now > nxt = [now] -- oflow
- | not increasing && now < nxt = [now] -- uflow
- | otherwise = now : go nxt
- where
- nxt = stepper now
-
-
-instance Read Word32 where
- readsPrec _ = readDec
-
-instance Show Word32 where
- showsPrec _ = showInt
-
-instance Bits Word32 where
- (W32# x) .&. (W32# y) = W32# (x `and#` y)
- (W32# x) .|. (W32# y) = W32# (x `or#` y)
- (W32# x) `xor` (W32# y) = W32# (x `xor#` y)
- complement (W32# x) = W32# (x `xor#` mb#) where (W32# mb#) = maxBound
- shift (W32# x) i@(I# i#)
- | i > 0 = W32# (wordToWord32# (shiftL# x i#))
- | otherwise = W32# (shiftRL# x (negateInt# i#))
- w@(W32# x) `rotate` (I# i)
- | i ==# 0# = w
- | i ># 0# = W32# ((wordToWord32# (shiftL# x i')) `or#`
- (shiftRL# (x `and#`
- (int2Word# (word2Int# maxBound# -# pow2# i2 +# 1#)))
- i2))
- | otherwise = rotate w (I# (32# +# i))
- where
- i' = word2Int# (int2Word# i `and#` int2Word# 31#)
- i2 = 32# -# i'
- (W32# maxBound#) = maxBound
-
- bit (I# i#)
- | i# >=# 0# && i# <=# 31# = W32# (shiftL# (int2Word# 1#) i#)
- | otherwise = 0 -- We'll be overbearing, for now..
-
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
-
- testBit (W32# x#) (I# i#)
- | i# <# 32# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0#
- | otherwise = False -- for now, this is really an error.
- bitSize _ = 32
- isSigned _ = False
-
-sizeofWord32 :: Word32
-sizeofWord32 = 4
-\end{code}
-
-\subsection[Word64]{The @Word64@ interface}
-
-\begin{code}
-#if WORD_SIZE_IN_BYTES == 8
---data Word64 = W64# Word#
-
-word32ToWord64 :: Word32 -> Word64
-word32ToWord64 (W32 w#) = W64# w#
-
-word8ToWord64 :: Word8 -> Word64
-word8ToWord64 (W8# w#) = W64# w#
-
-word64ToWord8 :: Word64 -> Word8
-word64ToWord8 (W64# w#) = W8# (w# `and#` (int2Word# 0xff#))
-
-word16ToWord64 :: Word16 -> Word64
-word16ToWord64 (W16# w#) = W64# w#
-
-word64ToWord16 :: Word64 -> Word16
-word64ToWord16 (W64# w#) = W16# (w# `and#` (int2Word# 0xffff#))
-
-wordToWord32# :: Word# -> Word#
-wordToWord32# w# = w# `and#` (case (maxBound::Word32) of W# x# -> x#)
-
-word64ToWord32 :: Word64 -> Word32
-word64ToWord32 (W64# w#) = W32# (wordToWord32# w#)
-
-wordToWord64# w# = w#
-word64ToWord# w# = w#
-
-instance Eq Word64 where
- (W64# x) == (W64# y) = x `eqWord#` y
- (W64# x) /= (W64# y) = x `neWord#` y
-
-instance Ord Word64 where
- compare (W64# x#) (W64# y#) = compareWord# x# y#
- (<) (W64# x) (W64# y) = x `ltWord#` y
- (<=) (W64# x) (W64# y) = x `leWord#` y
- (>=) (W64# x) (W64# y) = x `geWord#` y
- (>) (W64# x) (W64# y) = x `gtWord#` y
- max x@(W64# x#) y@(W64# y#) =
- case (compareWord# x# y#) of { LT -> y ; EQ -> x ; GT -> x }
- min x@(W64# x#) y@(W64# y#) =
- case (compareWord# x# y#) of { LT -> x ; EQ -> x ; GT -> y }
-
-instance Num Word64 where
- (W64# x) + (W64# y) =
- W64# (intToWord64# (word2Int# x +# word2Int# y))
- (W64# x) - (W64# y) =
- W64# (intToWord64# (word2Int# x -# word2Int# y))
- (W64# x) * (W64# y) =
- W64# (intToWord64# (word2Int# x *# word2Int# y))
- negate w@(W64# x) =
- if x' ==# 0#
- then w
- else W64# (int2Word# (0x100# -# x'))
- where
- x' = word2Int# x
- abs x = x
- signum = signumReal
- fromInteger (S# i#) = W64# (int2Word# i#)
- fromInteger (J# s# d#) = W64# (integer2Word# s# d#)
- fromInt = intToWord64
-
--- Note: no need to mask results here
--- as they cannot overflow.
-instance Integral Word64 where
- div x@(W64# x#) (W64# y#)
- | y# `neWord#` (int2Word# 0#) = W64# (x# `quotWord#` y#)
- | otherwise = divZeroError "div{Word64}" x
-
- quot x@(W64# x#) (W64# y#)
- | y# `neWord#` (int2Word# 0#) = W64# (x# `quotWord#` y#)
- | otherwise = divZeroError "quot{Word64}" x
-
- rem x@(W64# x#) (W64# y#)
- | y# `neWord#` (int2Word# 0#) = W64# (x# `remWord#` y#)
- | otherwise = divZeroError "rem{Word64}" x
-
- mod (W64# x) (W64# y)
- | y# `neWord#` (int2Word# 0#) = W64# (x `remWord#` y)
- | otherwise = divZeroError "mod{Word64}" x
-
- quotRem (W64# x) (W64# y) = (W64# (x `quotWord#` y), W64# (x `remWord#` y))
- divMod (W64# x) (W64# y) = (W64# (x `quotWord#` y), W64# (x `remWord#` y))
-
- toInteger (W64# x) = word2Integer# x
- toInt x = word64ToInt x
-
-
-instance Bits Word64 where
- (W64# x) .&. (W64# y) = W64# (x `and#` y)
- (W64# x) .|. (W64# y) = W64# (x `or#` y)
- (W64# x) `xor` (W64# y) = W64# (x `xor#` y)
- complement (W64# x) = W64# (x `xor#` (case (maxBound::Word64) of W64# x# -> x#))
- shift (W64# x#) i@(I# i#)
- | i > 0 = W64# (shiftL# x# i#)
- | otherwise = W64# (shiftRL# x# (negateInt# i#))
-
- w@(W64# x) `rotate` (I# i)
- | i ==# 0# = w
- | i ># 0# = W64# (shiftL# x i') `or#`
- (shiftRL# (x `and#`
- (int2Word# (word2Int# maxBound# -# pow2# i2 +# 1#)))
- i2))
- | otherwise = rotate w (I# (64# +# i))
- where
- i' = word2Int# (int2Word# i `and#` int2Word# 63#)
- i2 = 64# -# i'
- (W64# maxBound#) = maxBound
-
- bit (I# i#)
- | i# >=# 0# && i# <=# 63# = W64# (shiftL# (int2Word# 1#) i#)
- | otherwise = 0 -- We'll be overbearing, for now..
-
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
-
- testBit (W64# x#) (I# i#)
- | i# <# 64# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0#
- | otherwise = False -- for now, this is really an error.
-
- bitSize _ = 64
- isSigned _ = False
-
-#else
---defined in PrelCCall: data Word64 = W64 Word64# deriving (Eq, Ord, Bounded)
-
--- for completeness sake
-word32ToWord64 :: Word32 -> Word64
-word32ToWord64 (W32# w#) = W64# (wordToWord64# w#)
-
-word64ToWord32 :: Word64 -> Word32
-word64ToWord32 (W64# w#) = W32# (word64ToWord# w#)
-
-word8ToWord64 :: Word8 -> Word64
-word8ToWord64 (W8# w#) = W64# (wordToWord64# w#)
-
-word64ToWord8 :: Word64 -> Word8
-word64ToWord8 (W64# w#) = W8# ((word64ToWord# w#) `and#` (int2Word# 0xff#))
-
-word16ToWord64 :: Word16 -> Word64
-word16ToWord64 (W16# w#) = W64# (wordToWord64# w#)
-
-word64ToWord16 :: Word64 -> Word16
-word64ToWord16 (W64# w#) = W16# ((word64ToWord# w#) `and#` (int2Word# 0xffff#))
-
-
-word64ToInteger :: Word64 -> Integer
-word64ToInteger (W64# w#) =
- case word64ToInteger# w# of
- (# s#, p# #) -> J# s# p#
-
-word64ToInt :: Word64 -> Int
-word64ToInt w =
- case w `quotRem` 0x100000000 of
- (_,l) -> toInt (word64ToWord32 l)
-
-intToWord64# :: Int# -> Word64#
-intToWord64# i# = wordToWord64# (int2Word# i#)
-
-intToWord64 :: Int -> Word64
-intToWord64 (I# i#) = W64# (intToWord64# i#)
-
-integerToWord64 :: Integer -> Word64
-integerToWord64 (J# s# d#) = W64# (integerToWord64# s# d#)
-
-instance Eq Word64 where
- (W64# x) == (W64# y) = x `eqWord64#` y
- (W64# x) /= (W64# y) = not (x `eqWord64#` y)
-
-instance Ord Word64 where
- compare (W64# x#) (W64# y#) = compareWord64# x# y#
- (<) (W64# x) (W64# y) = x `ltWord64#` y
- (<=) (W64# x) (W64# y) = x `leWord64#` y
- (>=) (W64# x) (W64# y) = x `geWord64#` y
- (>) (W64# x) (W64# y) = x `gtWord64#` y
- max x@(W64# x#) y@(W64# y#) =
- case (compareWord64# x# y#) of { LT -> y ; EQ -> x ; GT -> x }
- min x@(W64# x#) y@(W64# y#) =
- case (compareWord64# x# y#) of { LT -> x ; EQ -> x ; GT -> y }
-
-instance Num Word64 where
- (W64# x) + (W64# y) =
- W64# (int64ToWord64# (word64ToInt64# x `plusInt64#` word64ToInt64# y))
- (W64# x) - (W64# y) =
- W64# (int64ToWord64# (word64ToInt64# x `minusInt64#` word64ToInt64# y))
- (W64# x) * (W64# y) =
- W64# (int64ToWord64# (word64ToInt64# x `timesInt64#` word64ToInt64# y))
- negate w
- | w == 0 = w
- | otherwise = maxBound - w
-
- abs x = x
- signum = signumReal
- fromInteger i = integerToWord64 i
- fromInt = intToWord64
-
--- Note: no need to mask results here
--- as they cannot overflow.
--- ToDo: protect against div by zero.
-instance Integral Word64 where
- div (W64# x) (W64# y) = W64# (x `quotWord64#` y)
- quot (W64# x) (W64# y) = W64# (x `quotWord64#` y)
- rem (W64# x) (W64# y) = W64# (x `remWord64#` y)
- mod (W64# x) (W64# y) = W64# (x `remWord64#` y)
- quotRem (W64# x) (W64# y) = (W64# (x `quotWord64#` y), W64# (x `remWord64#` y))
- divMod (W64# x) (W64# y) = (W64# (x `quotWord64#` y), W64# (x `remWord64#` y))
- toInteger w64 = word64ToInteger w64
- toInt x = word64ToInt x
-
-
-instance Bits Word64 where
- (W64# x) .&. (W64# y) = W64# (x `and64#` y)
- (W64# x) .|. (W64# y) = W64# (x `or64#` y)
- (W64# x) `xor` (W64# y) = W64# (x `xor64#` y)
- complement (W64# x) = W64# (x `xor64#` (case (maxBound::Word64) of W64# x# -> x#))
- shift (W64# x#) i@(I# i#)
- | i > 0 = W64# (shiftL64# x# i#)
- | otherwise = W64# (shiftRL64# x# (negateInt# i#))
-
- w@(W64# x) `rotate` (I# i)
- | i ==# 0# = w
- | i ># 0# = W64# ((shiftL64# x i') `or64#`
- (shiftRL64# (x `and64#`
- (int64ToWord64# ((word64ToInt64# maxBound#) `minusInt64#`
- (pow2_64# i2 `plusInt64#` (intToInt64# 1#))))))
- i2)
- | otherwise = rotate w (I# (64# +# i))
- where
- i' = word2Int# (int2Word# i `and#` int2Word# 63#)
- i2 = 64# -# i'
- (W64# maxBound#) = maxBound
-
- bit (I# i#)
- | i# >=# 0# && i# <=# 63# = W64# (shiftL64# (wordToWord64# (int2Word# 1#)) i#)
- | otherwise = 0 -- We'll be overbearing, for now..
-
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
-
- testBit (W64# x#) (I# i#)
- | i# <# 64# && i# >=# 0# = (word2Int# (word64ToWord# (x# `and64#` (shiftL64# (wordToWord64# (int2Word# 1#)) i#)))) /=# 0#
- | otherwise = False -- for now, this is really an error.
-
- bitSize _ = 64
- isSigned _ = False
-
-compareWord64# :: Word64# -> Word64# -> Ordering
-compareWord64# i# j#
- | i# `ltWord64#` j# = LT
- | i# `eqWord64#` j# = EQ
- | otherwise = GT
-
--- Word64# primop wrappers:
-
-ltWord64# :: Word64# -> Word64# -> Bool
-ltWord64# x# y# =
- case stg_ltWord64 x# y# of
- 0 -> False
- _ -> True
-
-leWord64# :: Word64# -> Word64# -> Bool
-leWord64# x# y# =
- case stg_leWord64 x# y# of
- 0 -> False
- _ -> True
-
-eqWord64# :: Word64# -> Word64# -> Bool
-eqWord64# x# y# =
- case stg_eqWord64 x# y# of
- 0 -> False
- _ -> True
-
-neWord64# :: Word64# -> Word64# -> Bool
-neWord64# x# y# =
- case stg_neWord64 x# y# of
- 0 -> False
- _ -> True
-
-geWord64# :: Word64# -> Word64# -> Bool
-geWord64# x# y# =
- case stg_geWord64 x# y# of
- 0 -> False
- _ -> True
-
-gtWord64# :: Word64# -> Word64# -> Bool
-gtWord64# x# y# =
- case stg_gtWord64 x# y# of
- 0 -> False
- _ -> True
-
-plusInt64# :: Int64# -> Int64# -> Int64#
-plusInt64# a# b# =
- case stg_plusInt64 a# b# of
- I64# i# -> i#
-
-minusInt64# :: Int64# -> Int64# -> Int64#
-minusInt64# a# b# =
- case stg_minusInt64 a# b# of
- I64# i# -> i#
-
-timesInt64# :: Int64# -> Int64# -> Int64#
-timesInt64# a# b# =
- case stg_timesInt64 a# b# of
- I64# i# -> i#
-
-quotWord64# :: Word64# -> Word64# -> Word64#
-quotWord64# a# b# =
- case stg_quotWord64 a# b# of
- W64# w# -> w#
-
-remWord64# :: Word64# -> Word64# -> Word64#
-remWord64# a# b# =
- case stg_remWord64 a# b# of
- W64# w# -> w#
-
-negateInt64# :: Int64# -> Int64#
-negateInt64# a# =
- case stg_negateInt64 a# of
- I64# i# -> i#
-
-and64# :: Word64# -> Word64# -> Word64#
-and64# a# b# =
- case stg_and64 a# b# of
- W64# w# -> w#
-
-or64# :: Word64# -> Word64# -> Word64#
-or64# a# b# =
- case stg_or64 a# b# of
- W64# w# -> w#
-
-xor64# :: Word64# -> Word64# -> Word64#
-xor64# a# b# =
- case stg_xor64 a# b# of
- W64# w# -> w#
-
-not64# :: Word64# -> Word64#
-not64# a# =
- case stg_not64 a# of
- W64# w# -> w#
-
-shiftL64# :: Word64# -> Int# -> Word64#
-shiftL64# a# b# =
- case stg_shiftL64 a# b# of
- W64# w# -> w#
-
-shiftRL64# :: Word64# -> Int# -> Word64#
-shiftRL64# a# b# =
- case stg_shiftRL64 a# b# of
- W64# w# -> w#
-
-word64ToWord# :: Word64# -> Word#
-word64ToWord# w64# =
- case stg_word64ToWord w64# of
- W# w# -> w#
-
-wordToWord64# :: Word# -> Word64#
-wordToWord64# w# =
- case stg_wordToWord64 w# of
- W64# w64# -> w64#
-
-word64ToInt64# :: Word64# -> Int64#
-word64ToInt64# w64# =
- case stg_word64ToInt64 w64# of
- I64# i# -> i#
-
-int64ToWord64# :: Int64# -> Word64#
-int64ToWord64# i64# =
- case stg_int64ToWord64 i64# of
- W64# w# -> w#
-
-intToInt64# :: Int# -> Int64#
-intToInt64# i# =
- case stg_intToInt64 i# of
- I64# i64# -> i64#
-
-foreign import "stg_intToInt64" stg_intToInt64 :: Int# -> Int64
-foreign import "stg_int64ToWord64" stg_int64ToWord64 :: Int64# -> Word64
-foreign import "stg_word64ToInt64" stg_word64ToInt64 :: Word64# -> Int64
-foreign import "stg_wordToWord64" stg_wordToWord64 :: Word# -> Word64
-foreign import "stg_word64ToWord" stg_word64ToWord :: Word64# -> Word
-foreign import "stg_shiftRL64" stg_shiftRL64 :: Word64# -> Int# -> Word64
-foreign import "stg_shiftL64" stg_shiftL64 :: Word64# -> Int# -> Word64
-foreign import "stg_not64" stg_not64 :: Word64# -> Word64
-foreign import "stg_xor64" stg_xor64 :: Word64# -> Word64# -> Word64
-foreign import "stg_or64" stg_or64 :: Word64# -> Word64# -> Word64
-foreign import "stg_and64" stg_and64 :: Word64# -> Word64# -> Word64
-foreign import "stg_negateInt64" stg_negateInt64 :: Int64# -> Int64
-foreign import "stg_remWord64" stg_remWord64 :: Word64# -> Word64# -> Word64
-foreign import "stg_quotWord64" stg_quotWord64 :: Word64# -> Word64# -> Word64
-foreign import "stg_timesInt64" stg_timesInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_minusInt64" stg_minusInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_plusInt64" stg_plusInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_gtWord64" stg_gtWord64 :: Word64# -> Word64# -> Int
-foreign import "stg_geWord64" stg_geWord64 :: Word64# -> Word64# -> Int
-foreign import "stg_neWord64" stg_neWord64 :: Word64# -> Word64# -> Int
-foreign import "stg_eqWord64" stg_eqWord64 :: Word64# -> Word64# -> Int
-foreign import "stg_leWord64" stg_leWord64 :: Word64# -> Word64# -> Int
-foreign import "stg_ltWord64" stg_ltWord64 :: Word64# -> Word64# -> Int
-
-#endif
-
-instance Enum Word64 where
- succ w
- | w == maxBound = succError "Word64"
- | otherwise = w+1
- pred w
- | w == minBound = predError "Word64"
- | otherwise = w-1
-
- toEnum i
- | i >= 0 = intToWord64 i
- | otherwise
- = toEnumError "Word64" i (minBound::Word64,maxBound::Word64)
-
- fromEnum w
- | w <= intToWord64 (maxBound::Int)
- = word64ToInt w
- | otherwise
- = fromEnumError "Word64" w
-
- enumFrom e1 = map integerToWord64 [word64ToInteger e1 .. word64ToInteger maxBound]
- enumFromTo e1 e2 = map integerToWord64 [word64ToInteger e1 .. word64ToInteger e2]
- enumFromThen e1 e2 = map integerToWord64 [word64ToInteger e1, word64ToInteger e2 .. word64ToInteger last]
- where
- last :: Word64
- last
- | e2 < e1 = minBound
- | otherwise = maxBound
-
- enumFromThenTo e1 e2 e3 = map integerToWord64 [word64ToInteger e1, word64ToInteger e2 .. word64ToInteger e3]
-
-instance Show Word64 where
- showsPrec p x = showsPrec p (word64ToInteger x)
-
-instance Read Word64 where
- readsPrec _ s = [ (integerToWord64 x,r) | (x,r) <- readDec s ]
-
-instance Ix Word64 where
- range (m,n) = [m..n]
- index b@(m,_) i
- | inRange b i = word64ToInt (i-m)
- | otherwise = indexError i b "Word64"
- inRange (m,n) i = m <= i && i <= n
-
-instance Bounded Word64 where
- minBound = 0
- maxBound = minBound - 1
-
-instance Real Word64 where
- toRational x = toInteger x % 1
-
-sizeofWord64 :: Word32
-sizeofWord64 = 8
-
-\end{code}
-
-
-
-The Hugs-GHC extension libraries provide functions for going between
-Int and the various (un)signed ints. Here we provide the same for
-the GHC specific Word type:
-
-\begin{code}
-wordToWord8 :: Word -> Word8
-wordToWord16 :: Word -> Word16
-wordToWord32 :: Word -> Word32
-
-word8ToWord :: Word8 -> Word
-word16ToWord :: Word16 -> Word
-word32ToWord :: Word32 -> Word
-
-word8ToWord# :: Word8 -> Word#
-word16ToWord# :: Word16 -> Word#
-word32ToWord# :: Word32 -> Word#
-
-word8ToWord (W8# w#) = W# w#
-word8ToWord# (W8# w#) = w#
-
-wordToWord8 (W# w#) = W8# (w# `and#` (case (maxBound::Word8) of W8# x# -> x#))
-word16ToWord (W16# w#) = W# w#
-word16ToWord# (W16# w#) = w#
-
-wordToWord16 (W# w#) = W16# (w# `and#` (case (maxBound::Word16) of W16# x# -> x#))
-wordToWord32 (W# w#) = W32# (w# `and#` (case (maxBound::Word32) of W32# x# -> x#))
-
-word32ToWord (W32# w#) = W# w#
-word32ToWord# (W32# w#) = w#
-
-wordToWord64 :: Word -> Word64
-wordToWord64 (W# w#) = W64# (wordToWord64# w#)
-
--- lossy on 32-bit platforms, but provided nontheless.
-word64ToWord :: Word64 -> Word
-word64ToWord (W64# w#) = W# (word64ToWord# w#)
-
-\end{code}
-
-
---End of exported definitions
-
-The remainder of this file consists of definitions which are only
-used in the implementation.
-
-\begin{code}
-signumReal :: (Ord a, Num a) => a -> a
-signumReal x | x == 0 = 0
- | x > 0 = 1
- | otherwise = -1
-
-\end{code}
-
-NOTE: the index is in units of the size of the type, *not* bytes.
-
-\begin{code}
-indexWord8OffAddr :: Addr -> Int -> Word8
-indexWord8OffAddr (A# a#) (I# i#) = intToWord8 (I# (ord# (indexCharOffAddr# a# i#)))
-
-indexWord16OffAddr :: Addr -> Int -> Word16
-indexWord16OffAddr a i =
-#ifdef WORDS_BIGENDIAN
- intToWord16 ( word8ToInt l + (word8ToInt maxBound) * word8ToInt h)
-#else
- intToWord16 ( word8ToInt h + (word8ToInt maxBound) * word8ToInt l)
-#endif
- where
- byte_idx = i * 2
- l = indexWord8OffAddr a byte_idx
- h = indexWord8OffAddr a (byte_idx+1)
-
-indexWord32OffAddr :: Addr -> Int -> Word32
-indexWord32OffAddr (A# a#) i = wordToWord32 (W# (indexWordOffAddr# a# i'#))
- where
- -- adjust index to be in Word units, not Word32 ones.
- (I# i'#)
-#if WORD_SIZE_IN_BYTES==8
- = i `div` 2
-#else
- = i
-#endif
-
-indexWord64OffAddr :: Addr -> Int -> Word64
-indexWord64OffAddr (A# a#) (I# i#)
-#if WORD_SIZE_IN_BYTES==8
- = W64# (indexWordOffAddr# a# i#)
-#else
- = W64# (indexWord64OffAddr# a# i#)
-#endif
-
-#ifndef __PARALLEL_HASKELL__
-
-indexWord8OffForeignObj :: ForeignObj -> Int -> Word8
-indexWord8OffForeignObj (ForeignObj fo#) (I# i#) = intToWord8 (I# (ord# (indexCharOffForeignObj# fo# i#)))
-
-indexWord16OffForeignObj :: ForeignObj -> Int -> Word16
-indexWord16OffForeignObj fo i =
-#ifdef WORDS_BIGENDIAN
- intToWord16 ( word8ToInt l + (word8ToInt maxBound) * word8ToInt h)
-#else
- intToWord16 ( word8ToInt h + (word8ToInt maxBound) * word8ToInt l)
-#endif
- where
- byte_idx = i * 2
- l = indexWord8OffForeignObj fo byte_idx
- h = indexWord8OffForeignObj fo (byte_idx+1)
-
-indexWord32OffForeignObj :: ForeignObj -> Int -> Word32
-indexWord32OffForeignObj (ForeignObj fo#) i = wordToWord32 (W# (indexWordOffForeignObj# fo# i'#))
- where
- -- adjust index to be in Word units, not Word32 ones.
- (I# i'#)
-#if WORD_SIZE_IN_BYTES==8
- = i `div` 2
-#else
- = i
-#endif
-
-indexWord64OffForeignObj :: ForeignObj -> Int -> Word64
-indexWord64OffForeignObj (ForeignObj fo#) (I# i#)
-#if WORD_SIZE_IN_BYTES==8
- = W64# (indexWordOffForeignObj# fo# i#)
-#else
- = W64# (indexWord64OffForeignObj# fo# i#)
-#endif
-#endif
-
-\end{code}
-
-Read words out of mutable memory:
-
-\begin{code}
-readWord8OffAddr :: Addr -> Int -> IO Word8
-readWord8OffAddr a i = _casm_ `` %r=((StgWord8*)%0)[(StgInt)%1]; '' a i
-
-readWord16OffAddr :: Addr -> Int -> IO Word16
-readWord16OffAddr a i = _casm_ `` %r=((StgWord16*)%0)[(StgInt)%1]; '' a i
-
-readWord32OffAddr :: Addr -> Int -> IO Word32
-readWord32OffAddr a i = _casm_ `` %r=((StgWord32*)%0)[(StgInt)%1]; '' a i
-
-readWord64OffAddr :: Addr -> Int -> IO Word64
-#if WORD_SIZE_IN_BYTES==8
-readWord64OffAddr a i = _casm_ `` %r=((StgWord*)%0)[(StgInt)%1]; '' a i
-#else
-readWord64OffAddr a i = _casm_ `` %r=((StgWord64*)%0)[(StgInt)%1]; '' a i
-#endif
-
-#ifndef __PARALLEL_HASKELL__
-readWord8OffForeignObj :: ForeignObj -> Int -> IO Word8
-readWord8OffForeignObj fo i = _casm_ `` %r=((StgWord8*)%0)[(StgInt)%1]; '' fo i
-
-readWord16OffForeignObj :: ForeignObj -> Int -> IO Word16
-readWord16OffForeignObj fo i = _casm_ `` %r=((StgWord16*)%0)[(StgInt)%1]; '' fo i
-
-readWord32OffForeignObj :: ForeignObj -> Int -> IO Word32
-readWord32OffForeignObj fo i = _casm_ `` %r=((StgWord32*)%0)[(StgInt)%1]; '' fo i
-
-readWord64OffForeignObj :: ForeignObj -> Int -> IO Word64
-#if WORD_SIZE_IN_BYTES==8
-readWord64OffForeignObj fo i = _casm_ `` %r=((StgWord*)%0)[(StgInt)%1]; '' fo i
-#else
-readWord64OffForeignObj fo i = _casm_ `` %r=((StgWord64*)%0)[(StgInt)%1]; '' fo i
-#endif
-
-#endif
-
-\end{code}
-
-Note: we provide primops for the writing via Addrs since that's used
-in the IO implementation (a place where we *really* do care about cycles.)
-
-\begin{code}
-writeWord8OffAddr :: Addr -> Int -> Word8 -> IO ()
-writeWord8OffAddr (A# a#) (I# i#) (W8# w#) = IO $ \ s# ->
- case (writeCharOffAddr# a# i# (chr# (word2Int# w#)) s#) of s2# -> (# s2#, () #)
-
-writeWord16OffAddr :: Addr -> Int -> Word16 -> IO ()
-writeWord16OffAddr a i e = _casm_ `` (((StgWord16*)%0)[(StgInt)%1])=(StgWord16)%2; '' a i e
-
-writeWord32OffAddr :: Addr -> Int -> Word32 -> IO ()
-writeWord32OffAddr (A# a#) i (W32# w#) = IO $ \ s# ->
- case (writeWordOffAddr# a# i'# w# s#) of s2# -> (# s2#, () #)
- where
- -- adjust index to be in Word units, not Word32 ones.
- (I# i'#)
-#if WORD_SIZE_IN_BYTES==8
- = i `div` 2
-#else
- = i
-#endif
-
-writeWord64OffAddr :: Addr -> Int -> Word64 -> IO ()
-#if WORD_SIZE_IN_BYTES==8
-writeWord64OffAddr (A# a#) (I# i#) (W64# w#) = IO $ \ s# ->
- case (writeWordOffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
-#else
-writeWord64OffAddr (A# a#) (I# i#) (W64# w#) = IO $ \ s# ->
- case (writeWord64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
-#endif
-
-#ifndef __PARALLEL_HASKELL__
-
-writeWord8OffForeignObj :: ForeignObj -> Int -> Word8 -> IO ()
-writeWord8OffForeignObj fo i w = _casm_ `` (((StgWord8*)%0)[(StgInt)%1])=(StgWord8)%2; '' fo i w
-
-writeWord16OffForeignObj :: ForeignObj -> Int -> Word16 -> IO ()
-writeWord16OffForeignObj fo i w = _casm_ `` (((StgWord16*)%0)[(StgInt)%1])=(StgWord16)%2; '' fo i w
-
-writeWord32OffForeignObj :: ForeignObj -> Int -> Word32 -> IO ()
-writeWord32OffForeignObj fo i w = _casm_ `` (((StgWord32*)%0)[(StgInt)%1])=(StgWord32)%2; '' fo i' w
- where
- -- adjust index to be in Word units, not Word32 ones.
- i'
-#if WORD_SIZE_IN_BYTES==8
- = i `div` 2
-#else
- = i
-#endif
-
-writeWord64OffForeignObj :: ForeignObj -> Int -> Word64 -> IO ()
-# if WORD_SIZE_IN_BYTES==8
-writeWord64OffForeignObj fo i e = _casm_ `` (((StgWord*)%0)[(StgInt)%1])=(StgWord)%2; '' fo i e
-# else
-writeWord64OffForeignObj fo i e = _casm_ `` (((StgWord64*)%0)[(StgInt)%1])=(StgWord64)%2; '' fo i e
-# endif
-
-#endif
-
-\end{code}
-
-Utils for generating friendly error messages.
-
-\begin{code}
-{-# NOINLINE indexError #-}
-indexError :: (Show a) => a -> (a,a) -> String -> b
-indexError i rng tp
- = error (showString "Ix{" . showString tp . showString "}.index: Index " .
- showParen True (showsPrec 0 i) .
- showString " out of range " $
- showParen True (showsPrec 0 rng) "")
-
-toEnumError :: (Show a,Show b) => String -> a -> (b,b) -> c
-toEnumError inst_ty tag bnds
- = error ("Enum.toEnum{" ++ inst_ty ++ "}: tag " ++
- (showParen True (showsPrec 0 tag) $
- " is outside of bounds " ++
- show bnds))
-
-fromEnumError :: (Show a,Show b) => String -> a -> b
-fromEnumError inst_ty tag
- = error ("Enum.fromEnum{" ++ inst_ty ++ "}: value " ++
- (showParen True (showsPrec 0 tag) $
- " is outside of Int's bounds " ++
- show (minBound::Int,maxBound::Int)))
-
-succError :: String -> a
-succError inst_ty
- = error ("Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound")
-
-predError :: String -> a
-predError inst_ty
- = error ("Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound")
-
-divZeroError :: (Show a) => String -> a -> b
-divZeroError meth v
- = error ("Integral." ++ meth ++ ": divide by 0 (" ++ show v ++ " / 0)")
-
-\end{code}
-#else
--- Here is the Hugs version
------------------------------------------------------------------------------
--- The "official" coercion functions
------------------------------------------------------------------------------
-
-word8ToWord32 :: Word8 -> Word32
-word32ToWord8 :: Word32 -> Word8
-word16ToWord32 :: Word16 -> Word32
-word32ToWord16 :: Word32 -> Word16
-
-word8ToInt :: Word8 -> Int
-intToWord8 :: Int -> Word8
-word16ToInt :: Word16 -> Int
-intToWord16 :: Int -> Word16
-
-word8ToInt = word32ToInt . word8ToWord32
-intToWord8 = word32ToWord8 . intToWord32
-word16ToInt = word32ToInt . word16ToWord32
-intToWord16 = word32ToWord16 . intToWord32
-
-intToWord = Word32
-wordToInt = unWord32
-
---primitive intToWord32 "intToWord" :: Int -> Word32
---primitive word32ToInt "wordToInt" :: Word32 -> Int
-
------------------------------------------------------------------------------
--- Word8
------------------------------------------------------------------------------
-
-newtype Word8 = W8 Word32
-
-word8ToWord32 (W8 x) = x .&. 0xff
-word32ToWord8 = W8
-
-instance Eq Word8 where (==) = binop (==)
-instance Ord Word8 where compare = binop compare
-
-instance Num Word8 where
- x + y = to (binop (+) x y)
- x - y = to (binop (-) x y)
- negate = to . negate . from
- x * y = to (binop (*) x y)
- abs = absReal
- signum = signumReal
--- fromInteger = to . primIntegerToWord
- fromInt = intToWord8
-
-instance Bounded Word8 where
- minBound = 0
- maxBound = 0xff
-
-instance Real Word8 where
- toRational x = toInteger x % 1
-
-instance Integral Word8 where
- x `div` y = to (binop div x y)
- x `quot` y = to (binop quot x y)
- x `rem` y = to (binop rem x y)
- x `mod` y = to (binop mod x y)
- x `quotRem` y = to2 (binop quotRem x y)
- divMod = quotRem
- even = even . from
- toInteger = toInteger . from
- toInt = word8ToInt
-
-instance Ix Word8 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = word32ToInt (from (i - m))
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Word8 where
- toEnum = to . intToWord32
- fromEnum = word32ToInt . from
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Word8)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Word8)]
- where last = if d < c then minBound else maxBound
-
-instance Read Word8 where
- readsPrec p = readDec
-
-instance Show Word8 where
- showsPrec p = showInt -- a particularily counterintuitive name!
-
-instance Bits Word8 where
- x .&. y = to (binop (.&.) x y)
- x .|. y = to (binop (.|.) x y)
- x `xor` y = to (binop xor x y)
- complement = to . complement . from
- x `shift` i = to (from x `shift` i)
--- rotate
- bit = to . bit
- setBit x i = to (setBit (from x) i)
- clearBit x i = to (clearBit (from x) i)
- complementBit x i = to (complementBit (from x) i)
- testBit x i = testBit (from x) i
- bitSize _ = 8
- isSigned _ = False
-
-sizeofWord8 :: Word32
-sizeofWord8 = 1
-
-writeWord8OffAddr :: Addr -> Int -> Word8 -> IO ()
-writeWord8OffAddr = error "TODO: writeWord8OffAddr"
-readWord8OffAddr :: Addr -> Int -> IO Word8
-readWord8OffAddr = error "TODO: readWord8OffAddr"
-indexWord8OffAddr :: Addr -> Int -> Word8
-indexWord8OffAddr = error "TODO: indexWord8OffAddr"
-
------------------------------------------------------------------------------
--- Word16
------------------------------------------------------------------------------
-
-newtype Word16 = W16 Word32
-
-word16ToWord32 (W16 x) = x .&. 0xffff
-word32ToWord16 = W16
-
-instance Eq Word16 where (==) = binop (==)
-instance Ord Word16 where compare = binop compare
-
-instance Num Word16 where
- x + y = to (binop (+) x y)
- x - y = to (binop (-) x y)
- negate = to . negate . from
- x * y = to (binop (*) x y)
- abs = absReal
- signum = signumReal
--- fromInteger = to . primIntegerToWord
- fromInt = intToWord16
-
-instance Bounded Word16 where
- minBound = 0
- maxBound = 0xffff
-
-instance Real Word16 where
- toRational x = toInteger x % 1
-
-instance Integral Word16 where
- x `div` y = to (binop div x y)
- x `quot` y = to (binop quot x y)
- x `rem` y = to (binop rem x y)
- x `mod` y = to (binop mod x y)
- x `quotRem` y = to2 (binop quotRem x y)
- divMod = quotRem
- even = even . from
- toInteger = toInteger . from
- toInt = word16ToInt
-
-instance Ix Word16 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = word32ToInt (from (i - m))
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Word16 where
- toEnum = to . intToWord32
- fromEnum = word32ToInt . from
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Word16)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Word16)]
- where last = if d < c then minBound else maxBound
-
-instance Read Word16 where
- readsPrec p = readDec
-
-instance Show Word16 where
- showsPrec p = showInt -- a particularily counterintuitive name!
-
-instance Bits Word16 where
- x .&. y = to (binop (.&.) x y)
- x .|. y = to (binop (.|.) x y)
- x `xor` y = to (binop xor x y)
- complement = to . complement . from
- x `shift` i = to (from x `shift` i)
--- rotate
- bit = to . bit
- setBit x i = to (setBit (from x) i)
- clearBit x i = to (clearBit (from x) i)
- complementBit x i = to (complementBit (from x) i)
- testBit x i = testBit (from x) i
- bitSize _ = 16
- isSigned _ = False
-
-sizeofWord16 :: Word32
-sizeofWord16 = 2
-
-writeWord16OffAddr :: Addr -> Int -> Word16 -> IO ()
-writeWord16OffAddr = error "TODO: writeWord16OffAddr"
-readWord16OffAddr :: Addr -> Int -> IO Word16
-readWord16OffAddr = error "TODO: readWord16OffAddr"
-indexWord16OffAddr :: Addr -> Int -> Word16
-indexWord16OffAddr = error "TODO: indexWord16OffAddr"
-
------------------------------------------------------------------------------
--- Word32
------------------------------------------------------------------------------
--- This presumes that Word is 32 bits long
-newtype Word32 = Word32 { unWord32 :: Word }
- deriving (Eq,Ord)
-
-to_ = Word32
-to2_ (x,y) = (to_ x, to_ y)
-from_ = unWord32
-binop_ op x y = from_ x `op` from_ y
-intToWord32 :: Int -> Word32
-intToWord32 = to_ . primIntToWord
-word32ToInt :: Word32 -> Int
-word32ToInt = primWordToInt . unWord32
-
-
-instance Num Word32 where
- (+) x y = to_ (binop_ primPlusWord x y)
- (-) x y = to_ (binop_ primMinusWord x y)
- negate = to_ . primNegateWord . from_
- (*) x y = to_ (binop_ primTimesWord x y)
- abs = absReal
- signum = signumReal
- fromInteger = intToWord32 . toInt -- overflow issues?
- fromInt = intToWord32
-
-instance Bounded Word32 where
- minBound = 0
--- maxBound = primMaxWord
-
-instance Real Word32 where
- toRational x = toInteger x % 1
-
-instance Integral Word32 where
- x `div` y = fromInteger (toInteger x `div` toInteger y)
- x `quot` y = fromInteger (toInteger x `quot` toInteger y)
- x `rem` y = fromInteger (toInteger x `rem` toInteger y)
- x `mod` y = fromInteger (toInteger x `mod` toInteger y)
- x `quotRem` y = (x `quot` y,x `rem` y)
- divMod = quotRem
- even = even . toInt
- toInteger x = (toInteger (word32ToInt x) + twoToPower32)
- `rem` twoToPower32
-
- toInt = word32ToInt
-
-instance Ix Word32 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = word32ToInt (i - m)
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Word32 where
- toEnum = intToWord32
- fromEnum = word32ToInt
-
- --No: suffers from overflow problems:
- -- [4294967295 .. 1] :: [Word32]
- -- = [4294967295,0,1]
- --enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Word32)]
- --enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Word32)]
- -- where last = if d < c then minBound else maxBound
-
- enumFrom = numericEnumFrom
- enumFromTo = numericEnumFromTo
- enumFromThen = numericEnumFromThen
- enumFromThenTo = numericEnumFromThenTo
-
-instance Read Word32 where
- readsPrec p = readDec
-
-instance Show Word32 where
- showsPrec p = showInt . toInteger
-
-instance Bits Word32 where
- x .&. y = to_ (binop_ primAndWord x y)
- x .|. y = to_ (binop_ primOrWord x y)
- x `xor` y = to_ (binop_ primXorWord x y)
- complement = xor ((-1) :: Word32)
- x `shift` i | i == 0 = x
- | i > 0 = to_ (primShiftLWord (from_ x) (primIntToWord i))
- | i < 0 = to_ (primShiftRLWord (from_ x) (primIntToWord (-i)))
--- rotate
- bit = shift 0x1
- setBit x i = x .|. bit i
- clearBit x i = x .&. (bit i `xor` (complement 0))
- complementBit x i = x `xor` bit i
- testBit x i = (0x1 .&. shift x i) == (0x1 :: Word32)
- bitSize _ = 32
- isSigned _ = False
-
-sizeofWord32 :: Word32
-sizeofWord32 = 4
-
-writeWord32OffAddr :: Addr -> Int -> Word32 -> IO ()
-writeWord32OffAddr = error "TODO: writeWord32OffAddr"
-readWord32OffAddr :: Addr -> Int -> IO Word32
-readWord32OffAddr = error "TODO: readWord32OffAddr"
-indexWord32OffAddr :: Addr -> Int -> Word32
-indexWord32OffAddr = error "TODO: indexWord32OffAddr"
-
------------------------------------------------------------------------------
--- Word64
------------------------------------------------------------------------------
-
-data Word64 = Word64 {lo,hi::Word32} deriving (Eq, Ord, Bounded)
-
-word64ToInteger Word64{lo=lo,hi=hi}
- = toInteger lo + twoToPower32 * toInteger hi
-integerToWord64 x = case x `quotRem` twoToPower32 of
- (h,l) -> Word64{lo=fromInteger l, hi=fromInteger h}
-
-twoToPower32 :: Integer
-twoToPower32 = 4294967296 -- 0x100000000
-
-instance Show Word64 where
- showsPrec p = showInt . word64ToInteger
-
-instance Read Word64 where
- readsPrec p s = [ (integerToWord64 x,r) | (x,r) <- readDec s ]
-
-sizeofWord64 :: Word32
-sizeofWord64 = 8
-
-writeWord64OffAddr :: Addr -> Int -> Word64 -> IO ()
-writeWord64OffAddr = error "TODO: writeWord64OffAddr"
-readWord64OffAddr :: Addr -> Int -> IO Word64
-readWord64OffAddr = error "TODO: readWord64OffAddr"
-indexWord64OffAddr :: Addr -> Int -> Word64
-indexWord64OffAddr = error "TODO: indexWord64OffAddr"
-
-intToWord64 = error "TODO: intToWord64"
-word64ToInt = error "TODO: word64ToInt"
-
-word64ToWord32 = error "TODO: word64ToWord32"
-word64ToWord16 = error "TODO: word64ToWord16"
-word64ToWord8 = error "TODO: word64ToWord8"
-
-word32ToWord64 = error "TODO: word32ToWord64"
-word16ToWord64 = error "TODO: word16ToWord64"
-word8ToWord64 = error "TODO: word64ToWord64"
-
------------------------------------------------------------------------------
--- End of exported definitions
---
--- The remainder of this file consists of definitions which are only
--- used in the implementation.
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
--- Enumeration code: copied from Prelude
------------------------------------------------------------------------------
-
-numericEnumFrom :: Real a => a -> [a]
-numericEnumFromThen :: Real a => a -> a -> [a]
-numericEnumFromTo :: Real a => a -> a -> [a]
-numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
-numericEnumFrom n = n : (numericEnumFrom $! (n+1))
-numericEnumFromThen n m = iterate ((m-n)+) n
-numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
-numericEnumFromThenTo n n' m = takeWhile (if n' >= n then (<= m) else (>= m))
- (numericEnumFromThen n n')
-
------------------------------------------------------------------------------
--- Coercions - used to make the instance declarations more uniform
------------------------------------------------------------------------------
-
-class Coerce a where
- to :: Word32 -> a
- from :: a -> Word32
-
-instance Coerce Word8 where
- from = word8ToWord32
- to = word32ToWord8
-
-instance Coerce Word16 where
- from = word16ToWord32
- to = word32ToWord16
-
-binop :: Coerce word => (Word32 -> Word32 -> a) -> (word -> word -> a)
-binop op x y = from x `op` from y
-
-to2 :: Coerce word => (Word32, Word32) -> (word, word)
-to2 (x,y) = (to x, to y)
-
------------------------------------------------------------------------------
--- primitives
------------------------------------------------------------------------------
-{-
-primitive primEqWord :: Word32 -> Word32 -> Bool
-primitive primCmpWord :: Word32 -> Word32 -> Ordering
-primitive primPlusWord,
- primMinusWord,
- primMulWord :: Word32 -> Word32 -> Word32
-primitive primNegateWord :: Word32 -> Word32
-primitive primIntegerToWord :: Integer -> Word32
-primitive primMaxWord :: Word32
-primitive primDivWord,
- primQuotWord,
- primRemWord,
- primModWord :: Word32 -> Word32 -> Word32
-primitive primQrmWord :: Word32 -> Word32 -> (Word32,Word32)
-primitive primEvenWord :: Word32 -> Bool
-primitive primWordToInteger :: Word32 -> Integer
-primitive primAndWord :: Word32 -> Word32 -> Word32
-primitive primOrWord :: Word32 -> Word32 -> Word32
-primitive primXorWord :: Word32 -> Word32 -> Word32
-primitive primComplementWord:: Word32 -> Word32
-primitive primShiftWord :: Word32 -> Int -> Word32
-primitive primBitWord :: Int -> Word32
-primitive primTestWord :: Word32 -> Int -> Bool
--}
------------------------------------------------------------------------------
--- Code copied from the Prelude
------------------------------------------------------------------------------
-
-absReal x | x >= 0 = x
- | otherwise = -x
-
-signumReal x | x == 0 = 0
- | x > 0 = 1
- | otherwise = -1
-
------------------------------------------------------------------------------
--- An theres more
------------------------------------------------------------------------------
-
-integerToWord8 :: Integer -> Word8
-integerToWord8 = fromInteger
-integerToWord16 :: Integer -> Word16
-integerToWord16 = fromInteger
-integerToWord32 :: Integer -> Word32
-integerToWord32 = fromInteger
---integerToWord64 :: Integer -> Word64
---integerToWord64 = fromInteger
-
-word8ToInteger :: Word8 -> Integer
-word8ToInteger = toInteger
-word16ToInteger :: Word16 -> Integer
-word16ToInteger = toInteger
-word32ToInteger :: Word32 -> Integer
-word32ToInteger = toInteger
---word64ToInteger :: Word64 -> Integer
---word64ToInteger = toInteger
-
-word16ToWord8 = error "TODO; word16ToWord8"
-word8ToWord16 = error "TODO; word8ToWord16"
-
------------------------------------------------------------------------------
--- End
------------------------------------------------------------------------------
-#endif
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1997
-%
-\section[BSD]{Misc BSD bindings}
-
-The @BSD@ module defines Haskell bindings to functionality
-provided by BSD Unix derivatives. Currently this covers
-network programming functionality and symbolic links.
-(OK, so the latter is pretty much supported by most *nixes
-today, but it was BSD that introduced them.)
-
-\begin{code}
-{-# OPTIONS -#include "cbits/ghcSockets.h" -#include "stgio.h" #-}
-
-#include "config.h"
-
-module BSD (
-
- HostName,
- getHostName, -- :: IO HostName
-
- ServiceEntry(..),
- ServiceName,
- getServiceByName, -- :: ServiceName -> ProtocolName -> IO ServiceEntry
- getServiceByPort, -- :: PortNumber -> ProtocolName -> IO ServiceEntry
- getServicePortNumber, -- :: ServiceName -> IO PortNumber
-
-#ifndef _WIN32
- getServiceEntry, -- :: IO ServiceEntry
- setServiceEntry, -- :: Bool -> IO ()
- endServiceEntry, -- :: IO ()
- getServiceEntries, -- :: Bool -> IO [ServiceEntry]
-#endif
-
- ProtocolName,
- ProtocolNumber,
- ProtocolEntry(..),
- getProtocolByName, -- :: ProtocolName -> IO ProtocolEntry
- getProtocolByNumber, -- :: ProtocolNumber -> IO ProtcolEntry
- getProtocolNumber, -- :: ProtocolName -> ProtocolNumber
-
-#ifndef _WIN32
- setProtocolEntry, -- :: Bool -> IO ()
- getProtocolEntry, -- :: IO ProtocolEntry
- endProtocolEntry, -- :: IO ()
- getProtocolEntries, -- :: Bool -> IO [ProtocolEntry]
-#endif
-
- PortNumber,
- mkPortNumber, -- :: Int -> PortNumber
-
- HostEntry(..),
- getHostByName, -- :: HostName -> IO HostEntry
- getHostByAddr, -- :: HostAddress -> Family -> IO HostEntry
- hostAddress, -- :: HostEntry -> HostAddress
-
-#ifndef _WIN32
- setHostEntry, -- :: Bool -> IO ()
- getHostEntry, -- :: IO HostEntry
- endHostEntry, -- :: IO ()
- getHostEntries, -- :: Bool -> IO [HostEntry]
-#endif
-
- NetworkName,
- NetworkAddr,
- NetworkEntry(..)
-#ifndef _WIN32
- , getNetworkByName -- :: NetworkName -> IO NetworkEntry
- , getNetworkByAddr -- :: NetworkAddr -> Family -> IO NetworkEntry
- , setNetworkEntry -- :: Bool -> IO ()
- , getNetworkEntry -- :: IO NetworkEntry
- , endNetworkEntry -- :: IO ()
- , getNetworkEntries -- :: Bool -> IO [NetworkEntry]
-#endif
-
-#ifdef HAVE_SYMLINK
- , symlink -- :: String -> String -> IO ()
-#endif
-#ifdef HAVE_READLINK
- , readlink -- :: String -> IO String
-#endif
-
- ) where
-
-
-import GlaExts
-import PrelIOBase ( IOError (..), IOErrorType(..) )
-
-import Foreign
-import Addr
-import CString ( unpackCStringIO, unpackCStringBA, unvectorize, unpackNBytesBA )
-import SocketPrim
-
-\end{code}
-
-
-%***************************************************************************
-%* *
-\subsection[BSD-DBTypes]{Service, Protocol \& Host Database Types}
-%* *
-%***************************************************************************
-
-\begin{code}
-type HostName = String
-type ProtocolName = String
-type ServiceName = String
-
-data ProtocolEntry =
- ProtocolEntry {
- protoName :: ProtocolName, -- Official Name
- protoAliases :: [ProtocolName], -- aliases
- protoNumber :: ProtocolNumber -- Protocol Number
- }
-
-data ServiceEntry =
- ServiceEntry {
- serviceName :: ServiceName, -- Official Name
- serviceAliases :: [ServiceName], -- aliases
- servicePort :: PortNumber, -- Port Number ( network byte order )
- serviceProtocol :: ProtocolName -- Protocol
- }
-
-data HostEntry =
- HostEntry {
- hostName :: HostName, -- Official Name
- hostAliases :: [HostName], -- aliases
- hostFamily :: Family, -- Host Type (currently AF_INET)
- hostAddresses :: [HostAddress] -- Set of Network Addresses (in network byte order)
- }
-
--- convenience function:
-hostAddress :: HostEntry -> HostAddress
-hostAddress (HostEntry nm _ _ ls) =
- case ls of
- [] -> error ("BSD.hostAddress: empty network address list for " ++ nm)
- (x:_) -> x
-
-\end{code}
-
-%***************************************************************************
-%* *
-\subsection[BSD-DBAccess]{Service, Protocol Host Database Access}
-%* *
-%***************************************************************************
-
-Calling @getServiceByName@ for a given service and protocol returns the
-systems service entry. This should be used to find the port numbers
-for standard protocols such as SMTP and FTP. The remaining three
-functions should be used for browsing the service database
-sequentially.
-
-Calling @setServiceEntry@ with \tr{True} indicates that the service
-database should be left open between calls to @getServiceEntry@. To
-close the database a call to @endServiceEntry@ is required. This
-database file is usually stored in the file /etc/services.
-
-\begin{code}
-getServiceByName :: ServiceName -- Service Name
- -> ProtocolName -- Protocol Name
- -> IO ServiceEntry -- Service Entry
-getServiceByName name proto = do
- ptr <- _ccall_ getservbyname name proto
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getServiceByName" "no such service entry")
- else unpackServiceEntry ptr
-
-getServiceByPort :: PortNumber
- -> ProtocolName
- -> IO ServiceEntry
-getServiceByPort (PNum port) proto = do
- ptr <- _ccall_ getservbyport port proto
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getServiceByPort" "no such service entry")
- else unpackServiceEntry ptr
-
-getServicePortNumber :: ServiceName -> IO PortNumber
-getServicePortNumber name = do
- (ServiceEntry _ _ port _) <- getServiceByName name "tcp"
- return port
-
-#ifndef _WIN32
-getServiceEntry :: IO ServiceEntry
-getServiceEntry = do
- ptr <- _ccall_ getservent
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getServiceEntry" "no such service entry")
- else unpackServiceEntry ptr
-
-setServiceEntry :: Bool -> IO ()
-setServiceEntry flg = _ccall_ setservent stayOpen
- where stayOpen = (if flg then 1 else 0) :: Int
-
-endServiceEntry :: IO ()
-endServiceEntry = _ccall_ endservent
-
-getServiceEntries :: Bool -> IO [ServiceEntry]
-getServiceEntries stayOpen = do
- setServiceEntry stayOpen
- getEntries (getServiceEntry) (endServiceEntry)
-#endif
-\end{code}
-
-The following relate directly to the corresponding \tr{UNIX} {C} calls for
-returning the protocol entries. The protocol entry is represented by
-the Haskell type @ProtocolEntry@.
-
-As for @setServiceEntry@ above, calling @setProtocolEntry@.
-determines whether or not the protocol database file, usually
-\tr{/etc/protocols}, is to be kept open between calls of
-@getProtocolEntry@. Similarly,
-
-\begin{code}
-getProtocolByName :: ProtocolName -> IO ProtocolEntry
-getProtocolByNumber :: ProtocolNumber -> IO ProtocolEntry
-getProtocolNumber :: ProtocolName -> IO ProtocolNumber
-
-#ifndef _WIN32
-setProtocolEntry :: Bool -> IO () -- Keep DB Open ?
-getProtocolEntry :: IO ProtocolEntry -- Next Protocol Entry from DB
-endProtocolEntry :: IO ()
-getProtocolEntries :: Bool -> IO [ProtocolEntry]
-#endif
-\end{code}
-
-\begin{code}
---getProtocolByName :: ProtocolName -> IO ProtocolEntry
-getProtocolByName name = do
- ptr <- _ccall_ getprotobyname name
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getProtocolByName" "no such protocol entry")
- else unpackProtocolEntry ptr
-
---getProtocolByNumber :: ProtocolNumber -> IO ProtocolEntry
-getProtocolByNumber num = do
- ptr <- _ccall_ getprotobynumber num
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getProtocolByNumber" "no such protocol entry")
- else unpackProtocolEntry ptr
-
---getProtocolNumber :: ProtocolName -> IO ProtocolNumber
-getProtocolNumber proto = do
- (ProtocolEntry _ _ num) <- getProtocolByName proto
- return num
-
-#ifndef _WIN32
---getProtocolEntry :: IO ProtocolEntry -- Next Protocol Entry from DB
-getProtocolEntry = do
- ptr <- _ccall_ getprotoent
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getProtocolEntry" "no such protocol entry")
- else unpackProtocolEntry ptr
-
---setProtocolEntry :: Bool -> IO () -- Keep DB Open ?
-setProtocolEntry flg = _ccall_ setprotoent v
- where v = (if flg then 1 else 0) :: Int
-
---endProtocolEntry :: IO ()
-endProtocolEntry = _ccall_ endprotoent
-
---getProtocolEntries :: Bool -> IO [ProtocolEntry]
-getProtocolEntries stayOpen = do
- setProtocolEntry stayOpen
- getEntries (getProtocolEntry) (endProtocolEntry)
-#endif
-
-\end{code}
-
-\begin{code}
-getHostByName :: HostName -> IO HostEntry
-getHostByName name = do
- ptr <- _ccall_ gethostbyname name
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getHostByName" "no such host entry")
- else unpackHostEntry ptr
-
-getHostByAddr :: Family -> HostAddress -> IO HostEntry
-getHostByAddr family addr = do
- ptr <- _casm_ ``struct in_addr addr;
- addr.s_addr = %0;
- %r = gethostbyaddr ((char*)&addr, sizeof(struct in_addr), %1);''
- addr
- (packFamily family)
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getHostByAddr" "no such host entry")
- else unpackHostEntry ptr
-
-#ifndef _WIN32
-getHostEntry :: IO HostEntry
-getHostEntry = do
- ptr <- _ccall_ gethostent
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getHostEntry" "unable to retrieve host entry")
- else unpackHostEntry ptr
-
-setHostEntry :: Bool -> IO ()
-setHostEntry flg = _ccall_ sethostent v
- where v = (if flg then 1 else 0) :: Int
-
-endHostEntry :: IO ()
-endHostEntry = _ccall_ endhostent
-
-getHostEntries :: Bool -> IO [HostEntry]
-getHostEntries stayOpen = do
- setHostEntry stayOpen
- getEntries (getHostEntry) (endHostEntry)
-#endif
-\end{code}
-
-%***************************************************************************
-%* *
-\subsection[BSD-Network]{Accessing network information}
-%* *
-%***************************************************************************
-
-Same set of access functions as for accessing host,protocol and service
-system info, this time for the types of networks supported.
-
-\begin{code}
--- network addresses are represented in host byte order.
-type NetworkAddr = Word
-
-type NetworkName = String
-
-data NetworkEntry =
- NetworkEntry {
- networkName :: NetworkName, -- official name
- networkAliases :: [NetworkName], -- aliases
- networkFamily :: Family, -- type
- networkAddress :: NetworkAddr
- }
-#ifndef _WIN32
-getNetworkByName :: NetworkName -> IO NetworkEntry
-getNetworkByName name = do
- ptr <- _ccall_ getnetbyname name
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getNetworkByName" "no such network entry")
- else unpackNetworkEntry ptr
-
-getNetworkByAddr :: NetworkAddr -> Family -> IO NetworkEntry
-getNetworkByAddr addr family = do
- ptr <- _ccall_ getnetbyaddr addr (packFamily family)
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getNetworkByAddr" "no such network entry")
- else unpackNetworkEntry ptr
-
-getNetworkEntry :: IO NetworkEntry
-getNetworkEntry = do
- ptr <- _ccall_ getnetent
- if ptr == nullAddr
- then ioError (IOError Nothing NoSuchThing "getNetworkEntry" "no more network entries")
- else unpackNetworkEntry ptr
-
-setNetworkEntry :: Bool -> IO ()
-setNetworkEntry flg = _ccall_ setnetent v
- where v = (if flg then 1 else 0) :: Int
-
-endNetworkEntry :: IO ()
-endNetworkEntry = _ccall_ endnetent
-
-getNetworkEntries :: Bool -> IO [NetworkEntry]
-getNetworkEntries stayOpen = do
- setNetworkEntry stayOpen
- getEntries (getNetworkEntry) (endNetworkEntry)
-#endif
-
-\end{code}
-
-%***************************************************************************
-%* *
-\subsection[BSD-Misc]{Miscellaneous Functions}
-%* *
-%***************************************************************************
-
-Calling @getHostName@ returns the standard host name for the current
-processor, as set at boot time.
-
-\begin{code}
-getHostName :: IO HostName
-getHostName = do
- ptr <- stToIO (newCharArray (0,256))
- rc <- _casm_ ``%r=gethostname(%0, 256);'' ptr
- if rc == ((-1)::Int)
- then ioError (userError "getHostName: unable to determine host name")
- else do
- ba <- stToIO (unsafeFreezeByteArray ptr)
- return (unpackCStringBA ba)
-\end{code}
-
-Helper function used by the exported functions that provides a
-Haskellised view of the enumerator functions:
-
-\begin{code}
-getEntries :: IO a -- read
- -> IO () -- at end
- -> IO [a]
-getEntries getOne atEnd = loop
- where
- loop =
- catch (do { v <- getOne; vs <- loop ; return (v:vs) })
- (\ _ -> do { atEnd; return [] } )
-\end{code}
-
-
-\begin{verbatim}
- struct servent {
- char *s_name; /* official name of service */
- char **s_aliases; /* alias list */
- int s_port; /* port service resides at */
- char *s_proto; /* protocol to use */
- };
-
- The members of this structure are:
- s_name The official name of the service.
- s_aliases A zero terminated list of alternate
- names for the service.
- s_port The port number at which the ser-
- vice resides. Port numbers are
- returned in network short byte
- order.
- s_proto The name of the protocol to use
- when contacting the service.
-\end{verbatim}
-
-\begin{code}
-unpackServiceEntry :: Addr -> PrimIO ServiceEntry
-unpackServiceEntry ptr = do
- pname <- _casm_ ``%r = ((struct servent*)%0)->s_name;'' ptr
- name <- unpackCStringIO pname
- alias <- _casm_ ``%r = ((struct servent*)%0)->s_aliases;'' ptr
- aliases <- unvectorize alias 0
- port <- _casm_ ``%r = (int)(((struct servent*)%0)->s_port);'' ptr
- str <- _casm_ ``%r = (char *)((struct servent*)%0)->s_proto;'' ptr
- proto <- unpackCStringIO str
- return (ServiceEntry name aliases (PNum port) proto)
-
--------------------------------------------------------------------------------
-
-unpackProtocolEntry :: Addr -> IO ProtocolEntry
-unpackProtocolEntry ptr = do
- str <- _casm_ ``%r = ((struct protoent*)%0)->p_name;'' ptr
- name <- unpackCStringIO str
- alias <- _casm_ ``%r = ((struct protoent*)%0)->p_aliases;'' ptr
- aliases <- unvectorize alias 0
- proto <- _casm_ ``%r = ((struct protoent*)%0)->p_proto;'' ptr
- return (ProtocolEntry name aliases proto)
-
--------------------------------------------------------------------------------
-
-unpackHostEntry :: Addr -> IO HostEntry
-unpackHostEntry ptr = do
- str <- _casm_ ``%r = ((struct hostent*)%0)->h_name;'' ptr
- name <- unpackCStringIO str
- alias <- _casm_ ``%r = ((struct hostent*)%0)->h_aliases;'' ptr
- aliases <- unvectorize alias 0
- addrList <- unvectorizeHostAddrs ptr 0
- return (HostEntry name aliases AF_INET addrList)
-
--------------------------------------------------------------------------------
-
-unpackNetworkEntry :: Addr -> IO NetworkEntry
-unpackNetworkEntry ptr = do
- str <- _casm_ ``%r = ((struct netent*)%0)->n_name;'' ptr
- name <- unpackCStringIO str
- alias <- _casm_ ``%r = ((struct netent*)%0)->n_aliases;'' ptr
- aliases <- unvectorize alias 0
- fam <- _casm_ ``%r = ((struct netent*)%0)->n_addrtype;'' ptr
- na <- _casm_ ``%r = ((struct netent*)%0)->n_net;'' ptr
- return (NetworkEntry name aliases (unpackFamily fam) na)
-
--------------------------------------------------------------------------------
-
-unvectorizeHostAddrs :: Addr -> Int -> IO [HostAddress]
-unvectorizeHostAddrs ptr n = do
- x <- _casm_ ``{ unsigned long tmp;
- if ((((struct hostent*)%0)->h_addr_list[(int)%1]) == NULL)
- tmp=(W_)0;
- else
- tmp = (W_)((struct in_addr *)(((struct hostent*)%0)->h_addr_list[(int)%1]))->s_addr;
- %r=(W_)tmp;} ''
- ptr n
- if x == (W# (int2Word# 0#))
- then return []
- else do
- xs <- unvectorizeHostAddrs ptr (n+1)
- return (x : xs)
-
-
-\end{code}
-
-%***************************************************************************
-%* *
-\subsection[BSD-symlink]{Symbolic links}
-%* *
-%***************************************************************************
-
-
-\begin{code}
-#ifdef HAVE_SYMLINK
-symlink :: String -> String -> IO ()
-symlink actual_path sym_path = do
- rc <- _ccall_ symlink actual_path sym_path
- if rc == (0::Int) then
- return ()
- else do
- _ccall_ convertErrno
- cstr <- _ccall_ getErrStr__
- estr <- unpackCStringIO cstr
- ioError (userError ("BSD.symlink: " ++ estr))
-#endif
-
-#ifdef HAVE_READLINK
-readlink :: String -> IO String
-readlink sym = do
- mbuf <- stToIO (newCharArray (0, path_max))
- buf <- stToIO (unsafeFreezeByteArray mbuf)
- rc <- _ccall_ readlink sym buf (path_max + 1)
- if rc /= -1 then
- return (unpackNBytesBA buf rc)
- else do
- _ccall_ convertErrno
- cstr <- _ccall_ getErrStr__
- estr <- unpackCStringIO cstr
- ioError (userError ("BSD.readlink: " ++ estr))
- where
- path_max = (``PATH_MAX''::Int)
-#endif
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[Bags]{@Bag@: an unordered collection with duplicates}
-
-\begin{code}
-module Bag (
- Bag, -- abstract type
-
- emptyBag, unitBag, unionBags, unionManyBags,
- mapBag,
- elemBag,
-
- filterBag, partitionBag, concatBag, foldBag,
- isEmptyBag, consBag, snocBag,
- listToBag, bagToList
- ) where
-
-import List(partition)
-
-data Bag a
- = EmptyBag
- | UnitBag a
- | TwoBags (Bag a) (Bag a) -- The ADT guarantees that at least
- -- one branch is non-empty
- | ListBag [a] -- The list is non-empty
- | ListOfBags [Bag a] -- The list is non-empty
-
-emptyBag :: Bag a
-emptyBag = EmptyBag
-
-unitBag :: a -> Bag a
-unitBag = UnitBag
-
-elemBag :: Eq a => a -> Bag a -> Bool
-elemBag _ EmptyBag = False
-elemBag x (UnitBag y) = x==y
-elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
-elemBag x (ListBag ys) = any (x ==) ys
-elemBag x (ListOfBags bs) = any (x `elemBag`) bs
-
-unionManyBags :: [Bag a] -> Bag a
-unionManyBags [] = EmptyBag
-unionManyBags xs = ListOfBags xs
-
--- This one is a bit stricter! The bag will get completely evaluated.
-
-unionBags :: Bag a -> Bag a -> Bag a
-unionBags EmptyBag b = b
-unionBags b EmptyBag = b
-unionBags b1 b2 = TwoBags b1 b2
-
-consBag :: a -> Bag a -> Bag a
-snocBag :: Bag a -> a -> Bag a
-
-consBag elt bag = (unitBag elt) `unionBags` bag
-snocBag bag elt = bag `unionBags` (unitBag elt)
-
-isEmptyBag :: Bag a -> Bool
-isEmptyBag EmptyBag = True
-isEmptyBag (UnitBag _) = False
-isEmptyBag (TwoBags b1 b2) = isEmptyBag b1 && isEmptyBag b2 -- Paranoid, but safe
-isEmptyBag (ListBag xs) = null xs -- Paranoid, but safe
-isEmptyBag (ListOfBags bs) = all isEmptyBag bs
-
-filterBag :: (a -> Bool) -> Bag a -> Bag a
-filterBag _ EmptyBag = EmptyBag
-filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag
-filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2
- where
- sat1 = filterBag pred b1
- sat2 = filterBag pred b2
-filterBag pred (ListBag vs) = listToBag (filter pred vs)
-filterBag pred (ListOfBags bs) = ListOfBags sats
- where
- sats = [filterBag pred b | b <- bs]
-
-concatBag :: Bag (Bag a) -> Bag a
-
-concatBag EmptyBag = EmptyBag
-concatBag (UnitBag b) = b
-concatBag (TwoBags b1 b2) = concatBag b1 `TwoBags` concatBag b2
-concatBag (ListBag bs) = ListOfBags bs
-concatBag (ListOfBags bbs) = ListOfBags (map concatBag bbs)
-
-partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
- Bag a {- Don't -})
-partitionBag _ EmptyBag = (EmptyBag, EmptyBag)
-partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
-partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
- where
- (sat1,fail1) = partitionBag pred b1
- (sat2,fail2) = partitionBag pred b2
-partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails)
- where
- (sats,fails) = partition pred vs
-partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails)
- where
- (sats, fails) = unzip [partitionBag pred b | b <- bs]
-
-
-foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative
- -> (a -> r) -- Replace UnitBag with this
- -> r -- Replace EmptyBag with this
- -> Bag a
- -> r
-
-{- Standard definition
-foldBag _ _ e EmptyBag = e
-foldBag t u e (UnitBag x) = u x
-foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)
-foldBag t u e (ListBag xs) = foldr (t.u) e xs
-foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs
--}
-
--- More tail-recursive definition, exploiting associativity of "t"
-foldBag _ _ e EmptyBag = e
-foldBag t u e (UnitBag x) = u x `t` e
-foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1
-foldBag t u e (ListBag xs) = foldr (t.u) e xs
-foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs
-
-
-mapBag :: (a -> b) -> Bag a -> Bag b
-mapBag _ EmptyBag = EmptyBag
-mapBag f (UnitBag x) = UnitBag (f x)
-mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)
-mapBag f (ListBag xs) = ListBag (map f xs)
-mapBag f (ListOfBags bs) = ListOfBags (map (mapBag f) bs)
-
-
-listToBag :: [a] -> Bag a
-listToBag [] = EmptyBag
-listToBag vs = ListBag vs
-
-bagToList :: Bag a -> [a]
-bagToList EmptyBag = []
-bagToList (ListBag vs) = vs
-bagToList b = bagToList_append b []
-
- -- (bagToList_append b xs) flattens b and puts xs on the end.
- -- (not exported)
-bagToList_append :: Bag a -> [a] -> [a]
-bagToList_append EmptyBag xs = xs
-bagToList_append (UnitBag x) xs = x:xs
-bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs)
-bagToList_append (ListBag xx) xs = xx++xs
-bagToList_append (ListOfBags bs) xs = foldr bagToList_append xs bs
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1994-1995
-%
-\section[BitSet]{An implementation of very small sets}
-
-Bit sets are a fast implementation of sets of integers ranging from 0
-to one less than the number of bits in a machine word (typically 31).
-If any element exceeds the maximum value for a particular machine
-architecture, the results of these operations are undefined. You have
-been warned. If you put any safety checks in this code, I will have
-to kill you.
-
-Note: the Yale Haskell implementation won't provide a full 32 bits.
-However, if you can handle the performance loss, you could change to
-Integer and get virtually unlimited sets.
-
-\begin{code}
-
-module BitSet (
- BitSet, -- abstract type
- mkBS, listBS, emptyBS, unitBS,
- unionBS, minusBS
-#if ! defined(COMPILING_GHC)
- , elementBS, intersectBS, isEmptyBS
-#endif
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import
- PrelBase
-
--- nothing to import
-#elif defined(__YALE_HASKELL__)
-{-hide import from mkdependHS-}
-import
- LogOpPrims
-#else
-{-hide import from mkdependHS-}
-import
- Word
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-
-data BitSet = MkBS Word#
-
-emptyBS :: BitSet
-emptyBS = MkBS (int2Word# 0#)
-
-mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . unitBS) emptyBS xs
-
-unitBS :: Int -> BitSet
-unitBS x = case x of
- I# i# -> MkBS ((int2Word# 1#) `shiftL#` i#)
-
-unionBS :: BitSet -> BitSet -> BitSet
-unionBS (MkBS x#) (MkBS y#) = MkBS (x# `or#` y#)
-
-minusBS :: BitSet -> BitSet -> BitSet
-minusBS (MkBS x#) (MkBS y#) = MkBS (x# `and#` (not# y#))
-
-#if ! defined(COMPILING_GHC)
--- not used in GHC
-isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s#)
- = case word2Int# s# of
- 0# -> True
- _ -> False
-
-intersectBS :: BitSet -> BitSet -> BitSet
-intersectBS (MkBS x#) (MkBS y#) = MkBS (x# `and#` y#)
-
-elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s#) = case x of
- I# i# -> case word2Int# (((int2Word# 1#) `shiftL#` i#) `and#` s#) of
- 0# -> False
- _ -> True
-#endif
-
-listBS :: BitSet -> [Int]
-listBS s = listify s 0
- where listify (MkBS s#) n =
- case word2Int# s# of
- 0# -> []
- _ -> let s' = (MkBS (s# `shiftr` 1#))
- more = listify s' (n + 1)
- in case word2Int# (s# `and#` (int2Word# 1#)) of
- 0# -> more
- _ -> n : more
- shiftr x y = shiftRL# x y
-
-#elif defined(__YALE_HASKELL__)
-
-data BitSet = MkBS Int
-
-emptyBS :: BitSet
-emptyBS = MkBS 0
-
-mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . unitBS) emptyBS xs
-
-unitBS :: Int -> BitSet
-unitBS x = MkBS (1 `ashInt` x)
-
-unionBS :: BitSet -> BitSet -> BitSet
-unionBS (MkBS x) (MkBS y) = MkBS (x `logiorInt` y)
-
-#if ! defined(COMPILING_GHC)
--- not used in GHC
-isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s)
- = case s of
- 0 -> True
- _ -> False
-
-intersectBS :: BitSet -> BitSet -> BitSet
-intersectBS (MkBS x) (MkBS y) = MkBS (x `logandInt` y)
-
-elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s)
- = case logbitpInt x s of
- 0 -> False
- _ -> True
-#endif
-
-minusBS :: BitSet -> BitSet -> BitSet
-minusBS (MkBS x) (MkBS y) = MkBS (x `logandc2Int` y)
-
--- rewritten to avoid right shifts (which would give nonsense on negative
--- values.
-listBS :: BitSet -> [Int]
-listBS (MkBS s) = listify s 0 1
- where listify s n m =
- case s of
- 0 -> []
- _ -> let n' = n+1; m' = m+m in
- case logbitpInt s m of
- 0 -> listify s n' m'
- _ -> n : listify (s `logandc2Int` m) n' m'
-
-#else /* HBC, perhaps? */
-
-data BitSet = MkBS Word
-
-emptyBS :: BitSet
-emptyBS = MkBS 0
-
-mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . unitBS) emptyBS xs
-
-unitBS :: Int -> BitSet
-unitBS x = MkBS (1 `bitLsh` x)
-
-unionBS :: BitSet -> BitSet -> BitSet
-unionBS (MkBS x) (MkBS y) = MkBS (x `bitOr` y)
-
-#if ! defined(COMPILING_GHC)
--- not used in GHC
-isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s)
- = case s of
- 0 -> True
- _ -> False
-
-intersectBS :: BitSet -> BitSet -> BitSet
-intersectBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` y)
-
-elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s)
- = case (1 `bitLsh` x) `bitAnd` s of
- 0 -> False
- _ -> True
-#endif
-
-minusBS :: BitSet -> BitSet -> BitSet
-minusBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` (bitCompl y))
-
-listBS :: BitSet -> [Int]
-listBS (MkBS s) = listify s 0
- where listify s n =
- case s of
- 0 -> []
- _ -> let s' = s `bitRsh` 1
- more = listify s' (n + 1)
- in case (s `bitAnd` 1) of
- 0 -> more
- _ -> n : more
-
-#endif
-
-\end{code}
-
-
-
-
+++ /dev/null
-{-
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
-%
-\section[ByteOps]{Convert to/from ``bytes''; to support @Native@ class}
-
-This mimics some code that comes with HBC.
--}
-
-\begin{code}
-{-# OPTIONS -#include "cbits/ByteOps.h" #-}
-
-module ByteOps (
- longToBytes,
- intToBytes,
- shortToBytes,
- floatToBytes,
- doubleToBytes,
-
- bytesToLong,
- bytesToInt,
- bytesToShort,
- bytesToFloat,
- bytesToDouble
- ) where
-
-import GlaExts
-import PrelBase
-
--- \tr{xxxToBytes} prepends an \tr{xxx} to a byte stream.
--- \tr{bytesToXxx} snaffles an \tr{xxx} from a byte stream,
--- also returning the rest of the stream.
-
-type Bytes = [Char]
-
-longToBytes :: Int -> Bytes -> Bytes
-intToBytes :: Int -> Bytes -> Bytes
-shortToBytes :: Int -> Bytes -> Bytes
-floatToBytes :: Float -> Bytes -> Bytes
-doubleToBytes :: Double -> Bytes -> Bytes
-
-bytesToLong :: Bytes -> (Int, Bytes)
-bytesToInt :: Bytes -> (Int, Bytes)
-bytesToShort :: Bytes -> (Int, Bytes)
-bytesToFloat :: Bytes -> (Float, Bytes)
-bytesToDouble :: Bytes -> (Double, Bytes)
-
---Here we go.
-
-#define XXXXToBytes(type,xxxx,xxxx__) \
-xxxx i stream \
- = let \
- long_bytes {- DANGEROUS! -} \
- = unsafePerformIO ( \
- {- Allocate a wad of memory to put the "long"'s bytes. \
- Let's hope 32 bytes will be big enough. -} \
- stToIO (newCharArray (0::Int, 31)) >>= \ arr# -> \
- \
- {- Call out to C to do the dirty deed: -} \
- _casm_ ``%r = xxxx__ ((type)%0, (unsigned char *)%1);'' i arr# \
- >>= \ num_bytes -> \
- \
- unpack arr# 0 (num_bytes - 1) \
- ) \
- in \
- long_bytes ++ stream
-
-XXXXToBytes(long,longToBytes,long2bytes__)
-XXXXToBytes(int,intToBytes,int2bytes__)
-XXXXToBytes(short,shortToBytes,short2bytes__)
-XXXXToBytes(float,floatToBytes,float2bytes__)
-XXXXToBytes(double,doubleToBytes,double2bytes__)
-
---------------
-unpack :: MutableByteArray RealWorld Int -> Int -> Int -> IO [Char]
-
-unpack arr# curr last
- = if curr > last then
- return []
- else
- stToIO (readCharArray arr# curr) >>= \ ch ->
- unpack arr# (curr + 1) last >>= \ rest ->
- return (ch : rest)
-
--------------
---Now we go the other way. The paranoia checking (absent) leaves
---something to be desired. Really have to be careful on
---funny-sized things like \tr{shorts}...
-
-#define bytesToXXXX(htype,xxxx,alloc,read,xxxx__) \
-xxxx stream \
- = unsafePerformIO ( \
- {- slam (up to) 32 bytes [random] from the stream into an array -} \
- stToIO (newCharArray (0::Int, 31)) >>= \ arr# -> \
- pack arr# 0 31 stream >> \
- \
- {- make a one-element array to hold the result: -} \
- stToIO (alloc (0::Int, 0)) >>= \ res# -> \
- \
- {- call the C to do the business: -} \
- _casm_ ``%r = xxxx__ ((P_)%0, (htype *) %1);'' arr# res# \
- >>= \ num_bytes -> \
- \
- {- read the result out of "res#": -} \
- stToIO (read res# (0::Int)) >>= \ i -> \
- \
- {- box the result and drop the number of bytes taken: -} \
- return (i, my_drop num_bytes stream) \
- )
-
-bytesToXXXX(I_,bytesToLong,newIntArray,readIntArray,bytes2long__)
-bytesToXXXX(I_,bytesToInt,newIntArray,readIntArray,bytes2int__)
-bytesToXXXX(I_,bytesToShort,newIntArray,readIntArray,bytes2short__)
-bytesToXXXX(StgFloat,bytesToFloat,newFloatArray,readFloatArray,bytes2float__)
-bytesToXXXX(StgDouble,bytesToDouble,newDoubleArray,readDoubleArray,bytes2double__)
-
-----------------------
-pack :: MutableByteArray RealWorld Int -> Int -> Int -> [Char] -> IO ()
-
-pack arr# curr last from_bytes
- = if curr > last then
- return ()
- else
- case from_bytes of
- [] -> stToIO (writeCharArray arr# curr (chr 0))
-
- (from_byte : xs) ->
- stToIO (writeCharArray arr# curr from_byte) >>
- pack arr# (curr + 1) last xs
-
--- more cavalier than usual; we know there will be enough bytes:
-
-my_drop :: Int -> [a] -> [a]
-
-my_drop 0 xs = xs
---my_drop _ [] = []
-my_drop m (_:xs) = my_drop (m - 1) xs
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section{Working with C strings}
-
-A collection of lower-level functions to help converting between
-C strings and Haskell Strings (packed or otherwise).
-
-A more user-friendly Haskell interface to packed string representation
-is the PackedString interface.
-
-\begin{code}
-module CString
- (
- unpackCString -- :: Addr -> [Char]
- , unpackNBytes -- :: Addr -> Int -> [Char]
- , unpackNBytesST -- :: Addr -> Int -> ST s [Char]
- , unpackNBytesAccST -- :: Addr -> Int -> [Char] -> ST s [Char]
- , unpackCString# -- :: Addr# -> [Char] **
- , unpackNBytes# -- :: Addr# -> Int# -> [Char] **
- , unpackNBytesST# -- :: Addr# -> Int# -> ST s [Char]
-
- -- terrrible names...
- , unpackCStringIO -- :: Addr -> IO String
- , unpackCStringLenIO -- :: Addr -> Int -> IO String
- , unpackNBytesIO -- :: Addr -> Int -> IO [Char]
- , unpackNBytesAccIO -- :: Addr -> Int -> [Char] -> IO [Char]
- , unpackNBytesBAIO -- :: ByteArray Int -> Int -> IO [Char]
- , unpackNBytesAccBAIO -- :: ByteArray Int -> Int -> [Char] -> IO [Char]
-
- , packString -- :: [Char] -> ByteArray Int
- , packStringST -- :: [Char] -> ST s (ByteArray Int)
- , packStringIO -- :: [Char] -> IO (ByteArray Int)
- , packNBytesST -- :: Int -> [Char] -> ByteArray Int
- , packCString# -- :: [Char] -> ByteArray#
-
- , unpackCStringBA -- :: ByteArray Int -> [Char]
- , unpackNBytesBA -- :: ByteArray Int -> Int -> [Char]
- , unpackCStringBA# -- :: ByteArray# -> Int# -> [Char]
- , unpackNBytesBA# -- :: ByteArray# -> Int# -> [Char]
-
- -- unmarshaling (char*) vectors.
- , unvectorize -- :: Addr -> Int -> IO [String]
- , vectorize -- :: [[Char]] -> IO (ByteArray Int)
-
-
- , allocChars -- :: Int -> IO (MutableByteArray RealWorld Int)
- , allocWords -- :: Int -> IO (MutableByteArray RealWorld Int)
- , freeze -- :: MutableByteArray RealWorld Int -> IO (ByteArray Int)
- , strcpy -- :: Addr -> IO String
-
- ) where
-
-import PrelPack
-import GlaExts
-import Addr
-import PrelIOBase ( IO(..) )
-import MutableArray
-
-\end{code}
-
-\begin{code}
-packStringIO :: [Char] -> IO (ByteArray Int)
-packStringIO str = stToIO (packStringST str)
-\end{code}
-
-\begin{code}
-unpackCStringIO :: Addr -> IO String
-unpackCStringIO addr
- | addr == nullAddr = return ""
- | otherwise = unpack 0#
- where
- unpack nh = do
- ch <- readCharOffAddr addr (I# nh)
- if ch == '\0'
- then return []
- else do
- ls <- unpack (nh +# 1#)
- return (ch : ls)
-
--- unpack 'len' chars
-unpackCStringLenIO :: Addr -> Int -> IO String
-unpackCStringLenIO addr l@(I# len#)
- | len# <# 0# = ioError (userError ("CString.unpackCStringLenIO: negative length (" ++ show l ++ ")"))
- | len# ==# 0# = return ""
- | otherwise = unpack [] (len# -# 1#)
- where
- unpack acc 0# = do
- ch <- readCharOffAddr addr (I# 0#)
- return (ch:acc)
- unpack acc nh = do
- ch <- readCharOffAddr addr (I# nh)
- unpack (ch:acc) (nh -# 1#)
-
-unpackNBytesIO :: Addr -> Int -> IO [Char]
-unpackNBytesIO a l = stToIO (unpackNBytesST a l)
-
-unpackNBytesAccIO :: Addr -> Int -> [Char] -> IO [Char]
-unpackNBytesAccIO a l acc = stToIO (unpackNBytesAccST a l acc)
-
-unpackNBytesBAIO :: ByteArray Int -> Int -> IO [Char]
-unpackNBytesBAIO ba l = unpackNBytesAccBAIO ba l []
-
--- note: no bounds checking!
-unpackNBytesAccBAIO :: ByteArray Int -> Int -> [Char] -> IO [Char]
-unpackNBytesAccBAIO _ 0 rest = return rest
-unpackNBytesAccBAIO (ByteArray _ _ ba) (I# len#) rest = unpack rest (len# -# 1#)
- where
- unpack acc i#
- | i# <# 0# = return acc
- | otherwise =
- case indexCharArray# ba i# of
- ch -> unpack (C# ch : acc) (i# -# 1#)
-
-\end{code}
-
-Turn a NULL-terminated vector of null-terminated strings into a string list
-(ToDo: create a module of common marshaling functions)
-
-\begin{code}
-unvectorize :: Addr -> Int -> IO [String]
-unvectorize ptr n
- | str == nullAddr = return []
- | otherwise = do
- x <- unpackCStringIO str
- xs <- unvectorize ptr (n+1)
- return (x : xs)
- where
- str = indexAddrOffAddr ptr n
-
-\end{code}
-
- Turn a string list into a NULL-terminated vector of null-terminated
-strings No indices...I hate indices. Death to Ix.
-
-\begin{code}
-vectorize :: [String] -> IO (ByteArray Int)
-vectorize vs = do
- arr <- allocWords (len + 1)
- fill arr 0 vs
- freeze arr
- where
- len :: Int
- len = length vs
-
- fill :: MutableByteArray RealWorld Int -> Int -> [String] -> IO ()
- fill arr n [] =
- _casm_ ``((PP_)%0)[%1] = NULL;'' arr n
- fill arr n (x:xs) = do
- barr <- packStringIO x
- _casm_ ``((PP_)%0)[%1] = (P_)%2;'' arr n barr
- fill arr (n+1) xs
-
-\end{code}
-
-Allocating chunks of memory in the Haskell heap, leaving
-out the bounds - use with care.
-
-\begin{code}
--- Allocate a mutable array of characters with no indices.
-allocChars :: Int -> IO (MutableByteArray RealWorld Int)
-allocChars size = stToIO (newCharArray (0,size))
-
-allocWords :: Int -> IO (MutableByteArray RealWorld Int)
-allocWords size = stToIO (newIntArray (0,size))
-
--- Freeze these index-free mutable arrays
-freeze :: MutableByteArray RealWorld Int -> IO (ByteArray Int)
-freeze mb = stToIO (unsafeFreezeByteArray mb)
-
--- Copy a null-terminated string from outside the heap to
--- Haskellized nonsense inside the heap
-strcpy :: Addr -> IO String
-strcpy str = unpackCStringIO str
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[CharSeq]{Characters sequences: the @CSeq@ type}
-
-\begin{code}
-#if defined(COMPILING_GHC)
-# include "HsVersions.h"
-#else
-# define FAST_STRING String
-# define FAST_INT Int
-# define ILIT(x) (x)
-# define IBOX(x) (x)
-# define _GE_ >=
-# define _ADD_ +
-# define _SUB_ -
-# define FAST_BOOL Bool
-# define _TRUE_ True
-# define _FALSE_ False
-#endif
-
-module CharSeq (
- CSeq,
- cNil, cAppend, cIndent, cNL, cStr, cPStr, cCh, cInt,
-#if ! defined(COMPILING_GHC)
- cLength,
- cShows,
-#endif
- cShow
-
-#if ! defined(COMPILING_GHC)
- ) where
-#else
- , cPutStr
- ) where
-
-CHK_Ubiq() -- debugging consistency check
-IMPORT_1_3(IO)
-
-#endif
-\end{code}
-
-%************************************************
-%* *
- \subsection{The interface}
-%* *
-%************************************************
-
-\begin{code}
-cShow :: CSeq -> [Char]
-
-#if ! defined(COMPILING_GHC)
--- not used in GHC
-cShows :: CSeq -> ShowS
-cLength :: CSeq -> Int
-#endif
-
-cNil :: CSeq
-cAppend :: CSeq -> CSeq -> CSeq
-cIndent :: Int -> CSeq -> CSeq
-cNL :: CSeq
-cStr :: [Char] -> CSeq
-cPStr :: FAST_STRING -> CSeq
-cCh :: Char -> CSeq
-cInt :: Int -> CSeq
-
-#if defined(COMPILING_GHC)
-cPutStr :: Handle -> CSeq -> IO ()
-#endif
-\end{code}
-
-%************************************************
-%* *
- \subsection{The representation}
-%* *
-%************************************************
-
-\begin{code}
-data CSeq
- = CNil
- | CAppend CSeq CSeq
- | CIndent Int CSeq
- | CNewline -- Move to start of next line, unless we're
- -- already at the start of a line.
- | CStr [Char]
- | CCh Char
- | CInt Int -- equiv to "CStr (show the_int)"
-#if defined(COMPILING_GHC)
- | CPStr FAST_STRING
-#endif
-\end{code}
-
-The construction functions do pattern matching, to ensure that
-redundant CNils are eliminated. This is bound to have some effect on
-evaluation order, but quite what I don't know.
-
-\begin{code}
-cNil = CNil
-\end{code}
-
-The following special cases were eating our lunch! They make the whole
-thing too strict. A classic strictness bug!
-\begin{code}
--- cAppend CNil cs2 = cs2
--- cAppend cs1 CNil = cs1
-
-cAppend cs1 cs2 = CAppend cs1 cs2
-
-cIndent n cs = CIndent n cs
-
-cNL = CNewline
-cStr = CStr
-cCh = CCh
-cInt = CInt
-
-#if defined(COMPILING_GHC)
-cPStr = CPStr
-#else
-cPStr = CStr
-#endif
-
-cShow seq = flatten ILIT(0) _TRUE_ seq []
-
-#if ! defined(COMPILING_GHC)
-cShows seq rest = cShow seq ++ rest
-cLength seq = length (cShow seq) -- *not* the best way to do this!
-#endif
-\end{code}
-
-This code is {\em hammered}. We are not above doing sleazy
-non-standard things. (WDP 94/10)
-
-\begin{code}
-data WorkItem = WI FAST_INT CSeq -- indentation, and sequence
-
-flatten :: FAST_INT -- Indentation
- -> FAST_BOOL -- True => just had a newline
- -> CSeq -- Current seq to flatten
- -> [WorkItem] -- Work list with indentation
- -> String
-
-flatten _ nlp CNil seqs = flattenS nlp seqs
-
-flatten n nlp (CAppend seq1 seq2) seqs = flatten n nlp seq1 ((WI n seq2) : seqs)
-flatten n nlp (CIndent IBOX(n2) seq) seqs = flatten (n2 _ADD_ n) nlp seq seqs
-
-flatten _ _FALSE_ CNewline seqs = '\n' : flattenS _TRUE_ seqs
-flatten _ _TRUE_ CNewline seqs = flattenS _TRUE_ seqs -- Already at start of line
-
-flatten _ _FALSE_ (CStr s) seqs = s ++ flattenS _FALSE_ seqs
-flatten _ _FALSE_ (CCh c) seqs = c : flattenS _FALSE_ seqs
-flatten _ _FALSE_ (CInt i) seqs = show i ++ flattenS _FALSE_ seqs
-#if defined(COMPILING_GHC)
-flatten n _FALSE_ (CPStr s) seqs = _UNPK_ s ++ flattenS _FALSE_ seqs
-#endif
-
-flatten n _TRUE_ (CStr s) seqs = mkIndent n (s ++ flattenS _FALSE_ seqs)
-flatten n _TRUE_ (CCh c) seqs = mkIndent n (c : flattenS _FALSE_ seqs)
-flatten n _TRUE_ (CInt i) seqs = mkIndent n (show i ++ flattenS _FALSE_ seqs)
-#if defined(COMPILING_GHC)
-flatten n _TRUE_ (CPStr s) seqs = mkIndent n ( _UNPK_ s ++ flattenS _FALSE_ seqs)
-#endif
-\end{code}
-
-\begin{code}
-flattenS :: FAST_BOOL -> [WorkItem] -> String
-flattenS _ [] = ""
-flattenS nlp ((WI col seq):seqs) = flatten col nlp seq seqs
-\end{code}
-
-\begin{code}
-mkIndent :: FAST_INT -> String -> String
-mkIndent ILIT(0) s = s
-mkIndent n s
- = if (n _GE_ ILIT(8))
- then '\t' : mkIndent (n _SUB_ ILIT(8)) s
- else ' ' : mkIndent (n _SUB_ ILIT(1)) s
- -- Hmm.. a little Unix-y.
-\end{code}
-
-Now the I/O version.
-This code is massively {\em hammered}.
-It {\em ignores} indentation.
-
-(NB: 1.3 compiler: efficiency hacks removed for now!)
-
-\begin{code}
-#if defined(COMPILING_GHC)
-
-cPutStr handle sq = flat sq
- where
- flat CNil = return ()
- flat (CIndent n2 seq) = flat seq
- flat (CAppend s1 s2) = flat s1 >> flat s2
- flat CNewline = hPutChar handle '\n'
- flat (CCh c) = hPutChar handle c
- flat (CInt i) = hPutStr handle (show i)
- flat (CStr s) = hPutStr handle s
- flat (CPStr s) = hPutStr handle (_UNPK_ s)
-
-#endif {- COMPILING_GHC -}
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1996
-%
-\section[FiniteMap]{An implementation of finite maps}
-
-``Finite maps'' are the heart of the compiler's
-lookup-tables/environments and its implementation of sets. Important
-stuff!
-
-This code is derived from that in the paper:
-\begin{display}
- S Adams
- "Efficient sets: a balancing act"
- Journal of functional programming 3(4) Oct 1993, pp553-562
-\end{display}
-
-The code is SPECIALIZEd to various highly-desirable types (e.g., Id)
-near the end (only \tr{#ifdef COMPILING_GHC}).
-
-\begin{code}
-#ifdef COMPILING_GHC
-#include "HsVersions.h"
-#define IF_NOT_GHC(a) {--}
-#else
-#define ASSERT(e) {--}
-#define IF_NOT_GHC(a) a
-#define COMMA ,
-#define _tagCmp compare
-#define _LT LT
-#define _GT GT
-#define _EQ EQ
-#endif
-
-#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)/* NB NB NB */
-#define OUTPUTABLE_key , Outputable key
-#else
-#define OUTPUTABLE_key {--}
-#endif
-
-module FiniteMap (
- FiniteMap, -- abstract type
-
- emptyFM, unitFM, listToFM,
-
- addToFM,
- addToFM_C,
- addListToFM,
- addListToFM_C,
- IF_NOT_GHC(delFromFM COMMA)
- delListFromFM,
-
- plusFM,
- plusFM_C,
- minusFM,
- foldFM,
-
- IF_NOT_GHC(intersectFM COMMA)
- IF_NOT_GHC(intersectFM_C COMMA)
- IF_NOT_GHC(mapFM COMMA filterFM COMMA)
-
- sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
-
- fmToList, keysFM, eltsFM
-
-#ifdef COMPILING_GHC
- , bagToFM
- , SYN_IE(FiniteSet), emptySet, mkSet, isEmptySet
- , elementOf, setToList, union, minusSet
-#endif
- ) where
-
-import PrelBase
-import Maybes
-#ifdef COMPILING_GHC
-IMP_Ubiq(){-uitous-}
-# ifdef DEBUG
-import Pretty
-# endif
-import Bag ( foldBag )
-
-# if ! OMIT_NATIVE_CODEGEN
-# define IF_NCG(a) a
-# else
-# define IF_NCG(a) {--}
-# endif
-#endif
-
--- SIGH: but we use unboxed "sizes"...
-#if __GLASGOW_HASKELL__
-#define IF_GHC(a,b) a
-#else /* not GHC */
-#define IF_GHC(a,b) b
-#endif /* not GHC */
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The signature of the module}
-%* *
-%************************************************************************
-
-\begin{code}
--- BUILDING
-emptyFM :: FiniteMap key elt
-unitFM :: key -> elt -> FiniteMap key elt
-listToFM :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt
- -- In the case of duplicates, the last is taken
-#ifdef COMPILING_GHC
-bagToFM :: (Ord key OUTPUTABLE_key) => Bag (key,elt) -> FiniteMap key elt
- -- In the case of duplicates, who knows which is taken
-#endif
-
--- ADDING AND DELETING
- -- Throws away any previous binding
- -- In the list case, the items are added starting with the
- -- first one in the list
-addToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> elt -> FiniteMap key elt
-addListToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt
-
- -- Combines with previous binding
- -- In the combining function, the first argument is the "old" element,
- -- while the second is the "new" one.
-addToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> key -> elt
- -> FiniteMap key elt
-addListToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> [(key,elt)]
- -> FiniteMap key elt
-
- -- Deletion doesn't complain if you try to delete something
- -- which isn't there
-delFromFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt
-delListFromFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [key] -> FiniteMap key elt
-
--- COMBINING
- -- Bindings in right argument shadow those in the left
-plusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
- -- Combines bindings for the same thing with the given function
-plusFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-
-minusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
- -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
-
-intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-
--- MAPPING, FOLDING, FILTERING
-foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
-mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2
-filterFM :: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool)
- -> FiniteMap key elt -> FiniteMap key elt
-
--- INTERROGATING
-sizeFM :: FiniteMap key elt -> Int
-isEmptyFM :: FiniteMap key elt -> Bool
-
-elemFM :: (Ord key OUTPUTABLE_key) => key -> FiniteMap key elt -> Bool
-lookupFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> Maybe elt
-lookupWithDefaultFM
- :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> elt -> key -> elt
- -- lookupWithDefaultFM supplies a "default" elt
- -- to return for an unmapped key
-
--- LISTIFYING
-fmToList :: FiniteMap key elt -> [(key,elt)]
-keysFM :: FiniteMap key elt -> [key]
-eltsFM :: FiniteMap key elt -> [elt]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @FiniteMap@ data type, and building of same}
-%* *
-%************************************************************************
-
-Invariants about @FiniteMap@:
-\begin{enumerate}
-\item
-all keys in a FiniteMap are distinct
-\item
-all keys in left subtree are $<$ key in Branch and
-all keys in right subtree are $>$ key in Branch
-\item
-size field of a Branch gives number of Branch nodes in the tree
-\item
-size of left subtree is differs from size of right subtree by a
-factor of at most \tr{sIZE_RATIO}
-\end{enumerate}
-
-\begin{code}
-data FiniteMap key elt
- = EmptyFM
- | Branch key elt -- Key and elt stored here
- IF_GHC(Int#,Int{-STRICT-}) -- Size >= 1
- (FiniteMap key elt) -- Children
- (FiniteMap key elt)
-\end{code}
-
-\begin{code}
-emptyFM = EmptyFM
-{-
-emptyFM
- = Branch bottom bottom IF_GHC(0#,0) bottom bottom
- where
- bottom = panic "emptyFM"
--}
-
--- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _)
-
-unitFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM
-
-listToFM = addListToFM emptyFM
-
-#ifdef COMPILING_GHC
-bagToFM = foldBag plusFM (\ (k,v) -> unitFM k v) emptyFM
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Adding to and deleting from @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt
-
-addToFM_C combiner EmptyFM key elt = unitFM key elt
-addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp new_key key of
- _LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
- _GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
- _EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r
-#else
- | new_key < key = mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
- | new_key > key = mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
- | otherwise = Branch new_key (combiner elt new_elt) size fm_l fm_r
-#endif
-
-addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs
-
-addListToFM_C combiner fm key_elt_pairs
- = foldl add fm key_elt_pairs -- foldl adds from the left
- where
- add fmap (key,elt) = addToFM_C combiner fmap key elt
-\end{code}
-
-\begin{code}
-delFromFM EmptyFM del_key = emptyFM
-delFromFM (Branch key elt size fm_l fm_r) del_key
-#if __GLASGOW_HASKELL__
- = case _tagCmp del_key key of
- _GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
- _LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
- _EQ -> glueBal fm_l fm_r
-#else
- | del_key > key
- = mkBalBranch key elt fm_l (delFromFM fm_r del_key)
-
- | del_key < key
- = mkBalBranch key elt (delFromFM fm_l del_key) fm_r
-
- | key == del_key
- = glueBal fm_l fm_r
-#endif
-
-delListFromFM fm keys = foldl delFromFM fm keys
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Combining @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-plusFM_C combiner EmptyFM fm2 = fm2
-plusFM_C combiner fm1 EmptyFM = fm1
-plusFM_C combiner fm1 (Branch split_key elt2 _ left right)
- = mkVBalBranch split_key new_elt
- (plusFM_C combiner lts left)
- (plusFM_C combiner gts right)
- where
- lts = splitLT fm1 split_key
- gts = splitGT fm1 split_key
- new_elt = case lookupFM fm1 split_key of
- Nothing -> elt2
- Just elt1 -> combiner elt1 elt2
-
--- It's worth doing plusFM specially, because we don't need
--- to do the lookup in fm1.
-
-plusFM EmptyFM fm2 = fm2
-plusFM fm1 EmptyFM = fm1
-plusFM fm1 (Branch split_key elt1 _ left right)
- = mkVBalBranch split_key elt1 (plusFM lts left) (plusFM gts right)
- where
- lts = splitLT fm1 split_key
- gts = splitGT fm1 split_key
-
-minusFM EmptyFM fm2 = emptyFM
-minusFM fm1 EmptyFM = fm1
-minusFM fm1 (Branch split_key elt _ left right)
- = glueVBal (minusFM lts left) (minusFM gts right)
- -- The two can be way different, so we need glueVBal
- where
- lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones
- gts = splitGT fm1 split_key -- are not in either.
-
-intersectFM fm1 fm2 = intersectFM_C (\ left right -> right) fm1 fm2
-
-intersectFM_C combiner fm1 EmptyFM = emptyFM
-intersectFM_C combiner EmptyFM fm2 = emptyFM
-intersectFM_C combiner fm1 (Branch split_key elt2 _ left right)
-
- | maybeToBool maybe_elt1 -- split_elt *is* in intersection
- = mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left)
- (intersectFM_C combiner gts right)
-
- | otherwise -- split_elt is *not* in intersection
- = glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right)
-
- where
- lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones
- gts = splitGT fm1 split_key -- are not in either.
-
- maybe_elt1 = lookupFM fm1 split_key
- Just elt1 = maybe_elt1
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Mapping, folding, and filtering with @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-foldFM k z EmptyFM = z
-foldFM k z (Branch key elt _ fm_l fm_r)
- = foldFM k (k key elt (foldFM k z fm_r)) fm_l
-
-mapFM f EmptyFM = emptyFM
-mapFM f (Branch key elt size fm_l fm_r)
- = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r)
-
-filterFM p EmptyFM = emptyFM
-filterFM p (Branch key elt _ fm_l fm_r)
- | p key elt -- Keep the item
- = mkVBalBranch key elt (filterFM p fm_l) (filterFM p fm_r)
-
- | otherwise -- Drop the item
- = glueVBal (filterFM p fm_l) (filterFM p fm_r)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Interrogating @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
---{-# INLINE sizeFM #-}
-sizeFM EmptyFM = 0
-sizeFM (Branch _ _ size _ _) = IF_GHC(I# size, size)
-
-isEmptyFM fm = sizeFM fm == 0
-
-lookupFM EmptyFM key = Nothing
-lookupFM (Branch key elt _ fm_l fm_r) key_to_find
-#if __GLASGOW_HASKELL__
- = case _tagCmp key_to_find key of
- _LT -> lookupFM fm_l key_to_find
- _GT -> lookupFM fm_r key_to_find
- _EQ -> Just elt
-#else
- | key_to_find < key = lookupFM fm_l key_to_find
- | key_to_find > key = lookupFM fm_r key_to_find
- | otherwise = Just elt
-#endif
-
-key `elemFM` fm
- = case (lookupFM fm key) of { Nothing -> False; Just elt -> True }
-
-lookupWithDefaultFM fm deflt key
- = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Listifying @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm
-keysFM fm = foldFM (\ key elt rest -> key : rest) [] fm
-eltsFM fm = foldFM (\ key elt rest -> elt : rest) [] fm
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The implementation of balancing}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection{Basic construction of a @FiniteMap@}
-%* *
-%************************************************************************
-
-@mkBranch@ simply gets the size component right. This is the ONLY
-(non-trivial) place the Branch object is built, so the ASSERTion
-recursively checks consistency. (The trivial use of Branch is in
-@unitFM@.)
-
-\begin{code}
-sIZE_RATIO :: Int
-sIZE_RATIO = 5
-
-mkBranch :: (Ord key OUTPUTABLE_key) -- Used for the assertion checking only
- => Int
- -> key -> elt
- -> FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-mkBranch which key elt fm_l fm_r
- = --ASSERT( left_ok && right_ok && balance_ok )
-#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)
- if not ( left_ok && right_ok && balance_ok ) then
- pprPanic ("mkBranch:"++show which) (ppAboves [ppr PprDebug [left_ok, right_ok, balance_ok],
- ppr PprDebug key,
- ppr PprDebug fm_l,
- ppr PprDebug fm_r])
- else
-#endif
- let
- result = Branch key elt (unbox (1 + left_size + right_size)) fm_l fm_r
- in
--- if sizeFM result <= 8 then
- result
--- else
--- pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) (
--- result
--- )
- where
- left_ok = case fm_l of
- EmptyFM -> True
- Branch left_key _ _ _ _ -> let
- biggest_left_key = fst (findMax fm_l)
- in
- biggest_left_key < key
- right_ok = case fm_r of
- EmptyFM -> True
- Branch right_key _ _ _ _ -> let
- smallest_right_key = fst (findMin fm_r)
- in
- key < smallest_right_key
- balance_ok = True -- sigh
-{- LATER:
- balance_ok
- = -- Both subtrees have one or no elements...
- (left_size + right_size <= 1)
--- NO || left_size == 0 -- ???
--- NO || right_size == 0 -- ???
- -- ... or the number of elements in a subtree does not exceed
- -- sIZE_RATIO times the number of elements in the other subtree
- || (left_size * sIZE_RATIO >= right_size &&
- right_size * sIZE_RATIO >= left_size)
--}
-
- left_size = sizeFM fm_l
- right_size = sizeFM fm_r
-
-#if __GLASGOW_HASKELL__
- unbox :: Int -> Int#
- unbox (I# size) = size
-#else
- unbox :: Int -> Int
- unbox x = x
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{{\em Balanced} construction of a @FiniteMap@}
-%* *
-%************************************************************************
-
-@mkBalBranch@ rebalances, assuming that the subtrees aren't too far
-out of whack.
-
-\begin{code}
-mkBalBranch :: (Ord key OUTPUTABLE_key)
- => key -> elt
- -> FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-mkBalBranch key elt fm_L fm_R
-
- | size_l + size_r < 2
- = mkBranch 1{-which-} key elt fm_L fm_R
-
- | size_r > sIZE_RATIO * size_l -- Right tree too big
- = case fm_R of
- Branch _ _ _ fm_rl fm_rr
- | sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R
- | otherwise -> double_L fm_L fm_R
- -- Other case impossible
-
- | size_l > sIZE_RATIO * size_r -- Left tree too big
- = case fm_L of
- Branch _ _ _ fm_ll fm_lr
- | sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R
- | otherwise -> double_R fm_L fm_R
- -- Other case impossible
-
- | otherwise -- No imbalance
- = mkBranch 2{-which-} key elt fm_L fm_R
-
- where
- size_l = sizeFM fm_L
- size_r = sizeFM fm_R
-
- single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)
- = mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr
-
- double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr)
- = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key elt fm_l fm_rll)
- (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)
-
- single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r
- = mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r)
-
- double_R (Branch key_l elt_l _ fm_ll (Branch key_lr elt_lr _ fm_lrl fm_lrr)) fm_r
- = mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll fm_lrl)
- (mkBranch 12{-which-} key elt fm_lrr fm_r)
-\end{code}
-
-
-\begin{code}
-mkVBalBranch :: (Ord key OUTPUTABLE_key)
- => key -> elt
- -> FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
--- Assert: in any call to (mkVBalBranch_C comb key elt l r),
--- (a) all keys in l are < all keys in r
--- (b) all keys in l are < key
--- (c) all keys in r are > key
-
-mkVBalBranch key elt EmptyFM fm_r = addToFM fm_r key elt
-mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt
-
-mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
- fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
- | sIZE_RATIO * size_l < size_r
- = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr
-
- | sIZE_RATIO * size_r < size_l
- = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r)
-
- | otherwise
- = mkBranch 13{-which-} key elt fm_l fm_r
-
- where
- size_l = sizeFM fm_l
- size_r = sizeFM fm_r
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Gluing two trees together}
-%* *
-%************************************************************************
-
-@glueBal@ assumes its two arguments aren't too far out of whack, just
-like @mkBalBranch@. But: all keys in first arg are $<$ all keys in
-second.
-
-\begin{code}
-glueBal :: (Ord key OUTPUTABLE_key)
- => FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-glueBal EmptyFM fm2 = fm2
-glueBal fm1 EmptyFM = fm1
-glueBal fm1 fm2
- -- The case analysis here (absent in Adams' program) is really to deal
- -- with the case where fm2 is a singleton. Then deleting the minimum means
- -- we pass an empty tree to mkBalBranch, which breaks its invariant.
- | sizeFM fm2 > sizeFM fm1
- = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)
-
- | otherwise
- = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2
- where
- (mid_key1, mid_elt1) = findMax fm1
- (mid_key2, mid_elt2) = findMin fm2
-\end{code}
-
-@glueVBal@ copes with arguments which can be of any size.
-But: all keys in first arg are $<$ all keys in second.
-
-\begin{code}
-glueVBal :: (Ord key OUTPUTABLE_key)
- => FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-glueVBal EmptyFM fm2 = fm2
-glueVBal fm1 EmptyFM = fm1
-glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
- fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
- | sIZE_RATIO * size_l < size_r
- = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr
-
- | sIZE_RATIO * size_r < size_l
- = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r)
-
- | otherwise -- We now need the same two cases as in glueBal above.
- = glueBal fm_l fm_r
- where
- size_l = sizeFM fm_l
- size_r = sizeFM fm_r
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Local utilities}
-%* *
-%************************************************************************
-
-\begin{code}
-splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt
-
--- splitLT fm split_key = fm restricted to keys < split_key
--- splitGT fm split_key = fm restricted to keys > split_key
-
-splitLT EmptyFM split_key = emptyFM
-splitLT (Branch key elt _ fm_l fm_r) split_key
-#if __GLASGOW_HASKELL__
- = case _tagCmp split_key key of
- _LT -> splitLT fm_l split_key
- _GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
- _EQ -> fm_l
-#else
- | split_key < key = splitLT fm_l split_key
- | split_key > key = mkVBalBranch key elt fm_l (splitLT fm_r split_key)
- | otherwise = fm_l
-#endif
-
-splitGT EmptyFM split_key = emptyFM
-splitGT (Branch key elt _ fm_l fm_r) split_key
-#if __GLASGOW_HASKELL__
- = case _tagCmp split_key key of
- _GT -> splitGT fm_r split_key
- _LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
- _EQ -> fm_r
-#else
- | split_key > key = splitGT fm_r split_key
- | split_key < key = mkVBalBranch key elt (splitGT fm_l split_key) fm_r
- | otherwise = fm_r
-#endif
-
-findMin :: FiniteMap key elt -> (key,elt)
-findMin (Branch key elt _ EmptyFM _) = (key,elt)
-findMin (Branch key elt _ fm_l _) = findMin fm_l
-
-deleteMin :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
-deleteMin (Branch key elt _ EmptyFM fm_r) = fm_r
-deleteMin (Branch key elt _ fm_l fm_r) = mkBalBranch key elt (deleteMin fm_l) fm_r
-
-findMax :: FiniteMap key elt -> (key,elt)
-findMax (Branch key elt _ _ EmptyFM) = (key,elt)
-findMax (Branch key elt _ _ fm_r) = findMax fm_r
-
-deleteMax :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
-deleteMax (Branch key elt _ fm_l EmptyFM) = fm_l
-deleteMax (Branch key elt _ fm_l fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Output-ery}
-%* *
-%************************************************************************
-
-\begin{code}
-#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)
-
-instance (Outputable key) => Outputable (FiniteMap key elt) where
- ppr sty fm = pprX sty fm
-
-pprX sty EmptyFM = ppChar '!'
-pprX sty (Branch key elt sz fm_l fm_r)
- = ppBesides [ppLparen, pprX sty fm_l, ppSP,
- ppr sty key, ppSP, ppInt (IF_GHC(I# sz, sz)), ppSP,
- pprX sty fm_r, ppRparen]
-#endif
-
-#ifndef COMPILING_GHC
-instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
- fm_1 == fm_2 = (sizeFM fm_1 == sizeFM fm_2) && -- quick test
- (fmToList fm_1 == fmToList fm_2)
-
-{- NO: not clear what The Right Thing to do is:
-instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
- fm_1 <= fm_2 = (sizeFM fm_1 <= sizeFM fm_2) && -- quick test
- (fmToList fm_1 <= fmToList fm_2)
--}
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{FiniteSets---a thin veneer}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef COMPILING_GHC
-
-type FiniteSet key = FiniteMap key ()
-emptySet :: FiniteSet key
-mkSet :: (Ord key OUTPUTABLE_key) => [key] -> FiniteSet key
-isEmptySet :: FiniteSet key -> Bool
-elementOf :: (Ord key OUTPUTABLE_key) => key -> FiniteSet key -> Bool
-minusSet :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key
-setToList :: FiniteSet key -> [key]
-union :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key
-
-emptySet = emptyFM
-mkSet xs = listToFM [ (x, ()) | x <- xs]
-isEmptySet = isEmptyFM
-elementOf = elemFM
-minusSet = minusFM
-setToList = keysFM
-union = plusFM
-
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Efficiency pragmas for GHC}
-%* *
-%************************************************************************
-
-When the FiniteMap module is used in GHC, we specialise it for
-\tr{Uniques}, for dastardly efficiency reasons.
-
-\begin{code}
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ && !defined(REALLY_HASKELL_1_3)
-
-{-# SPECIALIZE addListToFM
- :: FiniteMap (FAST_STRING, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
- , FiniteMap RdrName elt -> [(RdrName,elt)] -> FiniteMap RdrName elt
- IF_NCG(COMMA FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE addListToFM_C
- :: (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt
- , (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE addToFM
- :: FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt
- , FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
- , FiniteMap (FAST_STRING, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt
- , FiniteMap RdrName elt -> RdrName -> elt -> FiniteMap RdrName elt
- , FiniteMap OrigName elt -> OrigName -> elt -> FiniteMap OrigName elt
- IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE addToFM_C
- :: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt
- , (elt -> elt -> elt) -> FiniteMap (OrigName, OrigName) elt -> (OrigName, OrigName) -> elt -> FiniteMap (OrigName, OrigName) elt
- , (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE bagToFM
- :: Bag (FAST_STRING,elt) -> FiniteMap FAST_STRING elt
- #-}
-{-# SPECIALIZE delListFromFM
- :: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt
- , FiniteMap OrigName elt -> [OrigName] -> FiniteMap OrigName elt
- , FiniteMap FAST_STRING elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt
- IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE listToFM
- :: [([Char],elt)] -> FiniteMap [Char] elt
- , [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt
- , [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
- , [(OrigName,elt)] -> FiniteMap OrigName elt
- IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE lookupFM
- :: FiniteMap CLabel elt -> CLabel -> Maybe elt
- , FiniteMap [Char] elt -> [Char] -> Maybe elt
- , FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt
- , FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt
- , FiniteMap OrigName elt -> OrigName -> Maybe elt
- , FiniteMap (OrigName,OrigName) elt -> (OrigName,OrigName) -> Maybe elt
- , FiniteMap RdrName elt -> RdrName -> Maybe elt
- , FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt
- IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt)
- #-}
-{-# SPECIALIZE lookupWithDefaultFM
- :: FiniteMap FAST_STRING elt -> elt -> FAST_STRING -> elt
- IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt)
- #-}
-{-# SPECIALIZE plusFM
- :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt
- , FiniteMap OrigName elt -> FiniteMap OrigName elt -> FiniteMap OrigName elt
- , FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
- IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE plusFM_C
- :: (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
-
-#endif {- compiling for GHC -}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[ListSetOps]{Set-like operations on lists}
-
-\begin{code}
-#ifdef COMPILING_GHC
-#include "HsVersions.h"
-#endif
-
-module ListSetOps (
- unionLists,
- intersectLists,
- minusList
-#ifndef COMPILING_GHC
- , disjointLists, intersectingLists
-#endif
- ) where
-
-#if defined(COMPILING_GHC)
-IMP_Ubiq(){-uitous-}
-
-import Util ( isIn, isn'tIn )
-#endif
-\end{code}
-
-\begin{code}
-unionLists :: (Eq a) => [a] -> [a] -> [a]
-unionLists [] [] = []
-unionLists [] b = b
-unionLists a [] = a
-unionLists (a:as) b
- | a `is_elem` b = unionLists as b
- | otherwise = a : unionLists as b
- where
-#if defined(COMPILING_GHC)
- is_elem = isIn "unionLists"
-#else
- is_elem = elem
-#endif
-
-intersectLists :: (Eq a) => [a] -> [a] -> [a]
-intersectLists [] [] = []
-intersectLists [] _ = []
-intersectLists _ [] = []
-intersectLists (a:as) b
- | a `is_elem` b = a : intersectLists as b
- | otherwise = intersectLists as b
- where
-#if defined(COMPILING_GHC)
- is_elem = isIn "intersectLists"
-#else
- is_elem = elem
-#endif
-\end{code}
-
-Everything in the first list that is not in the second list:
-\begin{code}
-minusList :: (Eq a) => [a] -> [a] -> [a]
-minusList xs ys = [ x | x <- xs, x `not_elem` ys]
- where
-#if defined(COMPILING_GHC)
- not_elem = isn'tIn "minusList"
-#else
- not_elem = notElem
-#endif
-\end{code}
-
-\begin{code}
-#if ! defined(COMPILING_GHC)
-
-disjointLists, intersectingLists :: Eq a => [a] -> [a] -> Bool
-
-disjointLists [] _ = True
-disjointLists (a:as) bs
- | a `elem` bs = False
- | otherwise = disjointLists as bs
-
-intersectingLists xs ys = not (disjointLists xs ys)
-#endif
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\section[md5]{MD5: Message-digest}
-
-This module provides basic MD5 support for Haskell, using
-Colin Plumb's C implementation of MD5 to do the Hard Work.
-
-\begin{code}
-{-# OPTIONS -#include "cbits/md5.h" #-}
-module MD5
- (
- digest -- :: String -> IO String
- , digestPS -- :: PackedString -> IO (ByteArray Int)
- ) where
-
-
-import GlaExts
-import Addr
-import PackedString
-
-\end{code}
-
-\begin{code}
-digest :: String -> IO String
-digest str = do
- ps <- stToIO (packStringST str)
- ba <- digestPS ps
- let (ByteArray _ _ ba#) = ba
- baToString ba# 16# 0#
- where
- baToString ba# n# i#
- | n# ==# 0# = return []
- | otherwise = do
- let ch# = indexCharArray# ba# i#
- ls <- baToString ba# (n# -# 1#) (i# +# 1#)
- return ((C# ch#):ls)
-
-digestPS :: PackedString -> IO (ByteArray Int)
-digestPS ps = do
- ctxt <- stToIO (newCharArray (0::Int,``sizeof(struct MD5Context)''::Int))
- let len = lengthPS ps
- _ccall_ MD5Init ctxt
- (if isCString ps
- then _ccall_ MD5Update ctxt (psToCString ps) len
- else _ccall_ MD5Update ctxt (psToByteArray ps) len)
- dig <- stToIO (newCharArray (0::Int,16*(``sizeof(unsigned char)''::Int)))
- _ccall_ MD5Final dig ctxt
- stToIO (unsafeFreezeByteArray dig)
-
-\end{code}
+++ /dev/null
-# $Id: Makefile,v 1.20 1999/10/29 13:57:52 sof Exp $
-#
-# Makefile for miscellaneous libraries.
-#
-
-TOP = ../..
-include $(TOP)/mk/boilerplate.mk
-
-WAYS=$(GhcLibWays)
-
-ifeq "$(way)" ""
-SUBDIRS = cbits
-else
-SUBDIRS=
-endif
-
-HC = $(GHC)
-
-#-----------------------------------------------------------------------------
-# Setting the standard variables
-#
-
-LIBRARY = libHSmisc$(_way).a
-
-ifeq "$(EnableWin32DLLs)" "YES"
- HS_SRCS := $(filter-out Select.lhs,$(HS_SRCS))
-endif
-
-# Remove Readline.lhs if readline.h isn't available.
-ifneq "$(GhcLibsWithReadline)" "YES"
- HS_SRCS := $(filter-out Readline.lhs,$(HS_SRCS))
-else
- ifneq "$(ReadlineIncludePath)" ""
- SRC_HC_OPTS += -I$(ReadlineIncludePath)
- endif
-endif
-
-HS_OBJS = $(HS_SRCS:.lhs=.$(way_)o)
-LIBOBJS = $(HS_OBJS)
-HS_IFACES= $(HS_SRCS:.lhs=.$(way_)hi)
-SRC_MKDEPENDHS_OPTS += -optdep--include-prelude
-
-#-----------------------------------------------------------------------------
-# Setting the GHC compile options
-
-SRC_HC_OPTS += -i../concurrent:../posix -recomp -cpp -fglasgow-exts -fvia-C -Rghc-timing $(GhcLibHcOpts)
-
-#
-# Profiling options
-# (what's this stuff doing here?)
-WAY_p_HC_OPTS += -GPrelude
-WAY_mr_HC_OPTS += -GPrelude
-
-#
-# Object and interface files have suffixes tagged with their ways
-#
-ifneq "$(way)" ""
-SRC_HC_OPTS += -hisuf $(way_)hi
-endif
-
-ifneq "$(way)" "dll"
-SRC_HC_OPTS += -static
-endif
-
-#
-# Specific flags
-#
-
-BSD_HC_OPTS += -I../std/cbits -H8m -optc-DNON_POSIX_SOURCE
-Socket_HC_OPTS += -I../std/cbits -optc-DNON_POSIX_SOURCE
-SocketPrim_HC_OPTS += -I../std/cbits -H12m -optc-DNON_POSIX_SOURCE
-PackedString_HC_OPTS += -H12m
-Native_HC_OPTS += -H8m
-Pretty_HC_OPTS += -H8m
-
-#-----------------------------------------------------------------------------
-# Dependency generation
-
-SRC_MKDEPENDHS_OPTS += -I$(GHC_INCLUDE_DIR)
-
-#-----------------------------------------------------------------------------
-# Win32 DLL setup
-
-DLL_NAME = HSmisc.dll
-DLL_IMPLIB_NAME = libHSmisc_imp.a
-SRC_BLD_DLL_OPTS += --export-all --output-def=HSmisc.def DllVersionInfo.o
-SRC_BLD_DLL_OPTS += -lwinmm -lwsock32 -lHSrts_imp -lHScbits_imp -lHSmisc_cbits_imp -lHS_imp -lHSexts_imp -lgmp -L. -L../../rts/gmp -L../../rts -L../std -L../std/cbits -L../exts -Lcbits
-
-ifeq "$(way)" "dll"
-all :: DllVersionInfo.o
-endif
-
-#-----------------------------------------------------------------------------
-# Installation; need to install .hi files as well as libraries
-#
-# The interface files are put inside the $(libdir), since they
-# might (potentially) be platform specific..
-#
-# override is used here because for binary distributions, datadir is
-# set on the command line. sigh.
-#
-override datadir:=$(libdir)/imports/misc
-
-#
-# Files to install from here
-#
-INSTALL_LIBS += $(LIBRARY)
-INSTALL_DATAS += $(HS_IFACES)
-
-ifeq "$(EnableWin32DLLs)" "YES"
-INSTALL_PROGS += $(DLL_NAME)
-INSTALL_LIBS += $(patsubst %.a, %_imp.a, $(LIBRARY))
-INSTALL_DATAS += dLL_ifs.hi
-endif
-
-include $(TOP)/mk/target.mk
-
+++ /dev/null
-\section[match]{PackedString functions for matching}
-
-This module provides regular expression matching and substitution
-at the PackedString level. It is built on top of the GNU Regex
-library modified to handle perl regular expression syntax.
-For a complete description of the perl syntax, do `man perlre`
-or have a gander in (Programming|Learning) Perl. Here's
-a short summary:
-
-^ matches the beginning of line
-$ matches end of line
-\b matches word boundary
-\B matches non-word boundary
-\w matches a word(alpha-numeric) character
-\W matches a non-word character
-\d matches a digit
-\D matches a non-digit
-\s matches whitespace
-\S matches non-whitespace
-\A matches beginning of buffer
-\Z matches end-of-buffer
-. matches any (bar newline in single-line mode)
-+ matches 1 or more times
-* matches 0 or more times
-? matches 0 or 1
-{n,m} matches >=n and <=m atoms
-{n,} matches at least n times
-{n} matches n times
-[..] matches any character member of char class.
-(..) if pattern inside parens match, then the ith group is bound
- to the matched string
-\digit matches whatever the ith group matched.
-
-Backslashed letters
-\n newline
-\r carriage return
-\t tab
-\f formfeed
-\v vertical tab
-\a alarm bell
-\e escape
-
-
-\begin{code}
-module MatchPS
-
- (
- matchPS,
- searchPS,
- substPS,
- replacePS,
-
- match2PS,
- search2PS,
-
- getMatchesNo,
- getMatchedGroup,
- getWholeMatch,
- getLastMatch,
- getAfterMatch,
-
- findPS,
- rfindPS,
- chopPS,
-
- matchPrefixPS,
-
- REmatch(..)
- ) where
-
-import GlaExts
-import PackedString
-
-import Array ((!), bounds)
-import Char ( isDigit, ord )
-import PrelBase ( Char(..) )
-
-import Regex
-
-\end{code}
-
-\subsection[ps-matching]{PackedString matching}
-
-Posix matching, returning an array of the the intervals that
-the individual groups matched within the string.
-
-\begin{code}
-
-matchPS :: PackedString -- reg. exp
- -> PackedString -- string to match
- -> [Char] -- flags
- -> Maybe REmatch
-matchPS reg str flags
- = let
- insensitive = 'i' `elem` flags
- mode = 's' `elem` flags
- in
- unsafePerformIO (do
- pat <- re_compile_pattern reg mode insensitive
- re_match pat str 0 True)
-
-
-match2PS :: PackedString -- reg. exp
- -> PackedString -- string1 to match
- -> PackedString -- string2 to match
- -> [Char] -- flags
- -> Maybe REmatch
-match2PS reg str1 str2 flags
- = let
- insensitive = 'i' `elem` flags
- mode = 's' `elem` flags
- len1 = lengthPS str1
- len2 = lengthPS str2
- in
- unsafePerformIO (do
- pat <- re_compile_pattern reg mode insensitive
- re_match2 pat str1 str2 0 (len1+len2) True)
-
-\end{code}
-
-PackedString front-end to searching with GNU Regex
-
-\begin{code}
-
-searchPS :: PackedString -- reg. exp
- -> PackedString -- string to match
- -> [Char] -- flags
- -> Maybe REmatch
-searchPS reg str flags
- = let
- insensitive = 'i' `elem` flags
- mode = 's' `elem` flags
- in
- unsafePerformIO (do
- pat <- re_compile_pattern reg mode insensitive
- re_search pat str
- 0
- (lengthPS str)
- True)
-
-
-
-search2PS :: PackedString -- reg. exp
- -> PackedString -- string to match
- -> PackedString -- string to match
- -> [Char] -- flags
- -> Maybe REmatch
-search2PS reg str1 str2 flags
- = let
- insensitive = 'i' `elem` flags
- mode = 's' `elem` flags
- len1 = lengthPS str1
- len2 = lengthPS str2
- len = len1+len2
- in
- unsafePerformIO (do
- pat <- re_compile_pattern reg mode insensitive
- re_search2 pat
- str1
- str2
- 0
- len
- len
- True)
-
-
-
-\end{code}
-
-@substrPS s st end@ cuts out the chunk in \tr{s} between \tr{st} and \tr{end}, inclusive.
-The \tr{Regex} registers represent substrings by storing the start and the end point plus
-one( st==end => empty string) , so we use @chunkPS@ instead.
-
-
-\begin{code}
-
-chunkPS :: PackedString
- -> (Int,Int)
- -> PackedString
-chunkPS str (st,end)
- = if st==end then
- nilPS
- else
- substrPS str st (max 0 (end-1))
-
-\end{code}
-
-Perl-like match and substitute
-
-\begin{code}
-
-substPS :: PackedString -- reg. exp
- -> PackedString -- replacement
- -> [Char] -- flags
- -> PackedString -- string
- -> PackedString
-substPS rexp repl flags pstr = search pstr
- where
- global = 'g' `elem` flags
- case_insensitive = 'i' `elem` flags
- mode = 's' `elem` flags -- single-line mode
- pat = unsafePerformIO (
- re_compile_pattern rexp mode case_insensitive)
-
- search str
- = let
- search_res
- = unsafePerformIO (re_search pat str 0 (lengthPS str) True)
- in
- case search_res of
- Nothing -> str
- Just matcher@(REmatch _ before match after _) ->
- let
- (st,en) = match
- prefix = chunkPS str before
- suffix
- | global && (st /= en) = search (dropPS en str)
- | otherwise = chunkPS str after
- in
- concatPS [prefix,
- replace matcher repl str,
- suffix]
-
-
-replace :: REmatch
- -> PackedString
- -> PackedString
- -> PackedString
-replace (REmatch arr (_,b_end) match after lst)
- replacement
- str
- = concatPS (reverse acc) -- ToDo: write a `reversed' version of concatPS
- where
- (_,b) = bounds arr
-
- acc = replace' [] replacement False
-
- single :: Char -> PackedString
- single x = consPS x nilPS
-
- replace' :: [PackedString]
- -> PackedString
- -> Bool
- -> [PackedString]
- replace' acc repl escaped
- | nullPS repl = acc
- | otherwise =
- let
- x = headPS repl
- x# = case x of { C# c -> c }
- xs = tailPS repl
- in
- case x# of
- '\\'# ->
- if escaped then
- replace' acc xs True
- else
- replace' ((single x):acc) xs (not escaped)
- '$'# ->
- if (not escaped) then
- let
- x' = headPS xs
- xs' = tailPS xs
- ith_ival = arr!num
- (num,xs_num) = getNumber ((ord x') - ord '0') xs'
- in
- if (isDigit x') && (num<=b) then
- replace' ((chunkPS str ith_ival):acc) xs_num escaped
- else if x' == '&' then
- replace' ((chunkPS str match):acc) xs' escaped
- else if x' == '+' then
- replace' ((chunkPS str lst):acc) xs' escaped
- else if x' == '`' then
- replace' ((chunkPS str (0,b_end)):acc) xs' escaped
- else if x' == '\'' then
- replace' ((chunkPS str after):acc) xs' escaped
- else -- ignore
- replace' acc xs escaped
- else
- replace' ((single x):acc) xs False
-
- _ -> if escaped then
- (case x# of
- 'n'# -> -- newline
- replace' ((single '\n'):acc)
- 'f'# -> -- formfeed
- replace' ((single '\f'):acc)
- 'r'# -> -- carriage return
- replace' ((single '\r'):acc)
- 't'# -> -- (horiz) tab
- replace' ((single '\t'):acc)
- 'v'# -> -- vertical tab
- replace' ((single '\v'):acc)
- 'a'# -> -- alarm bell
- replace' ((single '\a'):acc)
- 'e'# -> -- escape
- replace' ((single '\033'):acc)
- _ ->
- replace' ((single x):acc)) xs False
- else
- replace' ((single x):acc) xs False
-
-
-getNumber :: Int -> PackedString -> (Int,PackedString)
-getNumber acc ps
- = if nullPS ps then
- (acc,ps)
- else
- let
- x = headPS ps
- xs = tailPS ps
- in
- if (isDigit x) then
- getNumber (acc*10+(ord x - ord '0')) xs
- else
- (acc,ps)
-
-\end{code}
-
-Just like substPS, but no prefix and suffix.
-
-\begin{code}
-
-replacePS :: PackedString -- reg. exp
- -> PackedString -- replacement
- -> [Char] -- flags
- -> PackedString -- string
- -> PackedString
-replacePS rexp
- repl
- flags
- str
- = search str
- where
- case_insensitive = 'i' `elem` flags
- mode = 's' `elem` flags -- single-line mode
- pat = unsafePerformIO (
- re_compile_pattern rexp mode case_insensitive)
-
- search str
- = let
- search_res
- = unsafePerformIO (re_search pat str 0 (lengthPS str) True)
- in
- case search_res of
- Nothing -> str
- Just matcher@(REmatch arr _ match _ lst) ->
- replace matcher repl str
-
-\end{code}
-
-Picking matched groups out of string
-
-\begin{code}
-
-getMatchesNo :: REmatch
- -> Int
-getMatchesNo (REmatch arr _ _ _ _)
- = snd (bounds arr)
-
-getMatchedGroup :: REmatch
- -> Int
- -> PackedString
- -> PackedString
-getMatchedGroup (REmatch arr bef mtch _ lst) nth str
- | (nth >= 1) && (nth <= grps) = chunkPS str (arr!nth)
- | otherwise = error "getMatchedGroup: group out of range"
- where
- (1,grps) = bounds arr
-
-getWholeMatch :: REmatch -> PackedString -> PackedString
-getWholeMatch (REmatch _ _ mtch _ _) str
- = chunkPS str mtch
-
-getLastMatch :: REmatch
- -> PackedString
- -> PackedString
-getLastMatch (REmatch _ _ _ _ lst) str
- = chunkPS str lst
-
-getAfterMatch :: REmatch
- -> PackedString
- -> PackedString
-getAfterMatch (REmatch _ _ _ aft _) str
- = chunkPS str aft
-
-\end{code}
-
-
-More or less straight translation of a brute-force string matching
-function written in C. (Sedgewick ch. 18)
-
-This is intended to provide much the same facilities as index/rindex in perl.
-
-\begin{code}
-
-
-findPS :: PackedString
- -> PackedString
- -> Maybe Int
-findPS str substr
- = let
- m = lengthPS substr
- n = lengthPS str
-
- loop i j
- | j>=m || i>=n = if j==m then (Just (i-m)) else Nothing
- | otherwise
- = inner_loop i j
-
- inner_loop i j
- = if j<m && i<n && (indexPS str i /= indexPS substr j) then
- inner_loop (i-j+1) 0
- else
- loop (i+1) (j+1)
- in
- loop 0 0
-
-rfindPS :: PackedString
- -> PackedString
- -> Maybe Int
-rfindPS str substr
- = let
- m = lengthPS substr - 1
- n = lengthPS str - 1
-
- loop i j
- | j<0 || i<0 = if j<0 then (Just (i+1)) else Nothing
- | otherwise
- = inner_loop i j
-
- inner_loop i j
- = if j>=0 && i>=0 && (indexPS str i /= indexPS substr j) then
- inner_loop (i+(m-j)-1) m
- else
- loop (i-1) (j-1)
- in
- loop n m
-
-
-\end{code}
-
-\begin{code}
-
-chopPS :: PackedString -> PackedString
-chopPS str = if nullPS str then
- nilPS
- else
- chunkPS str (0,lengthPS str-1)
-
-\end{code}
-
-Tries to match as much as possible of strA starting from the beginning of strB
-(handy when matching fancy literals in parsers)
-
-\begin{code}
-matchPrefixPS :: PackedString
- -> PackedString
- -> Int
-matchPrefixPS pref str
- = matchPrefixPS' pref str 0
- where
- matchPrefixPS' pref str n
- = if (nullPS pref) || (nullPS str) then
- n
- else if (headPS pref) == (headPS str) then
- matchPrefixPS' (tailPS pref) (tailPS str) (n+1)
- else
- n
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[Maybes]{The `Maybe' types and associated utility functions}
-
-\begin{code}
-#if defined(COMPILING_GHC)
-#include "HsVersions.h"
-#endif
-
-module Maybes (
--- Maybe(..), -- no, it's in 1.3
- MaybeErr(..),
-
- allMaybes,
- firstJust,
- expectJust,
- maybeToBool,
-
- assocMaybe,
- mkLookupFun, mkLookupFunDef,
-
- failMaB,
- failMaybe,
- seqMaybe,
- returnMaB,
- returnMaybe,
- thenMaB
-
-#if defined(COMPILING_GHC)
- , catMaybes
-#else
- , findJust
- , foldlMaybeErrs
- , listMaybeErrs
-#endif
- ) where
-
-#if defined(COMPILING_GHC)
-
-CHK_Ubiq() -- debugging consistency check
-
-import Unique (Unique) -- only for specialising
-
-#else
-import Maybe -- renamer will tell us if there are any conflicts
-#endif
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Maybe type]{The @Maybe@ type}
-%* *
-%************************************************************************
-
-\begin{code}
-maybeToBool :: Maybe a -> Bool
-maybeToBool Nothing = False
-maybeToBool (Just _) = True
-\end{code}
-
-@catMaybes@ takes a list of @Maybe@s and returns a list of
-the contents of all the @Just@s in it. @allMaybes@ collects
-a list of @Justs@ into a single @Just@, returning @Nothing@ if there
-are any @Nothings@.
-
-\begin{code}
-#ifdef COMPILING_GHC
-catMaybes :: [Maybe a] -> [a]
-catMaybes [] = []
-catMaybes (Nothing : xs) = catMaybes xs
-catMaybes (Just x : xs) = (x : catMaybes xs)
-#endif
-
-allMaybes :: [Maybe a] -> Maybe [a]
-allMaybes [] = Just []
-allMaybes (Nothing : _) = Nothing
-allMaybes (Just x : ms) = case (allMaybes ms) of
- Nothing -> Nothing
- Just xs -> Just (x:xs)
-\end{code}
-
-@firstJust@ takes a list of @Maybes@ and returns the
-first @Just@ if there is one, or @Nothing@ otherwise.
-
-\begin{code}
-firstJust :: [Maybe a] -> Maybe a
-firstJust [] = Nothing
-firstJust (Just x : _) = Just x
-firstJust (Nothing : ms) = firstJust ms
-\end{code}
-
-\begin{code}
-findJust :: (a -> Maybe b) -> [a] -> Maybe b
-findJust _ [] = Nothing
-findJust f (a:as) = case f a of
- Nothing -> findJust f as
- b -> b
-\end{code}
-
-\begin{code}
-expectJust :: String -> Maybe a -> a
-{-# INLINE expectJust #-}
-expectJust _ (Just x) = x
-expectJust err Nothing = error ("expectJust " ++ err)
-\end{code}
-
-The Maybe monad
-~~~~~~~~~~~~~~~
-\begin{code}
-seqMaybe :: Maybe a -> Maybe a -> Maybe a
-seqMaybe v@(Just _) _ = v
-seqMaybe Nothing my = my
-
-returnMaybe :: a -> Maybe a
-returnMaybe = Just
-
-failMaybe :: Maybe a
-failMaybe = Nothing
-\end{code}
-
-Lookup functions
-~~~~~~~~~~~~~~~~
-
-@assocMaybe@ looks up in an assocation list, returning
-@Nothing@ if it fails.
-
-\begin{code}
-assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b
-
-assocMaybe alist key
- = lookup alist
- where
- lookup [] = Nothing
- lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
-
-#if defined(COMPILING_GHC)
-{-# SPECIALIZE assocMaybe
- :: [(FAST_STRING, b)] -> FAST_STRING -> Maybe b
- , [(Int, b)] -> Int -> Maybe b
- , [(Unique, b)] -> Unique -> Maybe b
- , [(RdrName, b)] -> RdrName -> Maybe b
- #-}
-#endif
-\end{code}
-
-@mkLookupFun eq alist@ is a function which looks up
-its argument in the association list @alist@, returning a Maybe type.
-@mkLookupFunDef@ is similar except that it is given a value to return
-on failure.
-
-\begin{code}
-mkLookupFun :: (key -> key -> Bool) -- Equality predicate
- -> [(key,val)] -- The assoc list
- -> key -- The key
- -> Maybe val -- The corresponding value
-
-mkLookupFun eq alist s
- = case [a | (s',a) <- alist, s' `eq` s] of
- [] -> Nothing
- (a:_) -> Just a
-
-mkLookupFunDef :: (key -> key -> Bool) -- Equality predicate
- -> [(key,val)] -- The assoc list
- -> val -- Value to return on failure
- -> key -- The key
- -> val -- The corresponding value
-
-mkLookupFunDef eq alist deflt s
- = case [a | (s',a) <- alist, s' `eq` s] of
- [] -> deflt
- (a:_) -> a
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[MaybeErr type]{The @MaybeErr@ type}
-%* *
-%************************************************************************
-
-\begin{code}
-data MaybeErr val err = Succeeded val | Failed err
-\end{code}
-
-\begin{code}
-thenMaB :: MaybeErr val1 err -> (val1 -> MaybeErr val2 err) -> MaybeErr val2 err
-thenMaB m k
- = case m of
- Succeeded v -> k v
- Failed e -> Failed e
-
-returnMaB :: val -> MaybeErr val err
-returnMaB v = Succeeded v
-
-failMaB :: err -> MaybeErr val err
-failMaB e = Failed e
-\end{code}
-
-
-@listMaybeErrs@ takes a list of @MaybeErrs@ and, if they all succeed, returns
-a @Succeeded@ of a list of their values. If any fail, it returns a
-@Failed@ of the list of all the errors in the list.
-
-\begin{code}
-listMaybeErrs :: [MaybeErr val err] -> MaybeErr [val] [err]
-listMaybeErrs
- = foldr combine (Succeeded [])
- where
- combine (Succeeded v) (Succeeded vs) = Succeeded (v:vs)
- combine (Failed err) (Succeeded _) = Failed [err]
- combine (Succeeded _) (Failed errs) = Failed errs
- combine (Failed err) (Failed errs) = Failed (err:errs)
-\end{code}
-
-@foldlMaybeErrs@ works along a list, carrying an accumulator; it
-applies the given function to the accumulator and the next list item,
-accumulating any errors that occur.
-
-\begin{code}
-foldlMaybeErrs :: (acc -> input -> MaybeErr acc err)
- -> acc
- -> [input]
- -> MaybeErr acc [err]
-
-foldlMaybeErrs k accum ins = do_it [] accum ins
- where
- do_it [] acc [] = Succeeded acc
- do_it errs _ [] = Failed errs
- do_it errs acc (v:vs) = case (k acc v) of
- Succeeded acc' -> do_it errs acc' vs
- Failed err -> do_it (err:errs) acc vs
-\end{code}
+++ /dev/null
-% $Id: Memo.lhs,v 1.3 1999/02/26 17:43:55 simonm Exp $
-%
-% (c) The GHC Team, 1999
-%
-% Hashing memo tables.
-
-\begin{code}
-{-# OPTIONS -fglasgow-exts #-}
-
-module Memo
- ( memo -- :: (a -> b) -> a -> b
- , memo_sized -- :: Int -> (a -> b) -> a -> b
- ) where
-
-import Stable
-import Weak
-import IO
-import IOExts
-import Concurrent
-\end{code}
-
------------------------------------------------------------------------------
-Memo table representation.
-
-The representation is this: a fixed-size hash table where each bucket
-is a list of table entries, of the form (key,value).
-
-The key in this case is (StableName key), and we use hashStableName to
-hash it.
-
-It's important that we can garbage collect old entries in the table
-when the key is no longer reachable in the heap. Hence the value part
-of each table entry is (Weak val), where the weak pointer "key" is the
-key for our memo table, and 'val' is the value of this memo table
-entry. When the key becomes unreachable, a finalizer will fire and
-remove this entry from the hash bucket, and further attempts to
-dereference the weak pointer will return Nothing. References from
-'val' to the key are ignored (see the semantics of weak pointers in
-the documentation).
-
-\begin{code}
-type MemoTable key val
- = MVar (
- Int, -- current table size
- IOArray Int [(StableName key, Weak val)] -- hash table
- )
-\end{code}
-
-We use an MVar to the hash table, so that several threads may safely
-access it concurrently. This includes the finalization threads that
-remove entries from the table.
-
-ToDo: make the finalizers refer to the memo table only through a weak
-pointer, because otherwise the memo table will keep itself alive
-(i.e. even after the function is dead, the weak pointers in the memo
-table stay alive because their keys are alive, and hence the values
-and finalizers are alive, therefore the table itself stays alive.
-Bad).
-
-\begin{code}
-memo :: (a -> b) -> a -> b
-memo f = memo_sized default_table_size f
-
-default_table_size = 1001
-
-memo_sized :: Int -> (a -> b) -> a -> b
-memo_sized size f =
- let (table,weak) = unsafePerformIO (
- do { tbl <- newIOArray (0,1001) []
- ; mvar <- newMVar (size,tbl)
- ; weak <- mkWeakPtr mvar (Just (table_finalizer tbl size))
- ; return (mvar,weak)
- })
- in memo' f table weak
-
-table_finalizer :: IOArray Int [(StableName key, Weak val)] -> Int -> IO ()
-table_finalizer table size =
- sequence_ [ finalizeBucket i | i <- [0..size] ]
- where
- finalizeBucket i = do
- bucket <- readIOArray table i
- sequence_ [ finalize w | (_,w) <- bucket ]
-
-memo' :: (a -> b) -> MemoTable a b -> Weak (MemoTable a b) -> a -> b
-memo' f ref weak_ref = \k -> unsafePerformIO $ do
- stable_key <- makeStableName k
- (size, table) <- takeMVar ref
- let hash_key = hashStableName stable_key `mod` size
- bucket <- readIOArray table hash_key
- lkp <- lookupSN stable_key bucket
-
- case lkp of
- Just result -> do
- putMVar ref (size,table)
- return result
- Nothing -> do
- let result = f k
- weak <- mkWeak k result (Just (finalizer hash_key stable_key weak_ref))
- writeIOArray table hash_key ((stable_key,weak):bucket)
- putMVar ref (size,table)
- return result
-
-finalizer :: Int -> StableName a -> Weak (MemoTable a b) -> IO ()
-finalizer hash_key stable_key weak_ref =
- do r <- deRefWeak weak_ref
- case r of
- Nothing -> return ()
- Just mvar -> do
- (size,table) <- takeMVar mvar
- bucket <- readIOArray table hash_key
- let new_bucket = [ (sn,weak)
- | (sn,weak) <- bucket,
- sn /= stable_key ]
- writeIOArray table hash_key new_bucket
- putMVar mvar (size,table)
-
-lookupSN :: StableName key -> [(StableName key, Weak val)] -> IO (Maybe val)
-lookupSN sn [] = return Nothing
-lookupSN sn ((sn',weak) : xs)
- | sn == sn' = do maybe_item <- deRefWeak weak
- case maybe_item of
- Nothing -> error ("dead weak pair: " ++
- show (hashStableName sn))
- Just v -> return (Just v)
- | otherwise = lookupSN sn xs
-\end{code}
+++ /dev/null
-\begin{code}
-#if defined(__YALE_HASKELL__)
--- Native.hs -- native data conversions and I/O
---
--- author : Sandra Loosemore
--- date : 07 Jun 1994
---
---
--- Unlike in the original hbc version of this library, a Byte is a completely
--- abstract data type and not a character. You can't read and write Bytes
--- to ordinary text files; you must use the operations defined here on
--- Native files.
--- It's guaranteed to be more efficient to read and write objects directly
--- to a file than to do the conversion to a Byte stream and read/write
--- the Byte stream.
-#endif
-
-module Native(
- Native(..), Bytes,
- shortIntToBytes, bytesToShortInt,
- longIntToBytes, bytesToLongInt,
- showB, readB
-#if defined(__YALE_HASKELL__)
- , openInputByteFile, openOutputByteFile, closeByteFile
- , readBFile, readBytesFromByteFile
- , shortIntToByteFile, bytesToShortIntIO
- , ByteFile
- , Byte
-#endif
- ) where
-
-import Ix -- 1.3
-import Array -- 1.3
-
-#if defined(__YALE_HASKELL__)
-import NativePrims
-
--- these data types are completely opaque on the Haskell side.
-
-data Byte = Byte
-data ByteFile = ByteFile
-type Bytes = [Byte]
-
-instance Show(Byte) where
- showsPrec _ _ = showString "Byte"
-
-instance Show(ByteFile) where
- showsPrec _ _ = showString "ByteFile"
-
--- Byte file primitives
-
-openInputByteFile :: String -> IO (ByteFile)
-openOutputByteFile :: String -> IO (ByteFile)
-closeByteFile :: ByteFile -> IO ()
-
-openInputByteFile = primOpenInputByteFile
-openOutputByteFile = primOpenOutputByteFile
-closeByteFile = primCloseByteFile
-#endif {- YALE-}
-
-#if defined(__GLASGOW_HASKELL__)
-import ByteOps -- partain
-type Bytes = [Char]
-#endif
-
-#if defined(__HBC__)
-import LMLbyteops
-type Bytes = [Char]
-#endif
-
--- Here are the basic operations defined on the class.
-
-class Native a where
-
- -- these are primitives
- showBytes :: a -> Bytes -> Bytes -- convert to bytes
- readBytes :: Bytes -> Maybe (a, Bytes) -- get an item and the rest
-#if defined(__YALE_HASKELL__)
- showByteFile :: a -> ByteFile -> IO ()
- readByteFile :: ByteFile -> IO a
-#endif
-
- -- these are derived
- listShowBytes :: [a] -> Bytes -> Bytes -- convert a list to bytes
- listReadBytes :: Int -> Bytes -> Maybe ([a], Bytes) -- get n items and the rest
-#if defined(__YALE_HASKELL__)
- listShowByteFile :: [a] -> ByteFile -> IO ()
- listReadByteFile :: Int -> ByteFile -> IO [a]
-#endif
-
- -- here are defaults for the derived methods.
-
- listShowBytes [] bs = bs
- listShowBytes (x:xs) bs = showBytes x (listShowBytes xs bs)
-
- listReadBytes 0 bs = Just ([], bs)
- listReadBytes n bs =
- case readBytes bs of
- Nothing -> Nothing
- Just (x,bs') ->
- case listReadBytes (n-1) bs' of
- Nothing -> Nothing
- Just (xs,bs'') -> Just (x:xs, bs'')
-
-#if defined(__YALE_HASKELL__)
- listShowByteFile l f =
- foldr (\ head tail -> (showByteFile head f) >> tail)
- (return ())
- l
-
- listReadByteFile 0 f =
- return []
- listReadByteFile n f =
- readByteFile f >>= \ h ->
- listReadByteFile (n - 1) f >>= \ t ->
- return (h:t)
-#endif
-
-#if ! defined(__YALE_HASKELL__)
--- Some utilities that Yale doesn't use
-hasNElems :: Int -> [a] -> Bool
-hasNElems 0 _ = True
-hasNElems 1 (_:_) = True -- speedup
-hasNElems 2 (_:_:_) = True -- speedup
-hasNElems 3 (_:_:_:_) = True -- speedup
-hasNElems 4 (_:_:_:_:_) = True -- speedup
-hasNElems _ [] = False
-hasNElems n (_:xs) = hasNElems (n-1) xs
-
-lenLong, lenInt, lenShort, lenFloat, lenDouble :: Int
-lenLong = length (longToBytes 0 [])
-lenInt = length (intToBytes 0 [])
-lenShort = length (shortToBytes 0 [])
-lenFloat = length (floatToBytes 0 [])
-lenDouble = length (doubleToBytes 0 [])
-#endif
-
--- Basic instances, defined as primitives
-
-instance Native Char where
-#if defined(__YALE_HASKELL__)
- showBytes = primCharShowBytes
- readBytes = primCharReadBytes
- showByteFile = primCharShowByteFile
- readByteFile = primCharReadByteFile
-#else
- showBytes c bs = c:bs
- readBytes [] = Nothing
- readBytes (c:cs) = Just (c,cs)
- listReadBytes n bs = f n bs []
- where f 0 bs cs = Just (reverse cs, bs)
- f _ [] _ = Nothing
- f n (b:bs) cs = f (n-1::Int) bs (b:cs)
-#endif
-
-instance Native Int where
-#if defined(__YALE_HASKELL__)
- showBytes = primIntShowBytes
- readBytes = primIntReadBytes
- showByteFile = primIntShowByteFile
- readByteFile = primIntReadByteFile
-#else
- showBytes i bs = intToBytes i bs
- readBytes bs = if hasNElems lenInt bs then Just (bytesToInt bs) else Nothing
-#endif
-
-instance Native Float where
-#if defined(__YALE_HASKELL__)
- showBytes = primFloatShowBytes
- readBytes = primFloatReadBytes
- showByteFile = primFloatShowByteFile
- readByteFile = primFloatReadByteFile
-#else
- showBytes i bs = floatToBytes i bs
- readBytes bs = if hasNElems lenFloat bs then Just (bytesToFloat bs) else Nothing
-#endif
-
-instance Native Double where
-#if defined(__YALE_HASKELL__)
- showBytes = primDoubleShowBytes
- readBytes = primDoubleReadBytes
- showByteFile = primDoubleShowByteFile
- readByteFile = primDoubleReadByteFile
-#else
- showBytes i bs = doubleToBytes i bs
- readBytes bs = if hasNElems lenDouble bs then Just (bytesToDouble bs) else Nothing
-#endif
-
-instance Native Bool where
-#if defined(__YALE_HASKELL__)
- showBytes = primBoolShowBytes
- readBytes = primBoolReadBytes
- showByteFile = primBoolShowByteFile
- readByteFile = primBoolReadByteFile
-#else
- showBytes b bs = if b then '\x01':bs else '\x00':bs
- readBytes [] = Nothing
- readBytes (c:cs) = Just(c/='\x00', cs)
-#endif
-
-#if defined(__YALE_HASKELL__)
--- Byte instances, so you can write Bytes to a ByteFile
-
-instance Native Byte where
- showBytes = (:)
- readBytes l =
- case l of
- [] -> Nothing
- h:t -> Just(h,t)
- showByteFile = primByteShowByteFile
- readByteFile = primByteReadByteFile
-#endif
-
--- A pair is stored as two consecutive items.
-instance (Native a, Native b) => Native (a,b) where
- showBytes (a,b) = showBytes a . showBytes b
- readBytes bs = readBytes bs >>= \(a,bs') ->
- readBytes bs' >>= \(b,bs'') ->
- return ((a,b), bs'')
-#if defined(__YALE_HASKELL__)
- showByteFile (a,b) f = (showByteFile a f) >> (showByteFile b f)
-
- readByteFile f =
- readByteFile f >>= \ a ->
- readByteFile f >>= \ b ->
- return (a,b)
-#endif
-
--- A triple is stored as three consectutive items.
-instance (Native a, Native b, Native c) => Native (a,b,c) where
- showBytes (a,b,c) = showBytes a . showBytes b . showBytes c
- readBytes bs = readBytes bs >>= \(a,bs') ->
- readBytes bs' >>= \(b,bs'') ->
- readBytes bs'' >>= \(c,bs''') ->
- return ((a,b,c), bs''')
-#if defined(__YALE_HASKELL__)
- showByteFile (a,b,c) f =
- (showByteFile a f) >>
- (showByteFile b f) >>
- (showByteFile c f)
-
- readByteFile f =
- readByteFile f >>= \ a ->
- readByteFile f >>= \ b ->
- readByteFile f >>= \ c ->
- return (a,b,c)
-#endif
-
--- A list is stored with an Int with the number of items followed by the items.
-instance (Native a) => Native [a] where
- showBytes xs bs = showBytes (length xs) (f xs) where f [] = bs
- f (x:xs) = showBytes x (f xs)
- readBytes bs = readBytes bs >>= \(n,bs') ->
- listReadBytes n bs' >>= \(xs, bs'') ->
- return (xs, bs'')
-#if defined(__YALE_HASKELL__)
- showByteFile l f = (showByteFile (length l) f) >> (listShowByteFile l f)
- readByteFile f = readByteFile f >>= \ n -> listReadByteFile n f
-#endif
-
--- A Maybe is stored as a Boolean possibly followed by a value
-instance (Native a) => Native (Maybe a) where
-#if !defined(__YALE_HASKELL__)
- showBytes Nothing = ('\x00' :)
- showBytes (Just x) = ('\x01' :) . showBytes x
- readBytes ('\x00':bs) = Just (Nothing, bs)
- readBytes ('\x01':bs) = readBytes bs >>= \(a,bs') ->
- return (Just a, bs')
- readBytes _ = Nothing
-#else
- showBytes (Just a) = showBytes True . showBytes a
- showBytes Nothing = showBytes False
- readBytes bs =
- readBytes bs >>= \ (isJust, bs') ->
- if isJust then
- readBytes bs' >>= \ (a, bs'') ->
- return (Just a, bs'')
- else
- return (Nothing, bs')
-
- showByteFile (Just a) f = showByteFile True f >> showByteFile a f
- showByteFile Nothing f = showByteFile False f
- readByteFile f =
- readByteFile f >>= \ isJust ->
- if isJust then
- readByteFile f >>= \ a ->
- return (Just a)
- else
- return Nothing
-#endif
-
-instance (Native a, Ix a, Native b) => Native (Array a b) where
- showBytes a = showBytes (bounds a) . showBytes (elems a)
- readBytes bs = readBytes bs >>= \(b, bs')->
- readBytes bs' >>= \(xs, bs'')->
- return (listArray b xs, bs'')
-
-shortIntToBytes :: Int -> Bytes -> Bytes
-bytesToShortInt :: Bytes -> Maybe (Int, Bytes)
-longIntToBytes :: Int -> Bytes -> Bytes
-bytesToLongInt :: Bytes -> Maybe (Int, Bytes)
-#if defined(__YALE_HASKELL__)
-shortIntToByteFile :: Int -> ByteFile -> IO ()
-bytesToShortIntIO :: ByteFile -> IO Int
-#endif
-
-#if defined(__YALE_HASKELL__)
--- These functions are like the primIntxx but use a "short" rather than
--- "int" representation.
-shortIntToBytes = primShortShowBytes
-bytesToShortInt = primShortReadBytes
-shortIntToByteFile = primShortShowByteFile
-bytesToShortIntIO = primShortReadByteFile
-
-#else {-! YALE-}
-
-shortIntToBytes s bs = shortToBytes s bs
-
-bytesToShortInt bs = if hasNElems lenShort bs then Just (bytesToShort bs) else Nothing
-
-longIntToBytes s bs = longToBytes s bs
-
-bytesToLongInt bs = if hasNElems lenLong bs then Just (bytesToLong bs) else Nothing
-
-#endif {-! YALE-}
-
-showB :: (Native a) => a -> Bytes
-showB x = showBytes x []
-
-readB :: (Native a) => Bytes -> a
-readB bs =
- case readBytes bs of
- Just (x,[]) -> x
- Just (_,_) -> error "Native.readB data too long"
- Nothing -> error "Native.readB data too short"
-
-#if defined(__YALE_HASKELL__)
-readBFile :: String -> IO(Bytes)
-readBFile name =
- openInputByteFile name >>= \ f ->
- readBytesFromByteFile f
-
-readBytesFromByteFile :: ByteFile -> IO(Bytes)
-readBytesFromByteFile f =
- try
- (primByteReadByteFile f >>= \ h ->
- readBytesFromByteFile f >>= \ t ->
- return (h:t))
- onEOF
- where
- onEOF EOF = closeByteFile f >> return []
- onEOF err = closeByteFile f >> failwith err
-#endif
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section{Packed strings}
-
-This sits on top of the sequencing/arrays world, notably @ByteArray#@s.
-
-Glorious hacking (all the hard work) by Bryan O'Sullivan.
-
-\begin{code}
-{-# OPTIONS -#include "cbits/PackedString.h" #-}
-
-module PackedString (
- PackedString, -- abstract
-
- -- Creating the beasts
- packString, -- :: [Char] -> PackedString
- packStringST, -- :: [Char] -> ST s PackedString
- packCBytesST, -- :: Int -> Addr -> ST s PackedString
-
- byteArrayToPS, -- :: ByteArray Int -> PackedString
- cByteArrayToPS, -- :: ByteArray Int -> PackedString
- unsafeByteArrayToPS, -- :: ByteArray a -> Int -> PackedString
-
- psToByteArray, -- :: PackedString -> ByteArray Int
- psToCString, -- :: PackedString -> Addr
- isCString, -- :: PackedString -> Bool
-
- unpackPS, -- :: PackedString -> [Char]
- unpackNBytesPS, -- :: PackedString -> Int -> [Char]
- unpackPSIO, -- :: PackedString -> IO [Char]
-
- hPutPS, -- :: Handle -> PackedString -> IO ()
- hGetPS, -- :: Handle -> Int -> IO PackedString
-
- nilPS, -- :: PackedString
- consPS, -- :: Char -> PackedString -> PackedString
- headPS, -- :: PackedString -> Char
- tailPS, -- :: PackedString -> PackedString
- nullPS, -- :: PackedString -> Bool
- appendPS, -- :: PackedString -> PackedString -> PackedString
- lengthPS, -- :: PackedString -> Int
- {- 0-origin indexing into the string -}
- indexPS, -- :: PackedString -> Int -> Char
- mapPS, -- :: (Char -> Char) -> PackedString -> PackedString
- filterPS, -- :: (Char -> Bool) -> PackedString -> PackedString
- foldlPS, -- :: (a -> Char -> a) -> a -> PackedString -> a
- foldrPS, -- :: (Char -> a -> a) -> a -> PackedString -> a
- takePS, -- :: Int -> PackedString -> PackedString
- dropPS, -- :: Int -> PackedString -> PackedString
- splitAtPS, -- :: Int -> PackedString -> (PackedString, PackedString)
- takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
- dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
- spanPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
- breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
- linesPS, -- :: PackedString -> [PackedString]
-
- wordsPS, -- :: PackedString -> [PackedString]
- reversePS, -- :: PackedString -> PackedString
- splitPS, -- :: Char -> PackedString -> [PackedString]
- splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString]
- joinPS, -- :: PackedString -> [PackedString] -> PackedString
- concatPS, -- :: [PackedString] -> PackedString
- elemPS, -- :: Char -> PackedString -> Bool
-
- {-
- Pluck out a piece of a PS start and end
- chars you want; both 0-origin-specified
- -}
- substrPS, -- :: PackedString -> Int -> Int -> PackedString
-
- comparePS -- :: PackedString -> PackedString -> Ordering
-
- ) where
-
-import GlaExts
-import PrelShow ( showList__ ) -- ToDo: better
-import PrelPack
- ( new_ps_array
- , freeze_ps_array
- , write_ps_array
- )
-import Addr
-
-import PrelST
-import ST
-import IOExts ( unsafePerformIO )
-import IO
-import PrelHandle ( hFillBufBA )
-
-import Ix
-import Char (isSpace)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{@PackedString@ type declaration}
-%* *
-%************************************************************************
-
-\begin{code}
-data PackedString
- = PS ByteArray# -- the bytes
- Int# -- length (*not* including NUL at the end)
- Bool -- True <=> contains a NUL
- | CPS Addr# -- pointer to the (null-terminated) bytes in C land
- Int# -- length, as per strlen
- -- definitely doesn't contain a NUL
-
-instance Eq PackedString where
- x == y = compare x y == EQ
- x /= y = compare x y /= EQ
-
-instance Ord PackedString where
- compare = comparePS
- x <= y = compare x y /= GT
- x < y = compare x y == LT
- x >= y = compare x y /= LT
- x > y = compare x y == GT
- max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
- min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
-
---instance Read PackedString: ToDo
-
-instance Show PackedString where
- showsPrec p ps r = showsPrec p (unpackPS ps) r
- showList = showList__ (showsPrec 0)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{@PackedString@ instances}
-%* *
-%************************************************************************
-
-We try hard to make this go fast:
-\begin{code}
-comparePS :: PackedString -> PackedString -> Ordering
-
-comparePS (PS bs1 len1 has_null1) (PS bs2 len2 has_null2)
- | not has_null1 && not has_null2
- = unsafePerformIO (
- _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
- return (
- if res <# 0# then LT
- else if res ==# 0# then EQ
- else GT
- ))
- where
- ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1
- ba2 = ByteArray 0 (I# (len2 -# 1#)) bs2
-
-comparePS (PS bs1 len1 has_null1) (CPS bs2 _)
- | not has_null1
- = unsafePerformIO (
- _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
- return (
- if res <# 0# then LT
- else if res ==# 0# then EQ
- else GT
- ))
- where
- ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1
- ba2 = A# bs2
-
-comparePS (CPS bs1 len1) (CPS bs2 _)
- = unsafePerformIO (
- _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
- return (
- if res <# 0# then LT
- else if res ==# 0# then EQ
- else GT
- ))
- where
- ba1 = A# bs1
- ba2 = A# bs2
-
-comparePS a@(CPS _ _) b@(PS _ _ has_null2)
- | not has_null2
- = -- try them the other way 'round
- case (comparePS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
-
-comparePS ps1 ps2 -- slow catch-all case (esp for "has_null" True)
- = looking_at 0#
- where
- end1 = lengthPS# ps1 -# 1#
- end2 = lengthPS# ps2 -# 1#
-
- looking_at char#
- = if char# ># end1 then
- if char# ># end2 then -- both strings ran out at once
- EQ
- else -- ps1 ran out before ps2
- LT
- else if char# ># end2 then
- GT -- ps2 ran out before ps1
- else
- let
- ch1 = indexPS# ps1 char#
- ch2 = indexPS# ps2 char#
- in
- if ch1 `eqChar#` ch2 then
- looking_at (char# +# 1#)
- else if ch1 `ltChar#` ch2 then LT
- else GT
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Constructor functions}
-%* *
-%************************************************************************
-
-Easy ones first. @packString@ requires getting some heap-bytes and
-scribbling stuff into them.
-
-\begin{code}
-nilPS :: PackedString
-nilPS = CPS ""# 0#
-
-consPS :: Char -> PackedString -> PackedString
-consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better
-
-packString :: [Char] -> PackedString
-packString str = runST (packStringST str)
-
-packStringST :: [Char] -> ST s PackedString
-packStringST str =
- let len = length str in
- packNCharsST len str
-
-packNCharsST :: Int -> [Char] -> ST s PackedString
-packNCharsST (I# length#) str =
- {-
- allocate an array that will hold the string
- (not forgetting the NUL byte at the end)
- -}
- new_ps_array (length# +# 1#) >>= \ ch_array ->
- -- fill in packed string from "str"
- fill_in ch_array 0# str >>
- -- freeze the puppy:
- freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) ->
- let has_null = byteArrayHasNUL# frozen# length# in
- return (PS frozen# length# has_null)
- where
- fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
- fill_in arr_in# idx [] =
- write_ps_array arr_in# idx (chr# 0#) >>
- return ()
-
- fill_in arr_in# idx (C# c : cs) =
- write_ps_array arr_in# idx c >>
- fill_in arr_in# (idx +# 1#) cs
-
-byteArrayToPS :: ByteArray Int -> PackedString
-byteArrayToPS (ByteArray l u frozen#) =
- let
- ixs = (l,u)
- n# =
- case (
- if null (range ixs)
- then 0
- else ((index ixs u) + 1)
- ) of { I# x -> x }
- in
- PS frozen# n# (byteArrayHasNUL# frozen# n#)
-
--- byteArray is zero-terminated, make everything upto it
--- a packed string.
-cByteArrayToPS :: ByteArray Int -> PackedString
-cByteArrayToPS (ByteArray l u frozen#) =
- let
- ixs = (l,u)
- n# =
- case (
- if null (range ixs)
- then 0
- else ((index ixs u) + 1)
- ) of { I# x -> x }
- len# = findNull 0#
-
- findNull i#
- | i# ==# n# = n#
- | ch# `eqChar#` '\0'# = i# -- everything upto the sentinel
- | otherwise = findNull (i# +# 1#)
- where
- ch# = indexCharArray# frozen# i#
- in
- PS frozen# len# False
-
-unsafeByteArrayToPS :: ByteArray a -> Int -> PackedString
-unsafeByteArrayToPS (ByteArray _ _ frozen#) (I# n#)
- = PS frozen# n# (byteArrayHasNUL# frozen# n#)
-
-psToByteArray :: PackedString -> ByteArray Int
-psToByteArray (PS bytes n _) = ByteArray 0 (I# (n -# 1#)) bytes
-
-psToByteArray (CPS addr len#)
- = let
- len = I# len#
- byte_array_form = packCBytes len (A# addr)
- in
- case byte_array_form of { PS bytes _ _ ->
- ByteArray 0 (len - 1) bytes }
-
--- isCString is useful when passing PackedStrings to the
--- outside world, and need to figure out whether you can
--- pass it as an Addr or ByteArray.
---
-isCString :: PackedString -> Bool
-isCString (CPS _ _ ) = True
-isCString _ = False
-
-psToCString :: PackedString -> Addr
-psToCString (CPS addr _) = (A# addr)
-psToCString (PS bytes l# _) =
- unsafePerformIO $ do
- stuff <- _ccall_ malloc ((I# l#) * (``sizeof(char)''))
- let
- fill_in n# i#
- | n# ==# 0# = return ()
- | otherwise = do
- let ch# = indexCharArray# bytes i#
- writeCharOffAddr stuff (I# i#) (C# ch#)
- fill_in (n# -# 1#) (i# +# 1#)
- fill_in l# 0#
- return stuff
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Destructor functions (taking @PackedStrings@ apart)}
-%* *
-%************************************************************************
-
-\begin{code}
--- OK, but this code gets *hammered*:
--- unpackPS ps
--- = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ]
-
-unpackPS :: PackedString -> [Char]
-unpackPS (PS bytes len _) = unpack 0#
- where
- unpack nh
- | nh >=# len = []
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharArray# bytes nh
-
-unpackPS (CPS addr _) = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = []
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
-
-unpackNBytesPS :: PackedString -> Int -> [Char]
-unpackNBytesPS ps len@(I# l#)
- | len < 0 = error ("PackedString.unpackNBytesPS: negative length "++ show len)
- | len == 0 = []
- | otherwise =
- case ps of
- PS bytes len# has_null -> unpackPS (PS bytes (min# len# l#) has_null)
- CPS a len# -> unpackPS (CPS a (min# len# l#))
- where
- min# x# y#
- | x# <# y# = x#
- | otherwise = y#
-
-unpackPSIO :: PackedString -> IO String
-unpackPSIO ps@(PS bytes _ _) = return (unpackPS ps)
-unpackPSIO (CPS addr _) = unpack 0#
- where
- unpack nh = do
- ch <- readCharOffAddr (A# addr) (I# nh)
- if ch == '\0'
- then return []
- else do
- ls <- unpack (nh +# 1#)
- return (ch : ls)
-
-\end{code}
-
-Output a packed string via a handle:
-
-\begin{code}
-hPutPS :: Handle -> PackedString -> IO ()
-hPutPS handle (CPS a# len#) = hPutBuf handle (A# a#) (I# len#)
-hPutPS handle (PS ba# len# _) = hPutBufBA handle (ByteArray bottom bottom ba#) (I# len#)
- where
- bottom = error "hPutPS"
-\end{code}
-
-The dual to @_putPS@, note that the size of the chunk specified
-is the upper bound of the size of the chunk returned.
-
-\begin{code}
-hGetPS :: Handle -> Int -> IO PackedString
-hGetPS hdl len@(I# len#)
- | len# <=# 0# = return nilPS -- I'm being kind here.
- | otherwise =
- -- Allocate an array for system call to store its bytes into.
- stToIO (new_ps_array len# ) >>= \ ch_arr ->
- stToIO (freeze_ps_array ch_arr len#) >>= \ (ByteArray _ _ frozen#) ->
- let
- byte_array = ByteArray 0 (I# len#) frozen#
- in
- hFillBufBA hdl byte_array len >>= \ (I# read#) ->
- if read# ==# 0# then -- EOF or other error
- ioError (userError "hGetPS: EOF reached or other error")
- else
- {-
- The system call may not return the number of
- bytes requested. Instead of failing with an error
- if the number of bytes read is less than requested,
- a packed string containing the bytes we did manage
- to snarf is returned.
- -}
- let
- has_null = byteArrayHasNUL# frozen# read#
- in
- return (PS frozen# read# has_null)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{List-mimicking functions for @PackedStrings@}
-%* *
-%************************************************************************
-
-First, the basic functions that do look into the representation;
-@indexPS@ is the most important one.
-
-\begin{code}
-lengthPS :: PackedString -> Int
-lengthPS ps = I# (lengthPS# ps)
-
-{-# INLINE lengthPS# #-}
-
-lengthPS# :: PackedString -> Int#
-lengthPS# (PS _ i _) = i
-lengthPS# (CPS _ i) = i
-
-{-# INLINE strlen# #-}
-
-strlen# :: Addr# -> Int
-strlen# a
- = unsafePerformIO (
- _ccall_ strlen (A# a) >>= \ len@(I# _) ->
- return len
- )
-
-byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
-byteArrayHasNUL# bs len
- = unsafePerformIO (
- _ccall_ byteArrayHasNUL__ ba (I# len) >>= \ (I# res) ->
- return (
- if res ==# 0# then False else True
- ))
- where
- ba = ByteArray 0 (I# (len -# 1#)) bs
-
------------------------
-
-indexPS :: PackedString -> Int -> Char
-indexPS ps (I# n) = C# (indexPS# ps n)
-
-{-# INLINE indexPS# #-}
-
-indexPS# :: PackedString -> Int# -> Char#
-indexPS# (PS bs i _) n
- = --ASSERT (n >=# 0# && n <# i) -- error checking: my eye! (WDP 94/10)
- indexCharArray# bs n
-
-indexPS# (CPS a _) n
- = indexCharOffAddr# a n
-\end{code}
-
-Now, the rest of the functions can be defined without digging
-around in the representation.
-
-\begin{code}
-headPS :: PackedString -> Char
-headPS ps
- | nullPS ps = error "headPS: head []"
- | otherwise = C# (indexPS# ps 0#)
-
-tailPS :: PackedString -> PackedString
-tailPS ps
- | len <=# 0# = error "tailPS: tail []"
- | len ==# 1# = nilPS
- | otherwise = substrPS# ps 1# (len -# 1#)
- where
- len = lengthPS# ps
-
-nullPS :: PackedString -> Bool
-nullPS (PS _ i _) = i ==# 0#
-nullPS (CPS _ i) = i ==# 0#
-
-appendPS :: PackedString -> PackedString -> PackedString
-appendPS xs ys
- | nullPS xs = ys
- | nullPS ys = xs
- | otherwise = concatPS [xs,ys]
-
-mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
-mapPS f xs =
- if nullPS xs then
- xs
- else
- runST (
- new_ps_array (length +# 1#) >>= \ ps_arr ->
- whizz ps_arr length 0# >>
- freeze_ps_array ps_arr length >>= \ (ByteArray _ _ frozen#) ->
- let has_null = byteArrayHasNUL# frozen# length in
- return (PS frozen# length has_null))
- where
- length = lengthPS# xs
-
- whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
- whizz arr# n i
- | n ==# 0#
- = write_ps_array arr# i (chr# 0#) >>
- return ()
- | otherwise
- = let
- ch = indexPS# xs i
- in
- write_ps_array arr# i (case f (C# ch) of { (C# x) -> x}) >>
- whizz arr# (n -# 1#) (i +# 1#)
-
-filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
-filterPS pred ps =
- if nullPS ps then
- ps
- else
- {-
- Filtering proceeds as follows:
-
- * traverse the list, applying the pred. to each element,
- remembering the positions where it was satisfied.
-
- Encode these positions using a run-length encoding of the gaps
- between the matching positions.
-
- * Allocate a MutableByteArray in the heap big enough to hold
- all the matched entries, and copy the elements that matched over.
-
- A better solution that merges the scan© passes into one,
- would be to copy the filtered elements over into a growable
- buffer. No such operation currently supported over
- MutableByteArrays (could of course use malloc&realloc)
- But, this solution may in the case of repeated realloc's
- be worse than the current solution.
- -}
- runST (
- let
- (rle,len_filtered) = filter_ps (len# -# 1#) 0# 0# []
- len_filtered# = case len_filtered of { I# x# -> x#}
- in
- if len# ==# len_filtered# then
- {- not much filtering as everything passed through. -}
- return ps
- else if len_filtered# ==# 0# then
- return nilPS
- else
- new_ps_array (len_filtered# +# 1#) >>= \ ps_arr ->
- copy_arr ps_arr rle 0# 0# >>
- freeze_ps_array ps_arr len_filtered# >>= \ (ByteArray _ _ frozen#) ->
- let has_null = byteArrayHasNUL# frozen# len_filtered# in
- return (PS frozen# len_filtered# has_null))
- where
- len# = lengthPS# ps
-
- matchOffset :: Int# -> [Char] -> (Int,[Char])
- matchOffset off [] = (I# off,[])
- matchOffset off (C# c:cs) =
- let
- x = ord# c
- off' = off +# x
- in
- if x==# 0# then -- escape code, add 255#
- matchOffset off' cs
- else
- (I# off', cs)
-
- copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s ()
- copy_arr _ [_] _ _ = return ()
- copy_arr arr# ls n i =
- let
- (x,ls') = matchOffset 0# ls
- n' = n +# (case x of { (I# x#) -> x#}) -# 1#
- ch = indexPS# ps n'
- in
- write_ps_array arr# i ch >>
- copy_arr arr# ls' (n' +# 1#) (i +# 1#)
-
- esc :: Int# -> Int# -> [Char] -> [Char]
- esc v 0# ls = (C# (chr# v)):ls
- esc v n ls = esc v (n -# 1#) (C# (chr# 0#):ls)
-
- filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int)
- filter_ps n hits run acc
- | n <# 0# =
- let
- escs = run `quotInt#` 255#
- v = run `remInt#` 255#
- in
- (esc (v +# 1#) escs acc, I# hits)
- | otherwise
- = let
- ch = indexPS# ps n
- n' = n -# 1#
- in
- if pred (C# ch) then
- let
- escs = run `quotInt#` 255#
- v = run `remInt#` 255#
- acc' = esc (v +# 1#) escs acc
- in
- filter_ps n' (hits +# 1#) 0# acc'
- else
- filter_ps n' hits (run +# 1#) acc
-
-
-foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
-foldlPS f b ps
- = if nullPS ps then
- b
- else
- whizzLR b 0#
- where
- len = lengthPS# ps
-
- --whizzLR :: a -> Int# -> a
- whizzLR b idx
- | idx ==# len = b
- | otherwise = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#)
-
-
-foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
-foldrPS f v ps
- | nullPS ps = v
- | otherwise = whizzRL v len
- where
- len = lengthPS# ps
-
- --whizzRL :: a -> Int# -> a
- whizzRL b idx
- | idx <# 0# = b
- | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#)
-
-takePS :: Int -> PackedString -> PackedString
-takePS (I# n) ps
- | n ==# 0# = nilPS
- | otherwise = substrPS# ps 0# (n -# 1#)
-
-dropPS :: Int -> PackedString -> PackedString
-dropPS (I# n) ps
- | n ==# len = nilPS
- | otherwise = substrPS# ps n (lengthPS# ps -# 1#)
- where
- len = lengthPS# ps
-
-splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
-splitAtPS n ps = (takePS n ps, dropPS n ps)
-
-takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
-takeWhilePS pred ps
- = let
- break_pt = char_pos_that_dissatisfies
- (\ c -> pred (C# c))
- ps
- (lengthPS# ps)
- 0#
- in
- if break_pt ==# 0# then
- nilPS
- else
- substrPS# ps 0# (break_pt -# 1#)
-
-dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
-dropWhilePS pred ps
- = let
- len = lengthPS# ps
- break_pt = char_pos_that_dissatisfies
- (\ c -> pred (C# c))
- ps
- len
- 0#
- in
- if len ==# break_pt then
- nilPS
- else
- substrPS# ps break_pt (len -# 1#)
-
-elemPS :: Char -> PackedString -> Bool
-elemPS (C# ch) ps
- = let
- len = lengthPS# ps
- break_pt = first_char_pos_that_satisfies
- (`eqChar#` ch)
- ps
- len
- 0#
- in
- break_pt <# len
-
-char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
-
-char_pos_that_dissatisfies p ps len pos
- | pos >=# len = pos -- end
- | p (indexPS# ps pos) = -- predicate satisfied; keep going
- char_pos_that_dissatisfies p ps len (pos +# 1#)
- | otherwise = pos -- predicate not satisfied
-
-first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
-first_char_pos_that_satisfies p ps len pos
- | pos >=# len = pos -- end
- | p (indexPS# ps pos) = pos -- got it!
- | otherwise = first_char_pos_that_satisfies p ps len (pos +# 1#)
-
--- ToDo: could certainly go quicker
-spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
-spanPS p ps = (takeWhilePS p ps, dropWhilePS p ps)
-
-breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
-breakPS p ps = spanPS (not . p) ps
-
-linesPS :: PackedString -> [PackedString]
-linesPS ps = splitPS '\n' ps
-
-wordsPS :: PackedString -> [PackedString]
-wordsPS ps = splitWithPS isSpace ps
-
-reversePS :: PackedString -> PackedString
-reversePS ps =
- if nullPS ps then -- don't create stuff unnecessarily.
- ps
- else
- runST (
- new_ps_array (length +# 1#) >>= \ arr# -> -- incl NUL byte!
- fill_in arr# (length -# 1#) 0# >>
- freeze_ps_array arr# length >>= \ (ByteArray _ _ frozen#) ->
- let has_null = byteArrayHasNUL# frozen# length in
- return (PS frozen# length has_null))
- where
- length = lengthPS# ps
-
- fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
- fill_in arr_in# n i =
- let
- ch = indexPS# ps n
- in
- write_ps_array arr_in# i ch >>
- if n ==# 0# then
- write_ps_array arr_in# (i +# 1#) (chr# 0#) >>
- return ()
- else
- fill_in arr_in# (n -# 1#) (i +# 1#)
-
-concatPS :: [PackedString] -> PackedString
-concatPS [] = nilPS
-concatPS pss
- = let
- tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x }
- in
- runST (
- new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte!
- packum arr# pss 0# >>
- freeze_ps_array arr# tot_len# >>= \ (ByteArray _ _ frozen#) ->
-
- let has_null = byteArrayHasNUL# frozen# tot_len# in
-
- return (PS frozen# tot_len# has_null)
- )
- where
- packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s ()
-
- packum arr [] pos
- = write_ps_array arr pos (chr# 0#) >>
- return ()
- packum arr (ps : pss) pos
- = fill arr pos ps 0# (lengthPS# ps) >>= \ (I# next_pos) ->
- packum arr pss next_pos
-
- fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int
-
- fill arr arr_i ps ps_i ps_len
- | ps_i ==# ps_len
- = return (I# (arr_i +# ps_len))
- | otherwise
- = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >>
- fill arr arr_i ps (ps_i +# 1#) ps_len
-
-------------------------------------------------------------
-joinPS :: PackedString -> [PackedString] -> PackedString
-joinPS filler pss = concatPS (splice pss)
- where
- splice [] = []
- splice [x] = [x]
- splice (x:y:xs) = x:filler:splice (y:xs)
-
--- ToDo: the obvious generalisation
-{-
- Some properties that hold:
-
- * splitPS x ls = ls'
- where False = any (map (x `elemPS`) ls')
- False = any (map (nullPS) ls')
-
- * all x's have been chopped out.
- * no empty PackedStrings in returned list. A conseq.
- of this is:
- splitPS x nilPS = []
-
-
- * joinPS (packString [x]) (_splitPS x ls) = ls
-
--}
-
-splitPS :: Char -> PackedString -> [PackedString]
-splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch)
-
-splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
-splitWithPS pred ps =
- splitify 0#
- where
- len = lengthPS# ps
-
- splitify n
- | n >=# len = []
- | otherwise =
- let
- break_pt =
- first_char_pos_that_satisfies
- (\ c -> pred (C# c))
- ps
- len
- n
- in
- if break_pt ==# n then -- immediate match, no substring to cut out.
- splitify (break_pt +# 1#)
- else
- substrPS# ps n (break_pt -# 1#): -- leave out the matching character
- splitify (break_pt +# 1#)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Local utility functions}
-%* *
-%************************************************************************
-
-The definition of @_substrPS@ is essentially:
-@take (end - begin + 1) (drop begin str)@.
-
-\begin{code}
-substrPS :: PackedString -> Int -> Int -> PackedString
-substrPS ps (I# begin) (I# end) = substrPS# ps begin end
-
-substrPS# :: PackedString -> Int# -> Int# -> PackedString
-substrPS# ps s e
- | s <# 0# || e <# s
- = error "substrPS: bounds out of range"
-
- | s >=# len || result_len# <=# 0#
- = nilPS
-
- | otherwise
- = runST (
- new_ps_array (result_len# +# 1#) >>= \ ch_arr -> -- incl NUL byte!
- fill_in ch_arr 0# >>
- freeze_ps_array ch_arr result_len# >>= \ (ByteArray _ _ frozen#) ->
-
- let has_null = byteArrayHasNUL# frozen# result_len# in
-
- return (PS frozen# result_len# has_null)
- )
- where
- len = lengthPS# ps
-
- result_len# = (if e <# len then (e +# 1#) else len) -# s
-
- -----------------------
- fill_in :: MutableByteArray s Int -> Int# -> ST s ()
-
- fill_in arr_in# idx
- | idx ==# result_len#
- = write_ps_array arr_in# idx (chr# 0#) >>
- return ()
- | otherwise
- = let
- ch = indexPS# ps (s +# idx)
- in
- write_ps_array arr_in# idx ch >>
- fill_in arr_in# (idx +# 1#)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Packing and unpacking C strings}
-%* *
-%*********************************************************
-
-\begin{code}
-cStringToPS :: Addr -> PackedString
-cStringToPS (A# a#) = -- the easy one; we just believe the caller
- CPS a# len
- where
- len = case (strlen# a#) of { I# x -> x }
-
-packCBytes :: Int -> Addr -> PackedString
-packCBytes len addr = runST (packCBytesST len addr)
-
-packCBytesST :: Int -> Addr -> ST s PackedString
-packCBytesST (I# length#) (A# addr) =
- {-
- allocate an array that will hold the string
- (not forgetting the NUL byte at the end)
- -}
- new_ps_array (length# +# 1#) >>= \ ch_array ->
- -- fill in packed string from "addr"
- fill_in ch_array 0# >>
- -- freeze the puppy:
- freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) ->
- let has_null = byteArrayHasNUL# frozen# length# in
- return (PS frozen# length# has_null)
- where
- fill_in :: MutableByteArray s Int -> Int# -> ST s ()
-
- fill_in arr_in# idx
- | idx ==# length#
- = write_ps_array arr_in# idx (chr# 0#) >>
- return ()
- | otherwise
- = case (indexCharOffAddr# addr idx) of { ch ->
- write_ps_array arr_in# idx ch >>
- fill_in arr_in# (idx +# 1#) }
-
-\end{code}
+++ /dev/null
-
- A C printf like formatter.
- Conversion specs:
- - left adjust
- num field width
- * as num, but taken from argument list
- . separates width from precision
- Formatting characters:
- c Char, Int, Integer
- d Char, Int, Integer
- o Char, Int, Integer
- x Char, Int, Integer
- u Char, Int, Integer
- f Float, Double
- g Float, Double
- e Float, Double
- s String
-
-\begin{code}
-module Printf(UPrintf(..), printf) where
-
-import Char ( isDigit ) -- 1.3
-import Array ( array, (!) ) -- 1.3
-
-
-#if defined(__HBC__)
-import LMLfmtf
-#endif
-
-#if defined(__YALE_HASKELL__)
-import PrintfPrims
-#endif
-
-#if defined(__GLASGOW_HASKELL__)
-import GlaExts
-import PrelArr (Array(..), ByteArray(..))
-import PrelBase
-#endif
-
-data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double
-
-printf :: String -> [UPrintf] -> String
-printf "" [] = ""
-printf "" (_:_) = fmterr
-printf ('%':'%':cs) us = '%':printf cs us
-printf ('%':_) [] = argerr
-printf ('%':cs) us@(_:_) = fmt cs us
-printf (c:cs) us = c:printf cs us
-
-fmt :: String -> [UPrintf] -> String
-fmt cs us =
- let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us
- adjust (pre, str) =
- let lstr = length str
- lpre = length pre
- fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
- in if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
- in
- case cs' of
- [] -> fmterr
- c:cs'' ->
- case us' of
- [] -> argerr
- u:us'' ->
- (case c of
- 'c' -> adjust ("", [chr (toint u)])
- 'd' -> adjust (fmti u)
- 'x' -> adjust ("", fmtu 16 u)
- 'o' -> adjust ("", fmtu 8 u)
- 'u' -> adjust ("", fmtu 10 u)
-#if defined __YALE_HASKELL__
- 'e' -> adjust (fmte prec (todbl u))
- 'f' -> adjust (fmtf prec (todbl u))
- 'g' -> adjust (fmtg prec (todbl u))
-#else
- 'e' -> adjust (dfmt c prec (todbl u))
- 'f' -> adjust (dfmt c prec (todbl u))
- 'g' -> adjust (dfmt c prec (todbl u))
-#endif
- 's' -> adjust ("", tostr u)
- c -> perror ("bad formatting char " ++ [c])
- ) ++ printf cs'' us''
-
-fmti (UInt i) = if i < 0 then
- if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
- else
- ("", itos i)
-fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
-fmti (UChar c) = fmti (UInt (ord c))
-fmti u = baderr
-
-fmtu b (UInt i) = if i < 0 then
- if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
- else
- itosb b (toInteger i)
-fmtu b (UInteger i) = itosb b i
-fmtu b (UChar c) = itosb b (toInteger (ord c))
-fmtu b u = baderr
-
-maxi :: Integer
-maxi = (toInteger (maxBound::Int) + 1) * 2
-
-toint (UInt i) = i
-toint (UInteger i) = toInt i
-toint (UChar c) = ord c
-toint u = baderr
-
-tostr (UString s) = s
-tostr u = baderr
-
-todbl (UDouble d) = d
-#if defined(__GLASGOW_HASKELL__)
-todbl (UFloat (F# f)) = D# (float2Double# f) -- What a great system(TM) !
-#else
-todbl (UFloat f) = fromRational (toRational f)
-#endif
-todbl u = baderr
-
-itos n =
- if n < 10 then
- [chr (ord '0' + toInt n)]
- else
- let (q, r) = quotRem n 10 in
- itos q ++ [chr (ord '0' + toInt r)]
-
-chars :: Array Int Char
-chars = array (0,15) (zipWith (\x y -> (x,y)) [0..] "0123456789abcdef")
-
-itosb :: Integer -> Integer -> String
-itosb b n =
- if n < b then
- [chars ! fromInteger n]
- else
- let (q, r) = quotRem n b in
- itosb b q ++ [chars ! fromInteger r]
-
-stoi :: Int -> String -> (Int, String)
-stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '0') cs
-stoi a cs = (a, cs)
-
-getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
-getSpecs l z ('-':cs) us = getSpecs True z cs us
-getSpecs l z ('0':cs) us = getSpecs l True cs us
-getSpecs l z ('*':cs) us =
- case us of
- [] -> argerr
- nu : us' ->
- let n = toint nu
- (p, cs'', us'') =
- case cs of
- '.':'*':r -> case us' of { [] -> argerr; pu:us'' -> (toint pu, r, us'') }
- '.':r -> let (n, cs') = stoi 0 r in (n, cs', us')
- _ -> (-1, cs, us')
- in (n, p, l, z, cs'', us'')
-getSpecs l z cs@(c:_) us | isDigit c =
- let (n, cs') = stoi 0 cs
- (p, cs'') = case cs' of
- '.':r -> stoi 0 r
- _ -> (-1, cs')
- in (n, p, l, z, cs'', us)
-getSpecs l z cs us = (0, -1, l, z, cs, us)
-
-#if !defined(__YALE_HASKELL__)
-dfmt :: Char -> Int -> Double -> (String, String)
-#endif
-
-#if defined(__GLASGOW_HASKELL__)
-dfmt c{-e,f, or g-} prec d
- = unsafePerformIO (
- stToIO (newCharArray (0 :: Int, 511)){-pathetic malloc-}
- >>= \ sprintf_here ->
- let
- sprintf_fmt = "%1" ++ (if prec < 0 then "" else '.':itos prec) ++ [c]
- in
- _ccall_ sprintf sprintf_here sprintf_fmt d >>
- stToIO (freezeCharArray sprintf_here) >>= \ (ByteArray _ _ arr#) ->
- let
- unpack :: Int# -> [Char]
- unpack nh = case (ord# (indexCharArray# arr# nh)) of
- 0# -> []
- ch -> case (nh +# 1#) of
- mh -> C# (chr# ch) : unpack mh
- in
- return (
- case (indexCharArray# arr# 0#) of
- '-'# -> ("-", unpack 1#)
- _ -> ("" , unpack 0#)
- )
- )
-#endif
-
-#if defined(__HBC__)
-dfmt c p d =
- case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of
- '-':cs -> ("-", cs)
- cs -> ("" , cs)
-#endif
-
-#if defined(__YALE_HASKELL__)
-fmte p d =
- case (primFmte p d) of
- '-':cs -> ("-",cs)
- cs -> ("",cs)
-fmtf p d =
- case (primFmtf p d) of
- '-':cs -> ("-",cs)
- cs -> ("",cs)
-fmtg p d =
- case (primFmtg p d) of
- '-':cs -> ("-",cs)
- cs -> ("",cs)
-#endif
-
-perror s = error ("Printf.printf: "++s)
-fmterr = perror "formatting string ended prematurely"
-argerr = perror "argument list ended prematurely"
-baderr = perror "bad argument"
-
-#if defined(__YALE_HASKELL__)
--- This is needed because standard Haskell does not have toInt
-
-toInt :: Integral a => a -> Int
-toInt x = fromIntegral x
-#endif
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
-%
-\section[Readline]{GNU Readline Library Bindings}
-
-This module attempts to provide a better line based editing facility
-for Haskell programmers by providing access to the GNU Readline
-library. Related to this are bindings for the GNU History library
-which can be found in History (at some point in the future :-).
-
-Original version by Darren Moffat
-Heavily modified in 1999 by Sven Panne <Sven.Panne@informatik.uni-muenchen.de>
-
-Notes:
-
- * This binding is still *very* incomplete... Volunteers?
-
- * The GHC User's Guide section on Readline is not up-to-date anymore,
- the flags you need are: -syslib misc -syslib posix -lreadline -ltermcap
- (or -lncurses on some Linux systems)
-
-\begin{code}
-{-# OPTIONS -#include <readline/readline.h> -#include <readline/history.h> #-}
-
-module Readline (
- rlInitialize,
- readline, addHistory,
-
- rlBindKey, rlAddDefun,
- RlCallbackFunction,
-
- rlGetLineBuffer, rlSetLineBuffer,
- rlGetPoint, rlSetPoint,
- rlGetEnd, rlSetEnd,
- rlGetMark, rlSetMark,
- rlSetDone,
- rlPendingInput,
-
- rlPrompt, rlTerminalName,
- rlGetReadlineName, rlSetReadlineName,
-
- rlInStream, rlOutStream
- ) where
-
-import Addr(Addr)
-import ByteArray(ByteArray)
-import Char(ord, chr)
-import CString(packString, unpackCStringIO)
-import IO(Handle)
-import IOExts(IORef, newIORef, readIORef, writeIORef, unsafePerformIO, freeHaskellFunctionPtr)
-import Maybe(fromMaybe)
-import Monad(when)
-import Posix(intToFd, fdToHandle)
-import System(getProgName)
-
--- SUP: Haskell has closures and I've got no clue about the return value,
--- so a better type for the callbacks is probably
--- Int {- Numeric Arg -} -> IO ()
-
-type KeyCode = Char
-
-type RlCallbackFunction =
- (Int -> -- Numeric Argument
- KeyCode -> -- KeyCode of pressed Key
- IO Int) -- What's this?
-\end{code}
-
-%***************************************************************************
-%* *
-\subsection[Readline-Functions]{Main Readline Functions}
-%* *
-%***************************************************************************
-\begin{code}
-
-rlInitialize :: IO ()
-rlInitialize = rlSetReadlineName =<< getProgName
-
-foreign import "free" unsafe free :: Addr -> IO ()
-foreign import "readline" unsafe readlineAux :: ByteArray Int -> IO Addr
-
-readline :: String -- Prompt String
- -> IO (Maybe String) -- Just returned line or Nothing if EOF
-readline prompt = do
- cstr <- readlineAux (packString prompt)
- if cstr == ``NULL''
- then return Nothing
- else do str <- unpackCStringIO cstr
- free cstr
- return (Just str)
-
-foreign import "add_history" unsafe add_history :: ByteArray Int -> IO ()
-
-addHistory :: String -- String to enter in history
- -> IO ()
-addHistory = add_history . packString
-
-
-foreign export dynamic mkRlCallback :: (Int -> Int -> IO Int) -> IO Addr
-foreign import "rl_bind_key" rl_bind_key :: Int -> Addr -> IO Int
-
-rlBindKey :: KeyCode -- Key to Bind to
- -> RlCallbackFunction -- Function to exec on execution
- -> IO ()
-rlBindKey key cback = do
- cbAddr <- mkRlCallback (\n k -> cback n (chr k))
- ok <- rl_bind_key (ord key) cbAddr
- if ok /= 0 then wrongKeyCode else addCbackEntry key cbAddr
-
-foreign import "rl_add_defun" unsafe rl_add_defun :: ByteArray Int -> Addr -> Int -> IO Int
-
-rlAddDefun :: String -> -- Function Name
- RlCallbackFunction -> -- Function to call
- Maybe KeyCode -> -- Key to bind to
- IO ()
-rlAddDefun name cback mbKey = do
- cbAddr <- mkRlCallback (\n k -> cback n (chr k))
- ok <- rl_add_defun (packString name) cbAddr (maybe (-1) ord mbKey)
- when (ok /= 0) wrongKeyCode
-
--- Don't know how this should ever happen with KeyCode = Char
-wrongKeyCode :: IO ()
-wrongKeyCode = ioError (userError "Invalid ASCII Key Code, must be in range 0..255")
-
--- Global hacking for freeing callbacks
-
-theCbackTable :: IORef [(KeyCode,Addr)]
-theCbackTable = unsafePerformIO (newIORef [])
-
-addCbackEntry :: KeyCode -> Addr -> IO ()
-addCbackEntry key cbAddr = do
- cbackTable <- readIORef theCbackTable
- maybe (return ()) freeHaskellFunctionPtr (lookup key cbackTable)
- writeIORef theCbackTable
- ((key,cbAddr) : [ entry | entry@(k,_) <- cbackTable, k /= key ])
-
-\end{code}
-
-
-%***************************************************************************
-%* *
-\subsection[Readline-Globals]{Global Readline Variables}
-%* *
-%***************************************************************************
-
-These are the global variables required by the readline lib. Need to
-find a way of making these read/write from the Haskell side. Should
-they be in the IO Monad, should they be Mutable Variables?
-
-\begin{code}
-
-rlGetLineBuffer :: IO String
-rlGetLineBuffer = unpackCStringIO =<< _casm_ ``%r = rl_line_buffer;''
-
-rlSetLineBuffer :: String -> IO ()
-rlSetLineBuffer str = _casm_ ``rl_line_buffer = %0;'' str
-
-rlGetPoint :: IO Int
-rlGetPoint = _casm_ ``%r = rl_point;''
-
-rlSetPoint :: Int -> IO ()
-rlSetPoint point = _casm_ ``rl_point = %0;'' point
-
-rlGetEnd :: IO Int
-rlGetEnd = _casm_ ``%r = rl_end;''
-
-rlSetEnd :: Int -> IO ()
-rlSetEnd end = _casm_ ``rl_end = %0;'' end
-
-rlGetMark :: IO Int
-rlGetMark = _casm_ ``%r = rl_mark;''
-
-rlSetMark :: Int -> IO ()
-rlSetMark mark = _casm_ ``rl_mark = %0;'' mark
-
-rlSetDone :: Bool -> IO ()
-rlSetDone False = _casm_ ``rl_done = %0;'' (0::Int)
-rlSetDone True = _casm_ ``rl_done = %0;'' (1::Int)
-
-rlPendingInput :: KeyCode -> IO ()
-rlPendingInput key = _casm_ ``rl_pending_input = %0;'' key
-
-rlPrompt :: IO String
-rlPrompt = unpackCStringIO =<< _casm_ ``%r = rl_readline_name;''
-
-rlTerminalName :: IO String
-rlTerminalName = unpackCStringIO =<< _casm_ ``%r = rl_terminal_name;''
-
-rlGetReadlineName :: IO String
-rlGetReadlineName = unpackCStringIO =<< _casm_ ``%r = rl_readline_name;''
-
-rlSetReadlineName :: String -> IO ()
-rlSetReadlineName str = _casm_ ``rl_readline_name = %0;'' str
-
-rlInStream :: Handle
-rlInStream = unsafePerformIO (fdToHandle (intToFd ``fileno(rl_instream)''))
-
-rlOutStream :: Handle
-rlOutStream = unsafePerformIO (fdToHandle (intToFd ``fileno(rl_outstream)''))
-
-\end{code}
-
-A simple test:
-
-main :: IO ()
-main = do rlInitialize
- rlBindKey '\^X' (\nargc kc -> do print (nargc,kc); return 0)
- loop
- where loop = maybe (putStrLn "Qapla'!")
- (\reply -> do unless (null reply) (addHistory reply)
- putStrLn (reply ++ "... pItlh!")
- loop) =<< readline "nuqneH, ghunwI'? "
+++ /dev/null
-\section[regex]{Haskell binding to the GNU regex library}
-
-What follows is a straightforward binding to the functions
-provided by the GNU regex library (the GNU group of functions with Perl
-like syntax)
-
-\begin{code}
-{-# OPTIONS -#include "cbits/ghcRegex.h" #-}
-
-module Regex (
- PatBuffer(..),
- re_compile_pattern,
- re_match,
- re_search,
- re_match2,
- re_search2,
-
- REmatch(..)
- ) where
-
-import GlaExts
-import CCall
-import PackedString
-import Array ( array, bounds, (!) )
-import PrelArr ( MutableByteArray(..), Array(..) )
-import PrelGHC ( MutableByteArray# )
-import Char ( ord )
-import Foreign
-
-\end{code}
-
-First, the higher level matching structure that the functions herein
-return:
-\begin{code}
---
--- GroupBounds hold the interval where a group
--- matched inside a string, e.g.
---
--- matching "reg(exp)" "a regexp" returns the pair (5,7) for the
--- (exp) group. (PackedString indices start from 0)
-
-type GroupBounds = (Int, Int)
-
-data REmatch
- = REmatch (Array Int GroupBounds) -- for $1, ... $n
- GroupBounds -- for $` (everything before match)
- GroupBounds -- for $& (entire matched string)
- GroupBounds -- for $' (everything after)
- GroupBounds -- for $+ (matched by last bracket)
-\end{code}
-
-Prior to any matching (or searching), the regular expression
-have to compiled into an internal form, the pattern buffer.
-Represent the pattern buffer as a Haskell heap object:
-
-\begin{code}
-data PatBuffer = PatBuffer# (MutableByteArray# RealWorld)
-instance CCallable PatBuffer
-instance CReturnable PatBuffer
-
-createPatBuffer :: Bool -> IO PatBuffer
-
-createPatBuffer insensitive
- = _casm_ ``%r = (int)sizeof(struct re_pattern_buffer);'' >>= \ sz ->
- stToIO (newCharArray (0::Int,sz)) >>= \ (MutableByteArray _ _ pbuf#) ->
- let
- pbuf = PatBuffer# pbuf#
- in
- (if insensitive then
- {-
- See comment re: fastmap below
- -}
- ((_casm_ ``%r = (char *)malloc(256*sizeof(char));'')::IO Addr) >>= \ tmap ->
- {-
- Set up the translate table so that any lowercase
- char. gets mapped to an uppercase one. Beacuse quoting
- inside CAsmStrings is Problematic, we pass in the ordinal values
- of 'a','z' and 'A'
- -}
- _casm_ ``{ int i;
-
- for(i=0; i<256; i++)
- ((char *)%0)[i] = (char)i;
- for(i=(int)%1;i <=(int)%2;i++)
- ((char *)%0)[i] = i - ((int)%1 - (int)%3);
- }'' tmap (ord 'a') (ord 'z') (ord 'A') >>
- _casm_ ``((struct re_pattern_buffer *)%0)->translate = %1; '' pbuf tmap
- else
- _casm_ ``((struct re_pattern_buffer *)%0)->translate = 0; '' pbuf) >>
- {-
- Use a fastmap to speed things up, would like to have the fastmap
- in the Haskell heap, but it will get GCed before we can say regexp,
- as the reference to it is buried inside a ByteArray :-(
- -}
- ((_casm_ ``%r = (char *)malloc(256*sizeof(char));'')::IO Addr) >>= \ fmap ->
- _casm_ `` ((struct re_pattern_buffer *)%0)->fastmap = %1; '' pbuf fmap >>
- {-
- We want the compiler of the pattern to alloc. memory
- for the pattern.
- -}
- _casm_ `` ((struct re_pattern_buffer *)%0)->buffer = 0; '' pbuf >>
- _casm_ `` ((struct re_pattern_buffer *)%0)->allocated = 0; '' pbuf >>
- return pbuf
-\end{code}
-
-@re_compile_pattern@ converts a regular expression into a pattern buffer,
-GNU style.
-
-Q: should we lift the syntax bits configuration up to the Haskell
-programmer level ?
-
-\begin{code}
-re_compile_pattern :: PackedString -- pattern to compile
- -> Bool -- True <=> assume single-line mode
- -> Bool -- True <=> case-insensitive
- -> IO PatBuffer
-
-re_compile_pattern str single_line_mode insensitive
- = createPatBuffer insensitive >>= \ pbuf ->
- (if single_line_mode then -- match a multi-line buffer
- _casm_ ``re_syntax_options = RE_PERL_SINGLELINE_SYNTAX;''
- else
- _casm_ ``re_syntax_options = RE_PERL_MULTILINE_SYNTAX;'') >>
-
- _casm_ `` (int)re_compile_pattern((char *)%0,
- (int)%1,
- (struct re_pattern_buffer *)%2);''
- (unpackPS str) (lengthPS str) pbuf >>= \ () ->
- --
- -- No checking for how the compilation of the pattern went yet.
- --
- return pbuf
-\end{code}
-
-Got a match?
-
-Each call to re_match uses a new re_registers structures, so we need
-to ask the regex library to allocate enough memory to store the
-registers in each time. That's what the line '... REGS_UNALLOCATED'
-is all about.
-
-\begin{code}
-re_match :: PatBuffer -- compiled regexp
- -> PackedString -- string to match
- -> Int -- start position
- -> Bool -- True <=> record results in registers
- -> IO (Maybe REmatch)
-
-re_match pbuf str start reg
- = ((if reg then -- record result of match in registers
- _casm_ ``%r = (struct re_registers *)malloc(sizeof(struct re_registers *));''
- else
- _casm_ ``%r = (struct re_registers *)NULL;'')::IO Addr) >>= \ regs ->
- _casm_ ``((struct re_pattern_buffer *)%0)->regs_allocated = REGS_UNALLOCATED;
- %r=(int)re_match((struct re_pattern_buffer *)%0,
- (char *)%1,
- (int)%2,
- (int)%3,
- (struct re_registers *)%4);'' pbuf
- (unpackPS str)
- (lengthPS str)
- start
- regs >>= \ match_res ->
- if match_res == ((-2)::Int) then
- error "re_match: Internal error"
- else if match_res < 0 then
- _casm_ ``free((struct re_registers *)%0); '' regs >>
- return Nothing
- else
- build_re_match start (lengthPS str) regs >>= \ arr ->
- _casm_ ``free(((struct re_registers *)%0)->start);
- free(((struct re_registers *)%0)->end);
- free((struct re_registers *)%0); '' regs >>
- return (Just arr)
-\end{code}
-
-Matching on 2 strings is useful when you're dealing with multiple
-buffers, which is something that could prove useful for PackedStrings,
-as we don't want to stuff the contents of a file into one massive heap
-chunk, but load (smaller chunks) on demand.
-
-\begin{code}
-re_match2 :: PatBuffer
- -> PackedString
- -> PackedString
- -> Int
- -> Int
- -> Bool
- -> IO (Maybe REmatch)
-
-re_match2 pbuf str1 str2 start stop reg
- = ((if reg then -- record result of match in registers
- _casm_ ``%r = (struct re_registers *)malloc(sizeof(struct re_registers *));''
- else
- _casm_ ``%r = (struct re_registers *)NULL;'')::IO Addr) >>= \ regs ->
- _casm_ ``%r=(int)re_match_2((struct re_pattern_buffer *)%0,
- (char *)%1,
- (int)%2,
- (char *)%3,
- (int)%4,
- (int)%5,
- (struct re_registers *)%6,
- (int)%7);'' pbuf
- (unpackPS str1)
- (lengthPS str1)
- (unpackPS str2)
- (lengthPS str2)
- start
- regs
- stop >>= \ match_res ->
- if match_res == ((-2)::Int) then
- error "re_match2: Internal error"
- else if match_res < 0 then
- _casm_ ``free((struct re_registers *)%0); '' regs >>
- return Nothing
- else
- build_re_match start stop regs >>= \ arr ->
- _casm_ ``free((struct re_registers *)%0); '' regs >>
- return (Just arr)
-\end{code}
-
-Find all the matches in a string:
-\begin{code}
-re_search :: PatBuffer -- the compiled regexp
- -> PackedString -- the string to search
- -> Int -- start index
- -> Int -- stop index
- -> Bool -- record result of match in registers
- -> IO (Maybe REmatch)
-
-re_search pbuf str start range reg
- = (if reg then -- record result of match in registers
- _casm_ ``%r = (struct re_registers *)malloc(sizeof(struct re_registers *));''
- else
- _casm_ ``%r = (struct re_registers *)NULL;'') >>= \ regs ->
- _casm_ ``((struct re_pattern_buffer *)%0)->regs_allocated = REGS_UNALLOCATED;
- %r=(int)re_search((struct re_pattern_buffer *)%0,
- (char *)%1,
- (int)%2,
- (int)%3,
- (int)%4,
- (struct re_registers *)%5);'' pbuf
- (unpackPS str)
- (lengthPS str)
- start
- range
- regs >>= \ match_res ->
- if match_res== ((-1)::Int) then
- _casm_ `` free((struct re_registers *)%0); '' regs >>
- return Nothing
- else
- let
- (st,en) = if range > start then
- (start,range)
- else
- (range,start)
- in
- build_re_match st en regs >>= \ arr ->
- _casm_ ``free(((struct re_registers *)%0)->start);
- free(((struct re_registers *)%0)->end);
- free((struct re_registers *)%0); '' regs >>
- return (Just arr)
-\end{code}
-
-Double buffer search:
-\begin{code}
-re_search2 :: PatBuffer
- -> PackedString
- -> PackedString
- -> Int
- -> Int
- -> Int
- -> Bool
- -> IO (Maybe REmatch)
-
-re_search2 pbuf str1 str2 start range stop reg
-
- = (if reg then -- record result of match in registers
- _casm_ ``%r = (struct re_registers *)malloc(sizeof(struct re_registers *));''
- else
- _casm_ ``%r = (struct re_registers *)NULL;'') >>= \ regs ->
- _casm_ ``%r=(int)re_search_2((struct re_pattern_buffer *)%0,
- (char *)%1,
- (int)%2,
- (char *)%3,
- (int)%4,
- (int)%5,
- (int)%6,
- (struct re_registers *)%7,
- (int)%8);'' pbuf
- (unpackPS str1)
- (lengthPS str1)
- (unpackPS str2)
- (lengthPS str2)
- start
- range
- regs
- stop >>= \ match_res ->
- if match_res== ((-1)::Int) then
- _casm_ `` free((struct re_registers *)%0); '' regs >>
- return Nothing
- else
- let
- (st,en) = if range > start then
- (start,range)
- else
- (range,start)
- in
- build_re_match st en regs >>= \ arr ->
- _casm_ `` free((struct re_registers *)%0); '' regs >>
- return (Just arr)
-\end{code}
-
-\begin{code}
-build_re_match :: Int
- -> Int
- -> Addr
- -> IO REmatch
-
-build_re_match str_start str_end regs
- = _casm_ ``%r=(int)(*(struct re_registers *)%0).num_regs;'' regs >>= \ len ->
- match_reg_to_array regs len >>= \ (match_start,match_end,arr) ->
- let
- (1,x) = bounds arr
-
- bef = (str_start,match_start) -- $'
- aft = (match_end,str_end) -- $`
- lst = arr!x -- $+
- mtch = (match_start,match_end) -- $&
- in
- return (REmatch arr
- bef
- mtch
- aft
- lst)
- where
- match_reg_to_array rs len
- = trundleIO rs (0,[]) len >>= \ (no,ls) ->
- let
- (st,end,ls')
- = case ls of
- [] -> (0,0,[])
- [(a,b)] -> (a,b,ls)
- ((a,b):xs) -> (a,b,xs)
- in
- return
- (st,
- end,
- array (1,max 1 (no-1))
- [ (i, x) | (i,x) <- zip [1..] ls'])
-
- trundleIO :: Addr
- -> (Int,[(Int,Int)])
- -> Int
- -> IO (Int,[(Int,Int)])
-
- trundleIO rs (i,acc) len
- | i==len = return (i,reverse acc)
- | otherwise
- = _casm_ ``%r = (int)(((struct re_registers *)%0)->start)[(int)%1];'' rs i >>= \ start ->
- _casm_ ``%r = (int)(((struct re_registers *)%0)->end)[(int)%1];'' rs i >>= \ end ->
- let
- acc' = (start,end):acc
- in
- if (start == (-1)) && (end == (-1)) then
- return (i,reverse acc)
- else
- trundleIO rs (i+1,acc') len
-\end{code}
-
+++ /dev/null
------------------------------------------------------------------------------
-RegexString.lhs
-
-A simple high-level interface to Regex
-
-(c) Simon Marlow 1997
------------------------------------------------------------------------------
-
-> module RegexString (Regex(..), mkRegex, matchRegex) where
-
-> import Regex
-> import PackedString
-> import Array
-> import GlaExts
-
-> type Regex = PatBuffer
->
-> mkRegex :: String -> Regex
-> mkRegex s = unsafePerformPrimIO (
-> re_compile_pattern (packString s) False False)
->
-> matchRegex :: Regex -> String -> Maybe [String]
-> matchRegex p s = unsafePerformPrimIO (
-> re_match p str 0 True >>= \m ->
-> case m of
-> Nothing -> return Nothing
-> Just m -> return (Just (matches m str))
-> )
-> where
-> str = packString s
->
-> matches (REmatch arr _ _ _ _) s =
-> [ unpackPS (substrPS s beg (end-1)) |
-> index <- [1..], let (beg,end) = arr ! index ]
+++ /dev/null
-%
-% (c) sof, 1999
-%
-
-Haskell wrapper for select() OS functionality. It's use
-shouldn't be all that common in a Haskell system that implements
-IO in such a way that's thread friendly, but still.
-
-\begin{code}
-{-# OPTIONS -#include "cbits/selectFrom.h" #-}
-module Select
- (
- hSelect -- :: [Handle]
- -- -> [Handle]
- -- -> [Handle]
- -- -> TimeOut
- -- -> IO SelectResult
- , TimeOut(..) -- type _ = Maybe Int
- , SelectResult(..)
- ) where
-
-import Posix
-import GlaExts
-import IO
-import Monad
-import Maybe
-import PrelIOBase
-import PosixUtil (fdToInt)
-\end{code}
-
-This stuff should really be done using HDirect.
-
-\begin{code}
-type TimeOut
- = Maybe Int
- -- Nothing => wait indefinitely.
- -- Just x | x >= 0 => block waiting for 'x' micro seconds.
- -- | otherwise => block waiting for '-x' micro seconds.
-
-type SelectResult
- = ([Handle], [Handle], [Handle])
-
-hSelect :: [Handle] -- input/read handles
- -> [Handle] -- output/write handles
- -> [Handle] -- exceptional handles
- -> TimeOut
- -> IO SelectResult
-hSelect ins outs excps timeout = do
- ins_ <- mapM getFd ins
- outs_ <- mapM getFd outs
- excps_ <- mapM getFd excps
- (max_in, fds_ins) <- marshallFDs ins_
- (max_out, fds_outs) <- marshallFDs outs_
- (max_excp,fds_excps) <- marshallFDs excps_
- tout <- marshallTimeout timeout
- let max_fd = max_in `max` max_out `max` max_excp
- rc <- selectFrom__ fds_ins
- fds_outs
- fds_excps
- (max_fd+1) tout
- if (rc /= 0)
- then constructErrorAndFail "hSelect"
- else
- let
- -- thunk these so that we only pay unmarshalling costs if demanded.
- ins_ready = unsafePerformIO (getReadyOnes fds_ins ins_)
- outs_ready = unsafePerformIO (getReadyOnes fds_outs outs_)
- excps_ready = unsafePerformIO (getReadyOnes fds_outs outs_)
- in
- return (ins_ready, outs_ready, excps_ready)
-
-getFd :: Handle -> IO (Fd,Handle)
-getFd h = do
- f <- handleToFd h
- return (f,h)
-
-foreign import "selectFrom__" unsafe
- selectFrom__ :: ByteArray Int
- -> ByteArray Int
- -> ByteArray Int
- -> Int
- -> Int
- -> IO Int
-
-marshallTimeout :: Maybe Int -> IO Int
-marshallTimeout Nothing = return (-1)
-marshallTimeout (Just x) = return (abs x)
-
-getReadyOnes :: ByteArray Int -> [(Fd,Handle)] -> IO [Handle]
-getReadyOnes ba ls = do
- xs <- mapM isReady ls
- return (catMaybes xs)
- where
- isReady (f,h) = do
- let fi = fdToInt f
- flg <- is_fd_set ba fi
- if (flg /= 0) then
- return (Just h)
- else
- return Nothing
-
-marshallFDs :: [(Fd,Handle)] -> IO (Int, ByteArray Int)
-marshallFDs ls = do
- ba <- stToIO (newCharArray (0, sizeof_fd_set))
- fd_zero ba
- let
- fillIn acc (f,_) = do
- let fi = fdToInt f
- fd_set ba fi
- return (max acc fi)
- x <- foldM fillIn 0 ls
- ba <- stToIO (unsafeFreezeByteArray ba)
- return (x, ba)
-
-foreign import "is_fd_set__" unsafe
- is_fd_set :: ByteArray Int -> Int -> IO Int
-
-foreign import "fd_zero__" unsafe
- fd_zero :: MutableByteArray RealWorld Int -> IO ()
-
-foreign import "fd_set__" unsafe
- fd_set :: MutableByteArray RealWorld Int -> Int -> IO ()
-
-foreign import "sizeof_fd_set__" unsafe
- sizeof_fd_set :: Int
-
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[Set]{An implementation of sets}
-
-This new (94/04) implementation of sets sits squarely upon our
-implementation of @FiniteMaps@. The interface is (roughly?) as
-before.
-
-(95/08: This module is no longer part of the GHC compiler proper; it
-is now just a GHC library module).
-
-\begin{code}
-module Set (
- Set, -- abstract
- -- instance of: Eq
-
- emptySet, -- :: Set a
- mkSet, -- :: Ord a => [a] -> Set a
- setToList, -- :: Set a -> [a]
- unitSet, -- :: a -> Set a
- singletonSet, -- :: a -> Set a
-
- union, -- :: Ord a => Set a -> Set a -> Set a
- unionManySets, -- :: Ord a => [Set a] -> Set a
- minusSet, -- :: Ord a => Set a -> Set a -> Set a
- mapSet, -- :: Ord a => (b -> a) -> Set b -> Set a
- intersect, -- :: Ord a => Set a -> Set a -> Set a
-
- elementOf, -- :: Ord a => a -> Set a -> Bool
- isEmptySet, -- :: Set a -> Bool
-
- cardinality -- :: Set a -> Int
- ) where
-
-import FiniteMap
-import Maybe
-\end{code}
-
-\begin{code}
--- This can't be a type synonym if you want to use constructor classes.
-newtype Set a = MkSet (FiniteMap a ())
-
-emptySet :: Set a
-emptySet = MkSet emptyFM
-
-unitSet :: a -> Set a
-unitSet x = MkSet (unitFM x ())
-singletonSet = unitSet -- old;deprecated.
-
-setToList :: Set a -> [a]
-setToList (MkSet set) = keysFM set
-
-mkSet :: Ord a => [a] -> Set a
-mkSet xs = MkSet (listToFM [ (x, ()) | x <- xs])
-
-union :: Ord a => Set a -> Set a -> Set a
-union (MkSet set1) (MkSet set2) = MkSet (plusFM set1 set2)
-
-unionManySets :: Ord a => [Set a] -> Set a
-unionManySets ss = foldr union emptySet ss
-
-minusSet :: Ord a => Set a -> Set a -> Set a
-minusSet (MkSet set1) (MkSet set2) = MkSet (minusFM set1 set2)
-
-intersect :: Ord a => Set a -> Set a -> Set a
-intersect (MkSet set1) (MkSet set2) = MkSet (intersectFM set1 set2)
-
-elementOf :: Ord a => a -> Set a -> Bool
-elementOf x (MkSet set) = isJust (lookupFM set x)
-
-isEmptySet :: Set a -> Bool
-isEmptySet (MkSet set) = sizeFM set == 0
-
-mapSet :: Ord a => (b -> a) -> Set b -> Set a
-mapSet f (MkSet set) = MkSet (listToFM [ (f key, ()) | key <- keysFM set ])
-
-cardinality :: Set a -> Int
-cardinality (MkSet set) = sizeFM set
-
--- fair enough...
-instance (Eq a) => Eq (Set a) where
- (MkSet set_1) == (MkSet set_2) = set_1 == set_2
- (MkSet set_1) /= (MkSet set_2) = set_1 /= set_2
-
--- but not so clear what the right thing to do is:
-{- NO:
-instance (Ord a) => Ord (Set a) where
- (MkSet set_1) <= (MkSet set_2) = set_1 <= set_2
--}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-98
-%
-% Last Modified: Fri Jul 21 15:53:32 1995
-% Darren J Moffat <moffatd@dcs.gla.ac.uk>
-%
-% Further hacked on by Sigbjorn Finne <sof@dcs.gla.ac.uk>
-%
-\section[Socket]{Haskell 1.3 Socket bindings}
-
-
-\begin{code}
-{-# OPTIONS -#include "cbits/ghcSockets.h" #-}
-
-#include "config.h"
-
-module Socket (
- PortID(..),
- Hostname,
-
- connectTo, -- :: Hostname -> PortID -> IO Handle
- listenOn, -- :: PortID -> IO Socket
-
- accept, -- :: Socket -> IO (Handle, HostName)
-
- sendTo, -- :: Hostname -> PortID -> String -> IO ()
- recvFrom, -- :: Hostname -> PortID -> IO String
-
- socketPort, -- :: Socket -> IO PortID
-
- withSocketsDo, -- :: IO a -> IO a
-
- PortNumber,
- mkPortNumber -- :: Int -> PortNumber
-
- ) where
-
-import BSD
-import SocketPrim hiding ( accept, socketPort, recvFrom, sendTo )
-import qualified SocketPrim ( accept, socketPort )
-import IO
-\end{code}
-
-%***************************************************************************
-%* *
-\subsection[Socket-Setup]{High Level ``Setup'' functions}
-%* *
-%***************************************************************************
-
-Calling @connectTo@ creates a client side socket which is
-connected to the given host and port. The Protocol and socket type is
-derived from the given port identifier. If a port number is given
-then the result is always an internet family @Stream@ socket.
-
-If the @PortID@ specifies a unix family socket and the @Hostname@
-differs from that returned by @getHostname@ then an error is
-raised. Alternatively an empty string may be given to @connectTo@
-signalling that the current hostname applies.
-
-\begin{code}
-data PortID =
- Service String -- Service Name eg "ftp"
- | PortNumber PortNumber -- User defined Port Number
-#if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS)
- | UnixSocket String -- Unix family socket in file system
-#endif
-
-type Hostname = String
--- Maybe consider this alternative.
--- data Hostname = Name String | IP Int Int Int Int
-\end{code}
-
-If more control over the socket type is required then $socketPrim$
-should be used instead.
-
-\begin{code}
-connectTo :: Hostname -- Hostname
- -> PortID -- Port Identifier
- -> IO Handle -- Connected Socket
-
-connectTo hostname (Service serv) = do
- proto <- getProtocolNumber "tcp"
- sock <- socket AF_INET Stream proto
- port <- getServicePortNumber serv
- he <- getHostByName hostname
- connect sock (SockAddrInet port (hostAddress he))
- socketToHandle sock ReadWriteMode
-
-connectTo hostname (PortNumber port) = do
- proto <- getProtocolNumber "tcp"
- sock <- socket AF_INET Stream proto
- he <- getHostByName hostname
- connect sock (SockAddrInet port (hostAddress he))
- socketToHandle sock ReadWriteMode
-
-#if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS)
-connectTo _ (UnixSocket path) = do
- sock <- socket AF_UNIX Datagram 0
- connect sock (SockAddrUnix path)
- socketToHandle sock ReadWriteMode
-#endif
-
-\end{code}
-
-The dual to the @connectTo@ call. This creates the server side
-socket which has been bound to the specified port.
-
-\begin{code}
-listenOn :: PortID -- Port Identifier
- -> IO Socket -- Connected Socket
-
-listenOn (Service serv) = do
- proto <- getProtocolNumber "tcp"
- sock <- socket AF_INET Stream proto
- port <- getServicePortNumber serv
- bindSocket sock (SockAddrInet port iNADDR_ANY)
- listen sock maxListenQueue
- return sock
-
-listenOn (PortNumber port) = do
- proto <- getProtocolNumber "tcp"
- sock <- socket AF_INET Stream proto
- bindSocket sock (SockAddrInet port iNADDR_ANY)
- listen sock maxListenQueue
- return sock
-
-#if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS)
-listenOn (UnixSocket path) = do
- sock <- socket AF_UNIX Datagram 0
- bindSocket sock (SockAddrUnix path)
- return sock
-#endif
-\end{code}
-
-\begin{code}
-accept :: Socket -- Listening Socket
- -> IO (Handle, -- StdIO Handle for read/write
- HostName) -- HostName of Peer socket
-accept sock = do
- ~(sock', (SockAddrInet _ haddr)) <- SocketPrim.accept sock
- (HostEntry peer _ _ _) <- getHostByAddr AF_INET haddr
- handle <- socketToHandle sock' ReadWriteMode
- return (handle, peer)
-
-\end{code}
-
-Send and recived data from/to the given host and port number. These
-should normally only be used where the socket will not be required for
-further calls.
-
-Thse are wrappers around socket, bind, and listen.
-
-\begin{code}
-sendTo :: Hostname -- Hostname
- -> PortID -- Port Number
- -> String -- Message to send
- -> IO ()
-sendTo h p msg = do
- s <- connectTo h p
- hPutStr s msg
- hClose s
-
-recvFrom :: Hostname -- Hostname
- -> PortID -- Port Number
- -> IO String -- Received Data
-recvFrom host port = do
- s <- listenOn port
- let
- waiting = do
- ~(s', SockAddrInet _ haddr) <- SocketPrim.accept s
- (HostEntry peer _ _ _) <- getHostByAddr AF_INET haddr
- if peer /= host
- then do
- sClose s'
- waiting
- else do
- msg <- readSocketAll s'
- sClose s'
- return msg
-
- message <- waiting
- sClose s
- return message
-
-\end{code}
-
-Access function returning the port type/id of socket.
-
-\begin{code}
-socketPort :: Socket -> IO PortID
-socketPort s = do
- sockaddr <- getSocketName s
- return (portID sockaddr)
- where
- portID sa =
- case sa of
- SockAddrInet port _ -> PortNumber port
-#if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS)
- SockAddrUnix path -> UnixSocket path
-#endif
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1998
-%
-\section[SocketPrim]{Low-level socket bindings}
-
-The @SocketPrim@ module is for when you want full control over the
-sockets, exposing the C socket API.
-
-\begin{code}
-{-# OPTIONS -#include "stgio.h" -#include "cbits/ghcSockets.h" #-}
-
-#include "config.h"
-
-module SocketPrim (
-
- Socket,
- Family(..),
- SocketType(..),
- SockAddr(..),
- HostAddress,
- ShutdownCmd(..),
- ProtocolNumber,
-
- socket, -- :: Family -> SocketType -> ProtocolNumber -> IO Socket
- connect, -- :: Socket -> SockAddr -> IO ()
- bindSocket, -- :: Socket -> SockAddr -> IO ()
- listen, -- :: Socket -> Int -> IO ()
- accept, -- :: Socket -> IO (Socket, SockAddr)
- getPeerName, -- :: Socket -> IO SockAddr
- getSocketName, -- :: Socket -> IO SockAddr
-
- socketPort, -- :: Socket -> IO PortNumber
-
- writeSocket, -- :: Socket -> String -> IO Int
- readSocket, -- :: Socket -> Int -> IO (String, Int)
- readSocketAll, -- :: Socket -> IO String
-
- socketToHandle, -- :: Socket -> IO Handle
-
- sendTo, -- :: Socket -> String -> SockAddr -> IO Int
- recvFrom, -- :: Socket -> Int -> IO (String, Int, SockAddr)
--- sendmsg -- :: Socket -> Message -> MsgFlags -> IO Int
--- recvmsg -- :: Socket -> MsgFlags -> IO Message
-
-
- inet_addr, -- :: String -> IO HostAddress
- inet_ntoa, -- :: HostAddress -> IO String
-
- sIsConnected, -- :: Socket -> IO Bool
- sIsBound, -- :: Socket -> IO Bool
- sIsListening, -- :: Socket -> IO Bool
- sIsReadable, -- :: Socket -> IO Bool
- sIsWritable, -- :: Socket -> IO Bool
- shutdown, -- :: Socket -> ShutdownCmd -> IO ()
- sClose, -- :: Socket -> IO ()
-
- -- socket opts
- SocketOption(..),
- getSocketOption, -- :: Socket -> SocketOption -> IO Int
- setSocketOption, -- :: Socket -> SocketOption -> Int -> IO ()
-
- PortNumber(..),
- mkPortNumber, -- :: Int -> PortNumber
-
--- Special Constants
-
- aNY_PORT,
- iNADDR_ANY,
- sOMAXCONN,
- maxListenQueue,
-
-
--- The following are exported ONLY for use in the BSD module and
--- should not be used anywhere else.
-
- packFamily, unpackFamily,
- packSocketType,
- packSockAddr, unpackSockAddr
-
- , withSocketsDo -- :: IO a -> IO a
-
-) where
-
-import GlaExts
-import ST
-import Ix
-import Weak ( addForeignFinalizer )
-import PrelIOBase -- IOError, Handle representation
-import PrelHandle
-import PrelConc ( threadWaitRead, threadWaitWrite )
-import Foreign
-import Addr ( nullAddr )
-
-import IO
-import IOExts ( IORef, newIORef, readIORef, writeIORef )
-import CString ( unpackNBytesBAIO,
- unpackCStringIO,
- unpackCStringLenIO,
- allocChars
- )
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Socket-SocketTypes]{Socket Types}
-%* *
-%************************************************************************
-
-
-There are a few possible ways to do this. The first is convert the
-structs used in the C library into an equivalent Haskell type. An
-other possible implementation is to keep all the internals in the C
-code and use an Int\# and a status flag. The second method is used here
-since a lot of the C structures are not required to be manipulated.
-
-Originally the status was non-mutable so we had to return a new socket
-each time we changed the status. This version now uses mutable
-variables to avoid the need to do this. The result is a cleaner
-interface and better security since the application programmer now
-can't circumvent the status information to perform invalid operations
-on sockets.
-
-\begin{code}
-data SocketStatus
- -- Returned Status Function called
- = NotConnected -- socket
- | Bound -- bindSocket
- | Listening -- listen
- | Connected -- connect/accept
- | Error String -- Any
- deriving (Eq, Show)
-
-data Socket
- = MkSocket
- Int -- File Descriptor
- Family
- SocketType
- Int -- Protocol Number
- (IORef SocketStatus) -- Status Flag
-\end{code}
-
-The scheme used for addressing sockets is somewhat quirky. The
-calls in the BSD socket API that need to know the socket address all
-operate in terms of \tr{struct sockaddr}, a `virtual' type of socket address.
-
-The Internet family of sockets are addressed as \tr{struct sockaddr\_in},
-so when calling functions that operate on \tr{struct sockaddr}, we have
-to type cast the Internet socket address into a \tr{struct sockaddr}. By luck(!),
-the two structures are of the same size. Same casting is required of other
-families of sockets such as Xerox NS. Similarly for Unix domain sockets.
-
-To represent these socket addresses in Haskell-land, we do what BSD didn't do,
-and use a union/algebraic type for the different families. Currently only
-Unix domain sockets and the Internet family is supported.
-
-\begin{code}
-
--- NOTE: HostAddresses are represented in network byte order.
--- Functions that expect the address in machine byte order
--- will have to perform the necessary translation.
-type HostAddress = Word
-
---
--- newtyped to prevent accidental use of sane-looking
--- port numbers that haven't actually been converted to
--- network-byte-order first.
---
-newtype PortNumber = PNum Int -- 16-bit value stored in network byte order.
- deriving ( Eq )
-
-instance Show PortNumber where
- 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
-#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
- = SockAddrUnix -- struct sockaddr_un
- String -- sun_path
- | SockAddrInet -- struct sockaddr_in
- PortNumber -- sin_port (network byte order)
- HostAddress -- sin_addr (ditto)
-#else
- = SockAddrInet -- struct sockaddr_in
- PortNumber -- sin_port (network byte order)
- HostAddress -- sin_addr (ditto)
-
-#endif
- deriving Eq
-
-type ProtocolNumber = Int
-
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Socket-Connections]{Connection Functions}
-%* *
-%************************************************************************
-
-In the following connection and binding primitives. The names of the
-equivalent C functions have been preserved where possible. It should
-be noted that some of these names used in the C library, \tr{bind} in
-particular, have a different meaning to many Haskell programmers and
-have thus been renamed by appending the prefix Socket.
-
-Create an unconnected socket of the given family, type and protocol.
-The most common invocation of $socket$ is the following:
-
-\begin{verbatim}
- ...
- my_socket <- socket AF_INET Stream 6
- ...
-\end{verbatim}
-
-\begin{code}
-socket :: Family -- Family Name (usually AF_INET)
- -> SocketType -- Socket Type (usually Stream)
- -> ProtocolNumber -- Protocol Number (getProtocolByName to find value)
- -> IO Socket -- Unconnected Socket
-
-socket family stype protocol = do
- status <- _ccall_ createSocket (packFamily family)
- (packSocketType stype)
- protocol
- case (status::Int) of
- -1 -> constructErrorAndFail "socket"
- n -> do
- socket_status <- newIORef NotConnected
- return (MkSocket n family stype protocol socket_status)
-\end{code}
-
-Given a port number this {\em binds} the socket to that port. This
-means that the programmer is only interested in data being sent to
-that port number. The $Family$ passed to $bindSocket$ must
-be the same as that passed to $socket$. If the special port
-number $aNY\_PORT$ is passed then the system assigns the next
-available use port.
-
-Port numbers for standard unix services can be found by calling
-$getServiceEntry$. These are traditionally port numbers below
-1000; although there are afew, namely NFS and IRC, which used higher
-numbered ports.
-
-The port number allocated to a socket bound by using $aNY\_PORT$ can be
-found by calling $port$
-
-\begin{code}
-bindSocket :: Socket -- Unconnected Socket
- -> SockAddr -- Address to Bind to
- -> IO ()
-
-bindSocket (MkSocket s _family _stype _protocol socketStatus) addr = do
-#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
- let isDomainSocket = if _family == AF_UNIX then 1 else (0::Int)
-#else
- let isDomainSocket = 0
-#endif
- currentStatus <- readIORef socketStatus
- if currentStatus /= NotConnected
- then
- ioError (userError ("bindSocket: can't peform bind on socket in status " ++
- show currentStatus))
- else do
- addr' <- packSockAddr addr
- let (_,sz) = boundsOfMutableByteArray addr'
- status <- _ccall_ bindSocket s addr' sz (isDomainSocket::Int)
- case (status::Int) of
- -1 -> constructErrorAndFail "bindSocket"
- _ -> writeIORef socketStatus (Bound)
-\end{code}
-
-
-Make a connection to an already opened socket on a given machine and port.
-assumes that we have already called createSocket, otherwise it will fail.
-
-This is the dual to $bindSocket$. The {\em server} process will
-usually bind to a port number, the {\em client} will then connect to
-the same port number. Port numbers of user applications are normally
-agreed in advance, otherwise we must rely on some meta protocol for telling
-the other side what port number we have been allocated.
-
-\begin{code}
-connect :: Socket -- Unconnected Socket
- -> SockAddr -- Socket address stuff
- -> IO ()
-
-connect (MkSocket s _family _stype _protocol socketStatus) addr = do
-#if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS)
- let isDomainSocket = if _family == AF_UNIX then 1 else (0::Int)
-#else
- let isDomainSocket = 0
-#endif
- currentStatus <- readIORef socketStatus
- if currentStatus /= NotConnected
- then
- ioError (userError ("connect: can't peform connect on socket in status " ++
- show currentStatus))
- else do
- addr' <- packSockAddr addr
- let (_,sz) = boundsOfMutableByteArray addr'
- status <- _ccall_ connectSocket s addr' sz (isDomainSocket::Int)
- case (status::Int) of
- -1 -> constructErrorAndFail "connect"
- -6 -> do threadWaitWrite s >> writeIORef socketStatus Connected
- -- ToDo: check for error with getsockopt
- _ -> writeIORef socketStatus Connected
-\end{code}
-
-The programmer must call $listen$ to tell the system software
-that they are now interested in receiving data on this port. This
-must be called on the bound socket before any calls to read or write
-data are made.
-
-The programmer also gives a number which indicates the length of the
-incoming queue of unread messages for this socket. On most systems the
-maximum queue length is around 5. To remove a message from the queue
-for processing a call to $accept$ should be made.
-
-\begin{code}
-listen :: Socket -- Connected & Bound Socket
- -> Int -- Queue Length
- -> IO ()
-
-listen (MkSocket s _family _stype _protocol socketStatus) backlog = do
- currentStatus <- readIORef socketStatus
- if currentStatus /= Bound
- then
- ioError (userError ("listen: can't peform listen on socket in status " ++
- show currentStatus))
- else do
- status <- _ccall_ listenSocket s backlog
- case (status::Int) of
- -1 -> constructErrorAndFail "listen"
- _ -> writeIORef socketStatus Listening
-\end{code}
-
-A call to $accept$ only returns when data is available on the given
-socket, unless the socket has been set to non-blocking. It will
-return a new socket which should be used to read the incoming data and
-should then be closed. Using the socket returned by $accept$ allows
-incoming requests to be queued on the original socket.
-
-\begin{code}
-accept :: Socket -- Queue Socket
- -> IO (Socket, -- Readable Socket
- SockAddr) -- Peer details
-
-accept sock@(MkSocket s family stype protocol status) = do
- currentStatus <- readIORef status
- okay <- sIsAcceptable sock
- if not okay
- then
- ioError (userError ("accept: can't peform accept on socket in status " ++
- show currentStatus))
- else do
- (ptr, sz) <- allocSockAddr family
- int_star <- stToIO (newIntArray ((0::Int),1))
- stToIO (writeIntArray int_star 0 sz)
- new_sock <- accept_socket s ptr int_star
- a_sz <- stToIO (readIntArray int_star 0)
- addr <- unpackSockAddr ptr a_sz
- new_status <- newIORef Connected
- return ((MkSocket new_sock family stype protocol new_status), addr)
-
-accept_socket :: Int
- -> MutableByteArray RealWorld Int
- -> MutableByteArray RealWorld Int
- -> IO Int
-
-accept_socket s ptr int_star = do
- new_sock <- _ccall_ acceptSocket s ptr int_star
- case (new_sock::Int) of
- -1 -> constructErrorAndFail "accept"
-
- -- wait if there are no pending connections
- -5 -> threadWaitRead s >> accept_socket s ptr int_star
-
- _ -> return new_sock
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Socket-DataPass]{Data Passing Primitives}
-%* *
-%************************************************************************
-
-To allow Haskell to talk to C programs we need to be able to
-communicate in terms of byte streams. @writeSocket@ and
-@readSocket@ should only be used for this purpose and not for
-communication between Haskell programs. Haskell programs should use
-the 1.3 IO hPutStr and associated machinery for communicating with
-each other.
-
-
-\begin{code}
-writeSocket :: Socket -- Connected Socket
- -> String -- Data to send
- -> IO Int -- Number of Bytes sent
-
-writeSocket (MkSocket s _family _stype _protocol status) xs = do
- currentStatus <- readIORef status
- if not ((currentStatus == Connected) || (currentStatus == Listening))
- then
- ioError (userError ("writeSocket: can't peform write on socket in status " ++
- show currentStatus))
- else do
- nbytes <- _ccall_ writeDescriptor s xs (length xs)
- case (nbytes::Int) of
- -1 -> constructErrorAndFail "writeSocket"
- _ -> return nbytes
-
-
-sendTo :: Socket -- Bound/Connected Socket
- -> String -- Data to send
- -> SockAddr
- -> IO Int -- Number of Bytes sent
-
-sendTo (MkSocket s _family _stype _protocol status) xs addr = do
- currentStatus <- readIORef status
- if not ((currentStatus == Connected) || (currentStatus == Listening) || (currentStatus == Bound))
- then
- ioError (userError ("sendTo: can't peform write on socket in status " ++
- show currentStatus))
- else do
- addr' <- packSockAddr addr
- let (_,sz) = boundsOfMutableByteArray addr'
- nbytes <- _ccall_ sendTo__ s xs (length xs) addr' sz
- case (nbytes::Int) of
- -1 -> constructErrorAndFail "sendTo"
- _ -> return nbytes
-
-readSocket :: Socket -- Connected (or bound) Socket
- -> Int -- Number of Bytes to Read
- -> IO (String, Int) -- (Data Read, Number of Bytes)
-
-readSocket (MkSocket s _family _stype _protocol status) nbytes = do
- currentStatus <- readIORef status
- if not ((currentStatus == Connected) || (currentStatus == Listening))
- then
- ioError (userError ("readSocket: can't perform read on socket in status " ++
- show currentStatus))
- else do
- ptr <- allocChars nbytes
- rlen <- _ccall_ readDescriptor s ptr nbytes
- case (rlen::Int) of
- -1 -> constructErrorAndFail "readSocket"
- n -> do
- barr <- stToIO (unsafeFreezeByteArray ptr)
- str <- unpackNBytesBAIO barr n
- return (str, n)
-
-readSocketAll :: Socket -> IO String
-readSocketAll s =
- let
- loop xs =
- catch
- (readSocket s 4096 >>= \ (str, nbytes) ->
- if nbytes /= 0 then
- loop (str ++ xs)
- else
- return xs)
- (\ _ -> return xs)
- in
- loop ""
-
-recvFrom :: Socket -> Int -> IO (String, Int, SockAddr)
-recvFrom (MkSocket s _family _stype _protocol status) nbytes = do
- currentStatus <- readIORef status
- if not ((currentStatus == Connected) || (currentStatus == Listening) || (currentStatus == Bound))
- then
- ioError (userError ("recvFrom: can't perform read on socket in status " ++
- show currentStatus))
- else do
- ptr <- allocChars nbytes
- (ptr_addr,_) <- allocSockAddr AF_INET
- rlen <- _ccall_ recvFrom__ s ptr nbytes ptr_addr
- case (rlen::Int) of
- -1 -> constructErrorAndFail "recvFrom"
- n -> do
- barr <- stToIO (unsafeFreezeByteArray ptr)
- addr <- unpackSockAddrInet ptr_addr
- str <- unpackNBytesBAIO barr n
- return (str, n, addr)
-
-\end{code}
-
-The port number the given socket is currently connected to can be
-determined by calling $port$, is generally only useful when bind
-was given $aNY\_PORT$.
-
-\begin{code}
-socketPort :: Socket -- Connected & Bound Socket
- -> IO PortNumber -- Port Number of Socket
-socketPort sock@(MkSocket _ AF_INET _ _ _) =
- getSocketName sock >>= \(SockAddrInet port _) ->
- return port
-socketPort (MkSocket _ family _ _ _) =
- ioError (userError ("socketPort: not supported for Family " ++ show family))
-\end{code}
-
-Calling $getPeerName$ returns the address details of the machine,
-other than the local one, which is connected to the socket. This is
-used in programs such as FTP to determine where to send the returning
-data. The corresponding call to get the details of the local machine
-is $getSocketName$.
-
-\begin{code}
-getPeerName :: Socket -> IO SockAddr
-
-getPeerName (MkSocket s family _ _ _) = do
- (ptr, a_sz) <- allocSockAddr family
- int_star <- stToIO (newIntArray ((0::Int),1))
- stToIO (writeIntArray int_star 0 a_sz)
- status <- _ccall_ getPeerName s ptr int_star
- case (status::Int) of
- -1 -> constructErrorAndFail "getPeerName"
- _ -> do
- sz <- stToIO (readIntArray int_star 0)
- unpackSockAddr ptr sz
-
-getSocketName :: Socket -> IO SockAddr
-
-getSocketName (MkSocket s family _ _ _) = do
- (ptr, a_sz) <- allocSockAddr family
- int_star <- stToIO (newIntArray ((0::Int),1))
- stToIO (writeIntArray int_star 0 a_sz)
- rc <- _ccall_ getSockName s ptr int_star
- case (rc::Int) of
- -1 -> constructErrorAndFail "getSocketName"
- _ -> do
- sz <- stToIO (readIntArray int_star 0)
- unpackSockAddr ptr sz
-
-
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Socket-Properties]{Socket Properties}
-%* *
-%************************************************************************
-
-\begin{code}
-data SocketOption
- = Debug {- SO_DEBUG -}
- | ReuseAddr {- SO_REUSEADDR -}
- | Type {- SO_TYPE -}
- | SoError {- SO_ERROR -}
- | DontRoute {- SO_DONTROUTE -}
- | Broadcast {- SO_BROADCAST -}
- | SendBuffer {- SO_SNDBUF -}
- | RecvBuffer {- SO_RCVBUF -}
- | KeepAlive {- SO_KEEPALIVE -}
- | OOBInline {- SO_OOBINLINE -}
-#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
- | MaxSegment {- TCP_MAXSEG -}
-#endif
- | NoDelay {- TCP_NODELAY -}
--- | Linger {- SO_LINGER -}
-#if 0
- | ReusePort {- SO_REUSEPORT -} -- BSD only?
- | RecvLowWater {- SO_RCVLOWAT -}
- | SendLowWater {- SO_SNDLOWAT -}
- | RecvTimeOut {- SO_RCVTIMEO -}
- | SendTimeOut {- SO_SNDTIMEO -}
- | UseLoopBack {- SO_USELOOPBACK -} -- not used, I believe.
-#endif
-
-socketOptLevel :: SocketOption -> Int
-socketOptLevel so =
- case so of
-#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
- MaxSegment -> ``IPPROTO_TCP''
-#endif
- NoDelay -> ``IPPROTO_TCP''
- _ -> ``SOL_SOCKET''
-
-packSocketOption :: SocketOption -> Int
-packSocketOption so =
- case so of
- Debug -> ``SO_DEBUG''
- ReuseAddr -> ``SO_REUSEADDR''
- Type -> ``SO_TYPE''
- SoError -> ``SO_ERROR''
- DontRoute -> ``SO_DONTROUTE''
- Broadcast -> ``SO_BROADCAST''
- SendBuffer -> ``SO_SNDBUF''
- RecvBuffer -> ``SO_RCVBUF''
- KeepAlive -> ``SO_KEEPALIVE''
- OOBInline -> ``SO_OOBINLINE''
-#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
- MaxSegment -> ``TCP_MAXSEG''
-#endif
- NoDelay -> ``TCP_NODELAY''
-#if 0
- ReusePort -> ``SO_REUSEPORT'' -- BSD only?
- RecvLowWater -> ``SO_RCVLOWAT''
- SendLowWater -> ``SO_SNDLOWAT''
- RecvTimeOut -> ``SO_RCVTIMEO''
- SendTimeOut -> ``SO_SNDTIMEO''
- UseLoopBack -> ``SO_USELOOPBACK''
-#endif
-
-setSocketOption :: Socket
- -> SocketOption -- Option Name
- -> Int -- Option Value
- -> IO ()
-setSocketOption (MkSocket s _ _ _ _) so v = do
- rc <- _ccall_ setSocketOption__ s
- (packSocketOption so)
- (socketOptLevel so)
- v
- if rc /= (0::Int)
- then constructErrorAndFail "setSocketOption"
- else return ()
-
-getSocketOption :: Socket
- -> SocketOption -- Option Name
- -> IO Int -- Option Value
-getSocketOption (MkSocket s _ _ _ _) so = do
- rc <- _ccall_ getSocketOption__ s
- (packSocketOption so)
- (socketOptLevel so)
- if rc == -1 -- let's just hope that value isn't taken..
- then constructErrorAndFail "getSocketOption"
- else return rc
-
-\end{code}
-
-A calling sequence table for the main functions is shown in the table below.
-
-\begin{figure}[h]
-\begin{center}
-\begin{tabular}{|l|c|c|c|c|c|c|c|}
-\hline
-{\bf A Call to} & socket & connect & bindSocket & listen & accept & read & write \\
-\hline
-{\bf Precedes} & & & & & & & \\
-\hline
-socket & & & & & & & \\
-\hline
-connect & + & & & & & & \\
-\hline
-bindSocket & + & & & & & & \\
-\hline
-listen & & & + & & & & \\
-\hline
-accept & & & & + & & & \\
-\hline
-read & & + & & + & + & + & + \\
-\hline
-write & & + & & + & + & + & + \\
-\hline
-\end{tabular}
-\caption{Sequence Table for Major functions of Socket}
-\label{tab:api-seq}
-\end{center}
-\end{figure}
-
-%************************************************************************
-%* *
-\subsection[Socket-OSDefs]{OS Dependent Definitions}
-%* *
-%************************************************************************
-
-
-The following Family and Socket Type declarations were manually derived
-from @<sys/socket.h>@ on the appropriate machines.
-
-Maybe a configure script that could parse the socket.h file to produce
-the following declaration is required to make it ``portable'' rather than
-using the dreaded \#ifdefs.
-
-Presently only the following machine/os combinations are supported:
-
-\begin{itemize}
-\item Intelx86/Linux
-\item SPARC/SunOS
-\item SPARC/Solaris
-\item Alpha/OSF
-\item HPPA/HPUX9
-\item MIPS/IRIX6.2
-\end{itemize}
-
-\begin{code}
-unpackFamily :: Int -> Family
-packFamily :: Family -> Int
-
-packSocketType :: SocketType -> Int
-
-
-#if sunos4_TARGET_OS || solaris2_TARGET_OS
-
-data Family =
- AF_UNSPEC -- unspecified
- | AF_UNIX -- local to host (pipes, portals
- | AF_INET -- internetwork: UDP, TCP, etc
- | AF_IMPLINK -- arpanet imp addresses
- | AF_PUP -- pup protocols: e.g. BSP
- | AF_CHAOS -- mit CHAOS protocols
- | AF_NS -- XEROX NS protocols
- | AF_NBS -- nbs protocols
- | AF_ECMA -- european computer manufacturers
- | AF_DATAKIT -- datakit protocols
- | AF_CCITT -- CCITT protocols, X.25 etc
- | AF_SNA -- IBM SNA
- | AF_DECnet -- DECnet
- | AF_DLI -- Direct data link interface
- | AF_LAT -- LAT
- | AF_HYLINK -- NSC Hyperchannel
- | AF_APPLETALK -- Apple Talk
- | AF_NIT -- Network Interface Tap
- | AF_802 -- IEEE 802.2, also ISO 8802
- | AF_OSI -- umbrella of all families used by OSI
- | AF_X25 -- CCITT X.25
- | AF_OSINET -- AFI
- | AF_GOSSIP -- US Government OSI
- | AF_IPX -- Novell Internet Protocol
- deriving (Eq, Ord, Ix, Show)
-
-packFamily = index (AF_UNSPEC, AF_IPX)
-unpackFamily family = (range (AF_UNSPEC, AF_IPX))!!family
-
-#endif
-
-#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
-
-data Family =
- AF_UNSPEC -- unspecified
- | AF_UNIX -- local to host (pipes, portals)
- | AF_INET -- internetwork: UDP, TCP, etc
- | AF_IMPLINK -- arpanet imp addresses
- | AF_PUP -- pup protocols: e.g. BSP
- | AF_CHAOS -- mit CHAOS protocols
- | AF_NS -- XEROX NS protocols
- | AF_ISO -- ISO protocols
- | AF_OSI -- OSI protocols
- | AF_ECMA -- european computer manufacturers
- | AF_DATAKIT -- datakit protocols
- | AF_CCITT -- CCITT protocols, X.25 etc
- | AF_SNA -- IBM SNA
- | AF_DECnet -- DECnet
- | AF_DLI -- Direct data link interface
- | AF_LAT -- LAT
- | AF_HYLINK -- NSC Hyperchannel
- | AF_APPLETALK -- Apple Talk
- | AF_NETBIOS -- NetBios-style addresses
- deriving (Eq, Ord, Ix, Show)
-
-packFamily = index (AF_UNSPEC, AF_NETBIOS)
-unpackFamily family = (range (AF_UNSPEC, AF_NETBIOS))!!family
-
-
-#endif
-
-#if hpux_TARGET_OS
-
-data Family =
- AF_UNSPEC -- unspecified
- | AF_UNIX -- local to host (pipes, portals
- | AF_INET -- internetwork: UDP, TCP, etc
- | AF_IMPLINK -- arpanet imp addresses
- | AF_PUP -- pup protocols: e.g. BSP
- | AF_CHAOS -- mit CHAOS protocols
- | AF_NS -- XEROX NS protocols
- | AF_NBS -- nbs protocols
- | AF_ECMA -- european computer manufacturers
- | AF_DATAKIT -- datakit protocols
- | AF_CCITT -- CCITT protocols, X.25 etc
- | AF_SNA -- IBM SNA
- | AF_DECnet -- DECnet
- | AF_DLI -- Direct data link interface
- | AF_LAT -- LAT
- | AF_HYLINK -- NSC Hyperchannel
- | AF_APPLETALK -- Apple Talk
- | AF_NIT -- Network Interface Tap
- deriving (Eq, Ord, Ix, Show)
-
-packFamily = index (AF_UNSPEC, AF_NIT)
-unpackFamily family = (range (AF_UNSPEC, AF_NIT))!!family
-
-#endif
-
-#if osf1_TARGET_OS || osf3_TARGET_OS
-
-data Family =
- AF_UNSPEC -- unspecified
- | AF_UNIX -- local to host (pipes, portals)
- | AF_INET -- internetwork: UDP, TCP, etc.
- | AF_IMPLINK -- arpanet imp addresses
- | AF_PUP -- pup protocols: e.g. BSP
- | AF_CHAOS -- mit CHAOS protocols
- | AF_NS -- XEROX NS protocols
- | AF_ISO -- ISO protocols
- | AF_ECMA -- european computer manufacturers
- | AF_DATAKIT -- datakit protocols
- | AF_CCITT -- CCITT protocols, X.25 etc
- | AF_SNA -- IBM SNA
- | AF_DECnet -- DECnet
- | AF_DLI -- DEC Direct data link interface
- | AF_LAT -- LAT
- | AF_HYLINK -- NSC Hyperchannel
- | AF_APPLETALK -- Apple Talk
- | AF_ROUTE -- Internal Routing Protocol
- | AF_LINK -- Link layer interface
- | Pseudo_AF_XTP -- eXpress Transfer Protocol (no AF)
- | AF_NETMAN -- DNA Network Management
- | AF_X25 -- X25 protocol
- | AF_CTF -- Common Trace Facility
- | AF_WAN -- Wide Area Network protocols
- deriving (Eq, Ord, Ix, Show)
-
-packFamily = index (AF_UNSPEC, AF_WAN)
-unpackFamily family = (range (AF_UNSPEC, AF_WAN))!!family
-#endif
-
-#if linux_TARGET_OS
-
-data Family =
- AF_UNSPEC
- | AF_UNIX
- | AF_INET
- | AF_AX25
- | AF_IPX
- deriving (Eq, Ord, Ix, Show)
-
-packFamily = index (AF_UNSPEC, AF_IPX)
-unpackFamily family = (range (AF_UNSPEC, AF_IPX))!!family
-
-#endif
-
-#if irix_TARGET_OS
-
-data Family =
- AF_UNSPEC -- unspecified
- | AF_UNIX -- backward compatibility
- | AF_INET -- internetwork: UDP, TCP, etc.
- | AF_IMPLINK -- arpanet imp addresses
- | AF_PUP -- pup protocols: e.g. BSP
- | AF_CHAOS -- mit CHAOS protocols
- | AF_NS -- XEROX NS protocols
- | AF_ISO -- ISO protocols
- | AF_ECMA -- european computer manufacturers
- | AF_DATAKIT -- datakit protocols
- | AF_CCITT -- CCITT protocols, X.25 etc
- | AF_SNA -- IBM SNA
- | AF_DECnet -- DECnet
- | AF_DLI -- DEC Direct data link interface
- | AF_LAT -- LAT
- | AF_HYLINK -- NSC Hyperchannel
- | AF_APPLETALK -- Apple Talk
- | AF_ROUTE -- Internal Routing Protocol
- | AF_RAW -- Link layer interface
-
--- these two overlap AF_ROUTE and AF_RAW
--- | AF_NIT -- Network Interface Tap
--- | AF_802 -- IEEE 802.2, also ISO 8802
-
- | AF_OSI -- umbrella for all families used by OSI
- | AF_X25 -- CCITT X.25
- | AF_OSINET -- AFI
- | AF_GOSIP -- US Government OSI
-
- | AF_SDL -- SGI Data Link for DLPI
- | AF_INET6 -- Internet Protocol version 6
- | AF_LINK -- Link layer interface
- deriving (Eq, Ord, Ix, Show)
-
-packFamily = index (AF_UNSPEC, AF_LINK)
-unpackFamily family = (range (AF_UNSPEC, AF_LINK))!!family
-
-#endif
-
-#if aix_TARGET_OS
-
-data Family =
- AF_UNSPEC -- unspecified
- | AF_UNIX -- local to host (pipes, portals)
- | AF_INET -- internetwork: UDP, TCP, etc.
- | AF_IMPLINK -- arpanet imp addresses
- | AF_PUP -- pup protocols: e.g. BSP
- | AF_CHAOS -- mit CHAOS protocols
- | AF_NS -- XEROX NS protocols
- | AF_ISO -- ISO protocols
--- | AF_OSI is the same as AF_ISO on AIX
- | AF_ECMA -- european computer manufacturers
- | AF_DATAKIT -- datakit protocols
- | AF_CCITT -- CCITT protocols, X.25 etc
- | AF_SNA -- IBM SNA
- | AF_DECnet -- DECnet
- | AF_DLI -- DEC Direct data link interface
- | AF_LAT -- LAT
- | AF_HYLINK -- NSC Hyperchannel
- | AF_APPLETALK -- Apple Talk
- | AF_ROUTE -- Internal Routing Protocol
- | AF_LINK -- Link layer interface
- | Pseudo_AF_XTP -- eXpress Transfer Protocol (no AF)
- | AF_INTF -- Debugging use only
- | AF_RIF -- raw interface
- | AF_NETWARE
- | AF_NDD
- | AF_MAX
- deriving (Eq, Ord, Ix, Show)
-
-packFamily = index (AF_UNSPEC, AF_MAX)
-unpackFamily family = (range (AF_UNSPEC, AF_MAX))!!family
-
-#endif
-
-#if freebsd2_TARGET_OS || freebsd3_TARGET_OS
-
-data Family =
- AF_UNSPEC -- unspecified
- | AF_UNIX -- local to host (pipes, portals)
- | AF_INET -- internetwork: UDP, TCP, etc.
- | AF_IMPLINK -- arpanet imp addresses
- | AF_PUP -- pup protocols: e.g. BSP
- | AF_CHAOS -- mit CHAOS protocols
- | AF_NS -- XEROX NS protocols
- | AF_ISO -- ISO protocols
--- | AF_OSI is the same as AF_ISO
- | AF_ECMA -- european computer manufacturers
- | AF_DATAKIT -- datakit protocols
- | AF_CCITT -- CCITT protocols, X.25 etc
- | AF_SNA -- IBM SNA
- | AF_DECnet -- DECnet
- | AF_DLI -- DEC Direct data link interface
- | AF_LAT -- LAT
- | AF_HYLINK -- NSC Hyperchannel
- | AF_APPLETALK -- Apple Talk
- | AF_ROUTE -- Internal Routing Protocol
- | AF_LINK -- Link layer interface
- | Pseudo_AF_XTP -- eXpress Transfer Protocol (no AF)
- | AF_COIP -- connection-oriented IP, aka ST II
- | AF_CNT -- Computer Network Technology
- | Psuedo_AF_RTIP -- Help Identify RTIP packets
- | AF_IPX -- Novell Internet Protocol
- | AF_SIP -- Simple Internet Protocol
- | Pseudo_AF_PIP -- Help Identify PIP packets
- | AF_ISDN -- Integrated Services Digital Network
--- | AF_E164 is the same as AF_ISDN
- | Pseudo_AF_KEY -- Internal key-management function
- | AF_INET6 -- IPv6
- | AF_MAX
- deriving (Eq, Ord, Ix, Show)
-
-packFamily = index (AF_UNSPEC, AF_MAX)
-unpackFamily family = (range (AF_UNSPEC, AF_MAX))!!family
-
-#endif
-
--- 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 || freebsd2_TARGET_OS || freebsd3_TARGET_OS
-data SocketType =
- Stream
- | Datagram
- | Raw
- | RDM
- | SeqPacket
- deriving (Eq, Ord, Ix, Show)
-
-packSocketType stype = 1 + (index (Stream, SeqPacket) stype)
-#endif
-
--- This is for a box running cygwin32 toolchain.
-
-#if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
-data SocketType =
- Stream
- | Datagram
- | Raw
- | RDM -- reliably delivered msg
- | SeqPacket
- deriving (Eq, Ord, Ix, Show)
-
-packSocketType stype =
- case stype of
- Stream -> ``SOCK_STREAM''
- Datagram -> ``SOCK_DGRAM''
- Raw -> ``SOCK_RAW''
- RDM -> ``SOCK_RDM''
- SeqPacket -> ``SOCK_SEQPACKET''
-
-#endif
-
--- This is a Sun running Solaris rather than SunOS or SGI running IRIX
-
-#if defined(solaris2_TARGET_OS) || defined(irix_TARGET_OS)
-data SocketType =
- Datagram
- | Stream
- | NC_TPI_COTS_ORD
- | Raw
- | RDM
- | SeqPacket
- deriving (Eq, Ord, Ix, Show)
-
-packSocketType stype = 1 + (index (Datagram, SeqPacket) stype)
-#endif
-
-
-#if linux_TARGET_OS
-data SocketType =
- Stream
- | Datagram
- | Raw
- | RDM
- | SeqPacket
- | Packet
- deriving (Eq, Ord, Ix, Show)
-
-packSocketType stype = 1 + (index (Stream, Packet) stype)
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Socket-Util]{Utility Functions}
-%* *
-%************************************************************************
-
-\begin{code}
-aNY_PORT :: PortNumber
-aNY_PORT = mkPortNumber 0
-
-iNADDR_ANY :: HostAddress
-iNADDR_ANY = unsafePerformIO (_casm_ `` %r = htonl(INADDR_ANY); '')
-
-sOMAXCONN :: Int
-sOMAXCONN = ``SOMAXCONN''
-
-maxListenQueue :: Int
-maxListenQueue = sOMAXCONN
-
--------------------------------------------------------------------------------
-data ShutdownCmd
- = ShutdownReceive
- | ShutdownSend
- | ShutdownBoth
-
-sdownCmdToInt :: ShutdownCmd -> Int
-sdownCmdToInt ShutdownReceive = 0
-sdownCmdToInt ShutdownSend = 1
-sdownCmdToInt ShutdownBoth = 2
-
-shutdown :: Socket -> ShutdownCmd -> IO ()
-shutdown (MkSocket s _ _ _ _) stype = do
- let t = sdownCmdToInt stype
- status <- _ccall_ shutdownSocket s t
- case (status::Int) of
- -1 -> constructErrorAndFail "shutdown"
- _ -> return ()
-
--------------------------------------------------------------------------------
-
-sClose :: Socket -> IO ()
-sClose (MkSocket s _ _ _ _) = _ccall_ close s
-
--------------------------------------------------------------------------------
-
-sIsConnected :: Socket -> IO Bool
-sIsConnected (MkSocket _ _ _ _ status) = do
- value <- readIORef status
- return (value == Connected)
-
--------------------------------------------------------------------------------
-
-sIsBound :: Socket -> IO Bool
-sIsBound (MkSocket _ _ _ _ status) = do
- value <- readIORef status
- return (value == Bound)
-
--------------------------------------------------------------------------------
-
-sIsListening :: Socket -> IO Bool
-sIsListening (MkSocket _ _ _ _ status) = do
- value <- readIORef status
- return (value == Listening)
-
--------------------------------------------------------------------------------
-
-sIsReadable :: Socket -> IO Bool
-sIsReadable (MkSocket _ _ _ _ status) = do
- value <- readIORef status
- return (value == Listening || value == Connected)
-
--------------------------------------------------------------------------------
-
-sIsWritable :: Socket -> IO Bool
-sIsWritable = sIsReadable -- sort of.
-
--------------------------------------------------------------------------------
-
-sIsAcceptable :: Socket -> IO Bool
-#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
-sIsAcceptable (MkSocket _ AF_UNIX Stream _ status) = do
- value <- readIORef status
- return (value == Connected || value == Bound || value == Listening)
-sIsAcceptable (MkSocket _ AF_UNIX _ _ _) = return False
-#endif
-sIsAcceptable (MkSocket _ _ _ _ status) = do
- value <- readIORef status
- return (value == Connected || value == Listening)
-
--------------------------------------------------------------------------------
-
-{-
-sSetBlocking :: Socket -> Bool -> IO ()
-sIsBlocking :: Socket -> IO Bool
--}
-
-\end{code}
-
-Internet address manipulation routines:
-
-\begin{code}
-inet_addr :: String -> IO HostAddress
-inet_addr ipstr = do
- had <- _ccall_ inet_addr ipstr
- if had == (W# (int2Word# (negateInt# 1#))) -- hack to avoid depending on Int.intToWord here.
- then ioError (userError ("inet_addr: Malformed address: " ++ ipstr))
- else return had -- network byte order
-
-inet_ntoa :: HostAddress -> IO String
-inet_ntoa haddr = do
- pstr <- _casm_ ``struct in_addr addr;
- addr.s_addr = %0;
- %r = inet_ntoa (addr);'' haddr
- -- unpack straight away, since pstr points to static buffer.
- unpackCStringIO pstr
-
-\end{code}
-
-Marshaling and allocation helper functions:
-
-\begin{code}
--------------------------------------------------------------------------------
-
-allocSockAddr :: Family -> IO (MutableByteArray RealWorld Int, Int)
-
-#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
-allocSockAddr AF_UNIX = do
- ptr <- allocChars ``sizeof(struct sockaddr_un)''
- let (_,sz) = boundsOfMutableByteArray ptr
- return (ptr, sz)
-#endif
-
-allocSockAddr AF_INET = do
- ptr <- allocChars ``sizeof(struct sockaddr_in)''
- let (_,sz) = boundsOfMutableByteArray ptr
- return (ptr, sz)
-
--------------------------------------------------------------------------------
-
-unpackSockAddr :: MutableByteArray RealWorld Int -> Int -> IO SockAddr
-unpackSockAddr arr len = do
- fam <- _casm_ ``%r = ((struct sockaddr*)%0)->sa_family;'' arr
- case unpackFamily fam of
-#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
- AF_UNIX -> unpackSockAddrUnix arr (len - ``sizeof(short)'')
-#endif
- AF_INET -> unpackSockAddrInet arr
-
--------------------------------------------------------------------------------
-
-#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
-
-{-
- sun_path is *not* NULL terminated, hence we *do* need to know the
- length of it.
--}
-unpackSockAddrUnix :: (MutableByteArray RealWorld Int) -> Int -> IO SockAddr
-unpackSockAddrUnix ptr len = do
- char_star <- _casm_ ``%r = ((struct sockaddr_un*)%0)->sun_path;'' ptr
- path <- unpackCStringLenIO char_star len
- return (SockAddrUnix path)
-
-#endif
-
--------------------------------------------------------------------------------
-
-unpackSockAddrInet :: (MutableByteArray RealWorld Int) -> IO SockAddr
-unpackSockAddrInet ptr = do
- port <- _casm_ ``%r = ((struct sockaddr_in*)%0)->sin_port;'' ptr
- addr <- _casm_ ``%r = ((struct sockaddr_in*)%0)->sin_addr.s_addr;'' ptr
- return (SockAddrInet (PNum port) addr)
-
--------------------------------------------------------------------------------
-
-
-packSockAddr :: SockAddr -> IO (MutableByteArray RealWorld Int)
-#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
-packSockAddr (SockAddrUnix path) = do
- (ptr,_) <- allocSockAddr AF_UNIX
- _casm_ ``(((struct sockaddr_un *)%0)->sun_family) = AF_UNIX;'' ptr
- _casm_ ``strcpy ((((struct sockaddr_un *)%0)->sun_path),%1);'' ptr path
- return ptr
-#endif
-packSockAddr (SockAddrInet (PNum port) address) = do
- (ptr,_) <- allocSockAddr AF_INET
- _casm_ ``(((struct sockaddr_in *)%0)->sin_family) = AF_INET;'' ptr
- _casm_ ``(((struct sockaddr_in *)%0)->sin_port) = (int)%1;'' ptr port
- _casm_ ``(((struct sockaddr_in *)%0)->sin_addr.s_addr) = %1;'' ptr address
- return ptr
-
--------------------------------------------------------------------------------
-\end{code}
-
-@socketHandle@ turns a @Socket@ into a Haskell IO @Handle@. By default, the new
-handle will not be buffered, use @hSetBuffering@ if you want to change
-it subsequently.
-
-\begin{code}
-#ifndef __PARALLEL_HASKELL__
-socketToHandle :: Socket -> IOMode -> IO Handle
-
-socketToHandle (MkSocket fd _ _ _ _) m = do
- fileobj <- _ccall_ openFd fd (file_mode::Int) (file_flags::Int)
- if fileobj == nullAddr then
- ioError (userError "socketHandle: Failed to open file desc")
- else do
- fo <- mkForeignObj fileobj
- addForeignFinalizer fo (freeFileObject fo)
- mkBuffer__ fo 0 -- not buffered
- hndl <- newHandle (Handle__ fo htype NoBuffering socket_str)
- return hndl
- where
- socket_str = "<socket: "++show fd
-#if defined(mingw32_TARGET_OS)
- file_flags = flush_on_close + 1024{-I'm a socket fd, me!-}
-#else
- file_flags = flush_on_close
-#endif
-
- (flush_on_close, file_mode) =
- case m of
- AppendMode -> (1, 0)
- WriteMode -> (1, 1)
- ReadMode -> (0, 2)
- ReadWriteMode -> (1, 3)
-
- htype =
- case m of
- ReadMode -> ReadHandle
- WriteMode -> WriteHandle
- AppendMode -> AppendHandle
- ReadWriteMode -> ReadWriteHandle
-#else
-socketToHandle (MkSocket s family stype protocol status) m =
- error "socketToHandle not implemented in a parallel setup"
-#endif
-\end{code}
-
-If you're using WinSock, the programmer has to call a startup
-routine before starting to use the goods. So, if you want to
-stay portable across all ghc-supported platforms, you have to
-use @withSocketsDo@...:
-
-\begin{code}
-withSocketsDo :: IO a -> IO a
-#if !defined(HAVE_WINSOCK_H) || defined(cygwin32_TARGET_OS)
-withSocketsDo x = x
-#else
-withSocketsDo act = do
- x <- initWinSock
- if ( x /= 0 ) then
- ioError (userError "Failed to initialise WinSock")
- else do
- v <- act
- shutdownWinSock
- return v
-
-foreign import "initWinSock" initWinSock :: IO Int
-foreign import "shutdownWinSock" shutdownWinSock :: IO ()
-
-#endif
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[Util]{Highly random utility functions}
-
-\begin{code}
-#if defined(COMPILING_GHC)
-# include "HsVersions.h"
-# define IF_NOT_GHC(a) {--}
-#else
-# define panic error
-# define TAG_ Ordering
-# define LT_ LT
-# define EQ_ EQ
-# define GT_ GT
-# define _LT LT
-# define _EQ EQ
-# define _GT GT
-# define GT__ _
-# define tagCmp_ compare
-# define _tagCmp compare
-# define FAST_STRING String
-# define ASSERT(x) {-nothing-}
-# define IF_NOT_GHC(a) a
-# define COMMA ,
-#endif
-
-#ifndef __GLASGOW_HASKELL__
-# undef TAG_
-# undef LT_
-# undef EQ_
-# undef GT_
-# undef tagCmp_
-#endif
-
-module Util (
- -- Haskell-version support
-#ifndef __GLASGOW_HASKELL__
- tagCmp_,
- TAG_(..),
-#endif
- -- general list processing
- IF_NOT_GHC(forall COMMA exists COMMA)
- zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
- zipLazy,
- mapAndUnzip, mapAndUnzip3,
- nOfThem, lengthExceeds, isSingleton,
- startsWith, endsWith,
-#if defined(COMPILING_GHC)
- isIn, isn'tIn,
-#endif
-
- -- association lists
- assoc,
-
- -- duplicate handling
- hasNoDups, equivClasses, runs, removeDups,
-
- -- sorting
- IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
- sortLt,
- IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten
- IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
-
- -- transitive closures
- transitiveClosure,
-
- -- accumulating
- mapAccumL, mapAccumR, mapAccumB,
-
- -- comparisons
-#if defined(COMPILING_GHC)
- thenCmp, cmpList,
- cmpPString,
-#else
- cmpString,
-#endif
-
- -- pairs
- IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
- IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
- unzipWith
-
- -- error handling
-#if defined(COMPILING_GHC)
- , panic, panic#, pprPanic, pprPanic#, pprError, pprTrace
- , assertPanic
-#endif {- COMPILING_GHC -}
-
- ) where
-
-import List(zipWith4)
-import Addr
-
-infixr 9 `thenCmp`
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-version-support]{Functions to help pre-1.2 versions of (non-Glasgow) Haskell}
-%* *
-%************************************************************************
-
-This is our own idea:
-\begin{code}
-#ifndef __GLASGOW_HASKELL__
-data TAG_ = LT_ | EQ_ | GT_
-
-tagCmp_ :: Ord a => a -> a -> TAG_
-tagCmp_ a b = if a == b then EQ_ else if a < b then LT_ else GT_
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-lists]{General list processing}
-%* *
-%************************************************************************
-
-Quantifiers are not standard in Haskell. The following fill in the gap.
-
-\begin{code}
-forall :: (a -> Bool) -> [a] -> Bool
-forall pred [] = True
-forall pred (x:xs) = pred x && forall pred xs
-
-exists :: (a -> Bool) -> [a] -> Bool
-exists pred [] = False
-exists pred (x:xs) = pred x || exists pred xs
-\end{code}
-
-A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
-are of equal length. Alastair Reid thinks this should only happen if
-DEBUGging on; hey, why not?
-[In the GHC syslib, we want the paranoid behaviour by default --SOF]
-
-\begin{code}
-zipEqual :: String -> [a] -> [b] -> [(a,b)]
-zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
-zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
-zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
-
-#if (!defined(DEBUG)) && defined(COMPILING_GHC)
-zipEqual _ = zip
-zipWithEqual _ = zipWith
-zipWith3Equal _ = zipWith3
-zipWith4Equal _ = zipWith4
-#else
-zipEqual msg [] [] = []
-zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
-zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
-
-zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
-zipWithEqual msg _ [] [] = []
-zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
-
-zipWith3Equal msg z (a:as) (b:bs) (c:cs)
- = z a b c : zipWith3Equal msg z as bs cs
-zipWith3Equal msg _ [] [] [] = []
-zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
-
-zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
- = z a b c d : zipWith4Equal msg z as bs cs ds
-zipWith4Equal msg _ [] [] [] [] = []
-zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
-#endif
-\end{code}
-
-\begin{code}
--- zipLazy is lazy in the second list (observe the ~)
-
-zipLazy :: [a] -> [b] -> [(a,b)]
-zipLazy [] ys = []
-zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
-\end{code}
-
-\begin{code}
-mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
-
-mapAndUnzip f [] = ([],[])
-mapAndUnzip f (x:xs)
- = let
- (r1, r2) = f x
- (rs1, rs2) = mapAndUnzip f xs
- in
- (r1:rs1, r2:rs2)
-
-mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
-
-mapAndUnzip3 f [] = ([],[],[])
-mapAndUnzip3 f (x:xs)
- = let
- (r1, r2, r3) = f x
- (rs1, rs2, rs3) = mapAndUnzip3 f xs
- in
- (r1:rs1, r2:rs2, r3:rs3)
-\end{code}
-
-\begin{code}
-nOfThem :: Int -> a -> [a]
-nOfThem = replicate -- deprecated.
-
-lengthExceeds :: [a] -> Int -> Bool
--- (lengthExceeds xs n) is True if length xs > n
-[] `lengthExceeds` n = 0 > n
-(x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1))
-
-isSingleton :: [a] -> Bool
-
-isSingleton [x] = True
-isSingleton _ = False
-
-startsWith, endsWith :: String -> String -> Maybe String
-
-startsWith [] str = Just str
-startsWith (c:cs) (s:ss)
- = if c /= s then Nothing else startsWith cs ss
-startsWith _ [] = Nothing
-
-endsWith cs ss
- = case (startsWith (reverse cs) (reverse ss)) of
- Nothing -> Nothing
- Just rs -> Just (reverse rs)
-\end{code}
-
-Debugging/specialising versions of \tr{elem} and \tr{notElem}
-\begin{code}
-#if defined(COMPILING_GHC)
-isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
-
-# ifndef DEBUG
-isIn msg x ys = elem__ x ys
-isn'tIn msg x ys = notElem__ x ys
-
---these are here to be SPECIALIZEd (automagically)
-elem__ _ [] = False
-elem__ x (y:ys) = x==y || elem__ x ys
-
-notElem__ x [] = True
-notElem__ x (y:ys) = x /= y && notElem__ x ys
-
-# else {- DEBUG -}
-isIn msg x ys
- = elem ILIT(0) x ys
- where
- elem i _ [] = False
- elem i x (y:ys)
- | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
- | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
-
-isn'tIn msg x ys
- = notElem ILIT(0) x ys
- where
- notElem i x [] = True
- notElem i x (y:ys)
- | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
- | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
-
-# endif {- DEBUG -}
-
-#endif {- COMPILING_GHC -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-assoc]{Association lists}
-%* *
-%************************************************************************
-
-See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
-
-\begin{code}
-assoc :: (Eq a) => String -> [(a, b)] -> a -> b
-
-assoc crash_msg lst key
- = if (null res)
- then panic ("Failed in assoc: " ++ crash_msg)
- else head res
- where res = [ val | (key', val) <- lst, key == key']
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-dups]{Duplicate-handling}
-%* *
-%************************************************************************
-
-\begin{code}
-hasNoDups :: (Eq a) => [a] -> Bool
-
-hasNoDups xs = f [] xs
- where
- f seen_so_far [] = True
- f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
- False
- else
- f (x:seen_so_far) xs
-
-#if defined(COMPILING_GHC)
- is_elem = isIn "hasNoDups"
-#else
- is_elem = elem
-#endif
-\end{code}
-
-\begin{code}
-equivClasses :: (a -> a -> Ordering) -- Comparison
- -> [a]
- -> [[a]]
-
-equivClasses cmp stuff@[] = []
-equivClasses cmp stuff@[item] = [stuff]
-equivClasses cmp items
- = runs eq (sortLt lt items)
- where
- eq a b = case cmp a b of { EQ -> True; _ -> False }
- lt a b = case cmp a b of { LT -> True; _ -> False }
-\end{code}
-
-The first cases in @equivClasses@ above are just to cut to the point
-more quickly...
-
-@runs@ groups a list into a list of lists, each sublist being a run of
-identical elements of the input list. It is passed a predicate @p@ which
-tells when two elements are equal.
-
-\begin{code}
-runs :: (a -> a -> Bool) -- Equality
- -> [a]
- -> [[a]]
-
-runs p [] = []
-runs p (x:xs) = case (span (p x) xs) of
- (first, rest) -> (x:first) : (runs p rest)
-\end{code}
-
-\begin{code}
-removeDups :: (a -> a -> Ordering) -- Comparison function
- -> [a]
- -> ([a], -- List with no duplicates
- [[a]]) -- List of duplicate groups. One representative from
- -- each group appears in the first result
-
-removeDups cmp [] = ([], [])
-removeDups cmp [x] = ([x],[])
-removeDups cmp xs
- = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
- (xs', dups) }
- where
- collect_dups dups_so_far [x] = (dups_so_far, x)
- collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-sorting]{Sorting}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection[Utils-quicksorting]{Quicksorts}
-%* *
-%************************************************************************
-
-\begin{code}
--- tail-recursive, etc., "quicker sort" [as per Meira thesis]
-quicksort :: (a -> a -> Bool) -- Less-than predicate
- -> [a] -- Input list
- -> [a] -- Result list in increasing order
-
-quicksort lt [] = []
-quicksort lt [x] = [x]
-quicksort lt (x:xs) = split x [] [] xs
- where
- split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
- split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
- | True = split x lo (y:hi) ys
-\end{code}
-
-Quicksort variant from Lennart's Haskell-library contribution. This
-is a {\em stable} sort.
-
-\begin{code}
-stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
-
-sortLt :: (a -> a -> Bool) -- Less-than predicate
- -> [a] -- Input list
- -> [a] -- Result list
-
-sortLt lt l = qsort lt l []
-
--- qsort is stable and does not concatenate.
-qsort :: (a -> a -> Bool) -- Less-than predicate
- -> [a] -- xs, Input list
- -> [a] -- r, Concatenate this list to the sorted input list
- -> [a] -- Result = sort xs ++ r
-
-qsort lt [] r = r
-qsort lt [x] r = x:r
-qsort lt (x:xs) r = qpart lt x xs [] [] r
-
--- qpart partitions and sorts the sublists
--- rlt contains things less than x,
--- rge contains the ones greater than or equal to x.
--- Both have equal elements reversed with respect to the original list.
-
-qpart lt x [] rlt rge r =
- -- rlt and rge are in reverse order and must be sorted with an
- -- anti-stable sorting
- rqsort lt rlt (x : rqsort lt rge r)
-
-qpart lt x (y:ys) rlt rge r =
- if lt y x then
- -- y < x
- qpart lt x ys (y:rlt) rge r
- else
- -- y >= x
- qpart lt x ys rlt (y:rge) r
-
--- rqsort is as qsort but anti-stable, i.e. reverses equal elements
-rqsort lt [] r = r
-rqsort lt [x] r = x:r
-rqsort lt (x:xs) r = rqpart lt x xs [] [] r
-
-rqpart lt x [] rle rgt r =
- qsort lt rle (x : qsort lt rgt r)
-
-rqpart lt x (y:ys) rle rgt r =
- if lt x y then
- -- y > x
- rqpart lt x ys rle (y:rgt) r
- else
- -- y <= x
- rqpart lt x ys (y:rle) rgt r
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
-%* *
-%************************************************************************
-
-\begin{code}
-mergesort :: (a -> a -> Ordering) -> [a] -> [a]
-
-mergesort cmp xs = merge_lists (split_into_runs [] xs)
- where
- a `le` b = case cmp a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a `ge` b = case cmp a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
-
- split_into_runs [] [] = []
- split_into_runs run [] = [run]
- split_into_runs [] (x:xs) = split_into_runs [x] xs
- split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
- split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
- | True = rl : (split_into_runs [x] xs)
-
- merge_lists [] = []
- merge_lists (x:xs) = merge x (merge_lists xs)
-
- merge [] ys = ys
- merge xs [] = xs
- merge xl@(x:xs) yl@(y:ys)
- = case cmp x y of
- EQ_ -> x : y : (merge xs ys)
- LT_ -> x : (merge xs yl)
- GT__ -> y : (merge xl ys)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
-%* *
-%************************************************************************
-
-\begin{display}
-Date: Mon, 3 May 93 20:45:23 +0200
-From: Carsten Kehler Holst <kehler@cs.chalmers.se>
-To: partain@dcs.gla.ac.uk
-Subject: natural merge sort beats quick sort [ and it is prettier ]
-
-Here is a piece of Haskell code that I'm rather fond of. See it as an
-attempt to get rid of the ridiculous quick-sort routine. group is
-quite useful by itself I think it was John's idea originally though I
-believe the lazy version is due to me [surprisingly complicated].
-gamma [used to be called] is called gamma because I got inspired by
-the Gamma calculus. It is not very close to the calculus but does
-behave less sequentially than both foldr and foldl. One could imagine
-a version of gamma that took a unit element as well thereby avoiding
-the problem with empty lists.
-
-I've tried this code against
-
- 1) insertion sort - as provided by haskell
- 2) the normal implementation of quick sort
- 3) a deforested version of quick sort due to Jan Sparud
- 4) a super-optimized-quick-sort of Lennart's
-
-If the list is partially sorted both merge sort and in particular
-natural merge sort wins. If the list is random [ average length of
-rising subsequences = approx 2 ] mergesort still wins and natural
-merge sort is marginally beaten by Lennart's soqs. The space
-consumption of merge sort is a bit worse than Lennart's quick sort
-approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
-fpca article ] isn't used because of group.
-
-have fun
-Carsten
-\end{display}
-
-\begin{code}
-group :: (a -> a -> Bool) -> [a] -> [[a]]
-
-{-
-Date: Mon, 12 Feb 1996 15:09:41 +0000
-From: Andy Gill <andy@dcs.gla.ac.uk>
-
-Here is a `better' definition of group.
--}
-group p [] = []
-group p (x:xs) = group' xs x x (x :)
- where
- group' [] _ _ s = [s []]
- group' (x:xs) x_min x_max s
- | not (x `p` x_max) = group' xs x_min x (s . (x :))
- | x `p` x_min = group' xs x x_max ((x :) . s)
- | otherwise = s [] : group' xs x x (x :)
-
--- This one works forwards *and* backwards, as well as also being
--- faster that the one in Util.lhs.
-
-{- ORIG:
-group p [] = [[]]
-group p (x:xs) =
- let ((h1:t1):tt1) = group p xs
- (t,tt) = if null xs then ([],[]) else
- if x `p` h1 then (h1:t1,tt1) else
- ([], (h1:t1):tt1)
- in ((x:t):tt)
--}
-
-generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
-generalMerge p xs [] = xs
-generalMerge p [] ys = ys
-generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
- | otherwise = y : generalMerge p (x:xs) ys
-
--- gamma is now called balancedFold
-
-balancedFold :: (a -> a -> a) -> [a] -> a
-balancedFold f [] = error "can't reduce an empty list using balancedFold"
-balancedFold f [x] = x
-balancedFold f l = balancedFold f (balancedFold' f l)
-
-balancedFold' :: (a -> a -> a) -> [a] -> [a]
-balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
-balancedFold' f xs = xs
-
-generalMergeSort p [] = []
-generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
-
-generalNaturalMergeSort p [] = []
-generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
-
-mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
-
-mergeSort = generalMergeSort (<=)
-naturalMergeSort = generalNaturalMergeSort (<=)
-
-mergeSortLe le = generalMergeSort le
-naturalMergeSortLe le = generalNaturalMergeSort le
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-transitive-closure]{Transitive closure}
-%* *
-%************************************************************************
-
-This algorithm for transitive closure is straightforward, albeit quadratic.
-
-\begin{code}
-transitiveClosure :: (a -> [a]) -- Successor function
- -> (a -> a -> Bool) -- Equality predicate
- -> [a]
- -> [a] -- The transitive closure
-
-transitiveClosure succ eq xs
- = go [] xs
- where
- go done [] = done
- go done (x:xs) | x `is_in` done = go done xs
- | otherwise = go (x:done) (succ x ++ xs)
-
- x `is_in` [] = False
- x `is_in` (y:ys) | eq x y = True
- | otherwise = x `is_in` ys
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-accum]{Accumulating}
-%* *
-%************************************************************************
-
-@mapAccumL@ behaves like a combination
-of @map@ and @foldl@;
-it applies a function to each element of a list, passing an accumulating
-parameter from left to right, and returning a final value of this
-accumulator together with the new list.
-
-\begin{code}
-mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
- -- and accumulator, returning new
- -- accumulator and elt of result list
- -> acc -- Initial accumulator
- -> [x] -- Input list
- -> (acc, [y]) -- Final accumulator and result list
-
-mapAccumL f b [] = (b, [])
-mapAccumL f b (x:xs) = (b'', x':xs') where
- (b', x') = f b x
- (b'', xs') = mapAccumL f b' xs
-\end{code}
-
-@mapAccumR@ does the same, but working from right to left instead. Its type is
-the same as @mapAccumL@, though.
-
-\begin{code}
-mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
- -- and accumulator, returning new
- -- accumulator and elt of result list
- -> acc -- Initial accumulator
- -> [x] -- Input list
- -> (acc, [y]) -- Final accumulator and result list
-
-mapAccumR f b [] = (b, [])
-mapAccumR f b (x:xs) = (b'', x':xs') where
- (b'', x') = f b' x
- (b', xs') = mapAccumR f b xs
-\end{code}
-
-Here is the bi-directional version, that works from both left and right.
-
-\begin{code}
-mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
- -- Function of elt of input list
- -- and accumulator, returning new
- -- accumulator and elt of result list
- -> accl -- Initial accumulator from left
- -> accr -- Initial accumulator from right
- -> [x] -- Input list
- -> (accl, accr, [y]) -- Final accumulators and result list
-
-mapAccumB f a b [] = (a,b,[])
-mapAccumB f a b (x:xs) = (a'',b'',y:ys)
- where
- (a',b'',y) = f a b' x
- (a'',b',ys) = mapAccumB f a' b xs
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-comparison]{Comparisons}
-%* *
-%************************************************************************
-
-See also @tagCmp_@ near the versions-compatibility section.
-
-The Ord3 class will be subsumed into Ord in Haskell 1.3.
-
-\begin{code}
-{-
-class Ord3 a where
- cmp :: a -> a -> TAG_
--}
-
-thenCmp :: Ordering -> Ordering -> Ordering
-{-# INLINE thenCmp #-}
-thenCmp EQ any = any
-thenCmp other any = other
-
-cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
- -- `cmpList' uses a user-specified comparer
-
-cmpList cmp [] [] = EQ
-cmpList cmp [] _ = LT
-cmpList cmp _ [] = GT
-cmpList cmp (a:as) (b:bs)
- = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
-\end{code}
-
-begin{code}
-instance Ord3 a => Ord3 [a] where
- cmp [] [] = EQ_
- cmp (x:xs) [] = GT_
- cmp [] (y:ys) = LT_
- cmp (x:xs) (y:ys) = (x `cmp` y) `thenCmp` (xs `cmp` ys)
-
-instance Ord3 a => Ord3 (Maybe a) where
- cmp Nothing Nothing = EQ_
- cmp Nothing (Just y) = LT_
- cmp (Just x) Nothing = GT_
- cmp (Just x) (Just y) = x `cmp` y
-
-instance Ord3 Int where
- cmp a b | a < b = LT_
- | a > b = GT_
- | otherwise = EQ_
-end{code}
-
-\begin{code}
-cmpString :: String -> String -> TAG_
-
-cmpString [] [] = EQ_
-cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
- else if x < y then LT_
- else GT_
-cmpString [] ys = LT_
-cmpString xs [] = GT_
-\end{code}
-
-\begin{code}
-cmpPString :: FAST_STRING -> FAST_STRING -> TAG_
-
-cmpPString x y = compare x y
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-pairs]{Pairs}
-%* *
-%************************************************************************
-
-The following are curried versions of @fst@ and @snd@.
-
-\begin{code}
-cfst :: a -> b -> a -- stranal-sem only (Note)
-cfst x y = x
-\end{code}
-
-The following provide us higher order functions that, when applied
-to a function, operate on pairs.
-
-\begin{code}
-applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
-applyToPair (f,g) (x,y) = (f x, g y)
-
-applyToFst :: (a -> c) -> (a,b)-> (c,b)
-applyToFst f (x,y) = (f x,y)
-
-applyToSnd :: (b -> d) -> (a,b) -> (a,d)
-applyToSnd f (x,y) = (x,f y)
-
-foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
-foldPair fg ab [] = ab
-foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
- where (u,v) = foldPair fg ab abs
-\end{code}
-
-\begin{code}
-unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
-unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-errors]{Error handling}
-%* *
-%************************************************************************
-
-\begin{code}
-#if defined(COMPILING_GHC)
-panic x = error ("panic! (the `impossible' happened):\n\t"
- ++ x ++ "\n\n"
- ++ "Please report it as a compiler bug "
- ++ "to glasgow-haskell-bugs@haskell.org.\n\n" )
-
-pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg))
-pprError heading pretty_msg = error (heading++(ppShow 80 pretty_msg))
-#if __GLASGOW_HASKELL__ == 201
-pprTrace heading pretty_msg = GHCbase.trace (heading++(ppShow 80 pretty_msg))
-#elsif __GLASGOW_HASKELL__ >= 201
-pprTrace heading pretty_msg = GHC.trace (heading++(ppShow 80 pretty_msg))
-#else
-pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg))
-#endif
-
--- #-versions because panic can't return an unboxed int, and that's
--- what TAG_ is with GHC at the moment. Ugh. (Simon)
--- No, man -- Too Beautiful! (Will)
-
-panic# :: String -> TAG_
-panic# s = case (panic s) of () -> EQ_
-
-pprPanic# heading pretty_msg = panic# (heading++(ppShow 80 pretty_msg))
-
-assertPanic :: String -> Int -> a
-assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line)
-
-#endif {- COMPILING_GHC -}
-\end{code}
-
+++ /dev/null
-#if 0
-%---------------------------------------------------------------*
-%
-\section{Underlying code for converting to/from ``bytes''}
-%
-%---------------------------------------------------------------*
-
-Stolen from HBC, more or less.
-
-A \tr{I_ foo2bytes__(foo in, ptr arr)} routine takes a \tr{foo}
-input \tr{in}, scribbles some appropriate bytes into the array passed
-to it, \tr{arr}, and returns the number of bytes so put.
-
-A \tr{I_ bytes2foo__(ptr arr, foo *out)} routine looks at the
-array of bytes given to it (\tr{arr}) and gives them back interpreted
-as a \tr{foo} (sticks it in the place pointed to by \tr{out}). It
-returns the number of bytes taken.
-
-\begin{code}
-#endif /* 0 */
-
-#include "Rts.h"
-#include "ByteOps.h"
-
-#if __STDC__
- /* need the ANSI arg decl, so "short" and "float" args dont get promoted */
-#define X2BYTES(type) \
-I_ \
-type##2bytes__(type in, unsigned char *arr) \
-{ \
- union { \
- type i; \
- unsigned char cs[sizeof (type)]; \
- } u; \
- int k; \
- \
- u.i = in; \
- for (k = sizeof (type) - 1; k >= 0; k--) \
- arr[k] = u.cs[k]; \
- \
- return(sizeof (type)); \
-}
-
-#else /* not STDC */
-#define X2BYTES(type) \
-I_ \
-type##2bytes__(type in, unsigned char *arr) \
-{ \
- union { \
- type i; \
- unsigned char cs[sizeof (type)]; \
- } u; \
- int k; \
- \
- u.i = in; \
- for (k = sizeof (type) - 1; k >= 0; k--) \
- arr[k] = u.cs[k]; \
- \
- return(sizeof (type)); \
-}
-#endif /* not STDC */
-
-X2BYTES(long)
-X2BYTES(int)
-X2BYTES(short)
-X2BYTES(float)
-X2BYTES(double)
-
-#define BYTES2X(ctype,htype) \
-I_ \
-bytes2##ctype##__(P_ in, htype *out) \
-{ \
- union { \
- ctype i; \
- unsigned char cs[sizeof (ctype)]; \
- } u; \
- unsigned int k; \
- unsigned char *arr = (unsigned char *) in; \
- \
- for (k = 0; k < sizeof(ctype); k++) \
- u.cs[k] = arr[k]; \
- \
- *out = (htype) u.i; \
- \
- return(sizeof (ctype)); \
-}
-
-#define BYTES2FX(ctype,htype,assign_fx) \
-I_ \
-bytes2##ctype##__(P_ in, htype *out) \
-{ \
- union { \
- ctype i; \
- unsigned char cs[sizeof (ctype)]; \
- } u; \
- unsigned int k; \
- unsigned char *arr = (unsigned char *) in; \
- \
- for (k = 0; k < sizeof(ctype); k++) \
- u.cs[k] = arr[k]; \
- \
- assign_fx((P_)out, (htype) u.i); \
- \
- return(sizeof (ctype)); \
-}
-
-BYTES2X(long,I_)
-BYTES2X(int,I_)
-BYTES2X(short,I_)
-
-BYTES2FX(float,StgFloat,ASSIGN_FLT)
-BYTES2FX(double,StgDouble,ASSIGN_DBL)
+++ /dev/null
-#ifndef BYTEOPS_H
-#define BYTEOPS_H
-
-/* "Native" support */
-/* sigh again: without these some (notably "float") willnae work */
-I_ long2bytes__ (long, unsigned char *);
-I_ int2bytes__ (int, unsigned char *);
-I_ short2bytes__ (short, unsigned char *);
-I_ float2bytes__ (float, unsigned char *);
-I_ double2bytes__ (double, unsigned char *);
-
-I_ bytes2long__ (P_, I_ *);
-I_ bytes2int__ (P_, I_ *);
-I_ bytes2short__ (P_, I_ *);
-I_ bytes2float__ (P_, StgFloat *);
-I_ bytes2double__ (P_, StgDouble *);
-
-#endif
+++ /dev/null
-#
-# Makefile for cbits subdirectory
-#
-TOP=../../..
-include $(TOP)/mk/boilerplate.mk
-
-ifeq "$(filter dll,$(WAYS))" "dll"
-override WAYS=dll
-else
-override WAYS=
-endif
-
-CC:=$(GHC)
-
-C_SRCS=$(wildcard *.c)
-
-# Remove Readline.lhs if readline.h isn't available.
-ifneq "$(HAVE_READLINE)" "YES"
- C_SRCS := $(filter-out ghcReadline.c,$(C_SRCS))
-endif
-
-ifeq "$(EnableWin32DLLs)" "YES"
- C_SRCS := $(filter-out selectFrom.c,$(C_SRCS))
-endif
-
-ifneq "$(way)" "dll"
-SRC_CC_OPTS += -static
-endif
-
-SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR)
-SRC_CC_OPTS += -I$(GHC_INCLUDE_DIR) -I$(GHC_LIB_DIR)/std/cbits
-
-LIBRARY=libHSmisc_cbits$(_way).a
-LIBOBJS=$(C_OBJS)
-INSTALL_LIBS += $(LIBRARY)
-
-DLL_NAME = HSmisc_cbits.dll
-SRC_BLD_DLL_OPTS += --export-all --output-def=HSmisc_cbits.def DllVersionInfo.o
-SRC_BLD_DLL_OPTS += -lwinmm -lwsock32 -lHSrts_imp -lHScbits_imp -lgmp -L. -L../../../rts/gmp -L../../../rts -L../../std/cbits
-
-ifeq "$(way)" "dll"
-all :: DllVersionInfo.o
-endif
-
-ifeq "$(EnableWin32DLLs)" "YES"
-INSTALL_PROGS += $(DLL_NAME)
-INSTALL_LIBS += $(patsubst %.a, %_imp.a, $(LIBRARY))
-endif
-
-include $(TOP)/mk/target.mk
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: PackedString.c,v 1.2 1998/12/02 13:26:41 simonm Exp $
- *
- * PackedString C bits
- *
- * (c) The GHC Team 1998
- * -------------------------------------------------------------------------- */
-
-#include "Rts.h"
-
-StgInt
-byteArrayHasNUL__ (StgByteArray ba, StgInt len)
-{
- StgInt i;
-
- for (i = 0; i < len; i++) {
- if (*(ba + i) == '\0') {
- return(1); /* true */
- }
- }
-
- return(0); /* false */
-}
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: PackedString.h,v 1.2 1998/12/02 13:26:42 simonm Exp $
- *
- * PackedString C bits
- *
- * (c) The GHC Team 1998
- * -------------------------------------------------------------------------- */
-
-extern StgInt byteArrayHasNUL__ (StgByteArray ba, StgInt len);
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1996
-%
-\subsection[acceptSocket.lc]{Server wait for client to connect}
-
-\begin{code}
-#endif
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-acceptSocket(I_ sockfd, A_ peer, A_ addrlen)
-{
- StgInt fd;
- long flags;
-
- while ((fd = accept((int)sockfd, (struct sockaddr *)peer, (int *)addrlen)) < 0) {
- if (errno == EAGAIN) {
- errno = 0;
- return FILEOBJ_BLOCKED_READ;
-
- } else if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EBADF:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Not a valid descriptor";
- break;
- case GHC_EFAULT:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Address not in writeable part of user address space";
- break;
- case GHC_ENOTSOCK:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Descriptor not a socket";
- break;
- case GHC_EOPNOTSUPP:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Socket not of type that supports listen";
- break;
- case GHC_EWOULDBLOCK:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "No sockets are present to be accepted";
- break;
- }
- return -1;
- }
- }
-
- /* set the non-blocking flag on this file descriptor */
-#if !defined(_WIN32) || defined(__CYGWIN__) || defined(__CYGWIN32__)
- flags = fcntl(fd, F_GETFL);
- fcntl(fd, F_SETFL, flags | O_NONBLOCK);
-#endif
-
- return fd;
-}
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[bindSocket.lc]{Assign name to unnamed socket}
-
-\begin{code}
-#endif
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-bindSocket(I_ sockfd, A_ myaddr, I_ addrlen, I_ isUnixDomain)
-{
- int rc;
-
- while ((rc = bind((int)sockfd, (struct sockaddr *)myaddr, (int)addrlen)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EACCES:
- ghc_errtype = ERR_PERMISSIONDENIED;
- if (isUnixDomain != 0)
- ghc_errstr = "For a component of path prefix of path name";
- else
- ghc_errstr = "Requested address protected, cannot bind socket";
- break;
- case GHC_EISCONN:
- case GHC_EADDRINUSE:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "Address already in use";
- break;
- case GHC_EADDRNOTAVAIL:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "Address not available from local machine";
- break;
- case GHC_EBADF:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Not a valid socket file descriptor";
- break;
- case GHC_EFAULT:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Address not in valid part of user address space";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_SYSTEMERROR;
- ghc_errstr = "Specified size of structure not equal valid address for family";
- break;
- case GHC_ENOTSOCK:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "Descriptor for file, not a socket";
- break;
- case GHC_EIO:
- ghc_errtype = ERR_SYSTEMERROR;
- ghc_errstr = "Could not make directory entry or alloc inode";
- break;
- case GHC_EISDIR:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "A null path name was given";
- break;
- case GHC_ELOOP:
- ghc_errtype = ERR_SYSTEMERROR;
- ghc_errstr = "Too many symbolic links encountered";
- break;
- case GHC_ENAMETOOLONG:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Max length of path name exceeded";
- break;
- case GHC_ENOENT:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Component in path prefix does not exist";
- break;
- case GHC_ENOTDIR:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Component in path prefix is not a directory";
- break;
- case GHC_EROFS:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "The inode would reside on read only file system";
- break;
- }
- return -1;
- }
- }
- return 0;
-}
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[connectSocket.lc]{Assign name to client socket}
-
-\begin{code}
-#endif
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-connectSocket(I_ sockfd, A_ servaddr, I_ addrlen, I_ isUnixDomain)
-{
- int rc;
-
- while ((rc = connect((int)sockfd, (struct sockaddr *)servaddr, (int)addrlen)) < 0) {
-#if !defined(_WIN32) || defined(__CYGWIN__) || defined(__CYGWIN32__)
- if (errno == EINPROGRESS) {
- errno = 0;
- return FILEOBJ_BLOCKED_WRITE;
-
- } else
-#endif
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EACCES:
- ghc_errtype = ERR_PERMISSIONDENIED;
- if (isUnixDomain != 0)
- ghc_errstr = "For a component of path prefix of path name";
- else
- ghc_errstr = "Requested address protected, cannot bind socket";
- break;
- case GHC_EISCONN:
- case GHC_EADDRINUSE:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "Address already in use";
- break;
- case GHC_EADDRNOTAVAIL:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "Address not available from local machine";
- break;
- case GHC_EAFNOSUPPORT:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Address cannot be used with socket";
- break;
- case GHC_EALREADY:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "Non-blocking socket, previous connection attempt not completed";
- break;
- case GHC_EBADF:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Not a valid socket file descriptor";
- break;
- case GHC_ECONNREFUSED:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "Connection rejected";
- break;
- case GHC_EFAULT:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Address not in valid part of process address space";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_SYSTEMERROR;
- ghc_errstr = "Specified size of structure not equal valid address for family";
- break;
- case GHC_ENETUNREACH:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "Network not reachable from host";
- break;
- case GHC_ENOTSOCK:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "Descriptor for file, not a socket";
- break;
- case GHC_ETIMEDOUT:
- ghc_errtype = ERR_TIMEEXPIRED;
- ghc_errstr = "Connection attempt timed out";
- break;
- case GHC_EIO:
- ghc_errtype = ERR_SYSTEMERROR;
- ghc_errstr = "Could not make directory entry or alloc inode";
- break;
- case GHC_EISDIR:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "A null path name was given";
- break;
- case GHC_ELOOP:
- ghc_errtype = ERR_SYSTEMERROR;
- ghc_errstr = "Too many symbolic links encountered";
- break;
- case GHC_ENAMETOOLONG:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Max length of path name exceeded";
- break;
- case GHC_ENOENT:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Component in path prefix does not exist";
- break;
- case GHC_ENOTDIR:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Component in path prefix is not a directory";
- break;
- case GHC_EPROTOTYPE:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "File referred to is a socket of differing type";
- break;
- }
- return -1;
- }
- }
- return 0;
-}
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[createSocket.lc]{Create a socket file descriptor}
-
-\begin{code}
-#endif
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-createSocket(I_ family, I_ type, I_ protocol)
-{
- int fd;
- long flags;
-
- if ((fd = socket((int)family, (int)type, (int)protocol)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EACCES:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "cannot create socket";
- break;
- case GHC_EMFILE:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "Too many open files";
- break;
- case GHC_ENFILE:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "System file table overflow";
- break;
- case GHC_EPROTONOSUPPORT:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "Protocol type not supported";
- break;
- case GHC_EPROTOTYPE:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "Protocol wrong type for socket";
- break;
- }
- return (StgInt)-1;
- }
- }
-
- /* set the non-blocking flag on this file descriptor */
-#if !defined(_WIN32) || defined(__CYGWIN__) || defined(__CYGWIN32__)
- flags = fcntl(fd, F_GETFL);
- fcntl(fd, F_SETFL, flags | O_NONBLOCK);
-#endif
-
- return (StgInt)fd;
-}
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1996
-%
-\subsection[getPeerName.lc]{Return name of peer process}
-
-Returns name of peer process connected to a socket.
-
-\begin{code}
-#endif
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-getPeerName(I_ sockfd, A_ peer, A_ namelen)
-{
- StgInt name;
-
- while ((name = getpeername((int) sockfd, (struct sockaddr *) peer, (int *) namelen)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EBADF:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Not a valid write descriptor";
- break;
- case GHC_EFAULT:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Data not in writeable part of user address space";
- break;
- case GHC_ENOBUFS:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "Insuffcient resources";
- break;
- case GHC_ENOTCONN:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Socket not connected";
- break;
- case GHC_ENOTSOCK:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Descriptor is not a socket";
- break;
- }
- return -1;
- }
- }
- return name;
-}
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1996
-%
-\subsection[getSockName.lc]{Return name of process assoc with socket}
-
-\begin{code}
-#endif
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-getSockName(I_ sockfd, A_ peer, A_ namelen)
-{
- StgInt name;
-
- while ((name = getsockname((int) sockfd, (struct sockaddr *) peer, (int *) namelen)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EBADF:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Not a valid write descriptor";
- break;
- case GHC_EFAULT:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Data not in writeable part of user address space";
- break;
- case GHC_ENOBUFS:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "Insuffcient resources";
- break;
- case GHC_ENOTSOCK:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Descriptor is not a socket";
- break;
- }
- return -1;
- }
- }
- return name;
-}
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-% Last Modified: Wed Jul 19 12:03:26 1995
-% Darren J Moffat <moffatd@dcs.gla.ac.uk>
-\section[LibReadline]{GNU Readline Library Bindings}
-
-\begin{code}
-#endif
-
-#include "rtsdefs.h"
-
-#include "ghcReadline.h" /* to make sure the code here agrees...*/
-
-/*
-Wrapper around the callback mechanism to allow Haskell side functions
-to be callbacks for the Readline library.
-
-The C function $genericRlCback$ puts the cback args into global
-variables and enters the Haskell world through the $haskellRlEntry$
-function. Before exiting, the Haskell function will deposit its result
-in the global variable $rl_return$.
-*/
-
-I_ current_narg, rl_return, current_kc;
-
-char* rl_prompt_hack;
-
-StgStablePtr haskellRlEntry;
-StgStablePtr cbackList;
-
-
-I_
-genericRlCback (I_ narg, I_ kc)
-{
- current_narg = narg;
- current_kc = kc;
-
- performIO(haskellRlEntry);
-
- return rl_return;
-}
+++ /dev/null
-#ifndef GHC_READLINE_H
-#define GHC_READLINE_H
-
-/* Included to see the defn. the HAVE_* below */
-#include "config.h"
-
-#if HAVE_READLINE_READLINE_H
-#include <readline/readline.h>
-#include <readline/history.h>
-#endif
-
-/* For some reason the following 3 aren't defined in readline.h */
-extern int rl_mark;
-extern int rl_done;
-extern int rl_pending_input;
-
-
-/* Our C Hackery stuff for Callbacks */
-typedef I_ KeyCode;
-extern StgStablePtr cbackList;
-I_ genericRlCback (I_, I_);
-extern StgStablePtr haskellRlEntry;
-extern I_ current_narg, rl_return;
-extern KeyCode current_kc;
-extern char* rl_prompt_hack;
-
-#endif /* !GHC_READLINE_H */
+++ /dev/null
-/* Definitions for data structures and routines for the regular
- expression library, version 0.12.
- Copyright (C) 1985,89,90,91,92,93,95,96,97 Free Software Foundation, Inc.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2, or (at your option)
- any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software Foundation,
- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
-
-#ifndef __REGEXP_LIBRARY_H__
-#define __REGEXP_LIBRARY_H__
-
-/* Allow the use in C++ code. */
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-/* POSIX says that <sys/types.h> must be included (by the caller) before
- <regex.h>. */
-
-#if !defined (_POSIX_C_SOURCE) && !defined (_POSIX_SOURCE) && defined (VMS)
-/* VMS doesn't have `size_t' in <sys/types.h>, even though POSIX says it
- should be there. */
-#include <stddef.h>
-#endif
-
-/* The following two types have to be signed and unsigned integer type
- wide enough to hold a value of a pointer. For most ANSI compilers
- ptrdiff_t and size_t should be likely OK. Still size of these two
- types is 2 for Microsoft C. Ugh... */
-typedef long int s_reg_t;
-typedef unsigned long int active_reg_t;
-
-/* The following bits are used to determine the regexp syntax we
- recognize. The set/not-set meanings are chosen so that Emacs syntax
- remains the value 0. The bits are given in alphabetical order, and
- the definitions shifted by one from the previous bit; thus, when we
- add or remove a bit, only one other definition need change. */
-typedef unsigned long int reg_syntax_t;
-
-/* If this bit is not set, then \ inside a bracket expression is literal.
- If set, then such a \ quotes the following character. */
-#define RE_BACKSLASH_ESCAPE_IN_LISTS ((unsigned long int) 1)
-
-/* If this bit is not set, then + and ? are operators, and \+ and \? are
- literals.
- If set, then \+ and \? are operators and + and ? are literals. */
-#define RE_BK_PLUS_QM (RE_BACKSLASH_ESCAPE_IN_LISTS << 1)
-
-/* If this bit is set, then character classes are supported. They are:
- [:alpha:], [:upper:], [:lower:], [:digit:], [:alnum:], [:xdigit:],
- [:space:], [:print:], [:punct:], [:graph:], and [:cntrl:].
- If not set, then character classes are not supported. */
-#define RE_CHAR_CLASSES (RE_BK_PLUS_QM << 1)
-
-/* If this bit is set, then ^ and $ are always anchors (outside bracket
- expressions, of course).
- If this bit is not set, then it depends:
- ^ is an anchor if it is at the beginning of a regular
- expression or after an open-group or an alternation operator;
- $ is an anchor if it is at the end of a regular expression, or
- before a close-group or an alternation operator.
-
- This bit could be (re)combined with RE_CONTEXT_INDEP_OPS, because
- POSIX draft 11.2 says that * etc. in leading positions is undefined.
- We already implemented a previous draft which made those constructs
- invalid, though, so we haven't changed the code back. */
-#define RE_CONTEXT_INDEP_ANCHORS (RE_CHAR_CLASSES << 1)
-
-/* If this bit is set, then special characters are always special
- regardless of where they are in the pattern.
- If this bit is not set, then special characters are special only in
- some contexts; otherwise they are ordinary. Specifically,
- * + ? and intervals are only special when not after the beginning,
- open-group, or alternation operator. */
-#define RE_CONTEXT_INDEP_OPS (RE_CONTEXT_INDEP_ANCHORS << 1)
-
-/* If this bit is set, then *, +, ?, and { cannot be first in an re or
- immediately after an alternation or begin-group operator. */
-#define RE_CONTEXT_INVALID_OPS (RE_CONTEXT_INDEP_OPS << 1)
-
-/* If this bit is set, then . matches newline.
- If not set, then it doesn't. */
-#define RE_DOT_NEWLINE (RE_CONTEXT_INVALID_OPS << 1)
-
-/* If this bit is set, then . doesn't match NUL.
- If not set, then it does. */
-#define RE_DOT_NOT_NULL (RE_DOT_NEWLINE << 1)
-
-/* If this bit is set, nonmatching lists [^...] do not match newline.
- If not set, they do. */
-#define RE_HAT_LISTS_NOT_NEWLINE (RE_DOT_NOT_NULL << 1)
-
-/* If this bit is set, either \{...\} or {...} defines an
- interval, depending on RE_NO_BK_BRACES.
- If not set, \{, \}, {, and } are literals. */
-#define RE_INTERVALS (RE_HAT_LISTS_NOT_NEWLINE << 1)
-
-/* If this bit is set, +, ? and | aren't recognized as operators.
- If not set, they are. */
-#define RE_LIMITED_OPS (RE_INTERVALS << 1)
-
-/* If this bit is set, newline is an alternation operator.
- If not set, newline is literal. */
-#define RE_NEWLINE_ALT (RE_LIMITED_OPS << 1)
-
-/* If this bit is set, then `{...}' defines an interval, and \{ and \}
- are literals.
- If not set, then `\{...\}' defines an interval. */
-#define RE_NO_BK_BRACES (RE_NEWLINE_ALT << 1)
-
-/* If this bit is set, (...) defines a group, and \( and \) are literals.
- If not set, \(...\) defines a group, and ( and ) are literals. */
-#define RE_NO_BK_PARENS (RE_NO_BK_BRACES << 1)
-
-/* If this bit is set, then \<digit> matches <digit>.
- If not set, then \<digit> is a back-reference. */
-#define RE_NO_BK_REFS (RE_NO_BK_PARENS << 1)
-
-/* If this bit is set, then | is an alternation operator, and \| is literal.
- If not set, then \| is an alternation operator, and | is literal. */
-#define RE_NO_BK_VBAR (RE_NO_BK_REFS << 1)
-
-/* If this bit is set, then an ending range point collating higher
- than the starting range point, as in [z-a], is invalid.
- If not set, then when ending range point collates higher than the
- starting range point, the range is ignored. */
-#define RE_NO_EMPTY_RANGES (RE_NO_BK_VBAR << 1)
-
-/* If this bit is set, then an unmatched ) is ordinary.
- If not set, then an unmatched ) is invalid. */
-#define RE_UNMATCHED_RIGHT_PAREN_ORD (RE_NO_EMPTY_RANGES << 1)
-
-/* If this bit is set, succeed as soon as we match the whole pattern,
- without further backtracking. */
-#define RE_NO_POSIX_BACKTRACKING (RE_UNMATCHED_RIGHT_PAREN_ORD << 1)
-
-/* If this bit is set, do not process the GNU regex operators.
- If not set, then the GNU regex operators are recognized. */
-#define RE_NO_GNU_OPS (RE_NO_POSIX_BACKTRACKING << 1)
-
-/* If this bit is set, turn on internal regex debugging.
- If not set, and debugging was on, turn it off.
- This only works if regex.c is compiled -DDEBUG.
- We define this bit always, so that all that's needed to turn on
- debugging is to recompile regex.c; the calling code can always have
- this bit set, and it won't affect anything in the normal case. */
-#define RE_DEBUG (RE_NO_GNU_OPS << 1)
-
-/* This global variable defines the particular regexp syntax to use (for
- some interfaces). When a regexp is compiled, the syntax used is
- stored in the pattern buffer, so changing this does not affect
- already-compiled regexps. */
-extern reg_syntax_t re_syntax_options;
-\f
-/* Define combinations of the above bits for the standard possibilities.
- (The [[[ comments delimit what gets put into the Texinfo file, so
- don't delete them!) */
-/* [[[begin syntaxes]]] */
-#define RE_SYNTAX_EMACS 0
-
-#define RE_SYNTAX_AWK \
- (RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DOT_NOT_NULL \
- | RE_NO_BK_PARENS | RE_NO_BK_REFS \
- | RE_NO_BK_VBAR | RE_NO_EMPTY_RANGES \
- | RE_DOT_NEWLINE | RE_CONTEXT_INDEP_ANCHORS \
- | RE_UNMATCHED_RIGHT_PAREN_ORD | RE_NO_GNU_OPS)
-
-#define RE_SYNTAX_GNU_AWK \
- ((RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DEBUG) \
- & ~(RE_DOT_NOT_NULL | RE_INTERVALS | RE_CONTEXT_INDEP_OPS))
-
-#define RE_SYNTAX_POSIX_AWK \
- (RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS \
- | RE_INTERVALS | RE_NO_GNU_OPS)
-
-#define RE_SYNTAX_GREP \
- (RE_BK_PLUS_QM | RE_CHAR_CLASSES \
- | RE_HAT_LISTS_NOT_NEWLINE | RE_INTERVALS \
- | RE_NEWLINE_ALT)
-
-#define RE_SYNTAX_EGREP \
- (RE_CHAR_CLASSES | RE_CONTEXT_INDEP_ANCHORS \
- | RE_CONTEXT_INDEP_OPS | RE_HAT_LISTS_NOT_NEWLINE \
- | RE_NEWLINE_ALT | RE_NO_BK_PARENS \
- | RE_NO_BK_VBAR)
-
-#define RE_PERL_MULTILINE_SYNTAX \
- (RE_BACKSLASH_ESCAPE_IN_LISTS | RE_CONTEXT_INDEP_ANCHORS \
- | RE_CONTEXT_INDEP_OPS \
- | RE_INTERVALS | RE_NO_BK_BRACES \
- | RE_NO_BK_PARENS | RE_NO_BK_VBAR)
-
-#define RE_PERL_SINGLELINE_SYNTAX \
- (RE_BACKSLASH_ESCAPE_IN_LISTS | RE_CONTEXT_INDEP_ANCHORS \
- | RE_CONTEXT_INDEP_OPS | RE_DOT_NEWLINE \
- | RE_INTERVALS | RE_NO_BK_BRACES \
- | RE_NO_BK_PARENS | RE_NO_BK_VBAR)
-
-#define RE_SYNTAX_POSIX_EGREP \
- (RE_SYNTAX_EGREP | RE_INTERVALS | RE_NO_BK_BRACES)
-
-/* P1003.2/D11.2, section 4.20.7.1, lines 5078ff. */
-#define RE_SYNTAX_ED RE_SYNTAX_POSIX_BASIC
-
-#define RE_SYNTAX_SED RE_SYNTAX_POSIX_BASIC
-
-/* Syntax bits common to both basic and extended POSIX regex syntax. */
-#define _RE_SYNTAX_POSIX_COMMON \
- (RE_CHAR_CLASSES | RE_DOT_NEWLINE | RE_DOT_NOT_NULL \
- | RE_INTERVALS | RE_NO_EMPTY_RANGES)
-
-#define RE_SYNTAX_POSIX_BASIC \
- (_RE_SYNTAX_POSIX_COMMON | RE_BK_PLUS_QM)
-
-/* Differs from ..._POSIX_BASIC only in that RE_BK_PLUS_QM becomes
- RE_LIMITED_OPS, i.e., \? \+ \| are not recognized. Actually, this
- isn't minimal, since other operators, such as \`, aren't disabled. */
-#define RE_SYNTAX_POSIX_MINIMAL_BASIC \
- (_RE_SYNTAX_POSIX_COMMON | RE_LIMITED_OPS)
-
-#define RE_SYNTAX_POSIX_EXTENDED \
- (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \
- | RE_CONTEXT_INDEP_OPS | RE_NO_BK_BRACES \
- | RE_NO_BK_PARENS | RE_NO_BK_VBAR \
- | RE_UNMATCHED_RIGHT_PAREN_ORD)
-
-/* Differs from ..._POSIX_EXTENDED in that RE_CONTEXT_INVALID_OPS
- replaces RE_CONTEXT_INDEP_OPS and RE_NO_BK_REFS is added. */
-#define RE_SYNTAX_POSIX_MINIMAL_EXTENDED \
- (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \
- | RE_CONTEXT_INVALID_OPS | RE_NO_BK_BRACES \
- | RE_NO_BK_PARENS | RE_NO_BK_REFS \
- | RE_NO_BK_VBAR | RE_UNMATCHED_RIGHT_PAREN_ORD)
-/* [[[end syntaxes]]] */
-\f
-/* Maximum number of duplicates an interval can allow. Some systems
- (erroneously) define this in other header files, but we want our
- value, so remove any previous define. */
-#ifdef RE_DUP_MAX
-#undef RE_DUP_MAX
-#endif
-/* If sizeof(int) == 2, then ((1 << 15) - 1) overflows. */
-#define RE_DUP_MAX (0x7fff)
-
-
-/* POSIX `cflags' bits (i.e., information for `regcomp'). */
-
-/* If this bit is set, then use extended regular expression syntax.
- If not set, then use basic regular expression syntax. */
-#define REG_EXTENDED 1
-
-/* If this bit is set, then ignore case when matching.
- If not set, then case is significant. */
-#define REG_ICASE (REG_EXTENDED << 1)
-
-/* If this bit is set, then anchors do not match at newline
- characters in the string.
- If not set, then anchors do match at newlines. */
-#define REG_NEWLINE (REG_ICASE << 1)
-
-/* If this bit is set, then report only success or fail in regexec.
- If not set, then returns differ between not matching and errors. */
-#define REG_NOSUB (REG_NEWLINE << 1)
-
-
-/* POSIX `eflags' bits (i.e., information for regexec). */
-
-/* If this bit is set, then the beginning-of-line operator doesn't match
- the beginning of the string (presumably because it's not the
- beginning of a line).
- If not set, then the beginning-of-line operator does match the
- beginning of the string. */
-#define REG_NOTBOL 1
-
-/* Like REG_NOTBOL, except for the end-of-line. */
-#define REG_NOTEOL (1 << 1)
-
-
-/* If any error codes are removed, changed, or added, update the
- `re_error_msg' table in regex.c. */
-typedef enum
-{
- REG_NOERROR = 0, /* Success. */
- REG_NOMATCH, /* Didn't find a match (for regexec). */
-
- /* POSIX regcomp return error codes. (In the order listed in the
- standard.) */
- REG_BADPAT, /* Invalid pattern. */
- REG_ECOLLATE, /* Not implemented. */
- REG_ECTYPE, /* Invalid character class name. */
- REG_EESCAPE, /* Trailing backslash. */
- REG_ESUBREG, /* Invalid back reference. */
- REG_EBRACK, /* Unmatched left bracket. */
- REG_EPAREN, /* Parenthesis imbalance. */
- REG_EBRACE, /* Unmatched \{. */
- REG_BADBR, /* Invalid contents of \{\}. */
- REG_ERANGE, /* Invalid range end. */
- REG_ESPACE, /* Ran out of memory. */
- REG_BADRPT, /* No preceding re for repetition op. */
-
- /* Error codes we've added. */
- REG_EEND, /* Premature end. */
- REG_ESIZE, /* Compiled pattern bigger than 2^16 bytes. */
- REG_ERPAREN /* Unmatched ) or \); not returned from regcomp. */
-} reg_errcode_t;
-\f
-/* This data structure represents a compiled pattern. Before calling
- the pattern compiler, the fields `buffer', `allocated', `fastmap',
- `translate', and `no_sub' can be set. After the pattern has been
- compiled, the `re_nsub' field is available. All other fields are
- private to the regex routines. */
-
-#ifndef RE_TRANSLATE_TYPE
-#define RE_TRANSLATE_TYPE char *
-#endif
-
-struct re_pattern_buffer
-{
-/* [[[begin pattern_buffer]]] */
- /* Space that holds the compiled pattern. It is declared as
- `unsigned char *' because its elements are
- sometimes used as array indexes. */
- unsigned char *buffer;
-
- /* Number of bytes to which `buffer' points. */
- unsigned long int allocated;
-
- /* Number of bytes actually used in `buffer'. */
- unsigned long int used;
-
- /* Syntax setting with which the pattern was compiled. */
- reg_syntax_t syntax;
-
- /* Pointer to a fastmap, if any, otherwise zero. re_search uses
- the fastmap, if there is one, to skip over impossible
- starting points for matches. */
- char *fastmap;
-
- /* Either a translate table to apply to all characters before
- comparing them, or zero for no translation. The translation
- is applied to a pattern when it is compiled and to a string
- when it is matched. */
- RE_TRANSLATE_TYPE translate;
-
- /* Number of subexpressions found by the compiler. */
- size_t re_nsub;
-
- /* Zero if this pattern cannot match the empty string, one else.
- Well, in truth it's used only in `re_search_2', to see
- whether or not we should use the fastmap, so we don't set
- this absolutely perfectly; see `re_compile_fastmap' (the
- `duplicate' case). */
- unsigned can_be_null : 1;
-
- /* If REGS_UNALLOCATED, allocate space in the `regs' structure
- for `max (RE_NREGS, re_nsub + 1)' groups.
- If REGS_REALLOCATE, reallocate space if necessary.
- If REGS_FIXED, use what's there. */
-#define REGS_UNALLOCATED 0
-#define REGS_REALLOCATE 1
-#define REGS_FIXED 2
- unsigned regs_allocated : 2;
-
- /* Set to zero when `regex_compile' compiles a pattern; set to one
- by `re_compile_fastmap' if it updates the fastmap. */
- unsigned fastmap_accurate : 1;
-
- /* If set, `re_match_2' does not return information about
- subexpressions. */
- unsigned no_sub : 1;
-
- /* If set, a beginning-of-line anchor doesn't match at the
- beginning of the string. */
- unsigned not_bol : 1;
-
- /* Similarly for an end-of-line anchor. */
- unsigned not_eol : 1;
-
- /* If true, an anchor at a newline matches. */
- unsigned newline_anchor : 1;
-
-/* [[[end pattern_buffer]]] */
-};
-
-typedef struct re_pattern_buffer regex_t;
-\f
-/* Type for byte offsets within the string. POSIX mandates this. */
-typedef int regoff_t;
-
-
-/* This is the structure we store register match data in. See
- regex.texinfo for a full description of what registers match. */
-struct re_registers
-{
- unsigned num_regs;
- regoff_t *start;
- regoff_t *end;
-};
-
-
-/* If `regs_allocated' is REGS_UNALLOCATED in the pattern buffer,
- `re_match_2' returns information about at least this many registers
- the first time a `regs' structure is passed. */
-#ifndef RE_NREGS
-#define RE_NREGS 30
-#endif
-
-
-/* POSIX specification for registers. Aside from the different names than
- `re_registers', POSIX uses an array of structures, instead of a
- structure of arrays. */
-typedef struct
-{
- regoff_t rm_so; /* Byte offset from string's start to substring's start. */
- regoff_t rm_eo; /* Byte offset from string's start to substring's end. */
-} regmatch_t;
-\f
-/* Declarations for routines. */
-
-/* To avoid duplicating every routine declaration -- once with a
- prototype (if we are ANSI), and once without (if we aren't) -- we
- use the following macro to declare argument types. This
- unfortunately clutters up the declarations a bit, but I think it's
- worth it. */
-
-#if __STDC__
-
-#define _RE_ARGS(args) args
-
-#else /* not __STDC__ */
-
-#define _RE_ARGS(args) ()
-
-#endif /* not __STDC__ */
-
-/* Sets the current default syntax to SYNTAX, and return the old syntax.
- You can also simply assign to the `re_syntax_options' variable. */
-extern reg_syntax_t re_set_syntax _RE_ARGS ((reg_syntax_t syntax));
-
-/* Compile the regular expression PATTERN, with length LENGTH
- and syntax given by the global `re_syntax_options', into the buffer
- BUFFER. Return NULL if successful, and an error string if not. */
-extern const char *re_compile_pattern
- _RE_ARGS ((const char *pattern, size_t length,
- struct re_pattern_buffer *buffer));
-
-
-/* Compile a fastmap for the compiled pattern in BUFFER; used to
- accelerate searches. Return 0 if successful and -2 if was an
- internal error. */
-extern int re_compile_fastmap _RE_ARGS ((struct re_pattern_buffer *buffer));
-
-
-/* Search in the string STRING (with length LENGTH) for the pattern
- compiled into BUFFER. Start searching at position START, for RANGE
- characters. Return the starting position of the match, -1 for no
- match, or -2 for an internal error. Also return register
- information in REGS (if REGS and BUFFER->no_sub are nonzero). */
-extern int re_search
- _RE_ARGS ((struct re_pattern_buffer *buffer, const char *string,
- int length, int start, int range, struct re_registers *regs));
-
-
-/* Like `re_search', but search in the concatenation of STRING1 and
- STRING2. Also, stop searching at index START + STOP. */
-extern int re_search_2
- _RE_ARGS ((struct re_pattern_buffer *buffer, const char *string1,
- int length1, const char *string2, int length2,
- int start, int range, struct re_registers *regs, int stop));
-
-
-/* Like `re_search', but return how many characters in STRING the regexp
- in BUFFER matched, starting at position START. */
-extern int re_match
- _RE_ARGS ((struct re_pattern_buffer *buffer, const char *string,
- int length, int start, struct re_registers *regs));
-
-
-/* Relates to `re_match' as `re_search_2' relates to `re_search'. */
-extern int re_match_2
- _RE_ARGS ((struct re_pattern_buffer *buffer, const char *string1,
- int length1, const char *string2, int length2,
- int start, struct re_registers *regs, int stop));
-
-
-/* Set REGS to hold NUM_REGS registers, storing them in STARTS and
- ENDS. Subsequent matches using BUFFER and REGS will use this memory
- for recording register information. STARTS and ENDS must be
- allocated with malloc, and must each be at least `NUM_REGS * sizeof
- (regoff_t)' bytes long.
-
- If NUM_REGS == 0, then subsequent matches should allocate their own
- register data.
-
- Unless this function is called, the first search or match using
- PATTERN_BUFFER will allocate its own register data, without
- freeing the old data. */
-extern void re_set_registers
- _RE_ARGS ((struct re_pattern_buffer *buffer, struct re_registers *regs,
- unsigned num_regs, regoff_t *starts, regoff_t *ends));
-
-#ifdef _REGEX_RE_COMP
-#ifndef _CRAY
-/* 4.2 bsd compatibility. */
-extern char *re_comp _RE_ARGS ((const char *));
-extern int re_exec _RE_ARGS ((const char *));
-#endif
-#endif
-
-/* POSIX compatibility. */
-extern int regcomp _RE_ARGS ((regex_t *preg, const char *pattern, int cflags));
-extern int regexec
- _RE_ARGS ((const regex_t *preg, const char *string, size_t nmatch,
- regmatch_t pmatch[], int eflags));
-extern size_t regerror
- _RE_ARGS ((int errcode, const regex_t *preg, char *errbuf,
- size_t errbuf_size));
-extern void regfree _RE_ARGS ((regex_t *preg));
-
-
-#ifdef __cplusplus
-}
-#endif /* C++ */
-
-#endif /* not __REGEXP_LIBRARY_H__ */
-\f
-/*
-Local variables:
-make-backup-files: t
-version-control: t
-trim-versions-without-asking: nil
-End:
-*/
+++ /dev/null
-#ifndef GHC_SOCKETS_H
-#define GHC_SOCKETS_H
-
-#if defined(HAVE_WINSOCK_H) && !defined(__CYGWIN__)
-#include <winsock.h>
-#else
-
-#include <ctype.h>
-#include <netdb.h>
-#include <netinet/in.h>
-#include <arpa/inet.h>
-#include <stdio.h>
-#include <limits.h>
-
-#ifdef HAVE_STDLIB_H
-# include <stdlib.h>
-#endif
-#ifdef HAVE_STRING_H
-# include <string.h>
-#endif
-#ifdef HAVE_FCNTL_H
-# include <fcntl.h>
-#endif
-#ifdef HAVE_SYS_SOCKET_H
-# include <sys/socket.h>
-#endif
-#ifdef HAVE_NETINET_TCP_H
-# include <netinet/tcp.h>
-#endif
-#if TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-#else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-#endif
-#ifdef HAVE_SYS_TYPES_H
-# include <sys/types.h>
-#endif
-#include <sys/uio.h>
-
-/* ToDo: featurise this */
-#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
-#include <sys/un.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-# include <unistd.h>
-#endif
-
-#endif /* !HAVE_WINSOCK_H */
-
-/* acceptSocket.lc */
-StgInt acceptSocket (StgInt, StgAddr, StgAddr);
-
-/* bindSocket.lc */
-StgInt bindSocket (StgInt, StgAddr, StgInt, StgInt);
-
-/* connectSocket.lc */
-StgInt connectSocket (StgInt, StgAddr, StgInt, StgInt);
-
-/* createSocket.lc */
-StgInt createSocket (StgInt, StgInt, StgInt);
-
-/* getSockName.lc */
-StgInt getSockName (StgInt, StgAddr, StgAddr);
-
-/* getPeerName.lc */
-StgInt getPeerName (StgInt, StgAddr, StgAddr);
-
-/* listenSocket.lc */
-StgInt listenSocket (StgInt, StgInt);
-
-/* shutdownSocket.lc */
-StgInt shutdownSocket (StgInt, StgInt);
-
-/* readDescriptor.lc */
-StgInt readDescriptor (StgInt, StgAddr, StgInt);
-
-/* recvFrom.c */
-StgInt recvFrom__ (StgInt, StgAddr, StgInt, StgAddr);
-
-/* sendTo.c */
-StgInt sendTo__ (StgInt, StgAddr, StgInt, StgAddr, StgInt);
-
-/* socketOpt.c */
-StgInt getSocketOption__ (StgInt, StgInt, StgInt);
-StgInt setSocketOption__ (StgInt, StgInt, StgInt, StgInt);
-
-/* writeDescriptor.lc */
-StgInt writeDescriptor (StgInt, StgAddr, StgInt);
-
-/* initWinSock.c */
-#if defined(HAVE_WINSOCK_H) && !defined(__CYGWIN__)
-StgInt initWinSock();
-void shutdownWinSock();
-#endif
-
-#endif /* !GHC_SOCKETS_H */
+++ /dev/null
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-
-#if defined(HAVE_WINSOCK_H) && !defined(__CYGWIN__) && !defined(__CYGWIN32__)
-#define USE_WINSOCK
-#endif
-
-#ifdef USE_WINSOCK
-
-static int winsock_inited = 0;
-static int winsock_uninited = 0;
-
-/* Initialising WinSock... */
-StgInt
-initWinSock ()
-{
- WORD wVersionRequested;
- WSADATA wsaData;
- int err;
-
- if (!winsock_inited) {
- wVersionRequested = MAKEWORD( 1, 1 );
-
- err = WSAStartup ( wVersionRequested, &wsaData );
-
- if ( err != 0 ) {
- return err;
- }
-
- if ( LOBYTE( wsaData.wVersion ) != 1 ||
- HIBYTE( wsaData.wVersion ) != 1 ) {
- WSACleanup();
- return (-1);
- }
- winsock_inited = 1;
- }
- return 0;
-}
-
-static void
-shutdownHandler()
-{
- WSACleanup();
-}
-
-void
-shutdownWinSock()
-{
- if (!winsock_uninited) {
- atexit(shutdownHandler);
- winsock_uninited = 1;
- }
-}
-
-#endif
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1996
-%
-\subsection[listenSocket.lc]{Indicate willingness to receive connections}
-
-\begin{code}
-#endif
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-listenSocket(I_ sockfd, I_ backlog)
-{
- int rc;
-
- while ((rc = listen((int) sockfd, (int) backlog)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EBADF:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Not a valid descriptor";
- break;
- case GHC_ENOTSOCK:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Descriptor not a socket";
- break;
- case GHC_EOPNOTSUPP:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Socket not of type that supports listen";
- break;
- }
- return -1;
- }
- }
- return 0;
-}
+++ /dev/null
-/*
- * This code implements the MD5 message-digest algorithm.
- * The algorithm is due to Ron Rivest. This code was
- * written by Colin Plumb in 1993, no copyright is claimed.
- * This code is in the public domain; do with it what you wish.
- *
- * Equivalent code is available from RSA Data Security, Inc.
- * This code has been tested against that, and is equivalent,
- * except that you don't need to include two pages of legalese
- * with every copy.
- *
- * To compute the message digest of a chunk of bytes, declare an
- * MD5Context structure, pass it to MD5Init, call MD5Update as
- * needed on buffers full of bytes, and then call MD5Final, which
- * will fill a supplied 16-byte array with the digest.
- */
-
-#include <string.h>
-
-typedef unsigned long word32;
-typedef unsigned char byte;
-
-struct MD5Context {
- word32 buf[4];
- word32 bytes[2];
- word32 in[16];
-};
-
-void MD5Init(struct MD5Context *context);
-void MD5Update(struct MD5Context *context, byte const *buf, int len);
-void MD5Final(byte digest[16], struct MD5Context *context);
-void MD5Transform(word32 buf[4], word32 const in[16]);
-
-
-/*
- * Shuffle the bytes into little-endian order within words, as per the
- * MD5 spec. Note: this code works regardless of the byte order.
- */
-void
-byteSwap(word32 *buf, unsigned words)
-{
- byte *p = (byte *)buf;
-
- do {
- *buf++ = (word32)((unsigned)p[3] << 8 | p[2]) << 16 |
- ((unsigned)p[1] << 8 | p[0]);
- p += 4;
- } while (--words);
-}
-
-/*
- * Start MD5 accumulation. Set bit count to 0 and buffer to mysterious
- * initialization constants.
- */
-void
-MD5Init(struct MD5Context *ctx)
-{
- ctx->buf[0] = 0x67452301;
- ctx->buf[1] = 0xefcdab89;
- ctx->buf[2] = 0x98badcfe;
- ctx->buf[3] = 0x10325476;
-
- ctx->bytes[0] = 0;
- ctx->bytes[1] = 0;
-}
-
-/*
- * Update context to reflect the concatenation of another buffer full
- * of bytes.
- */
-void
-MD5Update(struct MD5Context *ctx, byte const *buf, int len)
-{
- word32 t;
-
- /* Update byte count */
-
- t = ctx->bytes[0];
- if ((ctx->bytes[0] = t + len) < t)
- ctx->bytes[1]++; /* Carry from low to high */
-
- t = 64 - (t & 0x3f); /* Space available in ctx->in (at least 1) */
- if ((unsigned)t > len) {
- memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, len);
- return;
- }
- /* First chunk is an odd size */
- memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, (unsigned)t);
- byteSwap(ctx->in, 16);
- MD5Transform(ctx->buf, ctx->in);
- buf += (unsigned)t;
- len -= (unsigned)t;
-
- /* Process data in 64-byte chunks */
- while (len >= 64) {
- memcpy(ctx->in, buf, 64);
- byteSwap(ctx->in, 16);
- MD5Transform(ctx->buf, ctx->in);
- buf += 64;
- len -= 64;
- }
-
- /* Handle any remaining bytes of data. */
- memcpy(ctx->in, buf, len);
-}
-
-/*
- * Final wrapup - pad to 64-byte boundary with the bit pattern
- * 1 0* (64-bit count of bits processed, MSB-first)
- */
-void
-MD5Final(byte digest[16], struct MD5Context *ctx)
-{
- int count = (int)(ctx->bytes[0] & 0x3f); /* Bytes in ctx->in */
- byte *p = (byte *)ctx->in + count; /* First unused byte */
-
- /* Set the first char of padding to 0x80. There is always room. */
- *p++ = 0x80;
-
- /* Bytes of padding needed to make 56 bytes (-8..55) */
- count = 56 - 1 - count;
-
- if (count < 0) { /* Padding forces an extra block */
- memset(p, 0, count+8);
- byteSwap(ctx->in, 16);
- MD5Transform(ctx->buf, ctx->in);
- p = (byte *)ctx->in;
- count = 56;
- }
- memset(p, 0, count+8);
- byteSwap(ctx->in, 14);
-
- /* Append length in bits and transform */
- ctx->in[14] = ctx->bytes[0] << 3;
- ctx->in[15] = ctx->bytes[1] << 3 | ctx->bytes[0] >> 29;
- MD5Transform(ctx->buf, ctx->in);
-
- byteSwap(ctx->buf, 4);
- memcpy(digest, ctx->buf, 16);
- memset(ctx,0,sizeof(ctx));
-}
-
-
-/* The four core functions - F1 is optimized somewhat */
-
-/* #define F1(x, y, z) (x & y | ~x & z) */
-#define F1(x, y, z) (z ^ (x & (y ^ z)))
-#define F2(x, y, z) F1(z, x, y)
-#define F3(x, y, z) (x ^ y ^ z)
-#define F4(x, y, z) (y ^ (x | ~z))
-
-/* This is the central step in the MD5 algorithm. */
-#define MD5STEP(f,w,x,y,z,in,s) \
- (w += f(x,y,z) + in, w = (w<<s | w>>(32-s)) + x)
-
-/*
- * The core of the MD5 algorithm, this alters an existing MD5 hash to
- * reflect the addition of 16 longwords of new data. MD5Update blocks
- * the data and converts bytes into longwords for this routine.
- */
-
-void
-MD5Transform(word32 buf[4], word32 const in[16])
-{
- register word32 a, b, c, d;
-
- a = buf[0];
- b = buf[1];
- c = buf[2];
- d = buf[3];
-
- MD5STEP(F1, a, b, c, d, in[0] + 0xd76aa478, 7);
- MD5STEP(F1, d, a, b, c, in[1] + 0xe8c7b756, 12);
- MD5STEP(F1, c, d, a, b, in[2] + 0x242070db, 17);
- MD5STEP(F1, b, c, d, a, in[3] + 0xc1bdceee, 22);
- MD5STEP(F1, a, b, c, d, in[4] + 0xf57c0faf, 7);
- MD5STEP(F1, d, a, b, c, in[5] + 0x4787c62a, 12);
- MD5STEP(F1, c, d, a, b, in[6] + 0xa8304613, 17);
- MD5STEP(F1, b, c, d, a, in[7] + 0xfd469501, 22);
- MD5STEP(F1, a, b, c, d, in[8] + 0x698098d8, 7);
- MD5STEP(F1, d, a, b, c, in[9] + 0x8b44f7af, 12);
- MD5STEP(F1, c, d, a, b, in[10] + 0xffff5bb1, 17);
- MD5STEP(F1, b, c, d, a, in[11] + 0x895cd7be, 22);
- MD5STEP(F1, a, b, c, d, in[12] + 0x6b901122, 7);
- MD5STEP(F1, d, a, b, c, in[13] + 0xfd987193, 12);
- MD5STEP(F1, c, d, a, b, in[14] + 0xa679438e, 17);
- MD5STEP(F1, b, c, d, a, in[15] + 0x49b40821, 22);
-
- MD5STEP(F2, a, b, c, d, in[1] + 0xf61e2562, 5);
- MD5STEP(F2, d, a, b, c, in[6] + 0xc040b340, 9);
- MD5STEP(F2, c, d, a, b, in[11] + 0x265e5a51, 14);
- MD5STEP(F2, b, c, d, a, in[0] + 0xe9b6c7aa, 20);
- MD5STEP(F2, a, b, c, d, in[5] + 0xd62f105d, 5);
- MD5STEP(F2, d, a, b, c, in[10] + 0x02441453, 9);
- MD5STEP(F2, c, d, a, b, in[15] + 0xd8a1e681, 14);
- MD5STEP(F2, b, c, d, a, in[4] + 0xe7d3fbc8, 20);
- MD5STEP(F2, a, b, c, d, in[9] + 0x21e1cde6, 5);
- MD5STEP(F2, d, a, b, c, in[14] + 0xc33707d6, 9);
- MD5STEP(F2, c, d, a, b, in[3] + 0xf4d50d87, 14);
- MD5STEP(F2, b, c, d, a, in[8] + 0x455a14ed, 20);
- MD5STEP(F2, a, b, c, d, in[13] + 0xa9e3e905, 5);
- MD5STEP(F2, d, a, b, c, in[2] + 0xfcefa3f8, 9);
- MD5STEP(F2, c, d, a, b, in[7] + 0x676f02d9, 14);
- MD5STEP(F2, b, c, d, a, in[12] + 0x8d2a4c8a, 20);
-
- MD5STEP(F3, a, b, c, d, in[5] + 0xfffa3942, 4);
- MD5STEP(F3, d, a, b, c, in[8] + 0x8771f681, 11);
- MD5STEP(F3, c, d, a, b, in[11] + 0x6d9d6122, 16);
- MD5STEP(F3, b, c, d, a, in[14] + 0xfde5380c, 23);
- MD5STEP(F3, a, b, c, d, in[1] + 0xa4beea44, 4);
- MD5STEP(F3, d, a, b, c, in[4] + 0x4bdecfa9, 11);
- MD5STEP(F3, c, d, a, b, in[7] + 0xf6bb4b60, 16);
- MD5STEP(F3, b, c, d, a, in[10] + 0xbebfbc70, 23);
- MD5STEP(F3, a, b, c, d, in[13] + 0x289b7ec6, 4);
- MD5STEP(F3, d, a, b, c, in[0] + 0xeaa127fa, 11);
- MD5STEP(F3, c, d, a, b, in[3] + 0xd4ef3085, 16);
- MD5STEP(F3, b, c, d, a, in[6] + 0x04881d05, 23);
- MD5STEP(F3, a, b, c, d, in[9] + 0xd9d4d039, 4);
- MD5STEP(F3, d, a, b, c, in[12] + 0xe6db99e5, 11);
- MD5STEP(F3, c, d, a, b, in[15] + 0x1fa27cf8, 16);
- MD5STEP(F3, b, c, d, a, in[2] + 0xc4ac5665, 23);
-
- MD5STEP(F4, a, b, c, d, in[0] + 0xf4292244, 6);
- MD5STEP(F4, d, a, b, c, in[7] + 0x432aff97, 10);
- MD5STEP(F4, c, d, a, b, in[14] + 0xab9423a7, 15);
- MD5STEP(F4, b, c, d, a, in[5] + 0xfc93a039, 21);
- MD5STEP(F4, a, b, c, d, in[12] + 0x655b59c3, 6);
- MD5STEP(F4, d, a, b, c, in[3] + 0x8f0ccc92, 10);
- MD5STEP(F4, c, d, a, b, in[10] + 0xffeff47d, 15);
- MD5STEP(F4, b, c, d, a, in[1] + 0x85845dd1, 21);
- MD5STEP(F4, a, b, c, d, in[8] + 0x6fa87e4f, 6);
- MD5STEP(F4, d, a, b, c, in[15] + 0xfe2ce6e0, 10);
- MD5STEP(F4, c, d, a, b, in[6] + 0xa3014314, 15);
- MD5STEP(F4, b, c, d, a, in[13] + 0x4e0811a1, 21);
- MD5STEP(F4, a, b, c, d, in[4] + 0xf7537e82, 6);
- MD5STEP(F4, d, a, b, c, in[11] + 0xbd3af235, 10);
- MD5STEP(F4, c, d, a, b, in[2] + 0x2ad7d2bb, 15);
- MD5STEP(F4, b, c, d, a, in[9] + 0xeb86d391, 21);
-
- buf[0] += a;
- buf[1] += b;
- buf[2] += c;
- buf[3] += d;
-}
-
+++ /dev/null
-/* MD5 message digest */
-#ifndef _MD5_H
-#define _MD5_H
-
-typedef unsigned long word32;
-typedef unsigned char byte;
-
-struct MD5Context {
- word32 buf[4];
- word32 bytes[2];
- word32 in[16];
-};
-
-void MD5Init(StgByteArray context);
-/*ORIG: void MD5Init(struct MD5Context *context);*/
-void MD5Update(StgByteArray context, void *buf, int len);
-/*ORIG: void MD5Update(struct MD5Context *context, byte const *buf, int len); */
-void MD5Final(StgByteArray digest, StgByteArray context);
-/*ORIG: void MD5Final(byte digest[16], struct MD5Context *context);*/
-
-#endif /* _MD5_H */
-
-
-
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1996
-%
-\subsection[readDescriptor.lc]{Suck some bytes from a descriptor}
-
-\begin{code}
-#endif
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-readDescriptor(I_ fd, A_ buf, I_ nbytes)
-{
- StgInt sucked;
-
- while ((sucked = read((int) fd, (char *) buf, (int) nbytes)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EBADF:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Not a valid write descriptor";
- break;
- case GHC_EBADMSG:
- ghc_errtype = ERR_SYSTEMERROR;
- ghc_errstr = "Message waiting to be read is not a data message";
- break;
- case GHC_EFAULT:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Data buffer not in writeable part of user address space";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Seek pointer associated with descriptor negative";
- break;
- case GHC_EIO:
- ghc_errtype = ERR_SYSTEMERROR;
- ghc_errstr = "I/O error occurred while writing to file system";
- break;
- case GHC_EISDIR:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "Descriptor refers to a directory";
- break;
- case GHC_EAGAIN:
- case GHC_EWOULDBLOCK:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "No data could be written immediately";
- break;
- }
- return -1;
- }
- }
- return sucked;
-}
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: recvFrom.c,v 1.3 1998/12/02 13:26:46 simonm Exp $
- *
- * recvFrom run-time support
- *
- * (c) The GHC Team 1998
- * -------------------------------------------------------------------------- */
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-recvFrom__(StgInt fd, StgAddr buf, StgInt nbytes, StgAddr from)
-{
- StgInt count;
- int sz;
- int flags = 0;
-
- sz = sizeof(struct sockaddr_in);
-
- while ( (count = recvfrom((int)fd, (void*)buf, (int)nbytes, flags, (struct sockaddr*)from, &sz)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return count;
-}
+++ /dev/null
-/* Extended regular expression matching and search library,
- version 0.12.
- (Implements POSIX draft P1003.2/D11.2, except for some of the
- internationalization features.)
-
- Copyright (C) 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2, or (at your option)
- any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software Foundation,
- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
-
-/* AIX requires this to be the first thing in the file. */
-#if defined (_AIX) && !defined (REGEX_MALLOC)
- #pragma alloca
-#endif
-
-#undef _GNU_SOURCE
-#define _GNU_SOURCE
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#if defined(STDC_HEADERS) && !defined(emacs)
-#include <stddef.h>
-#else
-/* We need this for `regex.h', and perhaps for the Emacs include files. */
-#include <sys/types.h>
-#endif
-
-/* For platform which support the ISO C amendement 1 functionality we
- support user defined character classes. */
-#if defined _LIBC || (defined HAVE_WCTYPE_H && defined HAVE_WCHAR_H)
-# include <wctype.h>
-# include <wchar.h>
-#endif
-
-/* This is for other GNU distributions with internationalized messages. */
-#if HAVE_LIBINTL_H || defined (_LIBC)
-# include <libintl.h>
-#else
-# define gettext(msgid) (msgid)
-#endif
-
-#ifndef gettext_noop
-/* This define is so xgettext can find the internationalizable
- strings. */
-#define gettext_noop(String) String
-#endif
-
-/* The `emacs' switch turns on certain matching commands
- that make sense only in Emacs. */
-#ifdef emacs
-
-#include "lisp.h"
-#include "buffer.h"
-#include "syntax.h"
-
-#else /* not emacs */
-
-/* If we are not linking with Emacs proper,
- we can't use the relocating allocator
- even if config.h says that we can. */
-#undef REL_ALLOC
-
-#if defined (STDC_HEADERS) || defined (_LIBC)
-#include <stdlib.h>
-#else
-char *malloc ();
-char *realloc ();
-#endif
-
-/* When used in Emacs's lib-src, we need to get bzero and bcopy somehow.
- If nothing else has been done, use the method below. */
-#ifdef INHIBIT_STRING_HEADER
-#if !(defined (HAVE_BZERO) && defined (HAVE_BCOPY))
-#if !defined (bzero) && !defined (bcopy)
-#undef INHIBIT_STRING_HEADER
-#endif
-#endif
-#endif
-
-/* This is the normal way of making sure we have a bcopy and a bzero.
- This is used in most programs--a few other programs avoid this
- by defining INHIBIT_STRING_HEADER. */
-#ifndef INHIBIT_STRING_HEADER
-#if defined (HAVE_STRING_H) || defined (STDC_HEADERS) || defined (_LIBC) || defined(_WIN32)
-#include <string.h>
-#ifndef bcmp
-#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n))
-#endif
-#ifndef bcopy
-#define bcopy(s, d, n) memcpy ((d), (s), (n))
-#endif
-#ifndef bzero
-#define bzero(s, n) memset ((s), 0, (n))
-#endif
-#else
-#include <strings.h>
-#endif
-#endif
-
-/* Define the syntax stuff for \<, \>, etc. */
-
-/* This must be nonzero for the wordchar and notwordchar pattern
- commands in re_match_2. */
-#ifndef Sword
-#define Sword 1
-#endif
-
-#ifdef SWITCH_ENUM_BUG
-#define SWITCH_ENUM_CAST(x) ((int)(x))
-#else
-#define SWITCH_ENUM_CAST(x) (x)
-#endif
-
-#ifdef SYNTAX_TABLE
-
-extern char *re_syntax_table;
-
-#else /* not SYNTAX_TABLE */
-
-/* How many characters in the character set. */
-#define CHAR_SET_SIZE 256
-
-static char re_syntax_table[CHAR_SET_SIZE];
-
-static void
-init_syntax_once ()
-{
- register int c;
- static int done = 0;
-
- if (done)
- return;
-
- bzero (re_syntax_table, sizeof re_syntax_table);
-
- for (c = 'a'; c <= 'z'; c++)
- re_syntax_table[c] = Sword;
-
- for (c = 'A'; c <= 'Z'; c++)
- re_syntax_table[c] = Sword;
-
- for (c = '0'; c <= '9'; c++)
- re_syntax_table[c] = Sword;
-
- re_syntax_table['_'] = Sword;
-
- done = 1;
-}
-
-#endif /* not SYNTAX_TABLE */
-
-#define SYNTAX(c) re_syntax_table[c]
-
-#endif /* not emacs */
-\f
-/* Get the interface, including the syntax bits. */
-#include "ghcRegex.h"
-
-/* isalpha etc. are used for the character classes. */
-#include <ctype.h>
-
-/* Jim Meyering writes:
-
- "... Some ctype macros are valid only for character codes that
- isascii says are ASCII (SGI's IRIX-4.0.5 is one such system --when
- using /bin/cc or gcc but without giving an ansi option). So, all
- ctype uses should be through macros like ISPRINT... If
- STDC_HEADERS is defined, then autoconf has verified that the ctype
- macros don't need to be guarded with references to isascii. ...
- Defining isascii to 1 should let any compiler worth its salt
- eliminate the && through constant folding." */
-
-#if defined (STDC_HEADERS) || (!defined (isascii) && !defined (HAVE_ISASCII))
-#define ISASCII(c) 1
-#else
-#define ISASCII(c) isascii(c)
-#endif
-
-#ifdef isblank
-#define ISBLANK(c) (ISASCII (c) && isblank (c))
-#else
-#define ISBLANK(c) ((c) == ' ' || (c) == '\t')
-#endif
-#ifdef isgraph
-#define ISGRAPH(c) (ISASCII (c) && isgraph (c))
-#else
-#define ISGRAPH(c) (ISASCII (c) && isprint (c) && !isspace (c))
-#endif
-
-#define ISPRINT(c) (ISASCII (c) && isprint (c))
-#define ISDIGIT(c) (ISASCII (c) && isdigit (c))
-#define ISALNUM(c) (ISASCII (c) && isalnum (c))
-#define ISALPHA(c) (ISASCII (c) && isalpha (c))
-#define ISCNTRL(c) (ISASCII (c) && iscntrl (c))
-#define ISLOWER(c) (ISASCII (c) && islower (c))
-#define ISPUNCT(c) (ISASCII (c) && ispunct (c))
-#define ISSPACE(c) (ISASCII (c) && isspace (c))
-#define ISUPPER(c) (ISASCII (c) && isupper (c))
-#define ISXDIGIT(c) (ISASCII (c) && isxdigit (c))
-
-#ifndef NULL
-#define NULL (void *)0
-#endif
-
-/* We remove any previous definition of `SIGN_EXTEND_CHAR',
- since ours (we hope) works properly with all combinations of
- machines, compilers, `char' and `unsigned char' argument types.
- (Per Bothner suggested the basic approach.) */
-#undef SIGN_EXTEND_CHAR
-#if __STDC__
-#define SIGN_EXTEND_CHAR(c) ((signed char) (c))
-#else /* not __STDC__ */
-/* As in Harbison and Steele. */
-#define SIGN_EXTEND_CHAR(c) ((((unsigned char) (c)) ^ 128) - 128)
-#endif
-\f
-/* Should we use malloc or alloca? If REGEX_MALLOC is not defined, we
- use `alloca' instead of `malloc'. This is because using malloc in
- re_search* or re_match* could cause memory leaks when C-g is used in
- Emacs; also, malloc is slower and causes storage fragmentation. On
- the other hand, malloc is more portable, and easier to debug.
-
- Because we sometimes use alloca, some routines have to be macros,
- not functions -- `alloca'-allocated space disappears at the end of the
- function it is called in. */
-
-#ifdef REGEX_MALLOC
-
-#define REGEX_ALLOCATE malloc
-#define REGEX_REALLOCATE(source, osize, nsize) realloc (source, nsize)
-#define REGEX_FREE free
-
-#else /* not REGEX_MALLOC */
-
-/* Emacs already defines alloca, sometimes. */
-#ifndef alloca
-
-/* Make alloca work the best possible way. */
-#ifdef __GNUC__
-#define alloca __builtin_alloca
-#else /* not __GNUC__ */
-#if HAVE_ALLOCA_H
-#include <alloca.h>
-#else /* not __GNUC__ or HAVE_ALLOCA_H */
-#if 0 /* It is a bad idea to declare alloca. We always cast the result. */
-#ifndef _AIX /* Already did AIX, up at the top. */
-char *alloca ();
-#endif /* not _AIX */
-#endif
-#endif /* not HAVE_ALLOCA_H */
-#endif /* not __GNUC__ */
-
-#endif /* not alloca */
-
-#define REGEX_ALLOCATE alloca
-
-/* Assumes a `char *destination' variable. */
-#define REGEX_REALLOCATE(source, osize, nsize) \
- (destination = (char *) alloca (nsize), \
- bcopy (source, destination, osize), \
- destination)
-
-/* No need to do anything to free, after alloca. */
-#define REGEX_FREE(arg) ((void)0) /* Do nothing! But inhibit gcc warning. */
-
-#endif /* not REGEX_MALLOC */
-
-/* Define how to allocate the failure stack. */
-
-#if defined (REL_ALLOC) && defined (REGEX_MALLOC)
-
-#define REGEX_ALLOCATE_STACK(size) \
- r_alloc (&failure_stack_ptr, (size))
-#define REGEX_REALLOCATE_STACK(source, osize, nsize) \
- r_re_alloc (&failure_stack_ptr, (nsize))
-#define REGEX_FREE_STACK(ptr) \
- r_alloc_free (&failure_stack_ptr)
-
-#else /* not using relocating allocator */
-
-#ifdef REGEX_MALLOC
-
-#define REGEX_ALLOCATE_STACK malloc
-#define REGEX_REALLOCATE_STACK(source, osize, nsize) realloc (source, nsize)
-#define REGEX_FREE_STACK free
-
-#else /* not REGEX_MALLOC */
-
-#define REGEX_ALLOCATE_STACK alloca
-
-#define REGEX_REALLOCATE_STACK(source, osize, nsize) \
- REGEX_REALLOCATE (source, osize, nsize)
-/* No need to explicitly free anything. */
-#define REGEX_FREE_STACK(arg)
-
-#endif /* not REGEX_MALLOC */
-#endif /* not using relocating allocator */
-
-
-/* True if `size1' is non-NULL and PTR is pointing anywhere inside
- `string1' or just past its end. This works if PTR is NULL, which is
- a good thing. */
-#define FIRST_STRING_P(ptr) \
- (size1 && string1 <= (ptr) && (ptr) <= string1 + size1)
-
-/* (Re)Allocate N items of type T using malloc, or fail. */
-#define TALLOC(n, t) ((t *) malloc ((n) * sizeof (t)))
-#define RETALLOC(addr, n, t) ((addr) = (t *) realloc (addr, (n) * sizeof (t)))
-#define RETALLOC_IF(addr, n, t) \
- if (addr) RETALLOC((addr), (n), t); else (addr) = TALLOC ((n), t)
-#define REGEX_TALLOC(n, t) ((t *) REGEX_ALLOCATE ((n) * sizeof (t)))
-
-#define BYTEWIDTH 8 /* In bits. */
-
-#define STREQ(s1, s2) ((strcmp (s1, s2) == 0))
-
-#undef MAX
-#undef MIN
-#define MAX(a, b) ((a) > (b) ? (a) : (b))
-#define MIN(a, b) ((a) < (b) ? (a) : (b))
-
-typedef char boolean;
-#define false 0
-#define true 1
-
-static int re_match_2_internal ();
-\f
-/* These are the command codes that appear in compiled regular
- expressions. Some opcodes are followed by argument bytes. A
- command code can specify any interpretation whatsoever for its
- arguments. Zero bytes may appear in the compiled regular expression. */
-
-typedef enum
-{
- no_op = 0,
-
- /* Succeed right away--no more backtracking. */
- succeed,
-
- /* Followed by one byte giving n, then by n literal bytes. */
- exactn,
-
- /* Matches any (more or less) character. */
- anychar,
-
- /* Matches any one char belonging to specified set. First
- following byte is number of bitmap bytes. Then come bytes
- for a bitmap saying which chars are in. Bits in each byte
- are ordered low-bit-first. A character is in the set if its
- bit is 1. A character too large to have a bit in the map is
- automatically not in the set. */
- charset,
-
- /* Same parameters as charset, but match any character that is
- not one of those specified. */
- charset_not,
-
- /* Start remembering the text that is matched, for storing in a
- register. Followed by one byte with the register number, in
- the range 0 to one less than the pattern buffer's re_nsub
- field. Then followed by one byte with the number of groups
- inner to this one. (This last has to be part of the
- start_memory only because we need it in the on_failure_jump
- of re_match_2.) */
- start_memory,
-
- /* Stop remembering the text that is matched and store it in a
- memory register. Followed by one byte with the register
- number, in the range 0 to one less than `re_nsub' in the
- pattern buffer, and one byte with the number of inner groups,
- just like `start_memory'. (We need the number of inner
- groups here because we don't have any easy way of finding the
- corresponding start_memory when we're at a stop_memory.) */
- stop_memory,
-
- /* Match a duplicate of something remembered. Followed by one
- byte containing the register number. */
- duplicate,
-
- /* Fail unless at beginning of line. */
- begline,
-
- /* Fail unless at end of line. */
- endline,
-
- /* Succeeds if at beginning of buffer (if emacs) or at beginning
- of string to be matched (if not). */
- begbuf,
-
- /* Analogously, for end of buffer/string. */
- endbuf,
-
- /* Followed by two byte relative address to which to jump. */
- jump,
-
- /* Same as jump, but marks the end of an alternative. */
- jump_past_alt,
-
- /* Followed by two-byte relative address of place to resume at
- in case of failure. */
- on_failure_jump,
-
- /* Like on_failure_jump, but pushes a placeholder instead of the
- current string position when executed. */
- on_failure_keep_string_jump,
-
- /* Throw away latest failure point and then jump to following
- two-byte relative address. */
- pop_failure_jump,
-
- /* Change to pop_failure_jump if know won't have to backtrack to
- match; otherwise change to jump. This is used to jump
- back to the beginning of a repeat. If what follows this jump
- clearly won't match what the repeat does, such that we can be
- sure that there is no use backtracking out of repetitions
- already matched, then we change it to a pop_failure_jump.
- Followed by two-byte address. */
- maybe_pop_jump,
-
- /* Jump to following two-byte address, and push a dummy failure
- point. This failure point will be thrown away if an attempt
- is made to use it for a failure. A `+' construct makes this
- before the first repeat. Also used as an intermediary kind
- of jump when compiling an alternative. */
- dummy_failure_jump,
-
- /* Push a dummy failure point and continue. Used at the end of
- alternatives. */
- push_dummy_failure,
-
- /* Followed by two-byte relative address and two-byte number n.
- After matching N times, jump to the address upon failure. */
- succeed_n,
-
- /* Followed by two-byte relative address, and two-byte number n.
- Jump to the address N times, then fail. */
- jump_n,
-
- /* Set the following two-byte relative address to the
- subsequent two-byte number. The address *includes* the two
- bytes of number. */
- set_number_at,
-
- wordchar, /* Matches any word-constituent character. */
- notwordchar, /* Matches any char that is not a word-constituent. */
-
- wordbeg, /* Succeeds if at word beginning. */
- wordend, /* Succeeds if at word end. */
-
- wordbound, /* Succeeds if at a word boundary. */
- notwordbound /* Succeeds if not at a word boundary. */
-
-#ifdef emacs
- ,before_dot, /* Succeeds if before point. */
- at_dot, /* Succeeds if at point. */
- after_dot, /* Succeeds if after point. */
-
- /* Matches any character whose syntax is specified. Followed by
- a byte which contains a syntax code, e.g., Sword. */
- syntaxspec,
-
- /* Matches any character whose syntax is not that specified. */
- notsyntaxspec
-#endif /* emacs */
-} re_opcode_t;
-\f
-/* Common operations on the compiled pattern. */
-
-/* Store NUMBER in two contiguous bytes starting at DESTINATION. */
-
-#define STORE_NUMBER(destination, number) \
- do { \
- (destination)[0] = (number) & 0377; \
- (destination)[1] = (number) >> 8; \
- } while (0)
-
-/* Same as STORE_NUMBER, except increment DESTINATION to
- the byte after where the number is stored. Therefore, DESTINATION
- must be an lvalue. */
-
-#define STORE_NUMBER_AND_INCR(destination, number) \
- do { \
- STORE_NUMBER (destination, number); \
- (destination) += 2; \
- } while (0)
-
-/* Put into DESTINATION a number stored in two contiguous bytes starting
- at SOURCE. */
-
-#define EXTRACT_NUMBER(destination, source) \
- do { \
- (destination) = *(source) & 0377; \
- (destination) += SIGN_EXTEND_CHAR (*((source) + 1)) << 8; \
- } while (0)
-
-#ifdef DEBUG
-static void extract_number _RE_ARGS ((int *dest, unsigned char *source));
-static void
-extract_number (dest, source)
- int *dest;
- unsigned char *source;
-{
- int temp = SIGN_EXTEND_CHAR (*(source + 1));
- *dest = *source & 0377;
- *dest += temp << 8;
-}
-
-#ifndef EXTRACT_MACROS /* To debug the macros. */
-#undef EXTRACT_NUMBER
-#define EXTRACT_NUMBER(dest, src) extract_number (&dest, src)
-#endif /* not EXTRACT_MACROS */
-
-#endif /* DEBUG */
-
-/* Same as EXTRACT_NUMBER, except increment SOURCE to after the number.
- SOURCE must be an lvalue. */
-
-#define EXTRACT_NUMBER_AND_INCR(destination, source) \
- do { \
- EXTRACT_NUMBER (destination, source); \
- (source) += 2; \
- } while (0)
-
-#ifdef DEBUG
-static void extract_number_and_incr _RE_ARGS ((int *destination,
- unsigned char **source));
-static void
-extract_number_and_incr (destination, source)
- int *destination;
- unsigned char **source;
-{
- extract_number (destination, *source);
- *source += 2;
-}
-
-#ifndef EXTRACT_MACROS
-#undef EXTRACT_NUMBER_AND_INCR
-#define EXTRACT_NUMBER_AND_INCR(dest, src) \
- extract_number_and_incr (&dest, &src)
-#endif /* not EXTRACT_MACROS */
-
-#endif /* DEBUG */
-\f
-/* If DEBUG is defined, Regex prints many voluminous messages about what
- it is doing (if the variable `debug' is nonzero). If linked with the
- main program in `iregex.c', you can enter patterns and strings
- interactively. And if linked with the main program in `main.c' and
- the other test files, you can run the already-written tests. */
-
-#ifdef DEBUG
-
-/* We use standard I/O for debugging. */
-#include <stdio.h>
-
-/* It is useful to test things that ``must'' be true when debugging. */
-#include <assert.h>
-
-static int debug = 0;
-
-#define DEBUG_STATEMENT(e) e
-#define DEBUG_PRINT1(x) if (debug) printf (x)
-#define DEBUG_PRINT2(x1, x2) if (debug) printf (x1, x2)
-#define DEBUG_PRINT3(x1, x2, x3) if (debug) printf (x1, x2, x3)
-#define DEBUG_PRINT4(x1, x2, x3, x4) if (debug) printf (x1, x2, x3, x4)
-#define DEBUG_PRINT_COMPILED_PATTERN(p, s, e) \
- if (debug) print_partial_compiled_pattern (s, e)
-#define DEBUG_PRINT_DOUBLE_STRING(w, s1, sz1, s2, sz2) \
- if (debug) print_double_string (w, s1, sz1, s2, sz2)
-
-
-/* Print the fastmap in human-readable form. */
-
-void
-print_fastmap (fastmap)
- char *fastmap;
-{
- unsigned was_a_range = 0;
- unsigned i = 0;
-
- while (i < (1 << BYTEWIDTH))
- {
- if (fastmap[i++])
- {
- was_a_range = 0;
- putchar (i - 1);
- while (i < (1 << BYTEWIDTH) && fastmap[i])
- {
- was_a_range = 1;
- i++;
- }
- if (was_a_range)
- {
- printf ("-");
- putchar (i - 1);
- }
- }
- }
- putchar ('\n');
-}
-
-
-/* Print a compiled pattern string in human-readable form, starting at
- the START pointer into it and ending just before the pointer END. */
-
-void
-print_partial_compiled_pattern (start, end)
- unsigned char *start;
- unsigned char *end;
-{
- int mcnt, mcnt2;
- unsigned char *p1;
- unsigned char *p = start;
- unsigned char *pend = end;
-
- if (start == NULL)
- {
- printf ("(null)\n");
- return;
- }
-
- /* Loop over pattern commands. */
- while (p < pend)
- {
- printf ("%d:\t", p - start);
-
- switch ((re_opcode_t) *p++)
- {
- case no_op:
- printf ("/no_op");
- break;
-
- case exactn:
- mcnt = *p++;
- printf ("/exactn/%d", mcnt);
- do
- {
- putchar ('/');
- putchar (*p++);
- }
- while (--mcnt);
- break;
-
- case start_memory:
- mcnt = *p++;
- printf ("/start_memory/%d/%d", mcnt, *p++);
- break;
-
- case stop_memory:
- mcnt = *p++;
- printf ("/stop_memory/%d/%d", mcnt, *p++);
- break;
-
- case duplicate:
- printf ("/duplicate/%d", *p++);
- break;
-
- case anychar:
- printf ("/anychar");
- break;
-
- case charset:
- case charset_not:
- {
- register int c, last = -100;
- register int in_range = 0;
-
- printf ("/charset [%s",
- (re_opcode_t) *(p - 1) == charset_not ? "^" : "");
-
- assert (p + *p < pend);
-
- for (c = 0; c < 256; c++)
- if (c / 8 < *p
- && (p[1 + (c/8)] & (1 << (c % 8))))
- {
- /* Are we starting a range? */
- if (last + 1 == c && ! in_range)
- {
- putchar ('-');
- in_range = 1;
- }
- /* Have we broken a range? */
- else if (last + 1 != c && in_range)
- {
- putchar (last);
- in_range = 0;
- }
-
- if (! in_range)
- putchar (c);
-
- last = c;
- }
-
- if (in_range)
- putchar (last);
-
- putchar (']');
-
- p += 1 + *p;
- }
- break;
-
- case begline:
- printf ("/begline");
- break;
-
- case endline:
- printf ("/endline");
- break;
-
- case on_failure_jump:
- extract_number_and_incr (&mcnt, &p);
- printf ("/on_failure_jump to %d", p + mcnt - start);
- break;
-
- case on_failure_keep_string_jump:
- extract_number_and_incr (&mcnt, &p);
- printf ("/on_failure_keep_string_jump to %d", p + mcnt - start);
- break;
-
- case dummy_failure_jump:
- extract_number_and_incr (&mcnt, &p);
- printf ("/dummy_failure_jump to %d", p + mcnt - start);
- break;
-
- case push_dummy_failure:
- printf ("/push_dummy_failure");
- break;
-
- case maybe_pop_jump:
- extract_number_and_incr (&mcnt, &p);
- printf ("/maybe_pop_jump to %d", p + mcnt - start);
- break;
-
- case pop_failure_jump:
- extract_number_and_incr (&mcnt, &p);
- printf ("/pop_failure_jump to %d", p + mcnt - start);
- break;
-
- case jump_past_alt:
- extract_number_and_incr (&mcnt, &p);
- printf ("/jump_past_alt to %d", p + mcnt - start);
- break;
-
- case jump:
- extract_number_and_incr (&mcnt, &p);
- printf ("/jump to %d", p + mcnt - start);
- break;
-
- case succeed_n:
- extract_number_and_incr (&mcnt, &p);
- p1 = p + mcnt;
- extract_number_and_incr (&mcnt2, &p);
- printf ("/succeed_n to %d, %d times", p1 - start, mcnt2);
- break;
-
- case jump_n:
- extract_number_and_incr (&mcnt, &p);
- p1 = p + mcnt;
- extract_number_and_incr (&mcnt2, &p);
- printf ("/jump_n to %d, %d times", p1 - start, mcnt2);
- break;
-
- case set_number_at:
- extract_number_and_incr (&mcnt, &p);
- p1 = p + mcnt;
- extract_number_and_incr (&mcnt2, &p);
- printf ("/set_number_at location %d to %d", p1 - start, mcnt2);
- break;
-
- case wordbound:
- printf ("/wordbound");
- break;
-
- case notwordbound:
- printf ("/notwordbound");
- break;
-
- case wordbeg:
- printf ("/wordbeg");
- break;
-
- case wordend:
- printf ("/wordend");
-
-#ifdef emacs
- case before_dot:
- printf ("/before_dot");
- break;
-
- case at_dot:
- printf ("/at_dot");
- break;
-
- case after_dot:
- printf ("/after_dot");
- break;
-
- case syntaxspec:
- printf ("/syntaxspec");
- mcnt = *p++;
- printf ("/%d", mcnt);
- break;
-
- case notsyntaxspec:
- printf ("/notsyntaxspec");
- mcnt = *p++;
- printf ("/%d", mcnt);
- break;
-#endif /* emacs */
-
- case wordchar:
- printf ("/wordchar");
- break;
-
- case notwordchar:
- printf ("/notwordchar");
- break;
-
- case begbuf:
- printf ("/begbuf");
- break;
-
- case endbuf:
- printf ("/endbuf");
- break;
-
- default:
- printf ("?%d", *(p-1));
- }
-
- putchar ('\n');
- }
-
- printf ("%d:\tend of pattern.\n", p - start);
-}
-
-
-void
-print_compiled_pattern (bufp)
- struct re_pattern_buffer *bufp;
-{
- unsigned char *buffer = bufp->buffer;
-
- print_partial_compiled_pattern (buffer, buffer + bufp->used);
- printf ("%ld bytes used/%ld bytes allocated.\n",
- bufp->used, bufp->allocated);
-
- if (bufp->fastmap_accurate && bufp->fastmap)
- {
- printf ("fastmap: ");
- print_fastmap (bufp->fastmap);
- }
-
- printf ("re_nsub: %d\t", bufp->re_nsub);
- printf ("regs_alloc: %d\t", bufp->regs_allocated);
- printf ("can_be_null: %d\t", bufp->can_be_null);
- printf ("newline_anchor: %d\n", bufp->newline_anchor);
- printf ("no_sub: %d\t", bufp->no_sub);
- printf ("not_bol: %d\t", bufp->not_bol);
- printf ("not_eol: %d\t", bufp->not_eol);
- printf ("syntax: %lx\n", bufp->syntax);
- /* Perhaps we should print the translate table? */
-}
-
-
-void
-print_double_string (where, string1, size1, string2, size2)
- const char *where;
- const char *string1;
- const char *string2;
- int size1;
- int size2;
-{
- int this_char;
-
- if (where == NULL)
- printf ("(null)");
- else
- {
- if (FIRST_STRING_P (where))
- {
- for (this_char = where - string1; this_char < size1; this_char++)
- putchar (string1[this_char]);
-
- where = string2;
- }
-
- for (this_char = where - string2; this_char < size2; this_char++)
- putchar (string2[this_char]);
- }
-}
-
-void
-printchar (c)
- int c;
-{
- putc (c, stderr);
-}
-
-#else /* not DEBUG */
-
-#undef assert
-#define assert(e)
-
-#define DEBUG_STATEMENT(e)
-#define DEBUG_PRINT1(x)
-#define DEBUG_PRINT2(x1, x2)
-#define DEBUG_PRINT3(x1, x2, x3)
-#define DEBUG_PRINT4(x1, x2, x3, x4)
-#define DEBUG_PRINT_COMPILED_PATTERN(p, s, e)
-#define DEBUG_PRINT_DOUBLE_STRING(w, s1, sz1, s2, sz2)
-
-#endif /* not DEBUG */
-\f
-/* Set by `re_set_syntax' to the current regexp syntax to recognize. Can
- also be assigned to arbitrarily: each pattern buffer stores its own
- syntax, so it can be changed between regex compilations. */
-/* This has no initializer because initialized variables in Emacs
- become read-only after dumping. */
-reg_syntax_t re_syntax_options;
-
-
-/* Specify the precise syntax of regexps for compilation. This provides
- for compatibility for various utilities which historically have
- different, incompatible syntaxes.
-
- The argument SYNTAX is a bit mask comprised of the various bits
- defined in regex.h. We return the old syntax. */
-
-reg_syntax_t
-re_set_syntax (syntax)
- reg_syntax_t syntax;
-{
- reg_syntax_t ret = re_syntax_options;
-
- re_syntax_options = syntax;
-#ifdef DEBUG
- if (syntax & RE_DEBUG)
- debug = 1;
- else if (debug) /* was on but now is not */
- debug = 0;
-#endif /* DEBUG */
- return ret;
-}
-\f
-/* This table gives an error message for each of the error codes listed
- in regex.h. Obviously the order here has to be same as there.
- POSIX doesn't require that we do anything for REG_NOERROR,
- but why not be nice? */
-
-static const char *re_error_msgid[] =
- {
- gettext_noop ("Success"), /* REG_NOERROR */
- gettext_noop ("No match"), /* REG_NOMATCH */
- gettext_noop ("Invalid regular expression"), /* REG_BADPAT */
- gettext_noop ("Invalid collation character"), /* REG_ECOLLATE */
- gettext_noop ("Invalid character class name"), /* REG_ECTYPE */
- gettext_noop ("Trailing backslash"), /* REG_EESCAPE */
- gettext_noop ("Invalid back reference"), /* REG_ESUBREG */
- gettext_noop ("Unmatched [ or [^"), /* REG_EBRACK */
- gettext_noop ("Unmatched ( or \\("), /* REG_EPAREN */
- gettext_noop ("Unmatched \\{"), /* REG_EBRACE */
- gettext_noop ("Invalid content of \\{\\}"), /* REG_BADBR */
- gettext_noop ("Invalid range end"), /* REG_ERANGE */
- gettext_noop ("Memory exhausted"), /* REG_ESPACE */
- gettext_noop ("Invalid preceding regular expression"), /* REG_BADRPT */
- gettext_noop ("Premature end of regular expression"), /* REG_EEND */
- gettext_noop ("Regular expression too big"), /* REG_ESIZE */
- gettext_noop ("Unmatched ) or \\)"), /* REG_ERPAREN */
- };
-\f
-/* Avoiding alloca during matching, to placate r_alloc. */
-
-/* Define MATCH_MAY_ALLOCATE unless we need to make sure that the
- searching and matching functions should not call alloca. On some
- systems, alloca is implemented in terms of malloc, and if we're
- using the relocating allocator routines, then malloc could cause a
- relocation, which might (if the strings being searched are in the
- ralloc heap) shift the data out from underneath the regexp
- routines.
-
- Here's another reason to avoid allocation: Emacs
- processes input from X in a signal handler; processing X input may
- call malloc; if input arrives while a matching routine is calling
- malloc, then we're scrod. But Emacs can't just block input while
- calling matching routines; then we don't notice interrupts when
- they come in. So, Emacs blocks input around all regexp calls
- except the matching calls, which it leaves unprotected, in the
- faith that they will not malloc. */
-
-/* Normally, this is fine. */
-#define MATCH_MAY_ALLOCATE
-
-/* When using GNU C, we are not REALLY using the C alloca, no matter
- what config.h may say. So don't take precautions for it. */
-#ifdef __GNUC__
-#undef C_ALLOCA
-#endif
-
-/* The match routines may not allocate if (1) they would do it with malloc
- and (2) it's not safe for them to use malloc.
- Note that if REL_ALLOC is defined, matching would not use malloc for the
- failure stack, but we would still use it for the register vectors;
- so REL_ALLOC should not affect this. */
-#if (defined (C_ALLOCA) || defined (REGEX_MALLOC)) && defined (emacs)
-#undef MATCH_MAY_ALLOCATE
-#endif
-
-\f
-/* Failure stack declarations and macros; both re_compile_fastmap and
- re_match_2 use a failure stack. These have to be macros because of
- REGEX_ALLOCATE_STACK. */
-
-
-/* Number of failure points for which to initially allocate space
- when matching. If this number is exceeded, we allocate more
- space, so it is not a hard limit. */
-#ifndef INIT_FAILURE_ALLOC
-#define INIT_FAILURE_ALLOC 5
-#endif
-
-/* Roughly the maximum number of failure points on the stack. Would be
- exactly that if always used MAX_FAILURE_ITEMS items each time we failed.
- This is a variable only so users of regex can assign to it; we never
- change it ourselves. */
-
-#ifdef INT_IS_16BIT
-
-#if defined (MATCH_MAY_ALLOCATE)
-/* 4400 was enough to cause a crash on Alpha OSF/1,
- whose default stack limit is 2mb. */
-long int re_max_failures = 4000;
-#else
-long int re_max_failures = 2000;
-#endif
-
-union fail_stack_elt
-{
- unsigned char *pointer;
- long int integer;
-};
-
-typedef union fail_stack_elt fail_stack_elt_t;
-
-typedef struct
-{
- fail_stack_elt_t *stack;
- unsigned long int size;
- unsigned long int avail; /* Offset of next open position. */
-} fail_stack_type;
-
-#else /* not INT_IS_16BIT */
-
-#if defined (MATCH_MAY_ALLOCATE)
-/* 4400 was enough to cause a crash on Alpha OSF/1,
- whose default stack limit is 2mb. */
-int re_max_failures = 20000;
-#else
-int re_max_failures = 2000;
-#endif
-
-union fail_stack_elt
-{
- unsigned char *pointer;
- int integer;
-};
-
-typedef union fail_stack_elt fail_stack_elt_t;
-
-typedef struct
-{
- fail_stack_elt_t *stack;
- unsigned size;
- unsigned avail; /* Offset of next open position. */
-} fail_stack_type;
-
-#endif /* INT_IS_16BIT */
-
-#define FAIL_STACK_EMPTY() (fail_stack.avail == 0)
-#define FAIL_STACK_PTR_EMPTY() (fail_stack_ptr->avail == 0)
-#define FAIL_STACK_FULL() (fail_stack.avail == fail_stack.size)
-
-
-/* Define macros to initialize and free the failure stack.
- Do `return -2' if the alloc fails. */
-
-#ifdef MATCH_MAY_ALLOCATE
-#define INIT_FAIL_STACK() \
- do { \
- fail_stack.stack = (fail_stack_elt_t *) \
- REGEX_ALLOCATE_STACK (INIT_FAILURE_ALLOC * sizeof (fail_stack_elt_t)); \
- \
- if (fail_stack.stack == NULL) \
- return -2; \
- \
- fail_stack.size = INIT_FAILURE_ALLOC; \
- fail_stack.avail = 0; \
- } while (0)
-
-#define RESET_FAIL_STACK() REGEX_FREE_STACK (fail_stack.stack)
-#else
-#define INIT_FAIL_STACK() \
- do { \
- fail_stack.avail = 0; \
- } while (0)
-
-#define RESET_FAIL_STACK()
-#endif
-
-
-/* Double the size of FAIL_STACK, up to approximately `re_max_failures' items.
-
- Return 1 if succeeds, and 0 if either ran out of memory
- allocating space for it or it was already too large.
-
- REGEX_REALLOCATE_STACK requires `destination' be declared. */
-
-#define DOUBLE_FAIL_STACK(fail_stack) \
- ((fail_stack).size > (unsigned) (re_max_failures * MAX_FAILURE_ITEMS) \
- ? 0 \
- : ((fail_stack).stack = (fail_stack_elt_t *) \
- REGEX_REALLOCATE_STACK ((fail_stack).stack, \
- (fail_stack).size * sizeof (fail_stack_elt_t), \
- ((fail_stack).size << 1) * sizeof (fail_stack_elt_t)), \
- \
- (fail_stack).stack == NULL \
- ? 0 \
- : ((fail_stack).size <<= 1, \
- 1)))
-
-
-/* Push pointer POINTER on FAIL_STACK.
- Return 1 if was able to do so and 0 if ran out of memory allocating
- space to do so. */
-#define PUSH_PATTERN_OP(POINTER, FAIL_STACK) \
- ((FAIL_STACK_FULL () \
- && !DOUBLE_FAIL_STACK (FAIL_STACK)) \
- ? 0 \
- : ((FAIL_STACK).stack[(FAIL_STACK).avail++].pointer = POINTER, \
- 1))
-
-/* Push a pointer value onto the failure stack.
- Assumes the variable `fail_stack'. Probably should only
- be called from within `PUSH_FAILURE_POINT'. */
-#define PUSH_FAILURE_POINTER(item) \
- fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (item)
-
-/* This pushes an integer-valued item onto the failure stack.
- Assumes the variable `fail_stack'. Probably should only
- be called from within `PUSH_FAILURE_POINT'. */
-#define PUSH_FAILURE_INT(item) \
- fail_stack.stack[fail_stack.avail++].integer = (item)
-
-/* Push a fail_stack_elt_t value onto the failure stack.
- Assumes the variable `fail_stack'. Probably should only
- be called from within `PUSH_FAILURE_POINT'. */
-#define PUSH_FAILURE_ELT(item) \
- fail_stack.stack[fail_stack.avail++] = (item)
-
-/* These three POP... operations complement the three PUSH... operations.
- All assume that `fail_stack' is nonempty. */
-#define POP_FAILURE_POINTER() fail_stack.stack[--fail_stack.avail].pointer
-#define POP_FAILURE_INT() fail_stack.stack[--fail_stack.avail].integer
-#define POP_FAILURE_ELT() fail_stack.stack[--fail_stack.avail]
-
-/* Used to omit pushing failure point id's when we're not debugging. */
-#ifdef DEBUG
-#define DEBUG_PUSH PUSH_FAILURE_INT
-#define DEBUG_POP(item_addr) (item_addr)->integer = POP_FAILURE_INT ()
-#else
-#define DEBUG_PUSH(item)
-#define DEBUG_POP(item_addr)
-#endif
-
-
-/* Push the information about the state we will need
- if we ever fail back to it.
-
- Requires variables fail_stack, regstart, regend, reg_info, and
- num_regs be declared. DOUBLE_FAIL_STACK requires `destination' be
- declared.
-
- Does `return FAILURE_CODE' if runs out of memory. */
-
-#define PUSH_FAILURE_POINT(pattern_place, string_place, failure_code) \
- do { \
- char *destination; \
- /* Must be int, so when we don't save any registers, the arithmetic \
- of 0 + -1 isn't done as unsigned. */ \
- /* Can't be int, since there is not a shred of a guarantee that int \
- is wide enough to hold a value of something to which pointer can \
- be assigned */ \
- s_reg_t this_reg; \
- \
- DEBUG_STATEMENT (failure_id++); \
- DEBUG_STATEMENT (nfailure_points_pushed++); \
- DEBUG_PRINT2 ("\nPUSH_FAILURE_POINT #%u:\n", failure_id); \
- DEBUG_PRINT2 (" Before push, next avail: %d\n", (fail_stack).avail);\
- DEBUG_PRINT2 (" size: %d\n", (fail_stack).size);\
- \
- DEBUG_PRINT2 (" slots needed: %d\n", NUM_FAILURE_ITEMS); \
- DEBUG_PRINT2 (" available: %d\n", REMAINING_AVAIL_SLOTS); \
- \
- /* Ensure we have enough space allocated for what we will push. */ \
- while (REMAINING_AVAIL_SLOTS < NUM_FAILURE_ITEMS) \
- { \
- if (!DOUBLE_FAIL_STACK (fail_stack)) \
- return failure_code; \
- \
- DEBUG_PRINT2 ("\n Doubled stack; size now: %d\n", \
- (fail_stack).size); \
- DEBUG_PRINT2 (" slots available: %d\n", REMAINING_AVAIL_SLOTS);\
- } \
- \
- /* Push the info, starting with the registers. */ \
- DEBUG_PRINT1 ("\n"); \
- \
- if (1) \
- for (this_reg = lowest_active_reg; this_reg <= highest_active_reg; \
- this_reg++) \
- { \
- DEBUG_PRINT2 (" Pushing reg: %d\n", this_reg); \
- DEBUG_STATEMENT (num_regs_pushed++); \
- \
- DEBUG_PRINT2 (" start: 0x%x\n", regstart[this_reg]); \
- PUSH_FAILURE_POINTER (regstart[this_reg]); \
- \
- DEBUG_PRINT2 (" end: 0x%x\n", regend[this_reg]); \
- PUSH_FAILURE_POINTER (regend[this_reg]); \
- \
- DEBUG_PRINT2 (" info: 0x%x\n ", reg_info[this_reg]); \
- DEBUG_PRINT2 (" match_null=%d", \
- REG_MATCH_NULL_STRING_P (reg_info[this_reg])); \
- DEBUG_PRINT2 (" active=%d", IS_ACTIVE (reg_info[this_reg])); \
- DEBUG_PRINT2 (" matched_something=%d", \
- MATCHED_SOMETHING (reg_info[this_reg])); \
- DEBUG_PRINT2 (" ever_matched=%d", \
- EVER_MATCHED_SOMETHING (reg_info[this_reg])); \
- DEBUG_PRINT1 ("\n"); \
- PUSH_FAILURE_ELT (reg_info[this_reg].word); \
- } \
- \
- DEBUG_PRINT2 (" Pushing low active reg: %d\n", lowest_active_reg);\
- PUSH_FAILURE_INT (lowest_active_reg); \
- \
- DEBUG_PRINT2 (" Pushing high active reg: %d\n", highest_active_reg);\
- PUSH_FAILURE_INT (highest_active_reg); \
- \
- DEBUG_PRINT2 (" Pushing pattern 0x%x:\n", pattern_place); \
- DEBUG_PRINT_COMPILED_PATTERN (bufp, pattern_place, pend); \
- PUSH_FAILURE_POINTER (pattern_place); \
- \
- DEBUG_PRINT2 (" Pushing string 0x%x: `", string_place); \
- DEBUG_PRINT_DOUBLE_STRING (string_place, string1, size1, string2, \
- size2); \
- DEBUG_PRINT1 ("'\n"); \
- PUSH_FAILURE_POINTER (string_place); \
- \
- DEBUG_PRINT2 (" Pushing failure id: %u\n", failure_id); \
- DEBUG_PUSH (failure_id); \
- } while (0)
-
-/* This is the number of items that are pushed and popped on the stack
- for each register. */
-#define NUM_REG_ITEMS 3
-
-/* Individual items aside from the registers. */
-#ifdef DEBUG
-#define NUM_NONREG_ITEMS 5 /* Includes failure point id. */
-#else
-#define NUM_NONREG_ITEMS 4
-#endif
-
-/* We push at most this many items on the stack. */
-/* We used to use (num_regs - 1), which is the number of registers
- this regexp will save; but that was changed to 5
- to avoid stack overflow for a regexp with lots of parens. */
-#define MAX_FAILURE_ITEMS (5 * NUM_REG_ITEMS + NUM_NONREG_ITEMS)
-
-/* We actually push this many items. */
-#define NUM_FAILURE_ITEMS \
- (((0 \
- ? 0 : highest_active_reg - lowest_active_reg + 1) \
- * NUM_REG_ITEMS) \
- + NUM_NONREG_ITEMS)
-
-/* How many items can still be added to the stack without overflowing it. */
-#define REMAINING_AVAIL_SLOTS ((fail_stack).size - (fail_stack).avail)
-
-
-/* Pops what PUSH_FAIL_STACK pushes.
-
- We restore into the parameters, all of which should be lvalues:
- STR -- the saved data position.
- PAT -- the saved pattern position.
- LOW_REG, HIGH_REG -- the highest and lowest active registers.
- REGSTART, REGEND -- arrays of string positions.
- REG_INFO -- array of information about each subexpression.
-
- Also assumes the variables `fail_stack' and (if debugging), `bufp',
- `pend', `string1', `size1', `string2', and `size2'. */
-
-#define POP_FAILURE_POINT(str, pat, low_reg, high_reg, regstart, regend, reg_info)\
-{ \
- DEBUG_STATEMENT (fail_stack_elt_t failure_id;) \
- s_reg_t this_reg; \
- const unsigned char *string_temp; \
- \
- assert (!FAIL_STACK_EMPTY ()); \
- \
- /* Remove failure points and point to how many regs pushed. */ \
- DEBUG_PRINT1 ("POP_FAILURE_POINT:\n"); \
- DEBUG_PRINT2 (" Before pop, next avail: %d\n", fail_stack.avail); \
- DEBUG_PRINT2 (" size: %d\n", fail_stack.size); \
- \
- assert (fail_stack.avail >= NUM_NONREG_ITEMS); \
- \
- DEBUG_POP (&failure_id); \
- DEBUG_PRINT2 (" Popping failure id: %u\n", failure_id); \
- \
- /* If the saved string location is NULL, it came from an \
- on_failure_keep_string_jump opcode, and we want to throw away the \
- saved NULL, thus retaining our current position in the string. */ \
- string_temp = POP_FAILURE_POINTER (); \
- if (string_temp != NULL) \
- str = (const char *) string_temp; \
- \
- DEBUG_PRINT2 (" Popping string 0x%x: `", str); \
- DEBUG_PRINT_DOUBLE_STRING (str, string1, size1, string2, size2); \
- DEBUG_PRINT1 ("'\n"); \
- \
- pat = (unsigned char *) POP_FAILURE_POINTER (); \
- DEBUG_PRINT2 (" Popping pattern 0x%x:\n", pat); \
- DEBUG_PRINT_COMPILED_PATTERN (bufp, pat, pend); \
- \
- /* Restore register info. */ \
- high_reg = (active_reg_t) POP_FAILURE_INT (); \
- DEBUG_PRINT2 (" Popping high active reg: %d\n", high_reg); \
- \
- low_reg = (active_reg_t) POP_FAILURE_INT (); \
- DEBUG_PRINT2 (" Popping low active reg: %d\n", low_reg); \
- \
- if (1) \
- for (this_reg = high_reg; this_reg >= low_reg; this_reg--) \
- { \
- DEBUG_PRINT2 (" Popping reg: %d\n", this_reg); \
- \
- reg_info[this_reg].word = POP_FAILURE_ELT (); \
- DEBUG_PRINT2 (" info: 0x%x\n", reg_info[this_reg]); \
- \
- regend[this_reg] = (const char *) POP_FAILURE_POINTER (); \
- DEBUG_PRINT2 (" end: 0x%x\n", regend[this_reg]); \
- \
- regstart[this_reg] = (const char *) POP_FAILURE_POINTER (); \
- DEBUG_PRINT2 (" start: 0x%x\n", regstart[this_reg]); \
- } \
- else \
- { \
- for (this_reg = highest_active_reg; this_reg > high_reg; this_reg--) \
- { \
- reg_info[this_reg].word.integer = 0; \
- regend[this_reg] = 0; \
- regstart[this_reg] = 0; \
- } \
- highest_active_reg = high_reg; \
- } \
- \
- set_regs_matched_done = 0; \
- DEBUG_STATEMENT (nfailure_points_popped++); \
-} /* POP_FAILURE_POINT */
-
-
-\f
-/* Structure for per-register (a.k.a. per-group) information.
- Other register information, such as the
- starting and ending positions (which are addresses), and the list of
- inner groups (which is a bits list) are maintained in separate
- variables.
-
- We are making a (strictly speaking) nonportable assumption here: that
- the compiler will pack our bit fields into something that fits into
- the type of `word', i.e., is something that fits into one item on the
- failure stack. */
-
-
-/* Declarations and macros for re_match_2. */
-
-typedef union
-{
- fail_stack_elt_t word;
- struct
- {
- /* This field is one if this group can match the empty string,
- zero if not. If not yet determined, `MATCH_NULL_UNSET_VALUE'. */
-#define MATCH_NULL_UNSET_VALUE 3
- unsigned match_null_string_p : 2;
- unsigned is_active : 1;
- unsigned matched_something : 1;
- unsigned ever_matched_something : 1;
- } bits;
-} register_info_type;
-
-#define REG_MATCH_NULL_STRING_P(R) ((R).bits.match_null_string_p)
-#define IS_ACTIVE(R) ((R).bits.is_active)
-#define MATCHED_SOMETHING(R) ((R).bits.matched_something)
-#define EVER_MATCHED_SOMETHING(R) ((R).bits.ever_matched_something)
-
-
-/* Call this when have matched a real character; it sets `matched' flags
- for the subexpressions which we are currently inside. Also records
- that those subexprs have matched. */
-#define SET_REGS_MATCHED() \
- do \
- { \
- if (!set_regs_matched_done) \
- { \
- active_reg_t r; \
- set_regs_matched_done = 1; \
- for (r = lowest_active_reg; r <= highest_active_reg; r++) \
- { \
- MATCHED_SOMETHING (reg_info[r]) \
- = EVER_MATCHED_SOMETHING (reg_info[r]) \
- = 1; \
- } \
- } \
- } \
- while (0)
-
-/* Registers are set to a sentinel when they haven't yet matched. */
-static char reg_unset_dummy;
-#define REG_UNSET_VALUE (®_unset_dummy)
-#define REG_UNSET(e) ((e) == REG_UNSET_VALUE)
-\f
-/* Subroutine declarations and macros for regex_compile. */
-
-static reg_errcode_t regex_compile _RE_ARGS ((const char *pattern, size_t size,
- reg_syntax_t syntax,
- struct re_pattern_buffer *bufp));
-static void store_op1 _RE_ARGS ((re_opcode_t op, unsigned char *loc, int arg));
-static void store_op2 _RE_ARGS ((re_opcode_t op, unsigned char *loc,
- int arg1, int arg2));
-static void insert_op1 _RE_ARGS ((re_opcode_t op, unsigned char *loc,
- int arg, unsigned char *end));
-static void insert_op2 _RE_ARGS ((re_opcode_t op, unsigned char *loc,
- int arg1, int arg2, unsigned char *end));
-static boolean at_begline_loc_p _RE_ARGS ((const char *pattern, const char *p,
- reg_syntax_t syntax));
-static boolean at_endline_loc_p _RE_ARGS ((const char *p, const char *pend,
- reg_syntax_t syntax));
-static reg_errcode_t compile_range _RE_ARGS ((const char **p_ptr,
- const char *pend,
- char *translate,
- reg_syntax_t syntax,
- unsigned char *b));
-
-/* Fetch the next character in the uncompiled pattern---translating it
- if necessary. Also cast from a signed character in the constant
- string passed to us by the user to an unsigned char that we can use
- as an array index (in, e.g., `translate'). */
-#ifndef PATFETCH
-#define PATFETCH(c) \
- do {if (p == pend) return REG_EEND; \
- c = (unsigned char) *p++; \
- if (translate) c = (unsigned char) translate[c]; \
- } while (0)
-#endif
-
-/* Fetch the next character in the uncompiled pattern, with no
- translation. */
-#define PATFETCH_RAW(c) \
- do {if (p == pend) return REG_EEND; \
- c = (unsigned char) *p++; \
- } while (0)
-
-/* Go backwards one character in the pattern. */
-#define PATUNFETCH p--
-
-
-/* If `translate' is non-null, return translate[D], else just D. We
- cast the subscript to translate because some data is declared as
- `char *', to avoid warnings when a string constant is passed. But
- when we use a character as a subscript we must make it unsigned. */
-#ifndef TRANSLATE
-#define TRANSLATE(d) \
- (translate ? (char) translate[(unsigned char) (d)] : (d))
-#endif
-
-
-/* Macros for outputting the compiled pattern into `buffer'. */
-
-/* If the buffer isn't allocated when it comes in, use this. */
-#define INIT_BUF_SIZE 32
-
-/* Make sure we have at least N more bytes of space in buffer. */
-#define GET_BUFFER_SPACE(n) \
- while ((unsigned long) (b - bufp->buffer + (n)) > bufp->allocated) \
- EXTEND_BUFFER ()
-
-/* Make sure we have one more byte of buffer space and then add C to it. */
-#define BUF_PUSH(c) \
- do { \
- GET_BUFFER_SPACE (1); \
- *b++ = (unsigned char) (c); \
- } while (0)
-
-
-/* Ensure we have two more bytes of buffer space and then append C1 and C2. */
-#define BUF_PUSH_2(c1, c2) \
- do { \
- GET_BUFFER_SPACE (2); \
- *b++ = (unsigned char) (c1); \
- *b++ = (unsigned char) (c2); \
- } while (0)
-
-
-/* As with BUF_PUSH_2, except for three bytes. */
-#define BUF_PUSH_3(c1, c2, c3) \
- do { \
- GET_BUFFER_SPACE (3); \
- *b++ = (unsigned char) (c1); \
- *b++ = (unsigned char) (c2); \
- *b++ = (unsigned char) (c3); \
- } while (0)
-
-
-/* Store a jump with opcode OP at LOC to location TO. We store a
- relative address offset by the three bytes the jump itself occupies. */
-#define STORE_JUMP(op, loc, to) \
- store_op1 (op, loc, (int) ((to) - (loc) - 3))
-
-/* Likewise, for a two-argument jump. */
-#define STORE_JUMP2(op, loc, to, arg) \
- store_op2 (op, loc, (int) ((to) - (loc) - 3), arg)
-
-/* Like `STORE_JUMP', but for inserting. Assume `b' is the buffer end. */
-#define INSERT_JUMP(op, loc, to) \
- insert_op1 (op, loc, (int) ((to) - (loc) - 3), b)
-
-/* Like `STORE_JUMP2', but for inserting. Assume `b' is the buffer end. */
-#define INSERT_JUMP2(op, loc, to, arg) \
- insert_op2 (op, loc, (int) ((to) - (loc) - 3), arg, b)
-
-
-/* This is not an arbitrary limit: the arguments which represent offsets
- into the pattern are two bytes long. So if 2^16 bytes turns out to
- be too small, many things would have to change. */
-/* Any other compiler which, like MSC, has allocation limit below 2^16
- bytes will have to use approach similar to what was done below for
- MSC and drop MAX_BUF_SIZE a bit. Otherwise you may end up
- reallocating to 0 bytes. Such thing is not going to work too well.
- You have been warned!! */
-#if defined(_MSC_VER) && !defined(WIN32)
-/* Microsoft C 16-bit versions limit malloc to approx 65512 bytes.
- The REALLOC define eliminates a flurry of conversion warnings,
- but is not required. */
-#define MAX_BUF_SIZE 65500L
-#define REALLOC(p,s) realloc ((p), (size_t) (s))
-#else
-#define MAX_BUF_SIZE (1L << 16)
-#define REALLOC(p,s) realloc ((p), (s))
-#endif
-
-/* Extend the buffer by twice its current size via realloc and
- reset the pointers that pointed into the old block to point to the
- correct places in the new one. If extending the buffer results in it
- being larger than MAX_BUF_SIZE, then flag memory exhausted. */
-#define EXTEND_BUFFER() \
- do { \
- unsigned char *old_buffer = bufp->buffer; \
- if (bufp->allocated == MAX_BUF_SIZE) \
- return REG_ESIZE; \
- bufp->allocated <<= 1; \
- if (bufp->allocated > MAX_BUF_SIZE) \
- bufp->allocated = MAX_BUF_SIZE; \
- bufp->buffer = (unsigned char *) REALLOC (bufp->buffer, bufp->allocated);\
- if (bufp->buffer == NULL) \
- return REG_ESPACE; \
- /* If the buffer moved, move all the pointers into it. */ \
- if (old_buffer != bufp->buffer) \
- { \
- b = (b - old_buffer) + bufp->buffer; \
- begalt = (begalt - old_buffer) + bufp->buffer; \
- if (fixup_alt_jump) \
- fixup_alt_jump = (fixup_alt_jump - old_buffer) + bufp->buffer;\
- if (laststart) \
- laststart = (laststart - old_buffer) + bufp->buffer; \
- if (pending_exact) \
- pending_exact = (pending_exact - old_buffer) + bufp->buffer; \
- } \
- } while (0)
-
-
-/* Since we have one byte reserved for the register number argument to
- {start,stop}_memory, the maximum number of groups we can report
- things about is what fits in that byte. */
-#define MAX_REGNUM 255
-
-/* But patterns can have more than `MAX_REGNUM' registers. We just
- ignore the excess. */
-typedef unsigned regnum_t;
-
-
-/* Macros for the compile stack. */
-
-/* Since offsets can go either forwards or backwards, this type needs to
- be able to hold values from -(MAX_BUF_SIZE - 1) to MAX_BUF_SIZE - 1. */
-/* int may be not enough when sizeof(int) == 2. */
-typedef long pattern_offset_t;
-
-typedef struct
-{
- pattern_offset_t begalt_offset;
- pattern_offset_t fixup_alt_jump;
- pattern_offset_t inner_group_offset;
- pattern_offset_t laststart_offset;
- regnum_t regnum;
-} compile_stack_elt_t;
-
-
-typedef struct
-{
- compile_stack_elt_t *stack;
- unsigned size;
- unsigned avail; /* Offset of next open position. */
-} compile_stack_type;
-
-
-#define INIT_COMPILE_STACK_SIZE 32
-
-#define COMPILE_STACK_EMPTY (compile_stack.avail == 0)
-#define COMPILE_STACK_FULL (compile_stack.avail == compile_stack.size)
-
-/* The next available element. */
-#define COMPILE_STACK_TOP (compile_stack.stack[compile_stack.avail])
-
-
-/* Set the bit for character C in a list. */
-#define SET_LIST_BIT(c) \
- (b[((unsigned char) (c)) / BYTEWIDTH] \
- |= 1 << (((unsigned char) c) % BYTEWIDTH))
-
-
-/* Get the next unsigned number in the uncompiled pattern. */
-#define GET_UNSIGNED_NUMBER(num) \
- { if (p != pend) \
- { \
- PATFETCH (c); \
- while (ISDIGIT (c)) \
- { \
- if (num < 0) \
- num = 0; \
- num = num * 10 + c - '0'; \
- if (p == pend) \
- break; \
- PATFETCH (c); \
- } \
- } \
- }
-
-#if defined _LIBC || (defined HAVE_WCTYPE_H && defined HAVE_WCHAR_H)
-/* The GNU C library provides support for user-defined character classes
- and the functions from ISO C amendement 1. */
-# ifdef CHARCLASS_NAME_MAX
-# define CHAR_CLASS_MAX_LENGTH CHARCLASS_NAME_MAX
-# else
-/* This shouldn't happen but some implementation might still have this
- problem. Use a reasonable default value. */
-# define CHAR_CLASS_MAX_LENGTH 256
-# endif
-
-# define IS_CHAR_CLASS(string) wctype (string)
-#else
-# define CHAR_CLASS_MAX_LENGTH 6 /* Namely, `xdigit'. */
-
-# define IS_CHAR_CLASS(string) \
- (STREQ (string, "alpha") || STREQ (string, "upper") \
- || STREQ (string, "lower") || STREQ (string, "digit") \
- || STREQ (string, "alnum") || STREQ (string, "xdigit") \
- || STREQ (string, "space") || STREQ (string, "print") \
- || STREQ (string, "punct") || STREQ (string, "graph") \
- || STREQ (string, "cntrl") || STREQ (string, "blank"))
-#endif
-\f
-#ifndef MATCH_MAY_ALLOCATE
-
-/* If we cannot allocate large objects within re_match_2_internal,
- we make the fail stack and register vectors global.
- The fail stack, we grow to the maximum size when a regexp
- is compiled.
- The register vectors, we adjust in size each time we
- compile a regexp, according to the number of registers it needs. */
-
-static fail_stack_type fail_stack;
-
-/* Size with which the following vectors are currently allocated.
- That is so we can make them bigger as needed,
- but never make them smaller. */
-static int regs_allocated_size;
-
-static const char ** regstart, ** regend;
-static const char ** old_regstart, ** old_regend;
-static const char **best_regstart, **best_regend;
-static register_info_type *reg_info;
-static const char **reg_dummy;
-static register_info_type *reg_info_dummy;
-
-/* Make the register vectors big enough for NUM_REGS registers,
- but don't make them smaller. */
-
-static
-regex_grow_registers (num_regs)
- int num_regs;
-{
- if (num_regs > regs_allocated_size)
- {
- RETALLOC_IF (regstart, num_regs, const char *);
- RETALLOC_IF (regend, num_regs, const char *);
- RETALLOC_IF (old_regstart, num_regs, const char *);
- RETALLOC_IF (old_regend, num_regs, const char *);
- RETALLOC_IF (best_regstart, num_regs, const char *);
- RETALLOC_IF (best_regend, num_regs, const char *);
- RETALLOC_IF (reg_info, num_regs, register_info_type);
- RETALLOC_IF (reg_dummy, num_regs, const char *);
- RETALLOC_IF (reg_info_dummy, num_regs, register_info_type);
-
- regs_allocated_size = num_regs;
- }
-}
-
-#endif /* not MATCH_MAY_ALLOCATE */
-\f
-static boolean group_in_compile_stack _RE_ARGS ((compile_stack_type
- compile_stack,
- regnum_t regnum));
-
-/* `regex_compile' compiles PATTERN (of length SIZE) according to SYNTAX.
- Returns one of error codes defined in `regex.h', or zero for success.
-
- Assumes the `allocated' (and perhaps `buffer') and `translate'
- fields are set in BUFP on entry.
-
- If it succeeds, results are put in BUFP (if it returns an error, the
- contents of BUFP are undefined):
- `buffer' is the compiled pattern;
- `syntax' is set to SYNTAX;
- `used' is set to the length of the compiled pattern;
- `fastmap_accurate' is zero;
- `re_nsub' is the number of subexpressions in PATTERN;
- `not_bol' and `not_eol' are zero;
-
- The `fastmap' and `newline_anchor' fields are neither
- examined nor set. */
-
-/* Return, freeing storage we allocated. */
-#define FREE_STACK_RETURN(value) \
- return (free (compile_stack.stack), value)
-
-static reg_errcode_t
-regex_compile (pattern, size, syntax, bufp)
- const char *pattern;
- size_t size;
- reg_syntax_t syntax;
- struct re_pattern_buffer *bufp;
-{
- /* We fetch characters from PATTERN here. Even though PATTERN is
- `char *' (i.e., signed), we declare these variables as unsigned, so
- they can be reliably used as array indices. */
- register unsigned char c, c1;
-
- /* A random temporary spot in PATTERN. */
- const char *p1;
-
- /* Points to the end of the buffer, where we should append. */
- register unsigned char *b;
-
- /* Keeps track of unclosed groups. */
- compile_stack_type compile_stack;
-
- /* Points to the current (ending) position in the pattern. */
- const char *p = pattern;
- const char *pend = pattern + size;
-
- /* How to translate the characters in the pattern. */
- RE_TRANSLATE_TYPE translate = bufp->translate;
-
- /* Address of the count-byte of the most recently inserted `exactn'
- command. This makes it possible to tell if a new exact-match
- character can be added to that command or if the character requires
- a new `exactn' command. */
- unsigned char *pending_exact = 0;
-
- /* Address of start of the most recently finished expression.
- This tells, e.g., postfix * where to find the start of its
- operand. Reset at the beginning of groups and alternatives. */
- unsigned char *laststart = 0;
-
- /* Address of beginning of regexp, or inside of last group. */
- unsigned char *begalt;
-
- /* Place in the uncompiled pattern (i.e., the {) to
- which to go back if the interval is invalid. */
- const char *beg_interval;
-
- /* Address of the place where a forward jump should go to the end of
- the containing expression. Each alternative of an `or' -- except the
- last -- ends with a forward jump of this sort. */
- unsigned char *fixup_alt_jump = 0;
-
- /* Counts open-groups as they are encountered. Remembered for the
- matching close-group on the compile stack, so the same register
- number is put in the stop_memory as the start_memory. */
- regnum_t regnum = 0;
-
-#ifdef DEBUG
- DEBUG_PRINT1 ("\nCompiling pattern: ");
- if (debug)
- {
- unsigned debug_count;
-
- for (debug_count = 0; debug_count < size; debug_count++)
- putchar (pattern[debug_count]);
- putchar ('\n');
- }
-#endif /* DEBUG */
-
- /* Initialize the compile stack. */
- compile_stack.stack = TALLOC (INIT_COMPILE_STACK_SIZE, compile_stack_elt_t);
- if (compile_stack.stack == NULL)
- return REG_ESPACE;
-
- compile_stack.size = INIT_COMPILE_STACK_SIZE;
- compile_stack.avail = 0;
-
- /* Initialize the pattern buffer. */
- bufp->syntax = syntax;
- bufp->fastmap_accurate = 0;
- bufp->not_bol = bufp->not_eol = 0;
-
- /* Set `used' to zero, so that if we return an error, the pattern
- printer (for debugging) will think there's no pattern. We reset it
- at the end. */
- bufp->used = 0;
-
- /* Always count groups, whether or not bufp->no_sub is set. */
- bufp->re_nsub = 0;
-
-#if !defined (emacs) && !defined (SYNTAX_TABLE)
- /* Initialize the syntax table. */
- init_syntax_once ();
-#endif
-
- if (bufp->allocated == 0)
- {
- if (bufp->buffer)
- { /* If zero allocated, but buffer is non-null, try to realloc
- enough space. This loses if buffer's address is bogus, but
- that is the user's responsibility. */
- RETALLOC (bufp->buffer, INIT_BUF_SIZE, unsigned char);
- }
- else
- { /* Caller did not allocate a buffer. Do it for them. */
- bufp->buffer = TALLOC (INIT_BUF_SIZE, unsigned char);
- }
- if (!bufp->buffer) FREE_STACK_RETURN (REG_ESPACE);
-
- bufp->allocated = INIT_BUF_SIZE;
- }
-
- begalt = b = bufp->buffer;
-
- /* Loop through the uncompiled pattern until we're at the end. */
- while (p != pend)
- {
- PATFETCH (c);
-
- switch (c)
- {
- case '^':
- {
- if ( /* If at start of pattern, it's an operator. */
- p == pattern + 1
- /* If context independent, it's an operator. */
- || syntax & RE_CONTEXT_INDEP_ANCHORS
- /* Otherwise, depends on what's come before. */
- || at_begline_loc_p (pattern, p, syntax))
- BUF_PUSH (begline);
- else
- goto normal_char;
- }
- break;
-
-
- case '$':
- {
- if ( /* If at end of pattern, it's an operator. */
- p == pend
- /* If context independent, it's an operator. */
- || syntax & RE_CONTEXT_INDEP_ANCHORS
- /* Otherwise, depends on what's next. */
- || at_endline_loc_p (p, pend, syntax))
- BUF_PUSH (endline);
- else
- goto normal_char;
- }
- break;
-
-
- case '+':
- case '?':
- if ((syntax & RE_BK_PLUS_QM)
- || (syntax & RE_LIMITED_OPS))
- goto normal_char;
- handle_plus:
- case '*':
- /* If there is no previous pattern... */
- if (!laststart)
- {
- if (syntax & RE_CONTEXT_INVALID_OPS)
- FREE_STACK_RETURN (REG_BADRPT);
- else if (!(syntax & RE_CONTEXT_INDEP_OPS))
- goto normal_char;
- }
-
- {
- /* Are we optimizing this jump? */
- boolean keep_string_p = false;
-
- /* 1 means zero (many) matches is allowed. */
- char zero_times_ok = 0, many_times_ok = 0;
-
- /* If there is a sequence of repetition chars, collapse it
- down to just one (the right one). We can't combine
- interval operators with these because of, e.g., `a{2}*',
- which should only match an even number of `a's. */
-
- for (;;)
- {
- zero_times_ok |= c != '+';
- many_times_ok |= c != '?';
-
- if (p == pend)
- break;
-
- PATFETCH (c);
-
- if (c == '*'
- || (!(syntax & RE_BK_PLUS_QM) && (c == '+' || c == '?')))
- ;
-
- else if (syntax & RE_BK_PLUS_QM && c == '\\')
- {
- if (p == pend) FREE_STACK_RETURN (REG_EESCAPE);
-
- PATFETCH (c1);
- if (!(c1 == '+' || c1 == '?'))
- {
- PATUNFETCH;
- PATUNFETCH;
- break;
- }
-
- c = c1;
- }
- else
- {
- PATUNFETCH;
- break;
- }
-
- /* If we get here, we found another repeat character. */
- }
-
- /* Star, etc. applied to an empty pattern is equivalent
- to an empty pattern. */
- if (!laststart)
- break;
-
- /* Now we know whether or not zero matches is allowed
- and also whether or not two or more matches is allowed. */
- if (many_times_ok)
- { /* More than one repetition is allowed, so put in at the
- end a backward relative jump from `b' to before the next
- jump we're going to put in below (which jumps from
- laststart to after this jump).
-
- But if we are at the `*' in the exact sequence `.*\n',
- insert an unconditional jump backwards to the .,
- instead of the beginning of the loop. This way we only
- push a failure point once, instead of every time
- through the loop. */
- assert (p - 1 > pattern);
-
- /* Allocate the space for the jump. */
- GET_BUFFER_SPACE (3);
-
- /* We know we are not at the first character of the pattern,
- because laststart was nonzero. And we've already
- incremented `p', by the way, to be the character after
- the `*'. Do we have to do something analogous here
- for null bytes, because of RE_DOT_NOT_NULL? */
- if (TRANSLATE (*(p - 2)) == TRANSLATE ('.')
- && zero_times_ok
- && p < pend && TRANSLATE (*p) == TRANSLATE ('\n')
- && !(syntax & RE_DOT_NEWLINE))
- { /* We have .*\n. */
- STORE_JUMP (jump, b, laststart);
- keep_string_p = true;
- }
- else
- /* Anything else. */
- STORE_JUMP (maybe_pop_jump, b, laststart - 3);
-
- /* We've added more stuff to the buffer. */
- b += 3;
- }
-
- /* On failure, jump from laststart to b + 3, which will be the
- end of the buffer after this jump is inserted. */
- GET_BUFFER_SPACE (3);
- INSERT_JUMP (keep_string_p ? on_failure_keep_string_jump
- : on_failure_jump,
- laststart, b + 3);
- pending_exact = 0;
- b += 3;
-
- if (!zero_times_ok)
- {
- /* At least one repetition is required, so insert a
- `dummy_failure_jump' before the initial
- `on_failure_jump' instruction of the loop. This
- effects a skip over that instruction the first time
- we hit that loop. */
- GET_BUFFER_SPACE (3);
- INSERT_JUMP (dummy_failure_jump, laststart, laststart + 6);
- b += 3;
- }
- }
- break;
-
-
- case '.':
- laststart = b;
- BUF_PUSH (anychar);
- break;
-
-
- case '[':
- {
- boolean had_char_class = false;
-
- if (p == pend) FREE_STACK_RETURN (REG_EBRACK);
-
- /* Ensure that we have enough space to push a charset: the
- opcode, the length count, and the bitset; 34 bytes in all. */
- GET_BUFFER_SPACE (34);
-
- laststart = b;
-
- /* We test `*p == '^' twice, instead of using an if
- statement, so we only need one BUF_PUSH. */
- BUF_PUSH (*p == '^' ? charset_not : charset);
- if (*p == '^')
- p++;
-
- /* Remember the first position in the bracket expression. */
- p1 = p;
-
- /* Push the number of bytes in the bitmap. */
- BUF_PUSH ((1 << BYTEWIDTH) / BYTEWIDTH);
-
- /* Clear the whole map. */
- bzero (b, (1 << BYTEWIDTH) / BYTEWIDTH);
-
- /* charset_not matches newline according to a syntax bit. */
- if ((re_opcode_t) b[-2] == charset_not
- && (syntax & RE_HAT_LISTS_NOT_NEWLINE))
- SET_LIST_BIT ('\n');
-
- /* Read in characters and ranges, setting map bits. */
- for (;;)
- {
- if (p == pend) FREE_STACK_RETURN (REG_EBRACK);
-
- PATFETCH (c);
-
- /* \ might escape characters inside [...] and [^...]. */
- if ((syntax & RE_BACKSLASH_ESCAPE_IN_LISTS) && c == '\\')
- {
- if (p == pend) FREE_STACK_RETURN (REG_EESCAPE);
-
- PATFETCH (c1);
- SET_LIST_BIT (c1);
- continue;
- }
-
- /* Could be the end of the bracket expression. If it's
- not (i.e., when the bracket expression is `[]' so
- far), the ']' character bit gets set way below. */
- if (c == ']' && p != p1 + 1)
- break;
-
- /* Look ahead to see if it's a range when the last thing
- was a character class. */
- if (had_char_class && c == '-' && *p != ']')
- FREE_STACK_RETURN (REG_ERANGE);
-
- /* Look ahead to see if it's a range when the last thing
- was a character: if this is a hyphen not at the
- beginning or the end of a list, then it's the range
- operator. */
- if (c == '-'
- && !(p - 2 >= pattern && p[-2] == '[')
- && !(p - 3 >= pattern && p[-3] == '[' && p[-2] == '^')
- && *p != ']')
- {
- reg_errcode_t ret
- = compile_range (&p, pend, translate, syntax, b);
- if (ret != REG_NOERROR) FREE_STACK_RETURN (ret);
- }
-
- else if (p[0] == '-' && p[1] != ']')
- { /* This handles ranges made up of characters only. */
- reg_errcode_t ret;
-
- /* Move past the `-'. */
- PATFETCH (c1);
-
- ret = compile_range (&p, pend, translate, syntax, b);
- if (ret != REG_NOERROR) FREE_STACK_RETURN (ret);
- }
-
- /* See if we're at the beginning of a possible character
- class. */
-
- else if (syntax & RE_CHAR_CLASSES && c == '[' && *p == ':')
- { /* Leave room for the null. */
- char str[CHAR_CLASS_MAX_LENGTH + 1];
-
- PATFETCH (c);
- c1 = 0;
-
- /* If pattern is `[[:'. */
- if (p == pend) FREE_STACK_RETURN (REG_EBRACK);
-
- for (;;)
- {
- PATFETCH (c);
- if (c == ':' || c == ']' || p == pend
- || c1 == CHAR_CLASS_MAX_LENGTH)
- break;
- str[c1++] = c;
- }
- str[c1] = '\0';
-
- /* If isn't a word bracketed by `[:' and:`]':
- undo the ending character, the letters, and leave
- the leading `:' and `[' (but set bits for them). */
- if (c == ':' && *p == ']')
- {
-#if defined _LIBC || (defined HAVE_WCTYPE_H && defined HAVE_WCHAR_H)
- boolean is_lower = STREQ (str, "lower");
- boolean is_upper = STREQ (str, "upper");
- wctype_t wt;
- int ch;
-
- wt = wctype (str);
- if (wt == 0)
- FREE_STACK_RETURN (REG_ECTYPE);
-
- /* Throw away the ] at the end of the character
- class. */
- PATFETCH (c);
-
- if (p == pend) FREE_STACK_RETURN (REG_EBRACK);
-
- for (ch = 0; ch < 1 << BYTEWIDTH; ++ch)
- {
- if (iswctype (btowc (ch), wt))
- SET_LIST_BIT (ch);
-
- if (translate && (is_upper || is_lower)
- && (ISUPPER (ch) || ISLOWER (ch)))
- SET_LIST_BIT (ch);
- }
-
- had_char_class = true;
-#else
- int ch;
- boolean is_alnum = STREQ (str, "alnum");
- boolean is_alpha = STREQ (str, "alpha");
- boolean is_blank = STREQ (str, "blank");
- boolean is_cntrl = STREQ (str, "cntrl");
- boolean is_digit = STREQ (str, "digit");
- boolean is_graph = STREQ (str, "graph");
- boolean is_lower = STREQ (str, "lower");
- boolean is_print = STREQ (str, "print");
- boolean is_punct = STREQ (str, "punct");
- boolean is_space = STREQ (str, "space");
- boolean is_upper = STREQ (str, "upper");
- boolean is_xdigit = STREQ (str, "xdigit");
-
- if (!IS_CHAR_CLASS (str))
- FREE_STACK_RETURN (REG_ECTYPE);
-
- /* Throw away the ] at the end of the character
- class. */
- PATFETCH (c);
-
- if (p == pend) FREE_STACK_RETURN (REG_EBRACK);
-
- for (ch = 0; ch < 1 << BYTEWIDTH; ch++)
- {
- /* This was split into 3 if's to
- avoid an arbitrary limit in some compiler. */
- if ( (is_alnum && ISALNUM (ch))
- || (is_alpha && ISALPHA (ch))
- || (is_blank && ISBLANK (ch))
- || (is_cntrl && ISCNTRL (ch)))
- SET_LIST_BIT (ch);
- if ( (is_digit && ISDIGIT (ch))
- || (is_graph && ISGRAPH (ch))
- || (is_lower && ISLOWER (ch))
- || (is_print && ISPRINT (ch)))
- SET_LIST_BIT (ch);
- if ( (is_punct && ISPUNCT (ch))
- || (is_space && ISSPACE (ch))
- || (is_upper && ISUPPER (ch))
- || (is_xdigit && ISXDIGIT (ch)))
- SET_LIST_BIT (ch);
- if ( translate && (is_upper || is_lower)
- && (ISUPPER (ch) || ISLOWER (ch)))
- SET_LIST_BIT (ch);
- }
- had_char_class = true;
-#endif /* libc || wctype.h */
- }
- else
- {
- c1++;
- while (c1--)
- PATUNFETCH;
- SET_LIST_BIT ('[');
- SET_LIST_BIT (':');
- had_char_class = false;
- }
- }
- else
- {
- had_char_class = false;
- SET_LIST_BIT (c);
- }
- }
-
- /* Discard any (non)matching list bytes that are all 0 at the
- end of the map. Decrease the map-length byte too. */
- while ((int) b[-1] > 0 && b[b[-1] - 1] == 0)
- b[-1]--;
- b += b[-1];
- }
- break;
-
-
- case '(':
- if (syntax & RE_NO_BK_PARENS)
- goto handle_open;
- else
- goto normal_char;
-
-
- case ')':
- if (syntax & RE_NO_BK_PARENS)
- goto handle_close;
- else
- goto normal_char;
-
-
- case '\n':
- if (syntax & RE_NEWLINE_ALT)
- goto handle_alt;
- else
- goto normal_char;
-
-
- case '|':
- if (syntax & RE_NO_BK_VBAR)
- goto handle_alt;
- else
- goto normal_char;
-
-
- case '{':
- if (syntax & RE_INTERVALS && syntax & RE_NO_BK_BRACES)
- goto handle_interval;
- else
- goto normal_char;
-
-
- case '\\':
- if (p == pend) FREE_STACK_RETURN (REG_EESCAPE);
-
- /* Do not translate the character after the \, so that we can
- distinguish, e.g., \B from \b, even if we normally would
- translate, e.g., B to b. */
- PATFETCH_RAW (c);
-
- switch (c)
- {
- case '(':
- if (syntax & RE_NO_BK_PARENS)
- goto normal_backslash;
-
- handle_open:
- bufp->re_nsub++;
- regnum++;
-
- if (COMPILE_STACK_FULL)
- {
- RETALLOC (compile_stack.stack, compile_stack.size << 1,
- compile_stack_elt_t);
- if (compile_stack.stack == NULL) return REG_ESPACE;
-
- compile_stack.size <<= 1;
- }
-
- /* These are the values to restore when we hit end of this
- group. They are all relative offsets, so that if the
- whole pattern moves because of realloc, they will still
- be valid. */
- COMPILE_STACK_TOP.begalt_offset = begalt - bufp->buffer;
- COMPILE_STACK_TOP.fixup_alt_jump
- = fixup_alt_jump ? fixup_alt_jump - bufp->buffer + 1 : 0;
- COMPILE_STACK_TOP.laststart_offset = b - bufp->buffer;
- COMPILE_STACK_TOP.regnum = regnum;
-
- /* We will eventually replace the 0 with the number of
- groups inner to this one. But do not push a
- start_memory for groups beyond the last one we can
- represent in the compiled pattern. */
- if (regnum <= MAX_REGNUM)
- {
- COMPILE_STACK_TOP.inner_group_offset = b - bufp->buffer + 2;
- BUF_PUSH_3 (start_memory, regnum, 0);
- }
-
- compile_stack.avail++;
-
- fixup_alt_jump = 0;
- laststart = 0;
- begalt = b;
- /* If we've reached MAX_REGNUM groups, then this open
- won't actually generate any code, so we'll have to
- clear pending_exact explicitly. */
- pending_exact = 0;
- break;
-
-
- case ')':
- if (syntax & RE_NO_BK_PARENS) goto normal_backslash;
-
- if (COMPILE_STACK_EMPTY)
- if (syntax & RE_UNMATCHED_RIGHT_PAREN_ORD)
- goto normal_backslash;
- else
- FREE_STACK_RETURN (REG_ERPAREN);
-
- handle_close:
- if (fixup_alt_jump)
- { /* Push a dummy failure point at the end of the
- alternative for a possible future
- `pop_failure_jump' to pop. See comments at
- `push_dummy_failure' in `re_match_2'. */
- BUF_PUSH (push_dummy_failure);
-
- /* We allocated space for this jump when we assigned
- to `fixup_alt_jump', in the `handle_alt' case below. */
- STORE_JUMP (jump_past_alt, fixup_alt_jump, b - 1);
- }
-
- /* See similar code for backslashed left paren above. */
- if (COMPILE_STACK_EMPTY)
- if (syntax & RE_UNMATCHED_RIGHT_PAREN_ORD)
- goto normal_char;
- else
- FREE_STACK_RETURN (REG_ERPAREN);
-
- /* Since we just checked for an empty stack above, this
- ``can't happen''. */
- assert (compile_stack.avail != 0);
- {
- /* We don't just want to restore into `regnum', because
- later groups should continue to be numbered higher,
- as in `(ab)c(de)' -- the second group is #2. */
- regnum_t this_group_regnum;
-
- compile_stack.avail--;
- begalt = bufp->buffer + COMPILE_STACK_TOP.begalt_offset;
- fixup_alt_jump
- = COMPILE_STACK_TOP.fixup_alt_jump
- ? bufp->buffer + COMPILE_STACK_TOP.fixup_alt_jump - 1
- : 0;
- laststart = bufp->buffer + COMPILE_STACK_TOP.laststart_offset;
- this_group_regnum = COMPILE_STACK_TOP.regnum;
- /* If we've reached MAX_REGNUM groups, then this open
- won't actually generate any code, so we'll have to
- clear pending_exact explicitly. */
- pending_exact = 0;
-
- /* We're at the end of the group, so now we know how many
- groups were inside this one. */
- if (this_group_regnum <= MAX_REGNUM)
- {
- unsigned char *inner_group_loc
- = bufp->buffer + COMPILE_STACK_TOP.inner_group_offset;
-
- *inner_group_loc = regnum - this_group_regnum;
- BUF_PUSH_3 (stop_memory, this_group_regnum,
- regnum - this_group_regnum);
- }
- }
- break;
-
-
- case '|': /* `\|'. */
- if (syntax & RE_LIMITED_OPS || syntax & RE_NO_BK_VBAR)
- goto normal_backslash;
- handle_alt:
- if (syntax & RE_LIMITED_OPS)
- goto normal_char;
-
- /* Insert before the previous alternative a jump which
- jumps to this alternative if the former fails. */
- GET_BUFFER_SPACE (3);
- INSERT_JUMP (on_failure_jump, begalt, b + 6);
- pending_exact = 0;
- b += 3;
-
- /* The alternative before this one has a jump after it
- which gets executed if it gets matched. Adjust that
- jump so it will jump to this alternative's analogous
- jump (put in below, which in turn will jump to the next
- (if any) alternative's such jump, etc.). The last such
- jump jumps to the correct final destination. A picture:
- _____ _____
- | | | |
- | v | v
- a | b | c
-
- If we are at `b', then fixup_alt_jump right now points to a
- three-byte space after `a'. We'll put in the jump, set
- fixup_alt_jump to right after `b', and leave behind three
- bytes which we'll fill in when we get to after `c'. */
-
- if (fixup_alt_jump)
- STORE_JUMP (jump_past_alt, fixup_alt_jump, b);
-
- /* Mark and leave space for a jump after this alternative,
- to be filled in later either by next alternative or
- when know we're at the end of a series of alternatives. */
- fixup_alt_jump = b;
- GET_BUFFER_SPACE (3);
- b += 3;
-
- laststart = 0;
- begalt = b;
- break;
-
-
- case '{':
- /* If \{ is a literal. */
- if (!(syntax & RE_INTERVALS)
- /* If we're at `\{' and it's not the open-interval
- operator. */
- || ((syntax & RE_INTERVALS) && (syntax & RE_NO_BK_BRACES))
- || (p - 2 == pattern && p == pend))
- goto normal_backslash;
-
- handle_interval:
- {
- /* If got here, then the syntax allows intervals. */
-
- /* At least (most) this many matches must be made. */
- int lower_bound = -1, upper_bound = -1;
-
- beg_interval = p - 1;
-
- if (p == pend)
- {
- if (syntax & RE_NO_BK_BRACES)
- goto unfetch_interval;
- else
- FREE_STACK_RETURN (REG_EBRACE);
- }
-
- GET_UNSIGNED_NUMBER (lower_bound);
-
- if (c == ',')
- {
- GET_UNSIGNED_NUMBER (upper_bound);
- if (upper_bound < 0) upper_bound = RE_DUP_MAX;
- }
- else
- /* Interval such as `{1}' => match exactly once. */
- upper_bound = lower_bound;
-
- if (lower_bound < 0 || upper_bound > RE_DUP_MAX
- || lower_bound > upper_bound)
- {
- if (syntax & RE_NO_BK_BRACES)
- goto unfetch_interval;
- else
- FREE_STACK_RETURN (REG_BADBR);
- }
-
- if (!(syntax & RE_NO_BK_BRACES))
- {
- if (c != '\\') FREE_STACK_RETURN (REG_EBRACE);
-
- PATFETCH (c);
- }
-
- if (c != '}')
- {
- if (syntax & RE_NO_BK_BRACES)
- goto unfetch_interval;
- else
- FREE_STACK_RETURN (REG_BADBR);
- }
-
- /* We just parsed a valid interval. */
-
- /* If it's invalid to have no preceding re. */
- if (!laststart)
- {
- if (syntax & RE_CONTEXT_INVALID_OPS)
- FREE_STACK_RETURN (REG_BADRPT);
- else if (syntax & RE_CONTEXT_INDEP_OPS)
- laststart = b;
- else
- goto unfetch_interval;
- }
-
- /* If the upper bound is zero, don't want to succeed at
- all; jump from `laststart' to `b + 3', which will be
- the end of the buffer after we insert the jump. */
- if (upper_bound == 0)
- {
- GET_BUFFER_SPACE (3);
- INSERT_JUMP (jump, laststart, b + 3);
- b += 3;
- }
-
- /* Otherwise, we have a nontrivial interval. When
- we're all done, the pattern will look like:
- set_number_at <jump count> <upper bound>
- set_number_at <succeed_n count> <lower bound>
- succeed_n <after jump addr> <succeed_n count>
- <body of loop>
- jump_n <succeed_n addr> <jump count>
- (The upper bound and `jump_n' are omitted if
- `upper_bound' is 1, though.) */
- else
- { /* If the upper bound is > 1, we need to insert
- more at the end of the loop. */
- unsigned nbytes = 10 + (upper_bound > 1) * 10;
-
- GET_BUFFER_SPACE (nbytes);
-
- /* Initialize lower bound of the `succeed_n', even
- though it will be set during matching by its
- attendant `set_number_at' (inserted next),
- because `re_compile_fastmap' needs to know.
- Jump to the `jump_n' we might insert below. */
- INSERT_JUMP2 (succeed_n, laststart,
- b + 5 + (upper_bound > 1) * 5,
- lower_bound);
- b += 5;
-
- /* Code to initialize the lower bound. Insert
- before the `succeed_n'. The `5' is the last two
- bytes of this `set_number_at', plus 3 bytes of
- the following `succeed_n'. */
- insert_op2 (set_number_at, laststart, 5, lower_bound, b);
- b += 5;
-
- if (upper_bound > 1)
- { /* More than one repetition is allowed, so
- append a backward jump to the `succeed_n'
- that starts this interval.
-
- When we've reached this during matching,
- we'll have matched the interval once, so
- jump back only `upper_bound - 1' times. */
- STORE_JUMP2 (jump_n, b, laststart + 5,
- upper_bound - 1);
- b += 5;
-
- /* The location we want to set is the second
- parameter of the `jump_n'; that is `b-2' as
- an absolute address. `laststart' will be
- the `set_number_at' we're about to insert;
- `laststart+3' the number to set, the source
- for the relative address. But we are
- inserting into the middle of the pattern --
- so everything is getting moved up by 5.
- Conclusion: (b - 2) - (laststart + 3) + 5,
- i.e., b - laststart.
-
- We insert this at the beginning of the loop
- so that if we fail during matching, we'll
- reinitialize the bounds. */
- insert_op2 (set_number_at, laststart, b - laststart,
- upper_bound - 1, b);
- b += 5;
- }
- }
- pending_exact = 0;
- beg_interval = NULL;
- }
- break;
-
- unfetch_interval:
- /* If an invalid interval, match the characters as literals. */
- assert (beg_interval);
- p = beg_interval;
- beg_interval = NULL;
-
- /* normal_char and normal_backslash need `c'. */
- PATFETCH (c);
-
- if (!(syntax & RE_NO_BK_BRACES))
- {
- if (p > pattern && p[-1] == '\\')
- goto normal_backslash;
- }
- goto normal_char;
-
-#ifdef emacs
- /* There is no way to specify the before_dot and after_dot
- operators. rms says this is ok. --karl */
- case '=':
- BUF_PUSH (at_dot);
- break;
-
- case 's':
- laststart = b;
- PATFETCH (c);
- BUF_PUSH_2 (syntaxspec, syntax_spec_code[c]);
- break;
-
- case 'S':
- laststart = b;
- PATFETCH (c);
- BUF_PUSH_2 (notsyntaxspec, syntax_spec_code[c]);
- break;
-#endif /* emacs */
-
-
- case 'w':
- if (re_syntax_options & RE_NO_GNU_OPS)
- goto normal_char;
- laststart = b;
- BUF_PUSH (wordchar);
- break;
-
-
- case 'W':
- if (re_syntax_options & RE_NO_GNU_OPS)
- goto normal_char;
- laststart = b;
- BUF_PUSH (notwordchar);
- break;
-
-
- case '<':
- if (re_syntax_options & RE_NO_GNU_OPS)
- goto normal_char;
- BUF_PUSH (wordbeg);
- break;
-
- case '>':
- if (re_syntax_options & RE_NO_GNU_OPS)
- goto normal_char;
- BUF_PUSH (wordend);
- break;
-
- case 'b':
- if (re_syntax_options & RE_NO_GNU_OPS)
- goto normal_char;
- BUF_PUSH (wordbound);
- break;
-
- case 'B':
- if (re_syntax_options & RE_NO_GNU_OPS)
- goto normal_char;
- BUF_PUSH (notwordbound);
- break;
-
- case '`':
- if (re_syntax_options & RE_NO_GNU_OPS)
- goto normal_char;
- BUF_PUSH (begbuf);
- break;
-
- case '\'':
- if (re_syntax_options & RE_NO_GNU_OPS)
- goto normal_char;
- BUF_PUSH (endbuf);
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- if (syntax & RE_NO_BK_REFS)
- goto normal_char;
-
- c1 = c - '0';
-
- if (c1 > regnum)
- FREE_STACK_RETURN (REG_ESUBREG);
-
- /* Can't back reference to a subexpression if inside of it. */
- if (group_in_compile_stack (compile_stack, (regnum_t) c1))
- goto normal_char;
-
- laststart = b;
- BUF_PUSH_2 (duplicate, c1);
- break;
-
-
- case '+':
- case '?':
- if (syntax & RE_BK_PLUS_QM)
- goto handle_plus;
- else
- goto normal_backslash;
-
- default:
- normal_backslash:
- /* You might think it would be useful for \ to mean
- not to translate; but if we don't translate it
- it will never match anything. */
- c = TRANSLATE (c);
- goto normal_char;
- }
- break;
-
-
- default:
- /* Expects the character in `c'. */
- normal_char:
- /* If no exactn currently being built. */
- if (!pending_exact
-
- /* If last exactn not at current position. */
- || pending_exact + *pending_exact + 1 != b
-
- /* We have only one byte following the exactn for the count. */
- || *pending_exact == (1 << BYTEWIDTH) - 1
-
- /* If followed by a repetition operator. */
- || *p == '*' || *p == '^'
- || ((syntax & RE_BK_PLUS_QM)
- ? *p == '\\' && (p[1] == '+' || p[1] == '?')
- : (*p == '+' || *p == '?'))
- || ((syntax & RE_INTERVALS)
- && ((syntax & RE_NO_BK_BRACES)
- ? *p == '{'
- : (p[0] == '\\' && p[1] == '{'))))
- {
- /* Start building a new exactn. */
-
- laststart = b;
-
- BUF_PUSH_2 (exactn, 0);
- pending_exact = b - 1;
- }
-
- BUF_PUSH (c);
- (*pending_exact)++;
- break;
- } /* switch (c) */
- } /* while p != pend */
-
-
- /* Through the pattern now. */
-
- if (fixup_alt_jump)
- STORE_JUMP (jump_past_alt, fixup_alt_jump, b);
-
- if (!COMPILE_STACK_EMPTY)
- FREE_STACK_RETURN (REG_EPAREN);
-
- /* If we don't want backtracking, force success
- the first time we reach the end of the compiled pattern. */
- if (syntax & RE_NO_POSIX_BACKTRACKING)
- BUF_PUSH (succeed);
-
- free (compile_stack.stack);
-
- /* We have succeeded; set the length of the buffer. */
- bufp->used = b - bufp->buffer;
-
-#ifdef DEBUG
- if (debug)
- {
- DEBUG_PRINT1 ("\nCompiled pattern: \n");
- print_compiled_pattern (bufp);
- }
-#endif /* DEBUG */
-
-#ifndef MATCH_MAY_ALLOCATE
- /* Initialize the failure stack to the largest possible stack. This
- isn't necessary unless we're trying to avoid calling alloca in
- the search and match routines. */
- {
- int num_regs = bufp->re_nsub + 1;
-
- /* Since DOUBLE_FAIL_STACK refuses to double only if the current size
- is strictly greater than re_max_failures, the largest possible stack
- is 2 * re_max_failures failure points. */
- if (fail_stack.size < (2 * re_max_failures * MAX_FAILURE_ITEMS))
- {
- fail_stack.size = (2 * re_max_failures * MAX_FAILURE_ITEMS);
-
-#ifdef emacs
- if (! fail_stack.stack)
- fail_stack.stack
- = (fail_stack_elt_t *) xmalloc (fail_stack.size
- * sizeof (fail_stack_elt_t));
- else
- fail_stack.stack
- = (fail_stack_elt_t *) xrealloc (fail_stack.stack,
- (fail_stack.size
- * sizeof (fail_stack_elt_t)));
-#else /* not emacs */
- if (! fail_stack.stack)
- fail_stack.stack
- = (fail_stack_elt_t *) malloc (fail_stack.size
- * sizeof (fail_stack_elt_t));
- else
- fail_stack.stack
- = (fail_stack_elt_t *) realloc (fail_stack.stack,
- (fail_stack.size
- * sizeof (fail_stack_elt_t)));
-#endif /* not emacs */
- }
-
- regex_grow_registers (num_regs);
- }
-#endif /* not MATCH_MAY_ALLOCATE */
-
- return REG_NOERROR;
-} /* regex_compile */
-\f
-/* Subroutines for `regex_compile'. */
-
-/* Store OP at LOC followed by two-byte integer parameter ARG. */
-
-static void
-store_op1 (op, loc, arg)
- re_opcode_t op;
- unsigned char *loc;
- int arg;
-{
- *loc = (unsigned char) op;
- STORE_NUMBER (loc + 1, arg);
-}
-
-
-/* Like `store_op1', but for two two-byte parameters ARG1 and ARG2. */
-
-static void
-store_op2 (op, loc, arg1, arg2)
- re_opcode_t op;
- unsigned char *loc;
- int arg1, arg2;
-{
- *loc = (unsigned char) op;
- STORE_NUMBER (loc + 1, arg1);
- STORE_NUMBER (loc + 3, arg2);
-}
-
-
-/* Copy the bytes from LOC to END to open up three bytes of space at LOC
- for OP followed by two-byte integer parameter ARG. */
-
-static void
-insert_op1 (op, loc, arg, end)
- re_opcode_t op;
- unsigned char *loc;
- int arg;
- unsigned char *end;
-{
- register unsigned char *pfrom = end;
- register unsigned char *pto = end + 3;
-
- while (pfrom != loc)
- *--pto = *--pfrom;
-
- store_op1 (op, loc, arg);
-}
-
-
-/* Like `insert_op1', but for two two-byte parameters ARG1 and ARG2. */
-
-static void
-insert_op2 (op, loc, arg1, arg2, end)
- re_opcode_t op;
- unsigned char *loc;
- int arg1, arg2;
- unsigned char *end;
-{
- register unsigned char *pfrom = end;
- register unsigned char *pto = end + 5;
-
- while (pfrom != loc)
- *--pto = *--pfrom;
-
- store_op2 (op, loc, arg1, arg2);
-}
-
-
-/* P points to just after a ^ in PATTERN. Return true if that ^ comes
- after an alternative or a begin-subexpression. We assume there is at
- least one character before the ^. */
-
-static boolean
-at_begline_loc_p (pattern, p, syntax)
- const char *pattern, *p;
- reg_syntax_t syntax;
-{
- const char *prev = p - 2;
- boolean prev_prev_backslash = prev > pattern && prev[-1] == '\\';
-
- return
- /* After a subexpression? */
- (*prev == '(' && (syntax & RE_NO_BK_PARENS || prev_prev_backslash))
- /* After an alternative? */
- || (*prev == '|' && (syntax & RE_NO_BK_VBAR || prev_prev_backslash));
-}
-
-
-/* The dual of at_begline_loc_p. This one is for $. We assume there is
- at least one character after the $, i.e., `P < PEND'. */
-
-static boolean
-at_endline_loc_p (p, pend, syntax)
- const char *p, *pend;
- reg_syntax_t syntax;
-{
- const char *next = p;
- boolean next_backslash = *next == '\\';
- const char *next_next = p + 1 < pend ? p + 1 : 0;
-
- return
- /* Before a subexpression? */
- (syntax & RE_NO_BK_PARENS ? *next == ')'
- : next_backslash && next_next && *next_next == ')')
- /* Before an alternative? */
- || (syntax & RE_NO_BK_VBAR ? *next == '|'
- : next_backslash && next_next && *next_next == '|');
-}
-
-
-/* Returns true if REGNUM is in one of COMPILE_STACK's elements and
- false if it's not. */
-
-static boolean
-group_in_compile_stack (compile_stack, regnum)
- compile_stack_type compile_stack;
- regnum_t regnum;
-{
- int this_element;
-
- for (this_element = compile_stack.avail - 1;
- this_element >= 0;
- this_element--)
- if (compile_stack.stack[this_element].regnum == regnum)
- return true;
-
- return false;
-}
-
-
-/* Read the ending character of a range (in a bracket expression) from the
- uncompiled pattern *P_PTR (which ends at PEND). We assume the
- starting character is in `P[-2]'. (`P[-1]' is the character `-'.)
- Then we set the translation of all bits between the starting and
- ending characters (inclusive) in the compiled pattern B.
-
- Return an error code.
-
- We use these short variable names so we can use the same macros as
- `regex_compile' itself. */
-
-static reg_errcode_t
-compile_range (p_ptr, pend, translate, syntax, b)
- const char **p_ptr, *pend;
- RE_TRANSLATE_TYPE translate;
- reg_syntax_t syntax;
- unsigned char *b;
-{
- unsigned this_char;
-
- const char *p = *p_ptr;
- unsigned int range_start, range_end;
-
- if (p == pend)
- return REG_ERANGE;
-
- /* Even though the pattern is a signed `char *', we need to fetch
- with unsigned char *'s; if the high bit of the pattern character
- is set, the range endpoints will be negative if we fetch using a
- signed char *.
-
- We also want to fetch the endpoints without translating them; the
- appropriate translation is done in the bit-setting loop below. */
- /* The SVR4 compiler on the 3B2 had trouble with unsigned const char *. */
- range_start = ((const unsigned char *) p)[-2];
- range_end = ((const unsigned char *) p)[0];
-
- /* Have to increment the pointer into the pattern string, so the
- caller isn't still at the ending character. */
- (*p_ptr)++;
-
- /* If the start is after the end, the range is empty. */
- if (range_start > range_end)
- return syntax & RE_NO_EMPTY_RANGES ? REG_ERANGE : REG_NOERROR;
-
- /* Here we see why `this_char' has to be larger than an `unsigned
- char' -- the range is inclusive, so if `range_end' == 0xff
- (assuming 8-bit characters), we would otherwise go into an infinite
- loop, since all characters <= 0xff. */
- for (this_char = range_start; this_char <= range_end; this_char++)
- {
- SET_LIST_BIT (TRANSLATE (this_char));
- }
-
- return REG_NOERROR;
-}
-\f
-/* re_compile_fastmap computes a ``fastmap'' for the compiled pattern in
- BUFP. A fastmap records which of the (1 << BYTEWIDTH) possible
- characters can start a string that matches the pattern. This fastmap
- is used by re_search to skip quickly over impossible starting points.
-
- The caller must supply the address of a (1 << BYTEWIDTH)-byte data
- area as BUFP->fastmap.
-
- We set the `fastmap', `fastmap_accurate', and `can_be_null' fields in
- the pattern buffer.
-
- Returns 0 if we succeed, -2 if an internal error. */
-
-int
-re_compile_fastmap (bufp)
- struct re_pattern_buffer *bufp;
-{
- int j, k;
-#ifdef MATCH_MAY_ALLOCATE
- fail_stack_type fail_stack;
-#endif
-#ifndef REGEX_MALLOC
- char *destination;
-#endif
- /* We don't push any register information onto the failure stack. */
- unsigned num_regs = 0;
-
- register char *fastmap = bufp->fastmap;
- unsigned char *pattern = bufp->buffer;
- unsigned char *p = pattern;
- register unsigned char *pend = pattern + bufp->used;
-
-#ifdef REL_ALLOC
- /* This holds the pointer to the failure stack, when
- it is allocated relocatably. */
- fail_stack_elt_t *failure_stack_ptr;
-#endif
-
- /* Assume that each path through the pattern can be null until
- proven otherwise. We set this false at the bottom of switch
- statement, to which we get only if a particular path doesn't
- match the empty string. */
- boolean path_can_be_null = true;
-
- /* We aren't doing a `succeed_n' to begin with. */
- boolean succeed_n_p = false;
-
- assert (fastmap != NULL && p != NULL);
-
- INIT_FAIL_STACK ();
- bzero (fastmap, 1 << BYTEWIDTH); /* Assume nothing's valid. */
- bufp->fastmap_accurate = 1; /* It will be when we're done. */
- bufp->can_be_null = 0;
-
- while (1)
- {
- if (p == pend || *p == succeed)
- {
- /* We have reached the (effective) end of pattern. */
- if (!FAIL_STACK_EMPTY ())
- {
- bufp->can_be_null |= path_can_be_null;
-
- /* Reset for next path. */
- path_can_be_null = true;
-
- p = fail_stack.stack[--fail_stack.avail].pointer;
-
- continue;
- }
- else
- break;
- }
-
- /* We should never be about to go beyond the end of the pattern. */
- assert (p < pend);
-
- switch (SWITCH_ENUM_CAST ((re_opcode_t) *p++))
- {
-
- /* I guess the idea here is to simply not bother with a fastmap
- if a backreference is used, since it's too hard to figure out
- the fastmap for the corresponding group. Setting
- `can_be_null' stops `re_search_2' from using the fastmap, so
- that is all we do. */
- case duplicate:
- bufp->can_be_null = 1;
- goto done;
-
-
- /* Following are the cases which match a character. These end
- with `break'. */
-
- case exactn:
- fastmap[p[1]] = 1;
- break;
-
-
- case charset:
- for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--)
- if (p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH)))
- fastmap[j] = 1;
- break;
-
-
- case charset_not:
- /* Chars beyond end of map must be allowed. */
- for (j = *p * BYTEWIDTH; j < (1 << BYTEWIDTH); j++)
- fastmap[j] = 1;
-
- for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--)
- if (!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))))
- fastmap[j] = 1;
- break;
-
-
- case wordchar:
- for (j = 0; j < (1 << BYTEWIDTH); j++)
- if (SYNTAX (j) == Sword)
- fastmap[j] = 1;
- break;
-
-
- case notwordchar:
- for (j = 0; j < (1 << BYTEWIDTH); j++)
- if (SYNTAX (j) != Sword)
- fastmap[j] = 1;
- break;
-
-
- case anychar:
- {
- int fastmap_newline = fastmap['\n'];
-
- /* `.' matches anything ... */
- for (j = 0; j < (1 << BYTEWIDTH); j++)
- fastmap[j] = 1;
-
- /* ... except perhaps newline. */
- if (!(bufp->syntax & RE_DOT_NEWLINE))
- fastmap['\n'] = fastmap_newline;
-
- /* Return if we have already set `can_be_null'; if we have,
- then the fastmap is irrelevant. Something's wrong here. */
- else if (bufp->can_be_null)
- goto done;
-
- /* Otherwise, have to check alternative paths. */
- break;
- }
-
-#ifdef emacs
- case syntaxspec:
- k = *p++;
- for (j = 0; j < (1 << BYTEWIDTH); j++)
- if (SYNTAX (j) == (enum syntaxcode) k)
- fastmap[j] = 1;
- break;
-
-
- case notsyntaxspec:
- k = *p++;
- for (j = 0; j < (1 << BYTEWIDTH); j++)
- if (SYNTAX (j) != (enum syntaxcode) k)
- fastmap[j] = 1;
- break;
-
-
- /* All cases after this match the empty string. These end with
- `continue'. */
-
-
- case before_dot:
- case at_dot:
- case after_dot:
- continue;
-#endif /* emacs */
-
-
- case no_op:
- case begline:
- case endline:
- case begbuf:
- case endbuf:
- case wordbound:
- case notwordbound:
- case wordbeg:
- case wordend:
- case push_dummy_failure:
- continue;
-
-
- case jump_n:
- case pop_failure_jump:
- case maybe_pop_jump:
- case jump:
- case jump_past_alt:
- case dummy_failure_jump:
- EXTRACT_NUMBER_AND_INCR (j, p);
- p += j;
- if (j > 0)
- continue;
-
- /* Jump backward implies we just went through the body of a
- loop and matched nothing. Opcode jumped to should be
- `on_failure_jump' or `succeed_n'. Just treat it like an
- ordinary jump. For a * loop, it has pushed its failure
- point already; if so, discard that as redundant. */
- if ((re_opcode_t) *p != on_failure_jump
- && (re_opcode_t) *p != succeed_n)
- continue;
-
- p++;
- EXTRACT_NUMBER_AND_INCR (j, p);
- p += j;
-
- /* If what's on the stack is where we are now, pop it. */
- if (!FAIL_STACK_EMPTY ()
- && fail_stack.stack[fail_stack.avail - 1].pointer == p)
- fail_stack.avail--;
-
- continue;
-
-
- case on_failure_jump:
- case on_failure_keep_string_jump:
- handle_on_failure_jump:
- EXTRACT_NUMBER_AND_INCR (j, p);
-
- /* For some patterns, e.g., `(a?)?', `p+j' here points to the
- end of the pattern. We don't want to push such a point,
- since when we restore it above, entering the switch will
- increment `p' past the end of the pattern. We don't need
- to push such a point since we obviously won't find any more
- fastmap entries beyond `pend'. Such a pattern can match
- the null string, though. */
- if (p + j < pend)
- {
- if (!PUSH_PATTERN_OP (p + j, fail_stack))
- {
- RESET_FAIL_STACK ();
- return -2;
- }
- }
- else
- bufp->can_be_null = 1;
-
- if (succeed_n_p)
- {
- EXTRACT_NUMBER_AND_INCR (k, p); /* Skip the n. */
- succeed_n_p = false;
- }
-
- continue;
-
-
- case succeed_n:
- /* Get to the number of times to succeed. */
- p += 2;
-
- /* Increment p past the n for when k != 0. */
- EXTRACT_NUMBER_AND_INCR (k, p);
- if (k == 0)
- {
- p -= 4;
- succeed_n_p = true; /* Spaghetti code alert. */
- goto handle_on_failure_jump;
- }
- continue;
-
-
- case set_number_at:
- p += 4;
- continue;
-
-
- case start_memory:
- case stop_memory:
- p += 2;
- continue;
-
-
- default:
- abort (); /* We have listed all the cases. */
- } /* switch *p++ */
-
- /* Getting here means we have found the possible starting
- characters for one path of the pattern -- and that the empty
- string does not match. We need not follow this path further.
- Instead, look at the next alternative (remembered on the
- stack), or quit if no more. The test at the top of the loop
- does these things. */
- path_can_be_null = false;
- p = pend;
- } /* while p */
-
- /* Set `can_be_null' for the last path (also the first path, if the
- pattern is empty). */
- bufp->can_be_null |= path_can_be_null;
-
- done:
- RESET_FAIL_STACK ();
- return 0;
-} /* re_compile_fastmap */
-\f
-/* Set REGS to hold NUM_REGS registers, storing them in STARTS and
- ENDS. Subsequent matches using PATTERN_BUFFER and REGS will use
- this memory for recording register information. STARTS and ENDS
- must be allocated using the malloc library routine, and must each
- be at least NUM_REGS * sizeof (regoff_t) bytes long.
-
- If NUM_REGS == 0, then subsequent matches should allocate their own
- register data.
-
- Unless this function is called, the first search or match using
- PATTERN_BUFFER will allocate its own register data, without
- freeing the old data. */
-
-void
-re_set_registers (bufp, regs, num_regs, starts, ends)
- struct re_pattern_buffer *bufp;
- struct re_registers *regs;
- unsigned num_regs;
- regoff_t *starts, *ends;
-{
- if (num_regs)
- {
- bufp->regs_allocated = REGS_REALLOCATE;
- regs->num_regs = num_regs;
- regs->start = starts;
- regs->end = ends;
- }
- else
- {
- bufp->regs_allocated = REGS_UNALLOCATED;
- regs->num_regs = 0;
- regs->start = regs->end = (regoff_t *) 0;
- }
-}
-\f
-/* Searching routines. */
-
-/* Like re_search_2, below, but only one string is specified, and
- doesn't let you say where to stop matching. */
-
-int
-re_search (bufp, string, size, startpos, range, regs)
- struct re_pattern_buffer *bufp;
- const char *string;
- int size, startpos, range;
- struct re_registers *regs;
-{
- return re_search_2 (bufp, NULL, 0, string, size, startpos, range,
- regs, size);
-}
-
-
-/* Using the compiled pattern in BUFP->buffer, first tries to match the
- virtual concatenation of STRING1 and STRING2, starting first at index
- STARTPOS, then at STARTPOS + 1, and so on.
-
- STRING1 and STRING2 have length SIZE1 and SIZE2, respectively.
-
- RANGE is how far to scan while trying to match. RANGE = 0 means try
- only at STARTPOS; in general, the last start tried is STARTPOS +
- RANGE.
-
- In REGS, return the indices of the virtual concatenation of STRING1
- and STRING2 that matched the entire BUFP->buffer and its contained
- subexpressions.
-
- Do not consider matching one past the index STOP in the virtual
- concatenation of STRING1 and STRING2.
-
- We return either the position in the strings at which the match was
- found, -1 if no match, or -2 if error (such as failure
- stack overflow). */
-
-int
-re_search_2 (bufp, string1, size1, string2, size2, startpos, range, regs, stop)
- struct re_pattern_buffer *bufp;
- const char *string1, *string2;
- int size1, size2;
- int startpos;
- int range;
- struct re_registers *regs;
- int stop;
-{
- int val;
- register char *fastmap = bufp->fastmap;
- register RE_TRANSLATE_TYPE translate = bufp->translate;
- int total_size = size1 + size2;
- int endpos = startpos + range;
-
- /* Check for out-of-range STARTPOS. */
- if (startpos < 0 || startpos > total_size)
- return -1;
-
- /* Fix up RANGE if it might eventually take us outside
- the virtual concatenation of STRING1 and STRING2.
- Make sure we won't move STARTPOS below 0 or above TOTAL_SIZE. */
- if (endpos < 0)
- range = 0 - startpos;
- else if (endpos > total_size)
- range = total_size - startpos;
-
- /* If the search isn't to be a backwards one, don't waste time in a
- search for a pattern that must be anchored. */
- if (bufp->used > 0 && (re_opcode_t) bufp->buffer[0] == begbuf && range > 0)
- {
- if (startpos > 0)
- return -1;
- else
- range = 1;
- }
-
-#ifdef emacs
- /* In a forward search for something that starts with \=.
- don't keep searching past point. */
- if (bufp->used > 0 && (re_opcode_t) bufp->buffer[0] == at_dot && range > 0)
- {
- range = PT - startpos;
- if (range <= 0)
- return -1;
- }
-#endif /* emacs */
-
- /* Update the fastmap now if not correct already. */
- if (fastmap && !bufp->fastmap_accurate)
- if (re_compile_fastmap (bufp) == -2)
- return -2;
-
- /* Loop through the string, looking for a place to start matching. */
- for (;;)
- {
- /* If a fastmap is supplied, skip quickly over characters that
- cannot be the start of a match. If the pattern can match the
- null string, however, we don't need to skip characters; we want
- the first null string. */
- if (fastmap && startpos < total_size && !bufp->can_be_null)
- {
- if (range > 0) /* Searching forwards. */
- {
- register const char *d;
- register int lim = 0;
- int irange = range;
-
- if (startpos < size1 && startpos + range >= size1)
- lim = range - (size1 - startpos);
-
- d = (startpos >= size1 ? string2 - size1 : string1) + startpos;
-
- /* Written out as an if-else to avoid testing `translate'
- inside the loop. */
- if (translate)
- while (range > lim
- && !fastmap[(unsigned char)
- translate[(unsigned char) *d++]])
- range--;
- else
- while (range > lim && !fastmap[(unsigned char) *d++])
- range--;
-
- startpos += irange - range;
- }
- else /* Searching backwards. */
- {
- register char c = (size1 == 0 || startpos >= size1
- ? string2[startpos - size1]
- : string1[startpos]);
-
- if (!fastmap[(unsigned char) TRANSLATE (c)])
- goto advance;
- }
- }
-
- /* If can't match the null string, and that's all we have left, fail. */
- if (range >= 0 && startpos == total_size && fastmap
- && !bufp->can_be_null)
- return -1;
-
- val = re_match_2_internal (bufp, string1, size1, string2, size2,
- startpos, regs, stop);
-#ifndef REGEX_MALLOC
-#ifdef C_ALLOCA
- alloca (0);
-#endif
-#endif
-
- if (val >= 0)
- return startpos;
-
- if (val == -2)
- return -2;
-
- advance:
- if (!range)
- break;
- else if (range > 0)
- {
- range--;
- startpos++;
- }
- else
- {
- range++;
- startpos--;
- }
- }
- return -1;
-} /* re_search_2 */
-\f
-/* This converts PTR, a pointer into one of the search strings `string1'
- and `string2' into an offset from the beginning of that string. */
-#define POINTER_TO_OFFSET(ptr) \
- (FIRST_STRING_P (ptr) \
- ? ((regoff_t) ((ptr) - string1)) \
- : ((regoff_t) ((ptr) - string2 + size1)))
-
-/* Macros for dealing with the split strings in re_match_2. */
-
-#define MATCHING_IN_FIRST_STRING (dend == end_match_1)
-
-/* Call before fetching a character with *d. This switches over to
- string2 if necessary. */
-#define PREFETCH() \
- while (d == dend) \
- { \
- /* End of string2 => fail. */ \
- if (dend == end_match_2) \
- goto fail; \
- /* End of string1 => advance to string2. */ \
- d = string2; \
- dend = end_match_2; \
- }
-
-
-/* Test if at very beginning or at very end of the virtual concatenation
- of `string1' and `string2'. If only one string, it's `string2'. */
-#define AT_STRINGS_BEG(d) ((d) == (size1 ? string1 : string2) || !size2)
-#define AT_STRINGS_END(d) ((d) == end2)
-
-
-/* Test if D points to a character which is word-constituent. We have
- two special cases to check for: if past the end of string1, look at
- the first character in string2; and if before the beginning of
- string2, look at the last character in string1. */
-#define WORDCHAR_P(d) \
- (SYNTAX ((d) == end1 ? *string2 \
- : (d) == string2 - 1 ? *(end1 - 1) : *(d)) \
- == Sword)
-
-/* Disabled due to a compiler bug -- see comment at case wordbound */
-#if 0
-/* Test if the character before D and the one at D differ with respect
- to being word-constituent. */
-#define AT_WORD_BOUNDARY(d) \
- (AT_STRINGS_BEG (d) || AT_STRINGS_END (d) \
- || WORDCHAR_P (d - 1) != WORDCHAR_P (d))
-#endif
-
-/* Free everything we malloc. */
-#ifdef MATCH_MAY_ALLOCATE
-#define FREE_VAR(var) if (var) REGEX_FREE (var); var = NULL
-#define FREE_VARIABLES() \
- do { \
- REGEX_FREE_STACK (fail_stack.stack); \
- FREE_VAR (regstart); \
- FREE_VAR (regend); \
- FREE_VAR (old_regstart); \
- FREE_VAR (old_regend); \
- FREE_VAR (best_regstart); \
- FREE_VAR (best_regend); \
- FREE_VAR (reg_info); \
- FREE_VAR (reg_dummy); \
- FREE_VAR (reg_info_dummy); \
- } while (0)
-#else
-#define FREE_VARIABLES() ((void)0) /* Do nothing! But inhibit gcc warning. */
-#endif /* not MATCH_MAY_ALLOCATE */
-
-/* These values must meet several constraints. They must not be valid
- register values; since we have a limit of 255 registers (because
- we use only one byte in the pattern for the register number), we can
- use numbers larger than 255. They must differ by 1, because of
- NUM_FAILURE_ITEMS above. And the value for the lowest register must
- be larger than the value for the highest register, so we do not try
- to actually save any registers when none are active. */
-#define NO_HIGHEST_ACTIVE_REG (1 << BYTEWIDTH)
-#define NO_LOWEST_ACTIVE_REG (NO_HIGHEST_ACTIVE_REG + 1)
-\f
-/* Matching routines. */
-
-#ifndef emacs /* Emacs never uses this. */
-/* re_match is like re_match_2 except it takes only a single string. */
-
-int
-re_match (bufp, string, size, pos, regs)
- struct re_pattern_buffer *bufp;
- const char *string;
- int size, pos;
- struct re_registers *regs;
-{
- int result = re_match_2_internal (bufp, NULL, 0, string, size,
- pos, regs, size);
-#ifndef REGEX_MALLOC
-#ifdef C_ALLOCA
- alloca (0);
-#endif
-#endif
- return result;
-}
-#endif /* not emacs */
-
-static boolean group_match_null_string_p _RE_ARGS ((unsigned char **p,
- unsigned char *end,
- register_info_type *reg_info));
-static boolean alt_match_null_string_p _RE_ARGS ((unsigned char *p,
- unsigned char *end,
- register_info_type *reg_info));
-static boolean common_op_match_null_string_p _RE_ARGS ((unsigned char **p,
- unsigned char *end,
- register_info_type *reg_info));
-static int bcmp_translate _RE_ARGS ((const char *s1, const char *s2,
- int len, char *translate));
-
-/* re_match_2 matches the compiled pattern in BUFP against the
- the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1
- and SIZE2, respectively). We start matching at POS, and stop
- matching at STOP.
-
- If REGS is non-null and the `no_sub' field of BUFP is nonzero, we
- store offsets for the substring each group matched in REGS. See the
- documentation for exactly how many groups we fill.
-
- We return -1 if no match, -2 if an internal error (such as the
- failure stack overflowing). Otherwise, we return the length of the
- matched substring. */
-
-int
-re_match_2 (bufp, string1, size1, string2, size2, pos, regs, stop)
- struct re_pattern_buffer *bufp;
- const char *string1, *string2;
- int size1, size2;
- int pos;
- struct re_registers *regs;
- int stop;
-{
- int result = re_match_2_internal (bufp, string1, size1, string2, size2,
- pos, regs, stop);
-#ifndef REGEX_MALLOC
-#ifdef C_ALLOCA
- alloca (0);
-#endif
-#endif
- return result;
-}
-
-/* This is a separate function so that we can force an alloca cleanup
- afterwards. */
-static int
-re_match_2_internal (bufp, string1, size1, string2, size2, pos, regs, stop)
- struct re_pattern_buffer *bufp;
- const char *string1, *string2;
- int size1, size2;
- int pos;
- struct re_registers *regs;
- int stop;
-{
- /* General temporaries. */
- int mcnt;
- unsigned char *p1;
-
- /* Just past the end of the corresponding string. */
- const char *end1, *end2;
-
- /* Pointers into string1 and string2, just past the last characters in
- each to consider matching. */
- const char *end_match_1, *end_match_2;
-
- /* Where we are in the data, and the end of the current string. */
- const char *d, *dend;
-
- /* Where we are in the pattern, and the end of the pattern. */
- unsigned char *p = bufp->buffer;
- register unsigned char *pend = p + bufp->used;
-
- /* Mark the opcode just after a start_memory, so we can test for an
- empty subpattern when we get to the stop_memory. */
- unsigned char *just_past_start_mem = 0;
-
- /* We use this to map every character in the string. */
- RE_TRANSLATE_TYPE translate = bufp->translate;
-
- /* Failure point stack. Each place that can handle a failure further
- down the line pushes a failure point on this stack. It consists of
- restart, regend, and reg_info for all registers corresponding to
- the subexpressions we're currently inside, plus the number of such
- registers, and, finally, two char *'s. The first char * is where
- to resume scanning the pattern; the second one is where to resume
- scanning the strings. If the latter is zero, the failure point is
- a ``dummy''; if a failure happens and the failure point is a dummy,
- it gets discarded and the next next one is tried. */
-#ifdef MATCH_MAY_ALLOCATE /* otherwise, this is global. */
- fail_stack_type fail_stack;
-#endif
-#ifdef DEBUG
- static unsigned failure_id = 0;
- unsigned nfailure_points_pushed = 0, nfailure_points_popped = 0;
-#endif
-
-#ifdef REL_ALLOC
- /* This holds the pointer to the failure stack, when
- it is allocated relocatably. */
- fail_stack_elt_t *failure_stack_ptr;
-#endif
-
- /* We fill all the registers internally, independent of what we
- return, for use in backreferences. The number here includes
- an element for register zero. */
- size_t num_regs = bufp->re_nsub + 1;
-
- /* The currently active registers. */
- active_reg_t lowest_active_reg = NO_LOWEST_ACTIVE_REG;
- active_reg_t highest_active_reg = NO_HIGHEST_ACTIVE_REG;
-
- /* Information on the contents of registers. These are pointers into
- the input strings; they record just what was matched (on this
- attempt) by a subexpression part of the pattern, that is, the
- regnum-th regstart pointer points to where in the pattern we began
- matching and the regnum-th regend points to right after where we
- stopped matching the regnum-th subexpression. (The zeroth register
- keeps track of what the whole pattern matches.) */
-#ifdef MATCH_MAY_ALLOCATE /* otherwise, these are global. */
- const char **regstart, **regend;
-#endif
-
- /* If a group that's operated upon by a repetition operator fails to
- match anything, then the register for its start will need to be
- restored because it will have been set to wherever in the string we
- are when we last see its open-group operator. Similarly for a
- register's end. */
-#ifdef MATCH_MAY_ALLOCATE /* otherwise, these are global. */
- const char **old_regstart, **old_regend;
-#endif
-
- /* The is_active field of reg_info helps us keep track of which (possibly
- nested) subexpressions we are currently in. The matched_something
- field of reg_info[reg_num] helps us tell whether or not we have
- matched any of the pattern so far this time through the reg_num-th
- subexpression. These two fields get reset each time through any
- loop their register is in. */
-#ifdef MATCH_MAY_ALLOCATE /* otherwise, this is global. */
- register_info_type *reg_info;
-#endif
-
- /* The following record the register info as found in the above
- variables when we find a match better than any we've seen before.
- This happens as we backtrack through the failure points, which in
- turn happens only if we have not yet matched the entire string. */
- unsigned best_regs_set = false;
-#ifdef MATCH_MAY_ALLOCATE /* otherwise, these are global. */
- const char **best_regstart, **best_regend;
-#endif
-
- /* Logically, this is `best_regend[0]'. But we don't want to have to
- allocate space for that if we're not allocating space for anything
- else (see below). Also, we never need info about register 0 for
- any of the other register vectors, and it seems rather a kludge to
- treat `best_regend' differently than the rest. So we keep track of
- the end of the best match so far in a separate variable. We
- initialize this to NULL so that when we backtrack the first time
- and need to test it, it's not garbage. */
- const char *match_end = NULL;
-
- /* This helps SET_REGS_MATCHED avoid doing redundant work. */
- int set_regs_matched_done = 0;
-
- /* Used when we pop values we don't care about. */
-#ifdef MATCH_MAY_ALLOCATE /* otherwise, these are global. */
- const char **reg_dummy;
- register_info_type *reg_info_dummy;
-#endif
-
-#ifdef DEBUG
- /* Counts the total number of registers pushed. */
- unsigned num_regs_pushed = 0;
-#endif
-
- DEBUG_PRINT1 ("\n\nEntering re_match_2.\n");
-
- INIT_FAIL_STACK ();
-
-#ifdef MATCH_MAY_ALLOCATE
- /* Do not bother to initialize all the register variables if there are
- no groups in the pattern, as it takes a fair amount of time. If
- there are groups, we include space for register 0 (the whole
- pattern), even though we never use it, since it simplifies the
- array indexing. We should fix this. */
- if (bufp->re_nsub)
- {
- regstart = REGEX_TALLOC (num_regs, const char *);
- regend = REGEX_TALLOC (num_regs, const char *);
- old_regstart = REGEX_TALLOC (num_regs, const char *);
- old_regend = REGEX_TALLOC (num_regs, const char *);
- best_regstart = REGEX_TALLOC (num_regs, const char *);
- best_regend = REGEX_TALLOC (num_regs, const char *);
- reg_info = REGEX_TALLOC (num_regs, register_info_type);
- reg_dummy = REGEX_TALLOC (num_regs, const char *);
- reg_info_dummy = REGEX_TALLOC (num_regs, register_info_type);
-
- if (!(regstart && regend && old_regstart && old_regend && reg_info
- && best_regstart && best_regend && reg_dummy && reg_info_dummy))
- {
- FREE_VARIABLES ();
- return -2;
- }
- }
- else
- {
- /* We must initialize all our variables to NULL, so that
- `FREE_VARIABLES' doesn't try to free them. */
- regstart = regend = old_regstart = old_regend = best_regstart
- = best_regend = reg_dummy = NULL;
- reg_info = reg_info_dummy = (register_info_type *) NULL;
- }
-#endif /* MATCH_MAY_ALLOCATE */
-
- /* The starting position is bogus. */
- if (pos < 0 || pos > size1 + size2)
- {
- FREE_VARIABLES ();
- return -1;
- }
-
- /* Initialize subexpression text positions to -1 to mark ones that no
- start_memory/stop_memory has been seen for. Also initialize the
- register information struct. */
- for (mcnt = 1; (unsigned) mcnt < num_regs; mcnt++)
- {
- regstart[mcnt] = regend[mcnt]
- = old_regstart[mcnt] = old_regend[mcnt] = REG_UNSET_VALUE;
-
- REG_MATCH_NULL_STRING_P (reg_info[mcnt]) = MATCH_NULL_UNSET_VALUE;
- IS_ACTIVE (reg_info[mcnt]) = 0;
- MATCHED_SOMETHING (reg_info[mcnt]) = 0;
- EVER_MATCHED_SOMETHING (reg_info[mcnt]) = 0;
- }
-
- /* We move `string1' into `string2' if the latter's empty -- but not if
- `string1' is null. */
- if (size2 == 0 && string1 != NULL)
- {
- string2 = string1;
- size2 = size1;
- string1 = 0;
- size1 = 0;
- }
- end1 = string1 + size1;
- end2 = string2 + size2;
-
- /* Compute where to stop matching, within the two strings. */
- if (stop <= size1)
- {
- end_match_1 = string1 + stop;
- end_match_2 = string2;
- }
- else
- {
- end_match_1 = end1;
- end_match_2 = string2 + stop - size1;
- }
-
- /* `p' scans through the pattern as `d' scans through the data.
- `dend' is the end of the input string that `d' points within. `d'
- is advanced into the following input string whenever necessary, but
- this happens before fetching; therefore, at the beginning of the
- loop, `d' can be pointing at the end of a string, but it cannot
- equal `string2'. */
- if (size1 > 0 && pos <= size1)
- {
- d = string1 + pos;
- dend = end_match_1;
- }
- else
- {
- d = string2 + pos - size1;
- dend = end_match_2;
- }
-
- DEBUG_PRINT1 ("The compiled pattern is:\n");
- DEBUG_PRINT_COMPILED_PATTERN (bufp, p, pend);
- DEBUG_PRINT1 ("The string to match is: `");
- DEBUG_PRINT_DOUBLE_STRING (d, string1, size1, string2, size2);
- DEBUG_PRINT1 ("'\n");
-
- /* This loops over pattern commands. It exits by returning from the
- function if the match is complete, or it drops through if the match
- fails at this starting point in the input data. */
- for (;;)
- {
-#ifdef _LIBC
- DEBUG_PRINT2 ("\n%p: ", p);
-#else
- DEBUG_PRINT2 ("\n0x%x: ", p);
-#endif
-
- if (p == pend)
- { /* End of pattern means we might have succeeded. */
- DEBUG_PRINT1 ("end of pattern ... ");
-
- /* If we haven't matched the entire string, and we want the
- longest match, try backtracking. */
- if (d != end_match_2)
- {
- /* 1 if this match ends in the same string (string1 or string2)
- as the best previous match. */
- boolean same_str_p = (FIRST_STRING_P (match_end)
- == MATCHING_IN_FIRST_STRING);
- /* 1 if this match is the best seen so far. */
- boolean best_match_p;
-
- /* AIX compiler got confused when this was combined
- with the previous declaration. */
- if (same_str_p)
- best_match_p = d > match_end;
- else
- best_match_p = !MATCHING_IN_FIRST_STRING;
-
- DEBUG_PRINT1 ("backtracking.\n");
-
- if (!FAIL_STACK_EMPTY ())
- { /* More failure points to try. */
-
- /* If exceeds best match so far, save it. */
- if (!best_regs_set || best_match_p)
- {
- best_regs_set = true;
- match_end = d;
-
- DEBUG_PRINT1 ("\nSAVING match as best so far.\n");
-
- for (mcnt = 1; (unsigned) mcnt < num_regs; mcnt++)
- {
- best_regstart[mcnt] = regstart[mcnt];
- best_regend[mcnt] = regend[mcnt];
- }
- }
- goto fail;
- }
-
- /* If no failure points, don't restore garbage. And if
- last match is real best match, don't restore second
- best one. */
- else if (best_regs_set && !best_match_p)
- {
- restore_best_regs:
- /* Restore best match. It may happen that `dend ==
- end_match_1' while the restored d is in string2.
- For example, the pattern `x.*y.*z' against the
- strings `x-' and `y-z-', if the two strings are
- not consecutive in memory. */
- DEBUG_PRINT1 ("Restoring best registers.\n");
-
- d = match_end;
- dend = ((d >= string1 && d <= end1)
- ? end_match_1 : end_match_2);
-
- for (mcnt = 1; (unsigned) mcnt < num_regs; mcnt++)
- {
- regstart[mcnt] = best_regstart[mcnt];
- regend[mcnt] = best_regend[mcnt];
- }
- }
- } /* d != end_match_2 */
-
- succeed_label:
- DEBUG_PRINT1 ("Accepting match.\n");
-
- /* If caller wants register contents data back, do it. */
- if (regs && !bufp->no_sub)
- {
- /* Have the register data arrays been allocated? */
- if (bufp->regs_allocated == REGS_UNALLOCATED)
- { /* No. So allocate them with malloc. We need one
- extra element beyond `num_regs' for the `-1' marker
- GNU code uses. */
- regs->num_regs = MAX (RE_NREGS, num_regs + 1);
- regs->start = TALLOC (regs->num_regs, regoff_t);
- regs->end = TALLOC (regs->num_regs, regoff_t);
- if (regs->start == NULL || regs->end == NULL)
- {
- FREE_VARIABLES ();
- return -2;
- }
- bufp->regs_allocated = REGS_REALLOCATE;
- }
- else if (bufp->regs_allocated == REGS_REALLOCATE)
- { /* Yes. If we need more elements than were already
- allocated, reallocate them. If we need fewer, just
- leave it alone. */
- if (regs->num_regs < num_regs + 1)
- {
- regs->num_regs = num_regs + 1;
- RETALLOC (regs->start, regs->num_regs, regoff_t);
- RETALLOC (regs->end, regs->num_regs, regoff_t);
- if (regs->start == NULL || regs->end == NULL)
- {
- FREE_VARIABLES ();
- return -2;
- }
- }
- }
- else
- {
- /* These braces fend off a "empty body in an else-statement"
- warning under GCC when assert expands to nothing. */
- assert (bufp->regs_allocated == REGS_FIXED);
- }
-
- /* Convert the pointer data in `regstart' and `regend' to
- indices. Register zero has to be set differently,
- since we haven't kept track of any info for it. */
- if (regs->num_regs > 0)
- {
- regs->start[0] = pos;
- regs->end[0] = (MATCHING_IN_FIRST_STRING
- ? ((regoff_t) (d - string1))
- : ((regoff_t) (d - string2 + size1)));
- }
-
- /* Go through the first `min (num_regs, regs->num_regs)'
- registers, since that is all we initialized. */
- for (mcnt = 1; (unsigned) mcnt < MIN (num_regs, regs->num_regs);
- mcnt++)
- {
- if (REG_UNSET (regstart[mcnt]) || REG_UNSET (regend[mcnt]))
- regs->start[mcnt] = regs->end[mcnt] = -1;
- else
- {
- regs->start[mcnt]
- = (regoff_t) POINTER_TO_OFFSET (regstart[mcnt]);
- regs->end[mcnt]
- = (regoff_t) POINTER_TO_OFFSET (regend[mcnt]);
- }
- }
-
- /* If the regs structure we return has more elements than
- were in the pattern, set the extra elements to -1. If
- we (re)allocated the registers, this is the case,
- because we always allocate enough to have at least one
- -1 at the end. */
- for (mcnt = num_regs; (unsigned) mcnt < regs->num_regs; mcnt++)
- regs->start[mcnt] = regs->end[mcnt] = -1;
- } /* regs && !bufp->no_sub */
-
- DEBUG_PRINT4 ("%u failure points pushed, %u popped (%u remain).\n",
- nfailure_points_pushed, nfailure_points_popped,
- nfailure_points_pushed - nfailure_points_popped);
- DEBUG_PRINT2 ("%u registers pushed.\n", num_regs_pushed);
-
- mcnt = d - pos - (MATCHING_IN_FIRST_STRING
- ? string1
- : string2 - size1);
-
- DEBUG_PRINT2 ("Returning %d from re_match_2.\n", mcnt);
-
- FREE_VARIABLES ();
- return mcnt;
- }
-
- /* Otherwise match next pattern command. */
- switch (SWITCH_ENUM_CAST ((re_opcode_t) *p++))
- {
- /* Ignore these. Used to ignore the n of succeed_n's which
- currently have n == 0. */
- case no_op:
- DEBUG_PRINT1 ("EXECUTING no_op.\n");
- break;
-
- case succeed:
- DEBUG_PRINT1 ("EXECUTING succeed.\n");
- goto succeed_label;
-
- /* Match the next n pattern characters exactly. The following
- byte in the pattern defines n, and the n bytes after that
- are the characters to match. */
- case exactn:
- mcnt = *p++;
- DEBUG_PRINT2 ("EXECUTING exactn %d.\n", mcnt);
-
- /* This is written out as an if-else so we don't waste time
- testing `translate' inside the loop. */
- if (translate)
- {
- do
- {
- PREFETCH ();
- if ((unsigned char) translate[(unsigned char) *d++]
- != (unsigned char) *p++)
- goto fail;
- }
- while (--mcnt);
- }
- else
- {
- do
- {
- PREFETCH ();
- if (*d++ != (char) *p++) goto fail;
- }
- while (--mcnt);
- }
- SET_REGS_MATCHED ();
- break;
-
-
- /* Match any character except possibly a newline or a null. */
- case anychar:
- DEBUG_PRINT1 ("EXECUTING anychar.\n");
-
- PREFETCH ();
-
- if ((!(bufp->syntax & RE_DOT_NEWLINE) && TRANSLATE (*d) == '\n')
- || (bufp->syntax & RE_DOT_NOT_NULL && TRANSLATE (*d) == '\000'))
- goto fail;
-
- SET_REGS_MATCHED ();
- DEBUG_PRINT2 (" Matched `%d'.\n", *d);
- d++;
- break;
-
-
- case charset:
- case charset_not:
- {
- register unsigned char c;
- boolean not = (re_opcode_t) *(p - 1) == charset_not;
-
- DEBUG_PRINT2 ("EXECUTING charset%s.\n", not ? "_not" : "");
-
- PREFETCH ();
- c = TRANSLATE (*d); /* The character to match. */
-
- /* Cast to `unsigned' instead of `unsigned char' in case the
- bit list is a full 32 bytes long. */
- if (c < (unsigned) (*p * BYTEWIDTH)
- && p[1 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH)))
- not = !not;
-
- p += 1 + *p;
-
- if (!not) goto fail;
-
- SET_REGS_MATCHED ();
- d++;
- break;
- }
-
-
- /* The beginning of a group is represented by start_memory.
- The arguments are the register number in the next byte, and the
- number of groups inner to this one in the next. The text
- matched within the group is recorded (in the internal
- registers data structure) under the register number. */
- case start_memory:
- DEBUG_PRINT3 ("EXECUTING start_memory %d (%d):\n", *p, p[1]);
-
- /* Find out if this group can match the empty string. */
- p1 = p; /* To send to group_match_null_string_p. */
-
- if (REG_MATCH_NULL_STRING_P (reg_info[*p]) == MATCH_NULL_UNSET_VALUE)
- REG_MATCH_NULL_STRING_P (reg_info[*p])
- = group_match_null_string_p (&p1, pend, reg_info);
-
- /* Save the position in the string where we were the last time
- we were at this open-group operator in case the group is
- operated upon by a repetition operator, e.g., with `(a*)*b'
- against `ab'; then we want to ignore where we are now in
- the string in case this attempt to match fails. */
- old_regstart[*p] = REG_MATCH_NULL_STRING_P (reg_info[*p])
- ? REG_UNSET (regstart[*p]) ? d : regstart[*p]
- : regstart[*p];
- DEBUG_PRINT2 (" old_regstart: %d\n",
- POINTER_TO_OFFSET (old_regstart[*p]));
-
- regstart[*p] = d;
- DEBUG_PRINT2 (" regstart: %d\n", POINTER_TO_OFFSET (regstart[*p]));
-
- IS_ACTIVE (reg_info[*p]) = 1;
- MATCHED_SOMETHING (reg_info[*p]) = 0;
-
- /* Clear this whenever we change the register activity status. */
- set_regs_matched_done = 0;
-
- /* This is the new highest active register. */
- highest_active_reg = *p;
-
- /* If nothing was active before, this is the new lowest active
- register. */
- if (lowest_active_reg == NO_LOWEST_ACTIVE_REG)
- lowest_active_reg = *p;
-
- /* Move past the register number and inner group count. */
- p += 2;
- just_past_start_mem = p;
-
- break;
-
-
- /* The stop_memory opcode represents the end of a group. Its
- arguments are the same as start_memory's: the register
- number, and the number of inner groups. */
- case stop_memory:
- DEBUG_PRINT3 ("EXECUTING stop_memory %d (%d):\n", *p, p[1]);
-
- /* We need to save the string position the last time we were at
- this close-group operator in case the group is operated
- upon by a repetition operator, e.g., with `((a*)*(b*)*)*'
- against `aba'; then we want to ignore where we are now in
- the string in case this attempt to match fails. */
- old_regend[*p] = REG_MATCH_NULL_STRING_P (reg_info[*p])
- ? REG_UNSET (regend[*p]) ? d : regend[*p]
- : regend[*p];
- DEBUG_PRINT2 (" old_regend: %d\n",
- POINTER_TO_OFFSET (old_regend[*p]));
-
- regend[*p] = d;
- DEBUG_PRINT2 (" regend: %d\n", POINTER_TO_OFFSET (regend[*p]));
-
- /* This register isn't active anymore. */
- IS_ACTIVE (reg_info[*p]) = 0;
-
- /* Clear this whenever we change the register activity status. */
- set_regs_matched_done = 0;
-
- /* If this was the only register active, nothing is active
- anymore. */
- if (lowest_active_reg == highest_active_reg)
- {
- lowest_active_reg = NO_LOWEST_ACTIVE_REG;
- highest_active_reg = NO_HIGHEST_ACTIVE_REG;
- }
- else
- { /* We must scan for the new highest active register, since
- it isn't necessarily one less than now: consider
- (a(b)c(d(e)f)g). When group 3 ends, after the f), the
- new highest active register is 1. */
- unsigned char r = *p - 1;
- while (r > 0 && !IS_ACTIVE (reg_info[r]))
- r--;
-
- /* If we end up at register zero, that means that we saved
- the registers as the result of an `on_failure_jump', not
- a `start_memory', and we jumped to past the innermost
- `stop_memory'. For example, in ((.)*) we save
- registers 1 and 2 as a result of the *, but when we pop
- back to the second ), we are at the stop_memory 1.
- Thus, nothing is active. */
- if (r == 0)
- {
- lowest_active_reg = NO_LOWEST_ACTIVE_REG;
- highest_active_reg = NO_HIGHEST_ACTIVE_REG;
- }
- else
- highest_active_reg = r;
- }
-
- /* If just failed to match something this time around with a
- group that's operated on by a repetition operator, try to
- force exit from the ``loop'', and restore the register
- information for this group that we had before trying this
- last match. */
- if ((!MATCHED_SOMETHING (reg_info[*p])
- || just_past_start_mem == p - 1)
- && (p + 2) < pend)
- {
- boolean is_a_jump_n = false;
-
- p1 = p + 2;
- mcnt = 0;
- switch ((re_opcode_t) *p1++)
- {
- case jump_n:
- is_a_jump_n = true;
- case pop_failure_jump:
- case maybe_pop_jump:
- case jump:
- case dummy_failure_jump:
- EXTRACT_NUMBER_AND_INCR (mcnt, p1);
- if (is_a_jump_n)
- p1 += 2;
- break;
-
- default:
- /* do nothing */ ;
- }
- p1 += mcnt;
-
- /* If the next operation is a jump backwards in the pattern
- to an on_failure_jump right before the start_memory
- corresponding to this stop_memory, exit from the loop
- by forcing a failure after pushing on the stack the
- on_failure_jump's jump in the pattern, and d. */
- if (mcnt < 0 && (re_opcode_t) *p1 == on_failure_jump
- && (re_opcode_t) p1[3] == start_memory && p1[4] == *p)
- {
- /* If this group ever matched anything, then restore
- what its registers were before trying this last
- failed match, e.g., with `(a*)*b' against `ab' for
- regstart[1], and, e.g., with `((a*)*(b*)*)*'
- against `aba' for regend[3].
-
- Also restore the registers for inner groups for,
- e.g., `((a*)(b*))*' against `aba' (register 3 would
- otherwise get trashed). */
-
- if (EVER_MATCHED_SOMETHING (reg_info[*p]))
- {
- unsigned r;
-
- EVER_MATCHED_SOMETHING (reg_info[*p]) = 0;
-
- /* Restore this and inner groups' (if any) registers. */
- for (r = *p; r < (unsigned) *p + (unsigned) *(p + 1);
- r++)
- {
- regstart[r] = old_regstart[r];
-
- /* xx why this test? */
- if (old_regend[r] >= regstart[r])
- regend[r] = old_regend[r];
- }
- }
- p1++;
- EXTRACT_NUMBER_AND_INCR (mcnt, p1);
- PUSH_FAILURE_POINT (p1 + mcnt, d, -2);
-
- goto fail;
- }
- }
-
- /* Move past the register number and the inner group count. */
- p += 2;
- break;
-
-
- /* \<digit> has been turned into a `duplicate' command which is
- followed by the numeric value of <digit> as the register number. */
- case duplicate:
- {
- register const char *d2, *dend2;
- int regno = *p++; /* Get which register to match against. */
- DEBUG_PRINT2 ("EXECUTING duplicate %d.\n", regno);
-
- /* Can't back reference a group which we've never matched. */
- if (REG_UNSET (regstart[regno]) || REG_UNSET (regend[regno]))
- goto fail;
-
- /* Where in input to try to start matching. */
- d2 = regstart[regno];
-
- /* Where to stop matching; if both the place to start and
- the place to stop matching are in the same string, then
- set to the place to stop, otherwise, for now have to use
- the end of the first string. */
-
- dend2 = ((FIRST_STRING_P (regstart[regno])
- == FIRST_STRING_P (regend[regno]))
- ? regend[regno] : end_match_1);
- for (;;)
- {
- /* If necessary, advance to next segment in register
- contents. */
- while (d2 == dend2)
- {
- if (dend2 == end_match_2) break;
- if (dend2 == regend[regno]) break;
-
- /* End of string1 => advance to string2. */
- d2 = string2;
- dend2 = regend[regno];
- }
- /* At end of register contents => success */
- if (d2 == dend2) break;
-
- /* If necessary, advance to next segment in data. */
- PREFETCH ();
-
- /* How many characters left in this segment to match. */
- mcnt = dend - d;
-
- /* Want how many consecutive characters we can match in
- one shot, so, if necessary, adjust the count. */
- if (mcnt > dend2 - d2)
- mcnt = dend2 - d2;
-
- /* Compare that many; failure if mismatch, else move
- past them. */
- if (translate
- ? bcmp_translate (d, d2, mcnt, translate)
- : bcmp (d, d2, mcnt))
- goto fail;
- d += mcnt, d2 += mcnt;
-
- /* Do this because we've match some characters. */
- SET_REGS_MATCHED ();
- }
- }
- break;
-
-
- /* begline matches the empty string at the beginning of the string
- (unless `not_bol' is set in `bufp'), and, if
- `newline_anchor' is set, after newlines. */
- case begline:
- DEBUG_PRINT1 ("EXECUTING begline.\n");
-
- if (AT_STRINGS_BEG (d))
- {
- if (!bufp->not_bol) break;
- }
- else if (d[-1] == '\n' && bufp->newline_anchor)
- {
- break;
- }
- /* In all other cases, we fail. */
- goto fail;
-
-
- /* endline is the dual of begline. */
- case endline:
- DEBUG_PRINT1 ("EXECUTING endline.\n");
-
- if (AT_STRINGS_END (d))
- {
- if (!bufp->not_eol) break;
- }
-
- /* We have to ``prefetch'' the next character. */
- else if ((d == end1 ? *string2 : *d) == '\n'
- && bufp->newline_anchor)
- {
- break;
- }
- goto fail;
-
-
- /* Match at the very beginning of the data. */
- case begbuf:
- DEBUG_PRINT1 ("EXECUTING begbuf.\n");
- if (AT_STRINGS_BEG (d))
- break;
- goto fail;
-
-
- /* Match at the very end of the data. */
- case endbuf:
- DEBUG_PRINT1 ("EXECUTING endbuf.\n");
- if (AT_STRINGS_END (d))
- break;
- goto fail;
-
-
- /* on_failure_keep_string_jump is used to optimize `.*\n'. It
- pushes NULL as the value for the string on the stack. Then
- `pop_failure_point' will keep the current value for the
- string, instead of restoring it. To see why, consider
- matching `foo\nbar' against `.*\n'. The .* matches the foo;
- then the . fails against the \n. But the next thing we want
- to do is match the \n against the \n; if we restored the
- string value, we would be back at the foo.
-
- Because this is used only in specific cases, we don't need to
- check all the things that `on_failure_jump' does, to make
- sure the right things get saved on the stack. Hence we don't
- share its code. The only reason to push anything on the
- stack at all is that otherwise we would have to change
- `anychar's code to do something besides goto fail in this
- case; that seems worse than this. */
- case on_failure_keep_string_jump:
- DEBUG_PRINT1 ("EXECUTING on_failure_keep_string_jump");
-
- EXTRACT_NUMBER_AND_INCR (mcnt, p);
-#ifdef _LIBC
- DEBUG_PRINT3 (" %d (to %p):\n", mcnt, p + mcnt);
-#else
- DEBUG_PRINT3 (" %d (to 0x%x):\n", mcnt, p + mcnt);
-#endif
-
- PUSH_FAILURE_POINT (p + mcnt, NULL, -2);
- break;
-
-
- /* Uses of on_failure_jump:
-
- Each alternative starts with an on_failure_jump that points
- to the beginning of the next alternative. Each alternative
- except the last ends with a jump that in effect jumps past
- the rest of the alternatives. (They really jump to the
- ending jump of the following alternative, because tensioning
- these jumps is a hassle.)
-
- Repeats start with an on_failure_jump that points past both
- the repetition text and either the following jump or
- pop_failure_jump back to this on_failure_jump. */
- case on_failure_jump:
- on_failure:
- DEBUG_PRINT1 ("EXECUTING on_failure_jump");
-
- EXTRACT_NUMBER_AND_INCR (mcnt, p);
-#ifdef _LIBC
- DEBUG_PRINT3 (" %d (to %p)", mcnt, p + mcnt);
-#else
- DEBUG_PRINT3 (" %d (to 0x%x)", mcnt, p + mcnt);
-#endif
-
- /* If this on_failure_jump comes right before a group (i.e.,
- the original * applied to a group), save the information
- for that group and all inner ones, so that if we fail back
- to this point, the group's information will be correct.
- For example, in \(a*\)*\1, we need the preceding group,
- and in \(zz\(a*\)b*\)\2, we need the inner group. */
-
- /* We can't use `p' to check ahead because we push
- a failure point to `p + mcnt' after we do this. */
- p1 = p;
-
- /* We need to skip no_op's before we look for the
- start_memory in case this on_failure_jump is happening as
- the result of a completed succeed_n, as in \(a\)\{1,3\}b\1
- against aba. */
- while (p1 < pend && (re_opcode_t) *p1 == no_op)
- p1++;
-
- if (p1 < pend && (re_opcode_t) *p1 == start_memory)
- {
- /* We have a new highest active register now. This will
- get reset at the start_memory we are about to get to,
- but we will have saved all the registers relevant to
- this repetition op, as described above. */
- highest_active_reg = *(p1 + 1) + *(p1 + 2);
- if (lowest_active_reg == NO_LOWEST_ACTIVE_REG)
- lowest_active_reg = *(p1 + 1);
- }
-
- DEBUG_PRINT1 (":\n");
- PUSH_FAILURE_POINT (p + mcnt, d, -2);
- break;
-
-
- /* A smart repeat ends with `maybe_pop_jump'.
- We change it to either `pop_failure_jump' or `jump'. */
- case maybe_pop_jump:
- EXTRACT_NUMBER_AND_INCR (mcnt, p);
- DEBUG_PRINT2 ("EXECUTING maybe_pop_jump %d.\n", mcnt);
- {
- register unsigned char *p2 = p;
-
- /* Compare the beginning of the repeat with what in the
- pattern follows its end. If we can establish that there
- is nothing that they would both match, i.e., that we
- would have to backtrack because of (as in, e.g., `a*a')
- then we can change to pop_failure_jump, because we'll
- never have to backtrack.
-
- This is not true in the case of alternatives: in
- `(a|ab)*' we do need to backtrack to the `ab' alternative
- (e.g., if the string was `ab'). But instead of trying to
- detect that here, the alternative has put on a dummy
- failure point which is what we will end up popping. */
-
- /* Skip over open/close-group commands.
- If what follows this loop is a ...+ construct,
- look at what begins its body, since we will have to
- match at least one of that. */
- while (1)
- {
- if (p2 + 2 < pend
- && ((re_opcode_t) *p2 == stop_memory
- || (re_opcode_t) *p2 == start_memory))
- p2 += 3;
- else if (p2 + 6 < pend
- && (re_opcode_t) *p2 == dummy_failure_jump)
- p2 += 6;
- else
- break;
- }
-
- p1 = p + mcnt;
- /* p1[0] ... p1[2] are the `on_failure_jump' corresponding
- to the `maybe_finalize_jump' of this case. Examine what
- follows. */
-
- /* If we're at the end of the pattern, we can change. */
- if (p2 == pend)
- {
- /* Consider what happens when matching ":\(.*\)"
- against ":/". I don't really understand this code
- yet. */
- p[-3] = (unsigned char) pop_failure_jump;
- DEBUG_PRINT1
- (" End of pattern: change to `pop_failure_jump'.\n");
- }
-
- else if ((re_opcode_t) *p2 == exactn
- || (bufp->newline_anchor && (re_opcode_t) *p2 == endline))
- {
- register unsigned char c
- = *p2 == (unsigned char) endline ? '\n' : p2[2];
-
- if ((re_opcode_t) p1[3] == exactn && p1[5] != c)
- {
- p[-3] = (unsigned char) pop_failure_jump;
- DEBUG_PRINT3 (" %c != %c => pop_failure_jump.\n",
- c, p1[5]);
- }
-
- else if ((re_opcode_t) p1[3] == charset
- || (re_opcode_t) p1[3] == charset_not)
- {
- int not = (re_opcode_t) p1[3] == charset_not;
-
- if (c < (unsigned char) (p1[4] * BYTEWIDTH)
- && p1[5 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH)))
- not = !not;
-
- /* `not' is equal to 1 if c would match, which means
- that we can't change to pop_failure_jump. */
- if (!not)
- {
- p[-3] = (unsigned char) pop_failure_jump;
- DEBUG_PRINT1 (" No match => pop_failure_jump.\n");
- }
- }
- }
- else if ((re_opcode_t) *p2 == charset)
- {
-#ifdef DEBUG
- register unsigned char c
- = *p2 == (unsigned char) endline ? '\n' : p2[2];
-#endif
-
-#if 0
- if ((re_opcode_t) p1[3] == exactn
- && ! ((int) p2[1] * BYTEWIDTH > (int) p1[5]
- && (p2[2 + p1[5] / BYTEWIDTH]
- & (1 << (p1[5] % BYTEWIDTH)))))
-#else
- if ((re_opcode_t) p1[3] == exactn
- && ! ((int) p2[1] * BYTEWIDTH > (int) p1[4]
- && (p2[2 + p1[4] / BYTEWIDTH]
- & (1 << (p1[4] % BYTEWIDTH)))))
-#endif
- {
- p[-3] = (unsigned char) pop_failure_jump;
- DEBUG_PRINT3 (" %c != %c => pop_failure_jump.\n",
- c, p1[5]);
- }
-
- else if ((re_opcode_t) p1[3] == charset_not)
- {
- int idx;
- /* We win if the charset_not inside the loop
- lists every character listed in the charset after. */
- for (idx = 0; idx < (int) p2[1]; idx++)
- if (! (p2[2 + idx] == 0
- || (idx < (int) p1[4]
- && ((p2[2 + idx] & ~ p1[5 + idx]) == 0))))
- break;
-
- if (idx == p2[1])
- {
- p[-3] = (unsigned char) pop_failure_jump;
- DEBUG_PRINT1 (" No match => pop_failure_jump.\n");
- }
- }
- else if ((re_opcode_t) p1[3] == charset)
- {
- int idx;
- /* We win if the charset inside the loop
- has no overlap with the one after the loop. */
- for (idx = 0;
- idx < (int) p2[1] && idx < (int) p1[4];
- idx++)
- if ((p2[2 + idx] & p1[5 + idx]) != 0)
- break;
-
- if (idx == p2[1] || idx == p1[4])
- {
- p[-3] = (unsigned char) pop_failure_jump;
- DEBUG_PRINT1 (" No match => pop_failure_jump.\n");
- }
- }
- }
- }
- p -= 2; /* Point at relative address again. */
- if ((re_opcode_t) p[-1] != pop_failure_jump)
- {
- p[-1] = (unsigned char) jump;
- DEBUG_PRINT1 (" Match => jump.\n");
- goto unconditional_jump;
- }
- /* Note fall through. */
-
-
- /* The end of a simple repeat has a pop_failure_jump back to
- its matching on_failure_jump, where the latter will push a
- failure point. The pop_failure_jump takes off failure
- points put on by this pop_failure_jump's matching
- on_failure_jump; we got through the pattern to here from the
- matching on_failure_jump, so didn't fail. */
- case pop_failure_jump:
- {
- /* We need to pass separate storage for the lowest and
- highest registers, even though we don't care about the
- actual values. Otherwise, we will restore only one
- register from the stack, since lowest will == highest in
- `pop_failure_point'. */
- active_reg_t dummy_low_reg, dummy_high_reg;
- unsigned char *pdummy;
- const char *sdummy;
-
- DEBUG_PRINT1 ("EXECUTING pop_failure_jump.\n");
- POP_FAILURE_POINT (sdummy, pdummy,
- dummy_low_reg, dummy_high_reg,
- reg_dummy, reg_dummy, reg_info_dummy);
- }
- /* Note fall through. */
-
- unconditional_jump:
-#ifdef _LIBC
- DEBUG_PRINT2 ("\n%p: ", p);
-#else
- DEBUG_PRINT2 ("\n0x%x: ", p);
-#endif
- /* Note fall through. */
-
- /* Unconditionally jump (without popping any failure points). */
- case jump:
- EXTRACT_NUMBER_AND_INCR (mcnt, p); /* Get the amount to jump. */
- DEBUG_PRINT2 ("EXECUTING jump %d ", mcnt);
- p += mcnt; /* Do the jump. */
-#ifdef _LIBC
- DEBUG_PRINT2 ("(to %p).\n", p);
-#else
- DEBUG_PRINT2 ("(to 0x%x).\n", p);
-#endif
- break;
-
-
- /* We need this opcode so we can detect where alternatives end
- in `group_match_null_string_p' et al. */
- case jump_past_alt:
- DEBUG_PRINT1 ("EXECUTING jump_past_alt.\n");
- goto unconditional_jump;
-
-
- /* Normally, the on_failure_jump pushes a failure point, which
- then gets popped at pop_failure_jump. We will end up at
- pop_failure_jump, also, and with a pattern of, say, `a+', we
- are skipping over the on_failure_jump, so we have to push
- something meaningless for pop_failure_jump to pop. */
- case dummy_failure_jump:
- DEBUG_PRINT1 ("EXECUTING dummy_failure_jump.\n");
- /* It doesn't matter what we push for the string here. What
- the code at `fail' tests is the value for the pattern. */
- PUSH_FAILURE_POINT (0, 0, -2);
- goto unconditional_jump;
-
-
- /* At the end of an alternative, we need to push a dummy failure
- point in case we are followed by a `pop_failure_jump', because
- we don't want the failure point for the alternative to be
- popped. For example, matching `(a|ab)*' against `aab'
- requires that we match the `ab' alternative. */
- case push_dummy_failure:
- DEBUG_PRINT1 ("EXECUTING push_dummy_failure.\n");
- /* See comments just above at `dummy_failure_jump' about the
- two zeroes. */
- PUSH_FAILURE_POINT (0, 0, -2);
- break;
-
- /* Have to succeed matching what follows at least n times.
- After that, handle like `on_failure_jump'. */
- case succeed_n:
- EXTRACT_NUMBER (mcnt, p + 2);
- DEBUG_PRINT2 ("EXECUTING succeed_n %d.\n", mcnt);
-
- assert (mcnt >= 0);
- /* Originally, this is how many times we HAVE to succeed. */
- if (mcnt > 0)
- {
- mcnt--;
- p += 2;
- STORE_NUMBER_AND_INCR (p, mcnt);
-#ifdef _LIBC
- DEBUG_PRINT3 (" Setting %p to %d.\n", p - 2, mcnt);
-#else
- DEBUG_PRINT3 (" Setting 0x%x to %d.\n", p - 2, mcnt);
-#endif
- }
- else if (mcnt == 0)
- {
-#ifdef _LIBC
- DEBUG_PRINT2 (" Setting two bytes from %p to no_op.\n", p+2);
-#else
- DEBUG_PRINT2 (" Setting two bytes from 0x%x to no_op.\n", p+2);
-#endif
- p[2] = (unsigned char) no_op;
- p[3] = (unsigned char) no_op;
- goto on_failure;
- }
- break;
-
- case jump_n:
- EXTRACT_NUMBER (mcnt, p + 2);
- DEBUG_PRINT2 ("EXECUTING jump_n %d.\n", mcnt);
-
- /* Originally, this is how many times we CAN jump. */
- if (mcnt)
- {
- mcnt--;
- STORE_NUMBER (p + 2, mcnt);
-#ifdef _LIBC
- DEBUG_PRINT3 (" Setting %p to %d.\n", p + 2, mcnt);
-#else
- DEBUG_PRINT3 (" Setting 0x%x to %d.\n", p + 2, mcnt);
-#endif
- goto unconditional_jump;
- }
- /* If don't have to jump any more, skip over the rest of command. */
- else
- p += 4;
- break;
-
- case set_number_at:
- {
- DEBUG_PRINT1 ("EXECUTING set_number_at.\n");
-
- EXTRACT_NUMBER_AND_INCR (mcnt, p);
- p1 = p + mcnt;
- EXTRACT_NUMBER_AND_INCR (mcnt, p);
-#ifdef _LIBC
- DEBUG_PRINT3 (" Setting %p to %d.\n", p1, mcnt);
-#else
- DEBUG_PRINT3 (" Setting 0x%x to %d.\n", p1, mcnt);
-#endif
- STORE_NUMBER (p1, mcnt);
- break;
- }
-
-#if 0
- /* The DEC Alpha C compiler 3.x generates incorrect code for the
- test WORDCHAR_P (d - 1) != WORDCHAR_P (d) in the expansion of
- AT_WORD_BOUNDARY, so this code is disabled. Expanding the
- macro and introducing temporary variables works around the bug. */
-
- case wordbound:
- DEBUG_PRINT1 ("EXECUTING wordbound.\n");
- if (AT_WORD_BOUNDARY (d))
- break;
- goto fail;
-
- case notwordbound:
- DEBUG_PRINT1 ("EXECUTING notwordbound.\n");
- if (AT_WORD_BOUNDARY (d))
- goto fail;
- break;
-#else
- case wordbound:
- {
- boolean prevchar, thischar;
-
- DEBUG_PRINT1 ("EXECUTING wordbound.\n");
- if (AT_STRINGS_BEG (d) || AT_STRINGS_END (d))
- break;
-
- prevchar = WORDCHAR_P (d - 1);
- thischar = WORDCHAR_P (d);
- if (prevchar != thischar)
- break;
- goto fail;
- }
-
- case notwordbound:
- {
- boolean prevchar, thischar;
-
- DEBUG_PRINT1 ("EXECUTING notwordbound.\n");
- if (AT_STRINGS_BEG (d) || AT_STRINGS_END (d))
- goto fail;
-
- prevchar = WORDCHAR_P (d - 1);
- thischar = WORDCHAR_P (d);
- if (prevchar != thischar)
- goto fail;
- break;
- }
-#endif
-
- case wordbeg:
- DEBUG_PRINT1 ("EXECUTING wordbeg.\n");
- if (WORDCHAR_P (d) && (AT_STRINGS_BEG (d) || !WORDCHAR_P (d - 1)))
- break;
- goto fail;
-
- case wordend:
- DEBUG_PRINT1 ("EXECUTING wordend.\n");
- if (!AT_STRINGS_BEG (d) && WORDCHAR_P (d - 1)
- && (!WORDCHAR_P (d) || AT_STRINGS_END (d)))
- break;
- goto fail;
-
-#ifdef emacs
- case before_dot:
- DEBUG_PRINT1 ("EXECUTING before_dot.\n");
- if (PTR_CHAR_POS ((unsigned char *) d) >= point)
- goto fail;
- break;
-
- case at_dot:
- DEBUG_PRINT1 ("EXECUTING at_dot.\n");
- if (PTR_CHAR_POS ((unsigned char *) d) != point)
- goto fail;
- break;
-
- case after_dot:
- DEBUG_PRINT1 ("EXECUTING after_dot.\n");
- if (PTR_CHAR_POS ((unsigned char *) d) <= point)
- goto fail;
- break;
-
- case syntaxspec:
- DEBUG_PRINT2 ("EXECUTING syntaxspec %d.\n", mcnt);
- mcnt = *p++;
- goto matchsyntax;
-
- case wordchar:
- DEBUG_PRINT1 ("EXECUTING Emacs wordchar.\n");
- mcnt = (int) Sword;
- matchsyntax:
- PREFETCH ();
- /* Can't use *d++ here; SYNTAX may be an unsafe macro. */
- d++;
- if (SYNTAX (d[-1]) != (enum syntaxcode) mcnt)
- goto fail;
- SET_REGS_MATCHED ();
- break;
-
- case notsyntaxspec:
- DEBUG_PRINT2 ("EXECUTING notsyntaxspec %d.\n", mcnt);
- mcnt = *p++;
- goto matchnotsyntax;
-
- case notwordchar:
- DEBUG_PRINT1 ("EXECUTING Emacs notwordchar.\n");
- mcnt = (int) Sword;
- matchnotsyntax:
- PREFETCH ();
- /* Can't use *d++ here; SYNTAX may be an unsafe macro. */
- d++;
- if (SYNTAX (d[-1]) == (enum syntaxcode) mcnt)
- goto fail;
- SET_REGS_MATCHED ();
- break;
-
-#else /* not emacs */
- case wordchar:
- DEBUG_PRINT1 ("EXECUTING non-Emacs wordchar.\n");
- PREFETCH ();
- if (!WORDCHAR_P (d))
- goto fail;
- SET_REGS_MATCHED ();
- d++;
- break;
-
- case notwordchar:
- DEBUG_PRINT1 ("EXECUTING non-Emacs notwordchar.\n");
- PREFETCH ();
- if (WORDCHAR_P (d))
- goto fail;
- SET_REGS_MATCHED ();
- d++;
- break;
-#endif /* not emacs */
-
- default:
- abort ();
- }
- continue; /* Successfully executed one pattern command; keep going. */
-
-
- /* We goto here if a matching operation fails. */
- fail:
- if (!FAIL_STACK_EMPTY ())
- { /* A restart point is known. Restore to that state. */
- DEBUG_PRINT1 ("\nFAIL:\n");
- POP_FAILURE_POINT (d, p,
- lowest_active_reg, highest_active_reg,
- regstart, regend, reg_info);
-
- /* If this failure point is a dummy, try the next one. */
- if (!p)
- goto fail;
-
- /* If we failed to the end of the pattern, don't examine *p. */
- assert (p <= pend);
- if (p < pend)
- {
- boolean is_a_jump_n = false;
-
- /* If failed to a backwards jump that's part of a repetition
- loop, need to pop this failure point and use the next one. */
- switch ((re_opcode_t) *p)
- {
- case jump_n:
- is_a_jump_n = true;
- case maybe_pop_jump:
- case pop_failure_jump:
- case jump:
- p1 = p + 1;
- EXTRACT_NUMBER_AND_INCR (mcnt, p1);
- p1 += mcnt;
-
- if ((is_a_jump_n && (re_opcode_t) *p1 == succeed_n)
- || (!is_a_jump_n
- && (re_opcode_t) *p1 == on_failure_jump))
- goto fail;
- break;
- default:
- /* do nothing */ ;
- }
- }
-
- if (d >= string1 && d <= end1)
- dend = end_match_1;
- }
- else
- break; /* Matching at this starting point really fails. */
- } /* for (;;) */
-
- if (best_regs_set)
- goto restore_best_regs;
-
- FREE_VARIABLES ();
-
- return -1; /* Failure to match. */
-} /* re_match_2 */
-\f
-/* Subroutine definitions for re_match_2. */
-
-
-/* We are passed P pointing to a register number after a start_memory.
-
- Return true if the pattern up to the corresponding stop_memory can
- match the empty string, and false otherwise.
-
- If we find the matching stop_memory, sets P to point to one past its number.
- Otherwise, sets P to an undefined byte less than or equal to END.
-
- We don't handle duplicates properly (yet). */
-
-static boolean
-group_match_null_string_p (p, end, reg_info)
- unsigned char **p, *end;
- register_info_type *reg_info;
-{
- int mcnt;
- /* Point to after the args to the start_memory. */
- unsigned char *p1 = *p + 2;
-
- while (p1 < end)
- {
- /* Skip over opcodes that can match nothing, and return true or
- false, as appropriate, when we get to one that can't, or to the
- matching stop_memory. */
-
- switch ((re_opcode_t) *p1)
- {
- /* Could be either a loop or a series of alternatives. */
- case on_failure_jump:
- p1++;
- EXTRACT_NUMBER_AND_INCR (mcnt, p1);
-
- /* If the next operation is not a jump backwards in the
- pattern. */
-
- if (mcnt >= 0)
- {
- /* Go through the on_failure_jumps of the alternatives,
- seeing if any of the alternatives cannot match nothing.
- The last alternative starts with only a jump,
- whereas the rest start with on_failure_jump and end
- with a jump, e.g., here is the pattern for `a|b|c':
-
- /on_failure_jump/0/6/exactn/1/a/jump_past_alt/0/6
- /on_failure_jump/0/6/exactn/1/b/jump_past_alt/0/3
- /exactn/1/c
-
- So, we have to first go through the first (n-1)
- alternatives and then deal with the last one separately. */
-
-
- /* Deal with the first (n-1) alternatives, which start
- with an on_failure_jump (see above) that jumps to right
- past a jump_past_alt. */
-
- while ((re_opcode_t) p1[mcnt-3] == jump_past_alt)
- {
- /* `mcnt' holds how many bytes long the alternative
- is, including the ending `jump_past_alt' and
- its number. */
-
- if (!alt_match_null_string_p (p1, p1 + mcnt - 3,
- reg_info))
- return false;
-
- /* Move to right after this alternative, including the
- jump_past_alt. */
- p1 += mcnt;
-
- /* Break if it's the beginning of an n-th alternative
- that doesn't begin with an on_failure_jump. */
- if ((re_opcode_t) *p1 != on_failure_jump)
- break;
-
- /* Still have to check that it's not an n-th
- alternative that starts with an on_failure_jump. */
- p1++;
- EXTRACT_NUMBER_AND_INCR (mcnt, p1);
- if ((re_opcode_t) p1[mcnt-3] != jump_past_alt)
- {
- /* Get to the beginning of the n-th alternative. */
- p1 -= 3;
- break;
- }
- }
-
- /* Deal with the last alternative: go back and get number
- of the `jump_past_alt' just before it. `mcnt' contains
- the length of the alternative. */
- EXTRACT_NUMBER (mcnt, p1 - 2);
-
- if (!alt_match_null_string_p (p1, p1 + mcnt, reg_info))
- return false;
-
- p1 += mcnt; /* Get past the n-th alternative. */
- } /* if mcnt > 0 */
- break;
-
-
- case stop_memory:
- assert (p1[1] == **p);
- *p = p1 + 2;
- return true;
-
-
- default:
- if (!common_op_match_null_string_p (&p1, end, reg_info))
- return false;
- }
- } /* while p1 < end */
-
- return false;
-} /* group_match_null_string_p */
-
-
-/* Similar to group_match_null_string_p, but doesn't deal with alternatives:
- It expects P to be the first byte of a single alternative and END one
- byte past the last. The alternative can contain groups. */
-
-static boolean
-alt_match_null_string_p (p, end, reg_info)
- unsigned char *p, *end;
- register_info_type *reg_info;
-{
- int mcnt;
- unsigned char *p1 = p;
-
- while (p1 < end)
- {
- /* Skip over opcodes that can match nothing, and break when we get
- to one that can't. */
-
- switch ((re_opcode_t) *p1)
- {
- /* It's a loop. */
- case on_failure_jump:
- p1++;
- EXTRACT_NUMBER_AND_INCR (mcnt, p1);
- p1 += mcnt;
- break;
-
- default:
- if (!common_op_match_null_string_p (&p1, end, reg_info))
- return false;
- }
- } /* while p1 < end */
-
- return true;
-} /* alt_match_null_string_p */
-
-
-/* Deals with the ops common to group_match_null_string_p and
- alt_match_null_string_p.
-
- Sets P to one after the op and its arguments, if any. */
-
-static boolean
-common_op_match_null_string_p (p, end, reg_info)
- unsigned char **p, *end;
- register_info_type *reg_info;
-{
- int mcnt;
- boolean ret;
- int reg_no;
- unsigned char *p1 = *p;
-
- switch ((re_opcode_t) *p1++)
- {
- case no_op:
- case begline:
- case endline:
- case begbuf:
- case endbuf:
- case wordbeg:
- case wordend:
- case wordbound:
- case notwordbound:
-#ifdef emacs
- case before_dot:
- case at_dot:
- case after_dot:
-#endif
- break;
-
- case start_memory:
- reg_no = *p1;
- assert (reg_no > 0 && reg_no <= MAX_REGNUM);
- ret = group_match_null_string_p (&p1, end, reg_info);
-
- /* Have to set this here in case we're checking a group which
- contains a group and a back reference to it. */
-
- if (REG_MATCH_NULL_STRING_P (reg_info[reg_no]) == MATCH_NULL_UNSET_VALUE)
- REG_MATCH_NULL_STRING_P (reg_info[reg_no]) = ret;
-
- if (!ret)
- return false;
- break;
-
- /* If this is an optimized succeed_n for zero times, make the jump. */
- case jump:
- EXTRACT_NUMBER_AND_INCR (mcnt, p1);
- if (mcnt >= 0)
- p1 += mcnt;
- else
- return false;
- break;
-
- case succeed_n:
- /* Get to the number of times to succeed. */
- p1 += 2;
- EXTRACT_NUMBER_AND_INCR (mcnt, p1);
-
- if (mcnt == 0)
- {
- p1 -= 4;
- EXTRACT_NUMBER_AND_INCR (mcnt, p1);
- p1 += mcnt;
- }
- else
- return false;
- break;
-
- case duplicate:
- if (!REG_MATCH_NULL_STRING_P (reg_info[*p1]))
- return false;
- break;
-
- case set_number_at:
- p1 += 4;
-
- default:
- /* All other opcodes mean we cannot match the empty string. */
- return false;
- }
-
- *p = p1;
- return true;
-} /* common_op_match_null_string_p */
-
-
-/* Return zero if TRANSLATE[S1] and TRANSLATE[S2] are identical for LEN
- bytes; nonzero otherwise. */
-
-static int
-bcmp_translate (s1, s2, len, translate)
- const char *s1, *s2;
- register int len;
- RE_TRANSLATE_TYPE translate;
-{
- register const unsigned char *p1 = (const unsigned char *) s1;
- register const unsigned char *p2 = (const unsigned char *) s2;
- while (len)
- {
- if (translate[*p1++] != translate[*p2++]) return 1;
- len--;
- }
- return 0;
-}
-\f
-/* Entry points for GNU code. */
-
-/* re_compile_pattern is the GNU regular expression compiler: it
- compiles PATTERN (of length SIZE) and puts the result in BUFP.
- Returns 0 if the pattern was valid, otherwise an error string.
-
- Assumes the `allocated' (and perhaps `buffer') and `translate' fields
- are set in BUFP on entry.
-
- We call regex_compile to do the actual compilation. */
-
-const char *
-re_compile_pattern (pattern, length, bufp)
- const char *pattern;
- size_t length;
- struct re_pattern_buffer *bufp;
-{
- reg_errcode_t ret;
-
- /* GNU code is written to assume at least RE_NREGS registers will be set
- (and at least one extra will be -1). */
- bufp->regs_allocated = REGS_UNALLOCATED;
-
- /* And GNU code determines whether or not to get register information
- by passing null for the REGS argument to re_match, etc., not by
- setting no_sub. */
- bufp->no_sub = 0;
-
- /* Match anchors at newline. */
- bufp->newline_anchor = 1;
-
- ret = regex_compile (pattern, length, re_syntax_options, bufp);
-
- if (!ret)
- return NULL;
- return gettext (re_error_msgid[(int) ret]);
-}
-\f
-/* Entry points compatible with 4.2 BSD regex library. We don't define
- them unless specifically requested. */
-
-#if defined (_REGEX_RE_COMP) || defined (_LIBC)
-
-/* BSD has one and only one pattern buffer. */
-static struct re_pattern_buffer re_comp_buf;
-
-char *
-#ifdef _LIBC
-/* Make these definitions weak in libc, so POSIX programs can redefine
- these names if they don't use our functions, and still use
- regcomp/regexec below without link errors. */
-weak_function
-#endif
-re_comp (s)
- const char *s;
-{
- reg_errcode_t ret;
-
- if (!s)
- {
- if (!re_comp_buf.buffer)
- return gettext ("No previous regular expression");
- return 0;
- }
-
- if (!re_comp_buf.buffer)
- {
- re_comp_buf.buffer = (unsigned char *) malloc (200);
- if (re_comp_buf.buffer == NULL)
- return gettext (re_error_msgid[(int) REG_ESPACE]);
- re_comp_buf.allocated = 200;
-
- re_comp_buf.fastmap = (char *) malloc (1 << BYTEWIDTH);
- if (re_comp_buf.fastmap == NULL)
- return gettext (re_error_msgid[(int) REG_ESPACE]);
- }
-
- /* Since `re_exec' always passes NULL for the `regs' argument, we
- don't need to initialize the pattern buffer fields which affect it. */
-
- /* Match anchors at newlines. */
- re_comp_buf.newline_anchor = 1;
-
- ret = regex_compile (s, strlen (s), re_syntax_options, &re_comp_buf);
-
- if (!ret)
- return NULL;
-
- /* Yes, we're discarding `const' here if !HAVE_LIBINTL. */
- return (char *) gettext (re_error_msgid[(int) ret]);
-}
-
-
-int
-#ifdef _LIBC
-weak_function
-#endif
-re_exec (s)
- const char *s;
-{
- const int len = strlen (s);
- return
- 0 <= re_search (&re_comp_buf, s, len, 0, len, (struct re_registers *) 0);
-}
-
-#endif /* _REGEX_RE_COMP */
-\f
-/* POSIX.2 functions. Don't define these for Emacs. */
-
-#ifndef emacs
-
-/* regcomp takes a regular expression as a string and compiles it.
-
- PREG is a regex_t *. We do not expect any fields to be initialized,
- since POSIX says we shouldn't. Thus, we set
-
- `buffer' to the compiled pattern;
- `used' to the length of the compiled pattern;
- `syntax' to RE_SYNTAX_POSIX_EXTENDED if the
- REG_EXTENDED bit in CFLAGS is set; otherwise, to
- RE_SYNTAX_POSIX_BASIC;
- `newline_anchor' to REG_NEWLINE being set in CFLAGS;
- `fastmap' and `fastmap_accurate' to zero;
- `re_nsub' to the number of subexpressions in PATTERN.
-
- PATTERN is the address of the pattern string.
-
- CFLAGS is a series of bits which affect compilation.
-
- If REG_EXTENDED is set, we use POSIX extended syntax; otherwise, we
- use POSIX basic syntax.
-
- If REG_NEWLINE is set, then . and [^...] don't match newline.
- Also, regexec will try a match beginning after every newline.
-
- If REG_ICASE is set, then we considers upper- and lowercase
- versions of letters to be equivalent when matching.
-
- If REG_NOSUB is set, then when PREG is passed to regexec, that
- routine will report only success or failure, and nothing about the
- registers.
-
- It returns 0 if it succeeds, nonzero if it doesn't. (See regex.h for
- the return codes and their meanings.) */
-
-int
-regcomp (preg, pattern, cflags)
- regex_t *preg;
- const char *pattern;
- int cflags;
-{
- reg_errcode_t ret;
- reg_syntax_t syntax
- = (cflags & REG_EXTENDED) ?
- RE_SYNTAX_POSIX_EXTENDED : RE_SYNTAX_POSIX_BASIC;
-
- /* regex_compile will allocate the space for the compiled pattern. */
- preg->buffer = 0;
- preg->allocated = 0;
- preg->used = 0;
-
- /* Don't bother to use a fastmap when searching. This simplifies the
- REG_NEWLINE case: if we used a fastmap, we'd have to put all the
- characters after newlines into the fastmap. This way, we just try
- every character. */
- preg->fastmap = 0;
-
- if (cflags & REG_ICASE)
- {
- unsigned i;
-
- preg->translate
- = (RE_TRANSLATE_TYPE) malloc (CHAR_SET_SIZE
- * sizeof (*(RE_TRANSLATE_TYPE)0));
- if (preg->translate == NULL)
- return (int) REG_ESPACE;
-
- /* Map uppercase characters to corresponding lowercase ones. */
- for (i = 0; i < CHAR_SET_SIZE; i++)
- preg->translate[i] = ISUPPER (i) ? tolower (i) : i;
- }
- else
- preg->translate = NULL;
-
- /* If REG_NEWLINE is set, newlines are treated differently. */
- if (cflags & REG_NEWLINE)
- { /* REG_NEWLINE implies neither . nor [^...] match newline. */
- syntax &= ~RE_DOT_NEWLINE;
- syntax |= RE_HAT_LISTS_NOT_NEWLINE;
- /* It also changes the matching behavior. */
- preg->newline_anchor = 1;
- }
- else
- preg->newline_anchor = 0;
-
- preg->no_sub = !!(cflags & REG_NOSUB);
-
- /* POSIX says a null character in the pattern terminates it, so we
- can use strlen here in compiling the pattern. */
- ret = regex_compile (pattern, strlen (pattern), syntax, preg);
-
- /* POSIX doesn't distinguish between an unmatched open-group and an
- unmatched close-group: both are REG_EPAREN. */
- if (ret == REG_ERPAREN) ret = REG_EPAREN;
-
- return (int) ret;
-}
-
-
-/* regexec searches for a given pattern, specified by PREG, in the
- string STRING.
-
- If NMATCH is zero or REG_NOSUB was set in the cflags argument to
- `regcomp', we ignore PMATCH. Otherwise, we assume PMATCH has at
- least NMATCH elements, and we set them to the offsets of the
- corresponding matched substrings.
-
- EFLAGS specifies `execution flags' which affect matching: if
- REG_NOTBOL is set, then ^ does not match at the beginning of the
- string; if REG_NOTEOL is set, then $ does not match at the end.
-
- We return 0 if we find a match and REG_NOMATCH if not. */
-
-int
-regexec (preg, string, nmatch, pmatch, eflags)
- const regex_t *preg;
- const char *string;
- size_t nmatch;
- regmatch_t pmatch[];
- int eflags;
-{
- int ret;
- struct re_registers regs;
- regex_t private_preg;
- int len = strlen (string);
- boolean want_reg_info = !preg->no_sub && nmatch > 0;
-
- private_preg = *preg;
-
- private_preg.not_bol = !!(eflags & REG_NOTBOL);
- private_preg.not_eol = !!(eflags & REG_NOTEOL);
-
- /* The user has told us exactly how many registers to return
- information about, via `nmatch'. We have to pass that on to the
- matching routines. */
- private_preg.regs_allocated = REGS_FIXED;
-
- if (want_reg_info)
- {
- regs.num_regs = nmatch;
- regs.start = TALLOC (nmatch, regoff_t);
- regs.end = TALLOC (nmatch, regoff_t);
- if (regs.start == NULL || regs.end == NULL)
- return (int) REG_NOMATCH;
- }
-
- /* Perform the searching operation. */
- ret = re_search (&private_preg, string, len,
- /* start: */ 0, /* range: */ len,
- want_reg_info ? ®s : (struct re_registers *) 0);
-
- /* Copy the register information to the POSIX structure. */
- if (want_reg_info)
- {
- if (ret >= 0)
- {
- unsigned r;
-
- for (r = 0; r < nmatch; r++)
- {
- pmatch[r].rm_so = regs.start[r];
- pmatch[r].rm_eo = regs.end[r];
- }
- }
-
- /* If we needed the temporary register info, free the space now. */
- free (regs.start);
- free (regs.end);
- }
-
- /* We want zero return to mean success, unlike `re_search'. */
- return ret >= 0 ? (int) REG_NOERROR : (int) REG_NOMATCH;
-}
-
-
-/* Returns a message corresponding to an error code, ERRCODE, returned
- from either regcomp or regexec. We don't use PREG here. */
-
-size_t
-regerror (errcode, preg, errbuf, errbuf_size)
- int errcode;
- const regex_t *preg;
- char *errbuf;
- size_t errbuf_size;
-{
- const char *msg;
- size_t msg_size;
-
- if (errcode < 0
- || errcode >= (int) (sizeof (re_error_msgid)
- / sizeof (re_error_msgid[0])))
- /* Only error codes returned by the rest of the code should be passed
- to this routine. If we are given anything else, or if other regex
- code generates an invalid error code, then the program has a bug.
- Dump core so we can fix it. */
- abort ();
-
- msg = gettext (re_error_msgid[errcode]);
-
- msg_size = strlen (msg) + 1; /* Includes the null. */
-
- if (errbuf_size != 0)
- {
- if (msg_size > errbuf_size)
- {
- strncpy (errbuf, msg, errbuf_size - 1);
- errbuf[errbuf_size - 1] = 0;
- }
- else
- strcpy (errbuf, msg);
- }
-
- return msg_size;
-}
-
-
-/* Free dynamically allocated space used by PREG. */
-
-void
-regfree (preg)
- regex_t *preg;
-{
- if (preg->buffer != NULL)
- free (preg->buffer);
- preg->buffer = NULL;
-
- preg->allocated = 0;
- preg->used = 0;
-
- if (preg->fastmap != NULL)
- free (preg->fastmap);
- preg->fastmap = NULL;
- preg->fastmap_accurate = 0;
-
- if (preg->translate != NULL)
- free (preg->translate);
- preg->translate = NULL;
-}
-
-#endif /* not emacs */
+++ /dev/null
-/*
- * (c) sof, 1999
- *
- * Stubs to help implement Select module.
- */
-
-/* we're outside the realms of POSIX here... */
-#define NON_POSIX_SOURCE
-
-#include "Rts.h"
-#include "selectFrom.h"
-#include "stgio.h"
-
-# if defined(HAVE_SYS_TYPES_H)
-# include <sys/types.h>
-# endif
-
-# ifdef HAVE_SYS_TIME_H
-# include <sys/time.h>
-# endif
-
-
-/* Helpers for the Haskell-side unmarshalling */
-
-int
-sizeof_fd_set__()
-{
- return (sizeof(fd_set));
-}
-
-void
-fd_zero__(StgByteArray a)
-{
- FD_ZERO((fd_set*)a);
-}
-
-void
-fd_set__(StgByteArray a, StgInt fd)
-{
- FD_SET(fd,(fd_set*)a);
-}
-
-int
-is_fd_set__(StgByteArray a, StgInt fd)
-{
- return FD_ISSET(fd,(fd_set*)a);
-}
-
-StgInt
-selectFrom__( StgByteArray rfd
- , StgByteArray wfd
- , StgByteArray efd
- , StgInt mFd
- , StgInt tout
- )
-{
- int rc, i;
- struct timeval tv;
-
- if (tout != (-1)) {
- tv.tv_sec = tout / 1000000;
- tv.tv_usec = tout % 1000000;
- }
-
- while ((rc = select(mFd, (fd_set*)rfd, (fd_set*)wfd, (fd_set*)efd, (tout == -1 ? NULL : &tv))) < 0) {
- if (errno != EINTR) {
- break;
- }
- }
- return 0;
-}
-
+++ /dev/null
-/*
- * (c) sof, 1999
- *
- * Stubs to help implement Select module
- */
-#ifndef __SELECTFROM_H__
-#define __SELECTFROM_H__
-
-extern StgInt sizeof_fd_set__();
-extern void fd_zero__(StgByteArray fds);
-extern void fd_set__(StgByteArray a, StgInt fd);
-extern StgInt is_fd_set__(StgByteArray a, StgInt fd);
-extern StgInt selectFrom__
- ( StgByteArray rfd
- , StgByteArray wfd
- , StgByteArray efd
- , StgInt mFd
- , StgInt tout
- );
-
-#endif /* __SELECTFROM_H__ */
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: sendTo.c,v 1.3 1998/12/02 13:26:46 simonm Exp $
- *
- * sendTo run-time support
- *
- * (c) The GHC Team 1998
- * -------------------------------------------------------------------------- */
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-sendTo__(StgInt fd, StgAddr buf, StgInt nbytes, StgAddr to, StgInt sz)
-{
- StgInt count;
- int flags = 0;
-
- while ( (count = sendto((int)fd, (void*)buf, (int)nbytes, flags, (struct sockaddr*)to, sz)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return count;
-}
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1996
-%
-\subsection[shutdownSocket.lc]{Shut down part of full duplex connection}
-
-\begin{code}
-#endif
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-shutdownSocket(I_ sockfd, I_ how)
-{
- StgInt rc;
-
- while ((rc = shutdown((int) sockfd, (int) how)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EBADF:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Not a valid write descriptor";
- break;
- case GHC_ENOTCONN:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Socket not connected";
- break;
- case GHC_ENOTSOCK:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Descriptor is not a socket";
- break;
- }
- return -1;
- }
- }
- return rc;
-}
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\subsection[socketOpt.lc]{Setting/Getting socket opts}
-
-\begin{code}
-#endif
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-getSocketOption__ (StgInt fd, StgInt opt, StgInt level)
-{
- int optval, sz_optval, rc;
-
- sz_optval = sizeof(int);
-
- while ( (rc = getsockopt((int)fd, level, opt, &optval, &sz_optval)) < 0 ) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return optval;
-}
-
-StgInt
-setSocketOption__ (StgInt fd, StgInt opt, StgInt level, StgInt val)
-{
- int optval, rc;
-
- optval = val;
-
- while ( (rc = setsockopt((int)fd, level, opt, &optval, sizeof(optval))) < 0 ) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 0;
-}
+++ /dev/null
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1996
-%
-\subsection[writeDescriptor.lc]{Stuff bytes down a descriptor}
-
-\begin{code}
-#endif
-
-#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "ghcSockets.h"
-#include "stgio.h"
-
-StgInt
-writeDescriptor(I_ fd, A_ buf, I_ nbytes)
-{
- StgInt dumped;
-
- while ((dumped = write((int) fd, (char *) buf, (int) nbytes)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EBADF:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Not a valid write descriptor";
- break;
- case GHC_EDQUOT:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "Disk quota exhausted";
- break;
- case GHC_EFAULT:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Data not in writeable part of user address space";
- break;
- case GHC_EFBIG:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "Maximum process or system file size exceeded";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Seek pointer associated with descriptor negative";
- break;
- case GHC_EIO:
- ghc_errtype = ERR_SYSTEMERROR;
- ghc_errstr = "I/O error occurred while writing to file system";
- break;
- case GHC_ENOSPC:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "No space left on device";
- break;
- case GHC_ENXIO:
- ghc_errtype = ERR_SYSTEMERROR;
- ghc_errstr = "Hangup occurred";
- break;
- case GHC_EPIPE:
- ghc_errtype = ERR_SYSTEMERROR;
- ghc_errstr = "Write to not read pipe/unconnected socket caught";
- break;
- case GHC_ERANGE:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "Too much or too little written to descriptor";
- break;
- case GHC_EAGAIN:
- case GHC_EWOULDBLOCK:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "No data could be written immediately";
- break;
- }
- return -1;
- }
- }
- return dumped;
-}
+++ /dev/null
-%************************************************************************
-%* *
-\section[syslibs]{System libraries}
-\index{system libraries}
-\index{libraries, system}
-%* *
-%************************************************************************
-
-We intend to provide more and more ready-to-use Haskell code, so that
-every program doesn't have to invent everything from scratch.
-
-If you provide a \tr{-syslib <name>}\index{-syslib <name> option} option,
-then the interfaces for that library will come into scope (and may be
-\tr{import}ed), and the code will be added in at link time.
-
-We supply a part of the HBC library (\tr{-syslib hbc}); as well as one
-of our own (\tr{-syslib ghc}); one for an interface to POSIX routines
-(\tr{-syslib posix}); and one of contributed stuff off the net, mostly
-numerical (\tr{-syslib contrib}).
-
-If you have Haggis (our GUI X~toolkit for Haskell), it probably works
-with a \tr{-syslib haggis} flag.
-
-%************************************************************************
-%* *
-\subsection[GHC-library]{The GHC system library}
-\index{library, GHC}
-\index{GHC library}
-%* *
-%************************************************************************
-
-We have started to put together a ``GHC system library.''
-
-At the moment, the library is made of generally-useful bits of the
-compiler itself.
-
-To use this library, just give a \tr{-syslib ghc}\index{-syslib ghc option}
-option to GHC, both for compiling and linking.
-
-%************************************************************************
-%* *
-\subsubsection[Bag]{The @Bag@ type}
-\index{Bag module (GHC syslib)}
-%* *
-%************************************************************************
-
-A {\em bag} is an unordered collection of elements which may contain
-duplicates. To use, \tr{import Bag}.
-
-\begin{verbatim}
-emptyBag :: Bag elt
-unitBag :: elt -> Bag elt
-
-unionBags :: Bag elt -> Bag elt -> Bag elt
-unionManyBags :: [Bag elt] -> Bag elt
-consBag :: elt -> Bag elt -> Bag elt
-snocBag :: Bag elt -> elt -> Bag elt
-
-concatBag :: Bag (Bag a) -> Bag a
-mapBag :: (a -> b) -> Bag a -> Bag b
-
-foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative
- -> (a -> r) -- Replace UnitBag with this
- -> r -- Replace EmptyBag with this
- -> Bag a
- -> r
-
-elemBag :: Eq elt => elt -> Bag elt -> Bool
-isEmptyBag :: Bag elt -> Bool
-filterBag :: (elt -> Bool) -> Bag elt -> Bag elt
-partitionBag :: (elt -> Bool) -> Bag elt-> (Bag elt, Bag elt)
- -- returns the elements that do/don't satisfy the predicate
-
-listToBag :: [elt] -> Bag elt
-bagToList :: Bag elt -> [elt]
-\end{verbatim}
-
-%************************************************************************
-%* *
-\subsubsection[BitSet]{The @BitSet@ type}
-\index{BitSet module (GHC syslib)}
-%* *
-%************************************************************************
-
-Bit sets are a fast implementation of sets of integers ranging from 0
-to one less than the number of bits in a machine word (typically 31).
-If any element exceeds the maximum value for a particular machine
-architecture, the results of these operations are undefined. You have
-been warned. [``If you put any safety checks in this code, I will have
-to kill you.'' --JSM]
-
-\begin{verbatim}
-mkBS :: [Int] -> BitSet
-listBS :: BitSet -> [Int]
-emptyBS :: BitSet
-unitBS :: Int -> BitSet
-
-unionBS :: BitSet -> BitSet -> BitSet
-minusBS :: BitSet -> BitSet -> BitSet
-elementBS :: Int -> BitSet -> Bool
-intersectBS :: BitSet -> BitSet -> BitSet
-
-isEmptyBS :: BitSet -> Bool
-\end{verbatim}
-
-%************************************************************************
-%* *
-\subsubsection[FiniteMap]{The @FiniteMap@ type}
-\index{FiniteMap module (GHC syslib)}
-%* *
-%************************************************************************
-
-What functional programmers call a {\em finite map}, everyone else
-calls a {\em lookup table}.
-
-Out code is derived from that in this paper:
-\begin{display}
-S Adams
-"Efficient sets: a balancing act"
-Journal of functional programming 3(4) Oct 1993, pages 553-562
-\end{display}
-Guess what? The implementation uses balanced trees.
-
-\begin{verbatim}
--- BUILDING
-emptyFM :: FiniteMap key elt
-unitFM :: key -> elt -> FiniteMap key elt
-listToFM :: Ord key => [(key,elt)] -> FiniteMap key elt
- -- In the case of duplicates, the last is taken
-
--- ADDING AND DELETING
- -- Throws away any previous binding
- -- In the list case, the items are added starting with the
- -- first one in the list
-addToFM :: Ord key => FiniteMap key elt -> key -> elt -> FiniteMap key elt
-addListToFM :: Ord key => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt
-
- -- Combines with previous binding
-addToFM_C :: Ord key => (elt -> elt -> elt)
- -> FiniteMap key elt -> key -> elt
- -> FiniteMap key elt
-addListToFM_C :: Ord key => (elt -> elt -> elt)
- -> FiniteMap key elt -> [(key,elt)]
- -> FiniteMap key elt
-
- -- Deletion doesn't complain if you try to delete something
- -- which isn't there
-delFromFM :: Ord key => FiniteMap key elt -> key -> FiniteMap key elt
-delListFromFM :: Ord key => FiniteMap key elt -> [key] -> FiniteMap key elt
-
--- COMBINING
- -- Bindings in right argument shadow those in the left
-plusFM :: Ord key => FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
- -- Combines bindings for the same thing with the given function
-plusFM_C :: Ord key => (elt -> elt -> elt)
- -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-
-minusFM :: Ord key => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
- -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
-
-intersectFM :: Ord key => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-intersectFM_C :: Ord key => (elt -> elt -> elt)
- -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-
--- MAPPING, FOLDING, FILTERING
-foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
-mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2
-filterFM :: Ord key => (key -> elt -> Bool)
- -> FiniteMap key elt -> FiniteMap key elt
-
--- INTERROGATING
-sizeFM :: FiniteMap key elt -> Int
-isEmptyFM :: FiniteMap key elt -> Bool
-
-elemFM :: Ord key => key -> FiniteMap key elt -> Bool
-lookupFM :: Ord key => FiniteMap key elt -> key -> Maybe elt
-lookupWithDefaultFM
- :: Ord key => FiniteMap key elt -> elt -> key -> elt
- -- lookupWithDefaultFM supplies a "default" elt
- -- to return for an unmapped key
-
--- LISTIFYING
-fmToList :: FiniteMap key elt -> [(key,elt)]
-keysFM :: FiniteMap key elt -> [key]
-eltsFM :: FiniteMap key elt -> [elt]
-\end{verbatim}
-
-%************************************************************************
-%* *
-\subsubsection[ListSetOps]{The @ListSetOps@ type}
-\index{ListSetOps module (GHC syslib)}
-%* *
-%************************************************************************
-
-Just a few set-sounding operations on lists. If you want sets, use
-the \tr{Set} module.
-
-\begin{verbatim}
-unionLists :: Eq a => [a] -> [a] -> [a]
-intersectLists :: Eq a => [a] -> [a] -> [a]
-minusList :: Eq a => [a] -> [a] -> [a]
-disjointLists :: Eq a => [a] -> [a] -> Bool
-intersectingLists :: Eq a => [a] -> [a] -> Bool
-\end{verbatim}
-
-%************************************************************************
-%* *
-\subsubsection[Maybes]{The @Maybes@ type}
-\index{Maybes module (GHC syslib)}
-%* *
-%************************************************************************
-
-The \tr{Maybe} type itself is in the Haskell~1.3 prelude. Moreover,
-the required \tr{Maybe} library provides many useful functions on
-\tr{Maybe}s. This (old) module provides more.
-
-An \tr{Either}-like type called \tr{MaybeErr}:
-\begin{verbatim}
-data MaybeErr val err = Succeeded val | Failed err
-\end{verbatim}
-
-Some operations to do with \tr{Maybe} (some commentary follows):
-\begin{verbatim}
-maybeToBool :: Maybe a -> Bool -- Nothing => False; Just => True
-allMaybes :: [Maybe a] -> Maybe [a]
-firstJust :: [Maybe a] -> Maybe a
-findJust :: (a -> Maybe b) -> [a] -> Maybe b
-
-assocMaybe :: Eq a => [(a,b)] -> a -> Maybe b
-mkLookupFun :: (key -> key -> Bool) -- Equality predicate
- -> [(key,val)] -- The assoc list
- -> (key -> Maybe val) -- A lookup fun to use
-mkLookupFunDef :: (key -> key -> Bool) -- Ditto, with a default
- -> [(key,val)]
- -> val -- the default
- -> (key -> val) -- NB: not a Maybe anymore
-
- -- a monad thing
-thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b
-returnMaybe :: a -> Maybe a
-failMaybe :: Maybe a
-mapMaybe :: (a -> Maybe b) -> [a] -> Maybe [b]
-\end{verbatim}
-
-NB: @catMaybes@, which used to be here, is in the Haskell~1.3 libraries.
-
-@allMaybes@ collects a list of @Justs@ into a single @Just@, returning
-@Nothing@ if there are any @Nothings@.
-
-@firstJust@ takes a list of @Maybes@ and returns the
-first @Just@ if there is one, or @Nothing@ otherwise.
-
-@assocMaybe@ looks up in an association list, returning
-@Nothing@ if it fails.
-
-Now, some operations to do with \tr{MaybeErr} (comments follow):
-\begin{verbatim}
- -- a monad thing (surprise, surprise)
-thenMaB :: MaybeErr a err -> (a -> MaybeErr b err) -> MaybeErr b err
-returnMaB :: val -> MaybeErr val err
-failMaB :: err -> MaybeErr val err
-
-listMaybeErrs :: [MaybeErr val err] -> MaybeErr [val] [err]
-foldlMaybeErrs :: (acc -> input -> MaybeErr acc err)
- -> acc
- -> [input]
- -> MaybeErr acc [err]
-\end{verbatim}
-
-@listMaybeErrs@ takes a list of @MaybeErrs@ and, if they all succeed,
-returns a @Succeeded@ of a list of their values. If any fail, it
-returns a @Failed@ of the list of all the errors in the list.
-
-@foldlMaybeErrs@ works along a list, carrying an accumulator; it
-applies the given function to the accumulator and the next list item,
-accumulating any errors that occur.
-
-%************************************************************************
-%* *
-\subsubsection[PackedString]{The @PackedString@ type}
-\index{PackedString module (GHC syslib)}
-%* *
-%************************************************************************
-
-You need \tr{import PackedString}, and
-heave in your \tr{-syslib ghc}.
-
-The basic type and functions which are available are:
-\begin{verbatim}
-data PackedString
-
-packString :: [Char] -> PackedString
-packStringST :: [Char] -> ST s PackedString
-packCString :: Addr -> PackedString
-packCBytes :: Int -> Addr -> PackedString
-packCBytesST :: Int -> Addr -> ST s PackedString
-packBytesForC :: [Char] -> ByteArray Int
-packBytesForCST :: [Char] -> ST s (ByteArray Int)
-byteArrayToPS :: ByteArray Int -> PackedString
-psToByteArray :: PackedString -> ByteArray Int
-
-unpackPS :: PackedString -> [Char]
-\end{verbatim}
-
-We also provide a wad of list-manipulation-like functions:
-\begin{verbatim}
-nilPS :: PackedString
-consPS :: Char -> PackedString -> PackedString
-
-headPS :: PackedString -> Char
-tailPS :: PackedString -> PackedString
-nullPS :: PackedString -> Bool
-appendPS :: PackedString -> PackedString -> PackedString
-lengthPS :: PackedString -> Int
-indexPS :: PackedString -> Int -> Char
- -- 0-origin indexing into the string
-mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
-filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
-foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
-foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
-takePS :: Int -> PackedString -> PackedString
-dropPS :: Int -> PackedString -> PackedString
-splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
-takeWhilePS:: (Char -> Bool) -> PackedString -> PackedString
-dropWhilePS:: (Char -> Bool) -> PackedString -> PackedString
-spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
-breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
-linesPS :: PackedString -> [PackedString]
-wordsPS :: PackedString -> [PackedString]
-reversePS :: PackedString -> PackedString
-concatPS :: [PackedString] -> PackedString
-
-substrPS :: PackedString -> Int -> Int -> PackedString
- -- pluck out a piece of a PS
- -- start and end chars you want; both 0-origin-specified
-\end{verbatim}
-
-%************************************************************************
-%* *
-\subsubsection[Pretty]{The @Pretty@ type}
-\index{Pretty module (GHC syslib)}
-%* *
-%************************************************************************
-
-This is the pretty-printer that we use in GHC.
-
-\begin{verbatim}
-type Pretty
-
-ppShow :: Int{-width-} -> Pretty -> [Char]
-
-pp'SP :: Pretty -- "comma space"
-ppComma :: Pretty -- ,
-ppEquals :: Pretty -- =
-ppLbrack :: Pretty -- [
-ppLparen :: Pretty -- (
-ppNil :: Pretty -- nothing
-ppRparen :: Pretty -- )
-ppRbrack :: Pretty -- ]
-ppSP :: Pretty -- space
-ppSemi :: Pretty -- ;
-
-ppChar :: Char -> Pretty
-ppDouble :: Double -> Pretty
-ppFloat :: Float -> Pretty
-ppInt :: Int -> Pretty
-ppInteger :: Integer -> Pretty
-ppRational :: Rational -> Pretty
-ppStr :: [Char] -> Pretty
-
-ppAbove :: Pretty -> Pretty -> Pretty
-ppAboves :: [Pretty] -> Pretty
-ppBeside :: Pretty -> Pretty -> Pretty
-ppBesides :: [Pretty] -> Pretty
-ppCat :: [Pretty] -> Pretty
-ppHang :: Pretty -> Int -> Pretty -> Pretty
-ppInterleave :: Pretty -> [Pretty] -> Pretty -- spacing between
-ppIntersperse :: Pretty -> [Pretty] -> Pretty -- no spacing between
-ppNest :: Int -> Pretty -> Pretty
-ppSep :: [Pretty] -> Pretty
-
-ppBracket :: Pretty -> Pretty -- [ ... ] around something
-ppParens :: Pretty -> Pretty -- ( ... ) around something
-ppQuote :: Pretty -> Pretty -- ` ... ' around something
-\end{verbatim}
-
-%************************************************************************
-%* *
-\subsubsection[Set]{The @Set@ type}
-\index{Set module (GHC syslib)}
-%* *
-%************************************************************************
-
-Our implementation of {\em sets} (key property: no duplicates) is just
-a variant of the \tr{FiniteMap} module.
-
-\begin{verbatim}
-mkSet :: Ord a => [a] -> Set a
-setToList :: Set a -> [a]
-emptySet :: Set a
-singletonSet :: a -> Set a
-
-union :: Ord a => Set a -> Set a -> Set a
-unionManySets :: Ord a => [Set a] -> Set a
-intersect :: Ord a => Set a -> Set a -> Set a
-minusSet :: Ord a => Set a -> Set a -> Set a
-mapSet :: Ord a => (b -> a) -> Set b -> Set a
-
-elementOf :: Ord a => a -> Set a -> Bool
-isEmptySet :: Set a -> Bool
-\end{verbatim}
-
-%************************************************************************
-%* *
-\subsubsection[Util]{The @Util@ type}
-\index{Util module (GHC syslib)}
-%* *
-%************************************************************************
-
-Stuff that has been useful to use in writing the compiler. Don't be
-too surprised if this stuff moves/gets-renamed/etc.
-
-\begin{verbatim}
--- general list processing
-exists :: (a -> Bool) -> [a] -> Bool
-forall :: (a -> Bool) -> [a] -> Bool
-isSingleton :: [a] -> Bool
-lengthExceeds :: [a] -> Int -> Bool
-mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
-mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
-nOfThem :: Int -> a -> [a]
-zipEqual :: [a] -> [b] -> [(a,b)]
-zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
-zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
-zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
-zipLazy :: [a] -> [b] -> [(a,b)] -- lazy in 2nd arg
-
--- association lists
-assoc :: Eq a => String -> [(a, b)] -> a -> b
-
--- duplicate handling
-hasNoDups :: Eq a => [a] -> Bool
-equivClasses :: (a -> a -> Ordering) -> [a] -> [[a]]
-runs :: (a -> a -> Bool) -> [a] -> [[a]]
-removeDups :: (a -> a -> Ordering) -> [a] -> ([a], [[a]])
-
--- sorting (don't complain of no choice...)
-quicksort :: (a -> a -> Bool) -> [a] -> [a]
-sortLt :: (a -> a -> Bool) -> [a] -> [a]
-stableSortLt :: (a -> a -> Bool) -> [a] -> [a]
-mergesort :: (a -> a -> Ordering) -> [a] -> [a]
-mergeSort :: Ord a => [a] -> [a]
-naturalMergeSort :: Ord a => [a] -> [a]
-mergeSortLe :: Ord a => [a] -> [a]
-naturalMergeSortLe :: Ord a => [a] -> [a]
-
--- transitive closures
-transitiveClosure :: (a -> [a]) -- Successor function
- -> (a -> a -> Bool) -- Equality predicate
- -> [a]
- -> [a] -- The transitive closure
-
--- accumulating (Left, Right, Bi-directional)
-mapAccumL :: (acc -> x -> (acc, y))
- -- Function of elt of input list and
- -- accumulator, returning new accumulator and
- -- elt of result list
- -> acc -- Initial accumulator
- -> [x] -- Input list
- -> (acc, [y]) -- Final accumulator and result list
-
-mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])
-
-mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
- -> accl -> accr -> [x]
- -> (accl, accr, [y])
-
--- comparisons
-cmpString :: String -> String -> Ordering
-
--- pairs
-applyToPair :: ((a -> c), (b -> d)) -> (a, b) -> (c, d)
-applyToFst :: (a -> c) -> (a, b) -> (c, b)
-applyToSnd :: (b -> d) -> (a, b) -> (a, d)
-foldPair :: (a->a->a, b->b->b) -> (a, b) -> [(a, b)] -> (a, b)
-unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
-\end{verbatim}
-
-%************************************************************************
-%* *
-\subsection[C-interfaces]{Interfaces to C libraries}
-\index{C library interfaces}
-\index{interfaces, C library}
-%* *
-%************************************************************************
-
-The GHC system library (\tr{-syslib ghc}) also provides interfaces to
-several useful C libraries, mostly from the GNU project.
-
-%************************************************************************
-%* *
-\subsubsection[Readline]{The @Readline@ interface}
-\index{Readline library (GHC syslib)}
-\index{command-line editing library}
-%* *
-%************************************************************************
-
-(Darren Moffat supplied the \tr{Readline} interface.)
-
-The \tr{Readline} module is a straightforward interface to the GNU
-Readline library. As such, you will need to look at the GNU
-documentation (and have a \tr{libreadline.a} file around somewhere...)
-
-You'll need to link any Readlining program with \tr{-lreadline -ltermcap},
-besides the usual \tr{-syslib ghc}.
-
-The main function you'll use is:
-\begin{verbatim}
-readline :: String{-the prompt-} -> IO String
-\end{verbatim}
-
-If you want to mess around with Full Readline G(l)ory, we also
-provide:
-\begin{verbatim}
-rlInitialize, addHistory,
-
-rlBindKey, rlAddDefun, RlCallbackFunction(..),
-
-rlGetLineBuffer, rlSetLineBuffer, rlGetPoint, rlSetPoint, rlGetEnd,
-rlSetEnd, rlGetMark, rlSetMark, rlSetDone, rlPendingInput,
-
-rlPrompt, rlTerminalName, rlSetReadlineName, rlGetReadlineName
-\end{verbatim}
-(All those names are just Haskellised versions of what you
-will see in the GNU readline documentation.)
-
-%************************************************************************
-%* *
-\subsubsection[Regexp]{The @Regexp@ and @MatchPS@ interfaces}
-\index{Regex library (GHC syslib)}
-\index{MatchPS library (GHC syslib)}
-\index{regular-expressions library}
-%* *
-%************************************************************************
-
-(Sigbjorn Finne supplied the regular-expressions interface.)
-
-The \tr{Regex} library provides quite direct interface to the GNU
-regular-expression library, for doing manipulation on
-\tr{PackedString}s. You probably need to see the GNU documentation
-if you are operating at this level.
-
-The datatypes and functions that \tr{Regex} provides are:
-\begin{verbatim}
-data PatBuffer # just a bunch of bytes (mutable)
-
-data REmatch
- = REmatch (Array Int GroupBounds) -- for $1, ... $n
- GroupBounds -- for $` (everything before match)
- GroupBounds -- for $& (entire matched string)
- GroupBounds -- for $' (everything after)
- GroupBounds -- for $+ (matched by last bracket)
-
--- GroupBounds hold the interval where a group
--- matched inside a string, e.g.
---
--- matching "reg(exp)" "a regexp" returns the pair (5,7) for the
--- (exp) group. (PackedString indices start from 0)
-
-type GroupBounds = (Int, Int)
-
-re_compile_pattern
- :: PackedString -- pattern to compile
- -> Bool -- True <=> assume single-line mode
- -> Bool -- True <=> case-insensitive
- -> PrimIO PatBuffer
-
-re_match :: PatBuffer -- compiled regexp
- -> PackedString -- string to match
- -> Int -- start position
- -> Bool -- True <=> record results in registers
- -> PrimIO (Maybe REmatch)
-
--- Matching on 2 strings is useful when you're dealing with multiple
--- buffers, which is something that could prove useful for
--- PackedStrings, as we don't want to stuff the contents of a file
--- into one massive heap chunk, but load (smaller chunks) on demand.
-
-re_match2 :: PatBuffer -- 2-string version
- -> PackedString
- -> PackedString
- -> Int
- -> Int
- -> Bool
- -> PrimIO (Maybe REmatch)
-
-re_search :: PatBuffer -- compiled regexp
- -> PackedString -- string to search
- -> Int -- start index
- -> Int -- stop index
- -> Bool -- True <=> record results in registers
- -> PrimIO (Maybe REmatch)
-
-re_search2 :: PatBuffer -- Double buffer search
- -> PackedString
- -> PackedString
- -> Int -- start index
- -> Int -- range (?)
- -> Int -- stop index
- -> Bool -- True <=> results in registers
- -> PrimIO (Maybe REmatch)
-\end{verbatim}
-
-The \tr{MatchPS} module provides Perl-like ``higher-level'' facilities
-to operate on \tr{PackedStrings}. The regular expressions in
-question are in Perl syntax. The ``flags'' on various functions can
-include: \tr{i} for case-insensitive, \tr{s} for single-line mode, and
-\tr{g} for global. (It's probably worth your time to peruse the
-source code...)
-
-\begin{verbatim}
-matchPS :: PackedString -- regexp
- -> PackedString -- string to match
- -> [Char] -- flags
- -> Maybe REmatch -- info about what matched and where
-
-searchPS :: PackedString -- regexp
- -> PackedString -- string to match
- -> [Char] -- flags
- -> Maybe REmatch
-
--- Perl-like match-and-substitute:
-substPS :: PackedString -- regexp
- -> PackedString -- replacement
- -> [Char] -- flags
- -> PackedString -- string
- -> PackedString
-
--- same as substPS, but no prefix and suffix:
-replacePS :: PackedString -- regexp
- -> PackedString -- replacement
- -> [Char] -- flags
- -> PackedString -- string
- -> PackedString
-
-match2PS :: PackedString -- regexp
- -> PackedString -- string1 to match
- -> PackedString -- string2 to match
- -> [Char] -- flags
- -> Maybe REmatch
-
-search2PS :: PackedString -- regexp
- -> PackedString -- string to match
- -> PackedString -- string to match
- -> [Char] -- flags
- -> Maybe REmatch
-
--- functions to pull the matched pieces out of an REmatch:
-
-getMatchesNo :: REmatch -> Int
-getMatchedGroup :: REmatch -> Int -> PackedString -> PackedString
-getWholeMatch :: REmatch -> PackedString -> PackedString
-getLastMatch :: REmatch -> PackedString -> PackedString
-getAfterMatch :: REmatch -> PackedString -> PackedString
-
--- (reverse) brute-force string matching;
--- Perl equivalent is index/rindex:
-findPS, rfindPS :: PackedString -> PackedString -> Maybe Int
-
--- Equivalent to Perl "chop" (off the last character, if any):
-chopPS :: PackedString -> PackedString
-
--- matchPrefixPS: tries to match as much as possible of strA starting
--- from the beginning of strB (handy when matching fancy literals in
--- parsers):
-matchPrefixPS :: PackedString -> PackedString -> Int
-\end{verbatim}
-
-%************************************************************************
-%* *
-\subsubsection[Socket]{Network-interface toolkit---@Socket@ and @SocketPrim@}
-\index{SocketPrim interface (GHC syslib)}
-\index{Socket interface (GHC syslib)}
-\index{network-interface library}
-\index{sockets library}
-\index{BSD sockets library}
-%* *
-%************************************************************************
-
-(Darren Moffat supplied the network-interface toolkit.)
-
-Your best bet for documentation is to look at the code---really!---
-normally in \tr{hslibs/ghc/src/{BSD,Socket,SocketPrim}.lhs}.
-
-The \tr{BSD} module provides functions to get at system-database info;
-pretty straightforward if you're into this sort of thing:
-\begin{verbatim}
-getHostName :: IO String
-
-getServiceByName :: ServiceName -> IO ServiceEntry
-getServicePortNumber:: ServiceName -> IO PortNumber
-getServiceEntry :: IO ServiceEntry
-setServiceEntry :: Bool -> IO ()
-endServiceEntry :: IO ()
-
-getProtocolByName :: ProtocolName -> IO ProtocolEntry
-getProtocolByNumber :: ProtocolNumber -> IO ProtcolEntry
-getProtocolNumber :: ProtocolName -> ProtocolNumber
-getProtocolEntry :: IO ProtocolEntry
-setProtocolEntry :: Bool -> IO ()
-endProtocolEntry :: IO ()
-
-getHostByName :: HostName -> IO HostEntry
-getHostByAddr :: Family -> HostAddress -> IO HostEntry
-getHostEntry :: IO HostEntry
-setHostEntry :: Bool -> IO ()
-endHostEntry :: IO ()
-\end{verbatim}
-
-The \tr{SocketPrim} interface provides quite direct access to the
-socket facilities in a BSD Unix system, including all the
-complications. We hope you don't need to use it! See the source if
-needed...
-
-The \tr{Socket} interface is a ``higher-level'' interface to sockets,
-and it is what we recommend. Please tell us if the facilities it
-offers are inadequate to your task!
-
-The interface is relatively modest:
-\begin{verbatim}
-connectTo :: Hostname -> PortID -> IO Handle
-listenOn :: PortID -> IO Socket
-
-accept :: Socket -> IO (Handle, HostName)
-sendTo :: Hostname -> PortID -> String -> IO ()
-
-recvFrom :: Hostname -> PortID -> IO String
-socketPort :: Socket -> IO PortID
-
-data PortID -- PortID is a non-abstract type
- = Service String -- Service Name eg "ftp"
- | PortNumber Int -- User defined Port Number
- | UnixSocket String -- Unix family socket in file system
-
-type Hostname = String
-\end{verbatim}
-
-Various examples of networking Haskell code are provided in
-\tr{ghc/misc/examples/}, notably the \tr{net???/Main.hs} programs.
-
-%************************************************************************
-%* *
-\subsection[HBC-library]{The HBC system library}
-\index{HBC system library}
-\index{system library, HBC}
-%* *
-%************************************************************************
-
-This documentation is stolen directly from the HBC distribution. The
-modules that GHC does not support (because they require HBC-specific
-extensions) are omitted.
-
-\begin{description}
-\item[\tr{ListUtil}:]
-\index{ListUtil module (HBC library)}%
-Various useful functions involving lists that are missing from the
-\tr{Prelude}:
-\begin{verbatim}
-assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b
- -- assoc f d l k looks for k in the association list l, if it
- -- is found f is applied to the value, otherwise d is returned.
-concatMap :: (a -> [b]) -> [a] -> [b]
- -- flattening map (LML's concmap)
-unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
- -- unfoldr f p x repeatedly applies f to x until (p x) holds.
- -- (f x) should give a list element and a new x.
-mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
- -- mapAccuml f s l maps f over l, but also threads the state s
- -- through (LML's mapstate).
-union :: (Eq a) => [a] -> [a] -> [a]
- -- union of two lists
-intersection :: (Eq a) => [a] -> [a] -> [a]
- -- intersection of two lists
-chopList :: ([a] -> (b, [a])) -> [a] -> [b]
- -- LMLs choplist
-assocDef :: (Eq a) => [(a, b)] -> b -> a -> b
- -- LMLs assocdef
-lookup :: (Eq a) => [(a, b)] -> a -> Option b
- -- lookup l k looks for the key k in the association list l
- -- and returns an optional value
-tails :: [a] -> [[a]]
- -- return all the tails of a list
-rept :: (Integral a) => a -> b -> [b]
- -- repeat a value a number of times
-groupEq :: (a->a->Bool) -> [a] -> [[a]]
- -- group list elements according to an equality predicate
-group :: (Eq a) => [a] -> [[a]]
- -- group according to} ==
-readListLazily :: (Read a) => String -> [a]
- -- read a list in a lazy fashion
-\end{verbatim}
-
-\item[\tr{Pretty}:]
-\index{Pretty module (HBC library)}%
-John Hughes's pretty printing library.
-\begin{verbatim}
-type Context = (Bool, Int, Int, Int)
-type IText = Context -> [String]
-text :: String -> IText -- just text
-(~.) :: IText -> IText -> IText -- horizontal composition
-(^.) :: IText -> IText -> IText -- vertical composition
-separate :: [IText] -> IText -- separate by spaces
-nest :: Int -> IText -> IText -- indent
-pretty :: Int -> Int -> IText -> String -- format it
-\end{verbatim}
-
-\item[\tr{QSort}:]
-\index{QSort module (HBC library)}%
-A sort function using quicksort.
-\begin{verbatim}
-sortLe :: (a -> a -> Bool) -> [a] -> [a]
- -- sort le l sorts l with le as less than predicate
-sort :: (Ord a) => [a] -> [a]
- -- sort l sorts l using the Ord class
-\end{verbatim}
-
-\item[\tr{Random}:]
-\index{Random module (HBC library)}%
-Random numbers.
-\begin{verbatim}
-randomInts :: Int -> Int -> [Int]
- -- given two seeds gives a list of random Int
-randomDoubles :: Int -> Int -> [Double]
- -- random Double with uniform distribution in (0,1)
-normalRandomDoubles :: Int -> Int -> [Double]
- -- random Double with normal distribution, mean 0, variance 1
-\end{verbatim}
-
-\item[\tr{Trace}:]
-Simple tracing. (Note: This comes with GHC anyway.)
-\begin{verbatim}
-trace :: String -> a -> a -- trace x y prints x and returns y
-\end{verbatim}
-
-\item[\tr{Miranda}:]
-\index{Miranda module (HBC library)}%
-Functions found in the Miranda library.
-(Note: Miranda is a registered trade mark of Research Software Ltd.)
-
-\item[\tr{Word}:]
-\index{Word module (HBC library)}
-Bit manipulation. (GHC doesn't implement absolutely all of this.
-And don't count on @Word@ being 32 bits on a Alpha...)
-\begin{verbatim}
-class Bits a where
- bitAnd :: a -> a -> a -- bitwise and
- bitOr :: a -> a -> a -- bitwise or
- bitXor :: a -> a -> a -- bitwise xor
- bitCompl :: a -> a -- bitwise negation
- bitRsh :: a -> Int -> a -- bitwise right shift
- bitLsh :: a -> Int -> a -- bitwise left shift
- bitSwap :: a -> a -- swap word halves
- bit0 :: a -- word with least significant bit set
- bitSize :: a -> Int -- number of bits in a word
-
-data Byte -- 8 bit quantity
-data Short -- 16 bit quantity
-data Word -- 32 bit quantity
-
-instance Bits Byte, Bits Short, Bits Word
-instance Eq Byte, Eq Short, Eq Word
-instance Ord Byte, Ord Short, Ord Word
-instance Show Byte, Show Short, Show Word
-instance Num Byte, Num Short, Num Word
-wordToShorts :: Word -> [Short] -- convert a Word to two Short
-wordToBytes :: Word -> [Byte] -- convert a Word to four Byte
-bytesToString :: [Byte] -> String -- convert a list of Byte to a String (bit by bit)
-wordToInt :: Word -> Int -- convert a Word to Int
-shortToInt :: Short -> Int -- convert a Short to Int
-byteToInt :: Byte -> Int -- convert a Byte to Int
-\end{verbatim}
-
-\item[\tr{Time}:]
-\index{Time module (HBC library)}%
-Manipulate time values (a Double with seconds since 1970).
-\begin{verbatim}
--- year mon day hour min sec dec-sec weekday
-data Time = Time Int Int Int Int Int Int Double Int
-dblToTime :: Double -> Time -- convert a Double to a Time
-timeToDbl :: Time -> Double -- convert a Time to a Double
-timeToString :: Time -> String -- convert a Time to a readable String
-\end{verbatim}
-
-\item[\tr{Hash}:]
-\index{Hash module (HBC library)}%
-Hashing functions.
-\begin{verbatim}
-class Hashable a where
- hash :: a -> Int -- hash a value, return an Int
--- instances for all Prelude types
-hashToMax :: (Hashable a) => Int -> a -> Int -- hash into interval [0..x-1]
-\end{verbatim}
-
-\item[\tr{NameSupply}:]
-\index{NameSupply module (HBC library)}%
-Functions to generate unique names (Int).
-\begin{verbatim}
-type Name = Int
-initialNameSupply :: NameSupply
- -- The initial name supply (may be different every
- -- time the program is run.
-splitNameSupply :: NameSupply -> (NameSupply,NameSupply)
- -- split the namesupply into two
-getName :: NameSupply -> Name
- -- get the name associated with a name supply
-\end{verbatim}
-
-\item[\tr{Parse}:]
-\index{Parse module (HBC library)}%
-Higher order functions to build parsers. With a little care these
-combinators can be used to build efficient parsers with good error
-messages.
-\begin{verbatim}
-infixr 8 +.+ , ..+ , +..
-infix 6 `act` , >>> , `into` , .>
-infixr 4 ||| , ||! , |!!
-data ParseResult a b
-type Parser a b = a -> Int -> ParseResult a b
-(|||) :: Parser a b -> Parser a b -> Parser a b
- -- Alternative
-(||!) :: Parser a b -> Parser a b -> Parser a b
- -- Alternative, but with committed choice
-(|!!) :: Parser a b -> Parser a b -> Parser a b
- -- Alternative, but with committed choice
-(+.+) :: Parser a b -> Parser a c -> Parser a (b,c)
- -- Sequence
-(..+) :: Parser a b -> Parser a c -> Parser a c
- -- Sequence, throw away first part
-(+..) :: Parser a b -> Parser a c -> Parser a b
- -- Sequence, throw away second part
-act :: Parser a b -> (b->c) -> Parser a c
- -- Action
-(>>>) :: Parser a (b,c) -> (b->c->d) -> Parser a d
- -- Action on two items
-(.>) :: Parser a b -> c -> Parse a c
- -- Action ignoring value
-into :: Parser a b -> (b -> Parser a c) -> Parser a c
- -- Use a produced value in a parser.
-succeed b :: Parser a b
- -- Always succeeds without consuming a token
-failP :: Parser a b
- -- Always fails.
-many :: Parser a b -> Parser a [b]
- -- Kleene star
-many1 :: Parser a b -> Parser a [b]
- -- Kleene plus
-count :: Parser a b -> Int -> Parser a [b]
- -- Parse an exact number of items
-sepBy1 :: Parser a b -> Parser a c -> Parser a [b]
- -- Non-empty sequence of items separated by something
-sepBy :: Parser a b -> Parser a c -> Parser a [b]
- -- Sequence of items separated by something
-lit :: (Eq a, Show a) => a -> Parser [a] a
- -- Recognise a literal token from a list of tokens
-litp :: String -> (a->Bool) -> Parser [a] a
- -- Recognise a token with a predicate.
- -- The string is a description for error messages.
-testp :: String -> (a -> Bool) -> (Parser b a) -> Parser b a
- -- Test a semantic value.
-token :: (a -> Either String (b, a)) -> Parser a b
- -- General token recogniser.
-parse :: Parser a b -> a -> Either ([String], a) [(b, a)]
- -- Do a parse. Return either error (possible tokens and rest
- -- of tokens) or all possible parses.
-sParse :: (Show a) => (Parser [a] b) -> [a] -> Either String b
- -- Simple parse. Return error message or result.
-\end{verbatim}
-
-%%%simpleLex :: String -> [String] -- A simple (but useful) lexical analyzer
-
-\item[\tr{Native}:]
-\index{Native module (HBC library)}%
-Functions to convert the primitive types \tr{Int}, \tr{Float}, and \tr{Double} to
-their native representation as a list of bytes (\tr{Char}). If such a list
-is read/written to a file it will have the same format as when, e.g.,
-C read/writes the same kind of data.
-\begin{verbatim}
-type Bytes = [Char] -- A byte stream is just a list of characters
-
-class Native a where
- showBytes :: a -> Bytes -> Bytes
- -- prepend the representation of an item the a byte stream
- listShowBytes :: [a] -> Bytes -> Bytes
- -- prepend the representation of a list of items to a stream
- -- (may be more efficient than repeating showBytes).
- readBytes :: Bytes -> Maybe (a, Bytes)
- -- get an item from the stream and return the rest,
- -- or fail if the stream is to short.
- listReadBytes :: Int -> Bytes -> Maybe ([a], Bytes)
- -- read n items from a stream.
-
-instance Native Int
-instance Native Float
-instance Native Double
-instance (Native a, Native b) => Native (a,b)
- -- juxtaposition of the two items
-instance (Native a, Native b, Native c) => Native (a, b, c)
- -- juxtaposition of the three items
-instance (Native a) => Native [a]
- -- an item count in an Int followed by the items
-
-shortIntToBytes :: Int -> Bytes -> Bytes
- -- Convert an Int to what corresponds to a short in C.
-bytesToShortInt :: Bytes -> Maybe (Int, Bytes)
- -- Get a short from a byte stream and convert to an Int.
-
-showB :: (Native a) => a -> Bytes -- Simple interface to showBytes.
-readB :: (Native a) => Bytes -> a -- Simple interface to readBytes.
-\end{verbatim}
-
-\item[\tr{Number}:]
-\index{Number module (HBC library)}%
-Simple numbers that belong to all numeric classes and behave like
-a naive user would expect (except that printing is still ugly).
-(NB: GHC does not provide a magic way to use \tr{Numbers} everywhere,
-but you should be able to do it with normal \tr{import}ing and
-\tr{default}ing.)
-\begin{verbatim}
-data Number -- The type itself.
-instance ... -- All reasonable instances.
-isInteger :: Number -> Bool -- Test if a Number is an integer.
-\end{verbatim}
-\end{description}
-
-%************************************************************************
-%* *
-\subsection[contrib-library]{The `contrib' system library}
-\index{contrib system library}
-\index{system library, contrib}
-%* *
-%************************************************************************
-
-Just for a bit of fun, we took all the old contributed ``Haskell
-library'' code---Stephen J.~Bevan the main hero, converted it to
-Haskell~1.3 and heaved it into a \tr{contrib} system library. It is
-mostly code for numerical methods (@SetMap@ is an exception); we have
-{\em no idea} whether it is any good or not.
-
-The modules provided are:
-@Adams_Bashforth_Approx@,
-@Adams_Predictor_Corrector_Approx@,
-@Choleski_Factorization@,
-@Crout_Reduction@,
-@Cubic_Spline@,
-@Fixed_Point_Approx@,
-@Gauss_Seidel_Iteration@,
-@Hermite_Interpolation@,
-@Horner@,
-@Jacobi_Iteration@,
-@LLDecompMethod@,
-@Least_Squares_Fit@,
-@Matrix_Ops@,
-@Neville_Iterated_Interpolation@,
-@Newton_Cotes@,
-@Newton_Interpolatory_Divided_Difference@,
-@Newton_Raphson_Approx@,
-@Runge_Kutta_Approx@,
-@SOR_Iteration@,
-@Secant_Approx@,
-@SetMap@,
-@Steffensen_Approx@,
-@Taylor_Approx@, and
-@Vector_Ops@.
+++ /dev/null
--- Test module for Finite Maps
-
-module Main where
-
-import IO
-import FiniteMap
-import Util
-
-main = hGetContents stdin >>= \ input ->
- let (s1, rest1) = rd_int input
- r1 = test1 s1
-
- (s2, rest2) = rd_int rest1
- r2 = test2 s2
- in
- putStr r1 >>
- putStr r2
-
-rd_int = \ i -> (head (reads i)) :: (Int,String)
-
-
--------------------------------------------------------------
---Test 1 creates two big maps with the same domain, mapping
---each domain elt to 1.
-
-test1 :: Int -- Size of maps
- -> String
-
-test1 size
- = "Test 1" ++ "\n" ++
- "N = " ++ show size ++ "\n" ++
- "Tot sum = " ++
--- show (fmToList fm1) ++ show (fmToList fm2) ++ show (fmToList sum_fm) ++
- show tot_sum ++ "\n" ++
- "Differences: " ++ diff ++ "\n" ++
- "Sum intersection:" ++ show sum_int ++ "\n\n"
- where
- fm1,fm2 :: FiniteMap Int Int
- fm1 = listToFM [(i,1) | i <- [1..size-1]]
- fm2 = listToFM [(i,1) | i <- [size,size-1..2]]
-
- -- Take their sum
- sum_fm = plusFM_C (+) fm1 fm2
- tot_sum = sum (map get [1..size])
- get n = lookupWithDefaultFM sum_fm (error ("lookup" ++ show n)) n
- -- Should be 1 + (size-2)*2 + 1 = 2*size - 2
-
-
- -- Take their difference
- diff_fm1 = fm1 `minusFM` fm2 -- Should be a singleton
- diff_fm2 = fm2 `minusFM` fm1 -- Should be a singleton
- diff = show (fmToList diff_fm1) ++ "; " ++ show (fmToList diff_fm2)
-
- -- Take their intersection
- int_fm = intersectFM_C (+) fm1 fm2
- sum_int = foldFM (\k n tot -> n+tot) 0 int_fm
-
-
-test2 :: Int -- No of maps
- -> String
-
-test2 size
- = "Test 2" ++ "\n" ++
- "N = " ++ show size ++ "\n" ++
- "Sizes =" ++ show [sizeFM fm1,sizeFM fm2] ++ "\n" ++
- "Sums = " ++ show [sum1,sum2] ++ "\n\n"
- where
- fm1,fm2 :: FiniteMap Int Int
-
- fms1 = [unitFM i 1 | i <- [1..size]]
- fm1 = foldr (plusFM_C (+)) emptyFM fms1
-
- fms2 = [unitFM 1 i | i <- [1..size]]
- fm2 = foldr (plusFM_C (+)) emptyFM fms2
-
- sum1 = foldr (+) 0 (eltsFM fm1)
- sum2 = foldr (+) 0 (eltsFM fm2)
+++ /dev/null
-TOP = ../../..
-include $(TOP)/mk/boilerplate.mk
-SRC_HC_OPTS += -syslib ghc
-SRC_RUNTEST_OPTS += +RTS -H25m -RTS
-include $(TOP)/mk/target.mk
+++ /dev/null
-13133
-9798
+++ /dev/null
-Test 1
-N = 13133
-Tot sum = 26264
-Differences: [(1, 1)]; [(13133, 1)]
-Sum intersection:26262
-
-Test 2
-N = 9798
-Sizes =[9798, 1]
-Sums = [9798, 48005301]
-
+++ /dev/null
-#
-# $Id: Makefile,v 1.8 1999/10/05 10:30:29 simonmar Exp $
-#
-# Makefile for POSIX library
-#
-
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-WAYS=$(GhcLibWays)
-
-ifeq "$(way)" ""
-SUBDIRS = cbits
-else
-SUBDIRS=
-endif
-
-HC = $(GHC)
-
-#-----------------------------------------------------------------------------
-# Setting the standard variables
-#
-
-LIBRARY = libHSposix$(_way).a
-HS_SRCS = $(wildcard *.lhs)
-LIBOBJS = $(HS_OBJS)
-HS_IFACES= $(HS_SRCS:.lhs=.$(way_)hi)
-SRC_MKDEPENDHS_OPTS += -optdep--include-prelude
-
-#-----------------------------------------------------------------------------
-# Setting the GHC compile options
-
-SRC_HC_OPTS += -i../misc -recomp -cpp -fglasgow-exts -fvia-C -Rghc-timing $(GhcLibHcOpts)
-
-#
-# Profiling options
-WAY_p_HC_OPTS += -GPrelude
-WAY_mr_HC_OPTS += -GPrelude
-
-#
-# Object and interface files have suffixes tagged with their ways
-#
-ifneq "$(way)" ""
-SRC_HC_OPTS += -hisuf $(way_)hi
-endif
-
-#
-# Specific flags
-#
-PosixUtil_HC_OPTS ='-\#include"cbits/libposix.h"' -monly-3-regs
-PosixDB_HC_OPTS ='-\#include"cbits/libposix.h"'
-PosixErr_HC_OPTS ='-\#include"cbits/libposix.h"'
-PosixFiles_HC_OPTS ='-\#include"cbits/libposix.h"'
-PosixIO_HC_OPTS ='-\#include"cbits/libposix.h"'
-PosixProcEnv_HC_OPTS ='-\#include"cbits/libposix.h"'
-PosixProcPrim_HC_OPTS ='-\#include"cbits/libposix.h"'
-PosixTTY_HC_OPTS ='-\#include"cbits/libposix.h"' -monly-2-regs
-Posix_HC_OPTS ='-\#include"cbits/libposix.h"'
-
-PosixProcPrim_HC_OPTS += -H8m
-PosixFiles_HC_OPTS += -H8m
-
-# sigh.
-../misc/PackedString_HC_OPTS += -H8m
-
-#-----------------------------------------------------------------------------
-# Dependency generation
-
-SRC_MKDEPENDHS_OPTS += -I$(GHC_INCLUDE_DIR)
-
-#-----------------------------------------------------------------------------
-# Installation; need to install .hi files as well as libraries
-#
-# The interface files are put inside the $(libdir), since they
-# might (potentially) be platform specific..
-#
-# override is used here because for binary distributions, datadir is
-# set on the command line. sigh.
-#
-override datadir:=$(libdir)/imports/posix
-
-#
-# Files to install from here
-#
-INSTALL_LIBS += $(LIBRARY)
-INSTALL_DATAS += $(HS_IFACES)
-
-include $(TOP)/mk/target.mk
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
-%
-\section[Posix]{Haskell 1.3 POSIX bindings}
-
-\begin{code}
-{-# OPTIONS -#include "../std/cbits/stgio.h" #-}
-module Posix (
- module PosixDB,
- module PosixErr,
- module PosixFiles,
- module PosixIO,
- module PosixProcEnv,
- module PosixProcPrim,
- module PosixTTY,
-
- runProcess,
-
- ByteCount,
- Fd, intToFd,
- ClockTick,
- EpochTime,
- FileOffset,
- GroupID,
- Limit,
- LinkCount,
- ProcessID,
- ProcessGroupID,
- UserID,
-
- ExitCode
-
- ) where
-
-import PrelBase
-import PrelIOBase
-import IO
-import PrelHandle
-
-import PosixDB
-import PosixErr
-import PosixFiles
-import PosixIO
-import PosixProcEnv
-import PosixProcPrim
-import PosixTTY
-import PosixUtil
-
--- [OLD COMMENT:]
--- runProcess is our candidate for the high-level OS-independent primitive
--- If accepted, it will be moved out of Posix into LibSystem.
---
--- ***NOTE***: make sure you completely force the evaluation of the path
--- and arguments to the child before calling runProcess. If you don't do
--- this *and* the arguments from runProcess are read in from a file lazily,
--- be prepared for some rather weird parent-child file I/O behaviour.
---
--- [If you don't force the args, consider the case where the
--- arguments emanate from a file that is read lazily, using hGetContents
--- or some such. Since a child of a fork() inherits the opened files of
--- the parent, the child can force the evaluation of the arguments and
--- read them off the file without any problems. The problem is that
--- while the child share a file table with the parent, it has
--- separate buffers, so a child may fill up its (copy of) the buffer, but
--- only read it partially. When the *parent* tries to read from the shared file again,
--- the (shared) file offset will have been stepped on by whatever number of chars
--- that was copied into the file buffer of the child. i.e., the unused parts of the
--- buffer will *not* be seen, resulting in random/unpredicatable results.
---
--- Based on a true (, debugged :-) story.
--- ]
-
-import Directory ( setCurrentDirectory )
-
-
-runProcess :: FilePath -- Command
- -> [String] -- Arguments
- -> Maybe [(String, String)] -- Environment
- -> Maybe FilePath -- Working directory
- -> Maybe Handle -- stdin
- -> Maybe Handle -- stdout
- -> Maybe Handle -- stderr
- -> IO ()
-runProcess path args env dir stdin stdout stderr = do
- pid <- forkProcess
- case pid of
- Nothing -> doTheBusiness
- Just _ -> return ()
- where
- doTheBusiness :: IO ()
- doTheBusiness = do
- maybeChangeWorkingDirectory
- maybeDup2 0 stdin
- maybeDup2 1 stdout
- maybeDup2 2 stderr
- executeFile path True args env
- syserr "runProcess"
-
- maybeChangeWorkingDirectory :: IO ()
- maybeChangeWorkingDirectory =
- case dir of
- Nothing -> return ()
- Just x -> setCurrentDirectory x
-
- maybeDup2 :: Int -> Maybe Handle -> IO ()
- maybeDup2 dest h =
- case h of Nothing -> return ()
- Just x -> do
- src <- handleToFd x
- dupTo src (intToFd dest)
- return ()
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1997
-%
-\section[PosixDB]{Haskell 1.4 POSIX System Databases}
-
-\begin{code}
-module PosixDB (
- GroupEntry(..),
- UserEntry(..),
-
- getUserEntryForID, -- :: UserID -> IO UserEntry
- getUserEntryForName, -- :: String -> IO UserEntry
-
- getGroupEntryForID, -- :: GroupID -> IO GroupEntry
- getGroupEntryForName -- :: String -> IO GroupEntry
-
- ) where
-
-import ST
-import PrelIOBase
-import Addr
-import IO
-import PosixUtil
-import CString ( unvectorize, strcpy, packStringIO )
-\end{code}
-
-
-\begin{code}
-
-data GroupEntry =
- GroupEntry {
- groupName :: String,
- groupID :: GroupID,
- groupMembers :: [String]
- }
-
-data UserEntry =
- UserEntry {
- userName :: String,
- userID :: UserID,
- userGroupID :: GroupID,
- homeDirectory :: String,
- userShell :: String
- }
-
-
-getGroupEntryForID :: GroupID -> IO GroupEntry
-getGroupEntryForID gid = do
- ptr <- _ccall_ getgrgid gid
- if ptr == nullAddr then
- ioError (IOError Nothing NoSuchThing
- "getGroupEntryForID" "no such group entry")
- else
- unpackGroupEntry ptr
-
-getGroupEntryForName :: String -> IO GroupEntry
-getGroupEntryForName name = do
- gname <- packStringIO name
- ptr <- _ccall_ getgrnam gname
- if ptr == nullAddr then
- ioError (IOError Nothing NoSuchThing
- "getGroupEntryForName" "no such group entry")
- else
- unpackGroupEntry ptr
-
-getUserEntryForID :: UserID -> IO UserEntry
-getUserEntryForID uid = do
- ptr <- _ccall_ getpwuid uid
- if ptr == nullAddr then
- ioError (IOError Nothing NoSuchThing
- "getUserEntryForID" "no such user entry")
- else
- unpackUserEntry ptr
-
-getUserEntryForName :: String -> IO UserEntry
-getUserEntryForName name = do
- uname <- packStringIO name
- ptr <- _ccall_ getpwnam uname
- if ptr == nullAddr then
- ioError (IOError Nothing NoSuchThing
- "getUserEntryForName" "no such user entry")
- else
- unpackUserEntry ptr
-\end{code}
-
-Local utility functions
-
-\begin{code}
--- Copy the static structure returned by getgr* into a Haskell structure
-
-unpackGroupEntry :: Addr -> IO GroupEntry
-unpackGroupEntry ptr =
- do
- str <- _casm_ ``%r = ((struct group *)%0)->gr_name;'' ptr
- name <- strcpy str
- gid <- _casm_ ``%r = ((struct group *)%0)->gr_gid;'' ptr
- mem <- _casm_ ``%r = ((struct group *)%0)->gr_mem;'' ptr
- members <- unvectorize mem 0
- return (GroupEntry name gid members)
-
--- Copy the static structure returned by getpw* into a Haskell structure
-
-unpackUserEntry :: Addr -> IO UserEntry
-unpackUserEntry ptr =
- do
- str <- _casm_ ``%r = ((struct passwd *)%0)->pw_name;'' ptr
- name <- strcpy str
- uid <- _casm_ ``%r = ((struct passwd *)%0)->pw_uid;'' ptr
- gid <- _casm_ ``%r = ((struct passwd *)%0)->pw_gid;'' ptr
- str <- _casm_ ``%r = ((struct passwd *)%0)->pw_dir;'' ptr
- home <- strcpy str
- str <- _casm_ ``%r = ((struct passwd *)%0)->pw_shell;'' ptr
- shell <- strcpy str
- return (UserEntry name uid gid home shell)
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
-%
-\section[PosixErr]{Haskell 1.3 POSIX Error Codes}
-
-\begin{code}
-module PosixErr where
-
-import ST
-import PrelIOBase
-
-type ErrorCode = Int
-
-getErrorCode :: IO ErrorCode
-getErrorCode = do
- errno <- _casm_ ``%r = errno;''
- return errno
-
-setErrorCode :: ErrorCode -> IO ()
-setErrorCode errno = do
- _casm_ ``errno = %0;'' errno
- return ()
-
-noError :: ErrorCode
-noError = 0
-
-argumentListTooLong, e2BIG :: ErrorCode
-argumentListTooLong = ``E2BIG''
-e2BIG = ``E2BIG''
-
-badFd, eBADF :: ErrorCode
-badFd = ``EBADF''
-eBADF = ``EBADF''
-
-brokenPipe, ePIPE :: ErrorCode
-brokenPipe = ``EPIPE''
-ePIPE = ``EPIPE''
-
-directoryNotEmpty, eNOTEMPTY :: ErrorCode
-directoryNotEmpty = ``ENOTEMPTY''
-eNOTEMPTY = ``ENOTEMPTY''
-
-execFormatError, eNOEXEC :: ErrorCode
-execFormatError = ``ENOEXEC''
-eNOEXEC = ``ENOEXEC''
-
-fileAlreadyExists, eEXIST :: ErrorCode
-fileAlreadyExists = ``EEXIST''
-eEXIST = ``EEXIST''
-
-fileTooLarge, eFBIG :: ErrorCode
-fileTooLarge = ``EFBIG''
-eFBIG = ``EFBIG''
-
-filenameTooLong, eNAMETOOLONG :: ErrorCode
-filenameTooLong = ``ENAMETOOLONG''
-eNAMETOOLONG = ``ENAMETOOLONG''
-
-improperLink, eXDEV :: ErrorCode
-improperLink = ``EXDEV''
-eXDEV = ``EXDEV''
-
-inappropriateIOControlOperation, eNOTTY :: ErrorCode
-inappropriateIOControlOperation = ``ENOTTY''
-eNOTTY = ``ENOTTY''
-
-inputOutputError, eIO :: ErrorCode
-inputOutputError = ``EIO''
-eIO = ``EIO''
-
-interruptedOperation, eINTR :: ErrorCode
-interruptedOperation = ``EINTR''
-eINTR = ``EINTR''
-
-invalidArgument, eINVAL :: ErrorCode
-invalidArgument = ``EINVAL''
-eINVAL = ``EINVAL''
-
-invalidSeek, eSPIPE :: ErrorCode
-invalidSeek = ``ESPIPE''
-eSPIPE = ``ESPIPE''
-
-isADirectory, eISDIR :: ErrorCode
-isADirectory = ``EISDIR''
-eISDIR = ``EISDIR''
-
-noChildProcess, eCHILD :: ErrorCode
-noChildProcess = ``ECHILD''
-eCHILD = ``ECHILD''
-
-noLocksAvailable, eNOLCK :: ErrorCode
-noLocksAvailable = ``ENOLCK''
-eNOLCK = ``ENOLCK''
-
-noSpaceLeftOnDevice, eNOSPC :: ErrorCode
-noSpaceLeftOnDevice = ``ENOSPC''
-eNOSPC = ``ENOSPC''
-
-noSuchOperationOnDevice, eNODEV :: ErrorCode
-noSuchOperationOnDevice = ``ENODEV''
-eNODEV = ``ENODEV''
-
-noSuchDeviceOrAddress, eNXIO :: ErrorCode
-noSuchDeviceOrAddress = ``ENXIO''
-eNXIO = ``ENXIO''
-
-noSuchFileOrDirectory, eNOENT :: ErrorCode
-noSuchFileOrDirectory = ``ENOENT''
-eNOENT = ``ENOENT''
-
-noSuchProcess, eSRCH :: ErrorCode
-noSuchProcess = ``ESRCH''
-eSRCH = ``ESRCH''
-
-notADirectory, eNOTDIR :: ErrorCode
-notADirectory = ``ENOTDIR''
-eNOTDIR = ``ENOTDIR''
-
-notEnoughMemory, eNOMEM :: ErrorCode
-notEnoughMemory = ``ENOMEM''
-eNOMEM = ``ENOMEM''
-
-operationNotImplemented, eNOSYS :: ErrorCode
-operationNotImplemented = ``ENOSYS''
-eNOSYS = ``ENOSYS''
-
-operationNotPermitted, ePERM :: ErrorCode
-operationNotPermitted = ``EPERM''
-ePERM = ``EPERM''
-
-permissionDenied, eACCES :: ErrorCode
-permissionDenied = ``EACCES''
-eACCES = ``EACCES''
-
-readOnlyFileSystem, eROFS :: ErrorCode
-readOnlyFileSystem = ``EROFS''
-eROFS = ``EROFS''
-
-resourceBusy, eBUSY :: ErrorCode
-resourceBusy = ``EBUSY''
-eBUSY = ``EBUSY''
-
-resourceDeadlockAvoided, eDEADLK :: ErrorCode
-resourceDeadlockAvoided = ``EDEADLK''
-eDEADLK = ``EDEADLK''
-
-resourceTemporarilyUnavailable, eAGAIN :: ErrorCode
-resourceTemporarilyUnavailable = ``EAGAIN''
-eAGAIN = ``EAGAIN''
-
-tooManyLinks, eMLINK :: ErrorCode
-tooManyLinks = ``EMLINK''
-eMLINK = ``EMLINK''
-
-tooManyOpenFiles, eMFILE :: ErrorCode
-tooManyOpenFiles = ``EMFILE''
-eMFILE = ``EMFILE''
-
-tooManyOpenFilesInSystem, eNFILE :: ErrorCode
-tooManyOpenFilesInSystem = ``ENFILE''
-eNFILE = ``ENFILE''
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
-%
-\section[PosixFiles]{Haskell 1.3 POSIX File and Directory Operations}
-
-\begin{code}
-module PosixFiles (
-
- -- Directory streams
- DirStream,
- openDirStream, closeDirStream,
- readDirStream, rewindDirStream,
-
- -- set/get process' working directory.
- getWorkingDirectory, changeWorkingDirectory,
-
- -- File modes/permissions
- FileMode,
- nullFileMode,
- ownerReadMode, ownerWriteMode, ownerExecuteMode, ownerModes,
- groupReadMode, groupWriteMode, groupExecuteMode, groupModes,
- otherReadMode, otherWriteMode, otherExecuteMode, otherModes,
- setUserIDMode, setGroupIDMode,
- stdFileMode, accessModes,
-
- unionFileModes, intersectFileModes,
-
- -- File operations on descriptors
- stdInput, stdOutput, stdError,
- OpenMode(..),
- OpenFileFlags(..), defaultFileFlags,
- openFd, createFile,
-
- -- other file&directory operations
- setFileCreationMask,
- createLink, removeLink,
- createDirectory, removeDirectory,
- createNamedPipe,
- rename,
-
- -- FileStatus
- FileStatus,
- getFileStatus, getFdStatus,
- fileExist,
- fileAccess,
- setFileMode,
-
- fileMode,
- fileID, FileID,
- deviceID, DeviceID,
- linkCount,
- fileOwner, fileGroup,
- fileSize,
- accessTime, modificationTime, statusChangeTime,
- isDirectory, isCharacterDevice,
- isBlockDevice, isRegularFile,
- isNamedPipe,
-
- setOwnerAndGroup, -- chown (might be restricted)
- setFileTimes, -- set access and modification time
- touchFile, -- set access and modification time to current time.
-
- -- run-time limit & POSIX feature testing
- PathVar(..),
- getPathVar,
- getFileVar
-
- ) where
-
-import PrelST
-import ST
-import PrelIOBase
-import IO
-import IOExts ( unsafePerformIO )
-import CString ( packStringIO, allocChars,
- freeze, strcpy
- )
-import Addr
-import CCall
-import PrelBase hiding( append )
-import ByteArray
-
-import PosixErr
-import PosixUtil
-import Directory ( removeDirectory, -- re-use its code
- getCurrentDirectory,
- setCurrentDirectory
- )
-
-\end{code}
-
-%************************************************************
-%* *
-\subsection[DirStream]{POSIX Directory streams}
-%* *
-%************************************************************
-
-Accessing directories is done in POSIX via @DIR@ streams, with
-operations for opening, closing, reading and rewinding the current
-pointer in a directory.
-
-{\bf Note:} The standard interface @Directory@ provides the
-operation @getDirectoryContents@ which returns the directory contents of a
-specified file path, which supplants some of the raw @DirStream@ operations
-defined here.
-
-\begin{code}
-
-data DirStream = DirStream# Addr#
-instance CCallable DirStream
-instance CReturnable DirStream
-
-openDirStream :: FilePath -> IO DirStream
-openDirStream name =
- packStringIO name >>= \dir ->
- _ccall_ opendir dir >>= \dirp@(A# dirp#) ->
- if dirp /= nullAddr
- then return (DirStream# dirp#)
- else syserr "openDirStream"
-
-readDirStream :: DirStream -> IO String
-readDirStream dirp = do
- setErrorCode noError
- dirent <- _ccall_ readdir dirp
- if dirent /= nullAddr
- then do
- str <- _casm_ ``%r = ((struct dirent *)%0)->d_name;'' dirent
- name <- strcpy str
- return name
- else do
- errno <- getErrorCode
- if errno == noError
- then ioError (IOError Nothing EOF "readDirStream" "EOF")
- else syserr "readDirStream"
-
-rewindDirStream :: DirStream -> IO ()
-rewindDirStream dirp = do
- _ccall_ rewinddir dirp
- return ()
-
-closeDirStream :: DirStream -> IO ()
-closeDirStream dirp = do
- rc <- _ccall_ closedir dirp
- if rc == (0::Int)
- then return ()
- else syserr "closeDirStream"
-
-{-
- Renamings of functionality provided via Directory interface,
- kept around for b.wards compatibility and for having more POSIXy
- names
--}
-getWorkingDirectory :: IO FilePath
-getWorkingDirectory = getCurrentDirectory
-
-changeWorkingDirectory :: FilePath -> IO ()
-changeWorkingDirectory name = setCurrentDirectory name
-\end{code}
-
-%************************************************************
-%* *
-\subsection[FileMode]{POSIX File modes}
-%* *
-%************************************************************
-
-The abstract type @FileMode@ and constants and operators for manipulating the
-file modes defined by POSIX.
-
-\begin{code}
-
-data FileMode = FileMode# Word#
-instance CCallable FileMode
-instance CReturnable FileMode
-
-nullFileMode :: FileMode
-nullFileMode = FileMode# (case ``0'' of { W# x -> x})
-
-ownerReadMode :: FileMode
-ownerReadMode = FileMode# (case ``S_IRUSR'' of { W# x -> x})
-
-ownerWriteMode :: FileMode
-ownerWriteMode = FileMode# (case ``S_IWUSR'' of { W# x -> x})
-
-ownerExecuteMode :: FileMode
-ownerExecuteMode = FileMode# (case ``S_IXUSR'' of { W# x -> x})
-
-groupReadMode :: FileMode
-groupReadMode = FileMode# (case ``S_IRGRP'' of { W# x -> x})
-
-groupWriteMode :: FileMode
-groupWriteMode = FileMode# (case ``S_IWGRP'' of { W# x -> x})
-
-groupExecuteMode :: FileMode
-groupExecuteMode = FileMode# (case ``S_IXGRP'' of { W# x -> x})
-
-otherReadMode :: FileMode
-otherReadMode = FileMode# (case ``S_IROTH'' of { W# x -> x})
-
-otherWriteMode :: FileMode
-otherWriteMode = FileMode# (case ``S_IWOTH'' of { W# x -> x})
-
-otherExecuteMode :: FileMode
-otherExecuteMode = FileMode# (case ``S_IXOTH'' of { W# x -> x})
-
-setUserIDMode :: FileMode
-setUserIDMode = FileMode# (case ``S_ISUID'' of { W# x -> x})
-
-setGroupIDMode :: FileMode
-setGroupIDMode = FileMode# (case ``S_ISGID'' of { W# x -> x})
-
-stdFileMode :: FileMode
-stdFileMode = FileMode# (case ``(S_IRUSR|S_IWUSR|S_IRGRP|S_IWGRP|S_IROTH|S_IWOTH)'' of { W# x -> x})
-
-ownerModes :: FileMode
-ownerModes = FileMode# (case ``S_IRWXU'' of { W# x -> x})
-
-groupModes :: FileMode
-groupModes = FileMode# (case ``S_IRWXG'' of { W# x -> x})
-
-otherModes :: FileMode
-otherModes = FileMode# (case ``S_IRWXO'' of { W# x -> x})
-
-accessModes :: FileMode
-accessModes = FileMode# (case ``(S_IRWXU|S_IRWXG|S_IRWXO)'' of { W# x -> x})
-
-unionFileModes :: FileMode -> FileMode -> FileMode
-unionFileModes (FileMode# m1#) (FileMode# m2#) = FileMode# (m1# `or#` m2#)
-
-intersectFileModes :: FileMode -> FileMode -> FileMode
-intersectFileModes (FileMode# m1#) (FileMode# m2#) = FileMode# (m1# `and#` m2#)
-
-\end{code}
-
-%************************************************************
-%* *
-\subsection[FileDescriptor]{POSIX File descriptors}
-%* *
-%************************************************************
-
-File descriptors (formerly @Channel@s) are the lowest level
-handles to file objects.
-
-\begin{code}
-stdInput, stdOutput, stdError :: Fd
-stdInput = intToFd 0
-stdOutput = intToFd 1
-stdError = intToFd 2
-
-data OpenMode = ReadOnly | WriteOnly | ReadWrite
-
-data OpenFileFlags =
- OpenFileFlags {
- append :: Bool,
- exclusive :: Bool,
- noctty :: Bool,
- nonBlock :: Bool,
- trunc :: Bool
- }
-
-defaultFileFlags :: OpenFileFlags
-defaultFileFlags =
- OpenFileFlags {
- append = False,
- exclusive = False,
- noctty = False,
- nonBlock = False,
- trunc = False
- }
-
-openFd :: FilePath
- -> OpenMode
- -> Maybe FileMode -- Just x => O_CREAT, Nothing => must exist
- -> OpenFileFlags
- -> IO Fd
-openFd name how maybe_mode (OpenFileFlags append exclusive noctty nonBlock truncate) =
- packStringIO name >>= \file ->
- _ccall_ open file flags mode_w >>= \fd@(I# fd#) ->
- if fd /= ((-1)::Int)
- then return (FD# fd#)
- else syserr "openFd"
- where
- mode_w = case maybe_mode of { Nothing -> ``0'' ; Just x -> x }
- flags = W# (creat# `or#` flags# `or#` how#)
-
- or (W# x#) (W# y#) = W# (x# `or#` y#)
-
- (W# flags#) =
- (if append then ``O_APPEND'' else zero) `or`
- (if exclusive then ``O_EXCL'' else zero) `or`
- (if noctty then ``O_NOCTTY'' else zero) `or`
- (if nonBlock then ``O_NONBLOCK'' else zero) `or`
- (if truncate then ``O_TRUNC'' else zero)
-
- zero = W# (int2Word# 0#)
-
- creat# =
- case (case maybe_mode of {
- Nothing -> zero ;
- Just _ -> ``O_CREAT'' }) of {
- W# x -> x }
-
- how# =
- case
- (case how of { ReadOnly -> ``O_RDONLY'';
- WriteOnly -> ``O_WRONLY'';
- ReadWrite -> ``O_RDWR''}) of {
- W# x -> x }
-
-createFile :: FilePath -> FileMode -> IO Fd
-createFile name mode =
- packStringIO name >>= \file ->
- _ccall_ creat file mode >>= \fd@(I# fd#) ->
- if fd /= ((-1)::Int)
- then return (FD# fd#)
- else syserr "createFile"
-
-setFileCreationMask :: FileMode -> IO FileMode
-setFileCreationMask mask = _ccall_ umask mask
-
-createLink :: FilePath -> FilePath -> IO ()
-createLink name1 name2 = do
- path1 <- packStringIO name1
- path2 <- packStringIO name2
- rc <- _ccall_ link path1 path2
- if rc == (0::Int)
- then return ()
- else syserr "createLink"
-
-createDirectory :: FilePath -> FileMode -> IO ()
-createDirectory name mode = do -- NB: diff signature from LibDirectory one!
- dir <- packStringIO name
- rc <- _ccall_ mkdir dir mode
- if rc == (0::Int)
- then return ()
- else syserr "createDirectory"
-
-createNamedPipe :: FilePath -> FileMode -> IO ()
-createNamedPipe name mode = do
- pipe <- packStringIO name
- rc <-_ccall_ mkfifo pipe mode
- if rc == (0::Int)
- then return ()
- else syserr "createNamedPipe"
-
-removeLink :: FilePath -> IO ()
-removeLink name = do
- path <- packStringIO name
- rc <-_ccall_ unlink path
- if rc == (0::Int)
- then return ()
- else syserr "removeLink"
-
-rename :: FilePath -> FilePath -> IO ()
-rename name1 name2 = do
- path1 <- packStringIO name1
- path2 <- packStringIO name2
- rc <- _ccall_ rename path1 path2
- if rc == (0::Int)
- then return ()
- else syserr "rename"
-
-type FileStatus = ByteArray Int
-type FileID = Int
-type DeviceID = Int
-
-fileMode :: FileStatus -> FileMode
-fileMode stat = unsafePerformIO $
- _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat
-
-fileID :: FileStatus -> FileID
-fileID stat = unsafePerformIO $
- _casm_ ``%r = ((struct stat *)%0)->st_ino;'' stat
-
-deviceID :: FileStatus -> DeviceID
-deviceID stat = unsafePerformIO $
- _casm_ ``%r = ((struct stat *)%0)->st_dev;'' stat
-
-linkCount :: FileStatus -> LinkCount
-linkCount stat = unsafePerformIO $
- _casm_ ``%r = ((struct stat *)%0)->st_nlink;'' stat
-
-fileOwner :: FileStatus -> UserID
-fileOwner stat = unsafePerformIO $
- _casm_ ``%r = ((struct stat *)%0)->st_uid;'' stat
-
-fileGroup :: FileStatus -> GroupID
-fileGroup stat = unsafePerformIO $
- _casm_ ``%r = ((struct stat *)%0)->st_gid;'' stat
-
-fileSize :: FileStatus -> FileOffset
-fileSize stat = unsafePerformIO $
- _casm_ ``%r = ((struct stat *)%0)->st_size;'' stat
-
-accessTime :: FileStatus -> EpochTime
-accessTime stat = unsafePerformIO $
- _casm_ ``%r = ((struct stat *)%0)->st_atime;'' stat
-
-modificationTime :: FileStatus -> EpochTime
-modificationTime stat = unsafePerformIO $
- _casm_ ``%r = ((struct stat *)%0)->st_mtime;'' stat
-
-statusChangeTime :: FileStatus -> EpochTime
-statusChangeTime stat = unsafePerformIO $
- _casm_ ``%r = ((struct stat *)%0)->st_ctime;'' stat
-
-isDirectory :: FileStatus -> Bool
-isDirectory stat = unsafePerformIO $
- _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat >>= \ rc ->
- return (rc /= (0::Int))
-
-isCharacterDevice :: FileStatus -> Bool
-isCharacterDevice stat = unsafePerformIO $
- _casm_ ``%r = S_ISCHR(((struct stat *)%0)->st_mode);'' stat >>= \ rc ->
- return (rc /= (0::Int))
-
-isBlockDevice :: FileStatus -> Bool
-isBlockDevice stat = unsafePerformIO $
- _casm_ ``%r = S_ISBLK(((struct stat *)%0)->st_mode);'' stat >>= \ rc ->
- return (rc /= (0::Int))
-
-isRegularFile :: FileStatus -> Bool
-isRegularFile stat = unsafePerformIO $
- _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat >>= \ rc ->
- return (rc /= (0::Int))
-
-isNamedPipe :: FileStatus -> Bool
-isNamedPipe stat = unsafePerformIO $
- _casm_ ``%r = S_ISFIFO(((struct stat *)%0)->st_mode);'' stat >>= \ rc ->
- return (rc /= (0::Int))
-
-getFileStatus :: FilePath -> IO FileStatus
-getFileStatus name = do
- path <- packStringIO name
- bytes <- allocChars ``sizeof(struct stat)''
- rc <- _casm_ ``%r = stat(%0,(struct stat *)%1);'' path bytes
- if rc == (0::Int)
- then do
- stat <- freeze bytes
- return stat
- else syserr "getFileStatus"
-
-getFdStatus :: Fd -> IO FileStatus
-getFdStatus fd = do
- bytes <- allocChars ``sizeof(struct stat)''
- rc <- _casm_ ``%r = fstat(%0,(struct stat *)%1);'' fd bytes
- if rc == (0::Int)
- then do
- stat <- freeze bytes
- return stat
- else syserr "getFdStatus"
-
-fileAccess :: FilePath -> Bool -> Bool -> Bool -> IO Bool
-fileAccess name read write exec = do
- path <- packStringIO name
- rc <- _ccall_ access path flags
- return (rc == (0::Int))
- where
- flags = I# (word2Int# (read# `or#` write# `or#` exec#))
- read# = case (if read then ``R_OK'' else ``0'') of { W# x -> x }
- write# = case (if write then ``W_OK'' else ``0'') of { W# x -> x }
- exec# = case (if exec then ``X_OK'' else ``0'') of { W# x -> x }
-
-fileExist :: FilePath -> IO Bool
-fileExist name = do
- path <- packStringIO name
- rc <- _ccall_ access path (``F_OK''::Int)
- return (rc == (0::Int))
-
-setFileMode :: FilePath -> FileMode -> IO ()
-setFileMode name mode = do
- path <- packStringIO name
- rc <- _ccall_ chmod path mode
- if rc == (0::Int)
- then return ()
- else syserr "setFileMode"
-
-setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
-setOwnerAndGroup name uid gid = do
- path <- packStringIO name
- rc <- _ccall_ chown path uid gid
- if rc == (0::Int)
- then return ()
- else syserr "setOwnerAndGroup"
-
-setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO ()
-setFileTimes name atime mtime = do
- path <- packStringIO name
- rc <- _casm_ ``do {struct utimbuf ub; ub.actime = (time_t) %0;
- ub.modtime = (time_t) %1;
- %r = utime(%2, &ub);} while(0);'' atime mtime path
- if rc == (0::Int)
- then return ()
- else syserr "setFileTimes"
-
-{- Set access and modification time to current time -}
-touchFile :: FilePath -> IO ()
-touchFile name = do
- path <- packStringIO name
- rc <- _ccall_ utime path nullAddr
- if rc == (0::Int)
- then return ()
- else syserr "touchFile"
-
-data PathVar = LinkLimit {- _PC_LINK_MAX -}
- | InputLineLimit {- _PC_MAX_CANON -}
- | InputQueueLimit {- _PC_MAX_INPUT -}
- | FileNameLimit {- _PC_NAME_MAX -}
- | PathNameLimit {- _PC_PATH_MAX -}
- | PipeBufferLimit {- _PC_PIPE_BUF -}
- | SetOwnerAndGroupIsRestricted {- _PC_CHOWN_RESTRICTED -}
- | FileNamesAreNotTruncated {- _PC_NO_TRUNC -}
-
-getPathVar :: PathVar -> FilePath -> IO Limit
-getPathVar v name =
- (case v of
- LinkLimit -> pathconf ``_PC_LINK_MAX''
- InputLineLimit -> pathconf ``_PC_MAX_CANON''
- InputQueueLimit -> pathconf ``_PC_MAX_INPUT''
- FileNameLimit -> pathconf ``_PC_NAME_MAX''
- PathNameLimit -> pathconf ``_PC_PATH_MAX''
- PipeBufferLimit -> pathconf ``_PC_PIPE_BUF''
- SetOwnerAndGroupIsRestricted -> pathconf ``_PC_CHOWN_RESTRICTED''
- FileNamesAreNotTruncated -> pathconf ``_PC_NO_TRUNC'') name
-
-pathconf :: Int -> FilePath -> IO Limit
-pathconf n name = do
- path <- packStringIO name
- rc <- _ccall_ pathconf path n
- if rc /= ((-1)::Int)
- then return rc
- else do
- errno <- getErrorCode
- if errno == invalidArgument
- then ioError (IOError Nothing NoSuchThing "getPathVar" "no such path limit or option")
- else syserr "PosixFiles.getPathVar"
-
-
-getFileVar :: PathVar -> Fd -> IO Limit
-getFileVar v fd =
- (case v of
- LinkLimit -> fpathconf (``_PC_LINK_MAX''::Int)
- InputLineLimit -> fpathconf (``_PC_MAX_CANON''::Int)
- InputQueueLimit -> fpathconf ``_PC_MAX_INPUT''
- FileNameLimit -> fpathconf ``_PC_NAME_MAX''
- PathNameLimit -> fpathconf ``_PC_PATH_MAX''
- PipeBufferLimit -> fpathconf ``_PC_PIPE_BUF''
- SetOwnerAndGroupIsRestricted -> fpathconf ``_PC_CHOWN_RESTRICTED''
- FileNamesAreNotTruncated -> fpathconf ``_PC_NO_TRUNC'') fd
-
-fpathconf :: Int -> Fd -> IO Limit
-fpathconf n fd = do
- rc <- _ccall_ fpathconf fd n
- if rc /= ((-1)::Int)
- then return rc
- else do
- errno <- getErrorCode
- if errno == invalidArgument
- then ioError (IOError Nothing NoSuchThing "getFileVar" "no such path limit or option")
- else syserr "getFileVar"
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
-%
-\section[PosixIO]{Haskell 1.3 POSIX Input/Output Primitives}
-
-\begin{code}
-{-# OPTIONS -#include "../std/cbits/stgio.h" #-}
-module PosixIO (
- FdOption(..),
- FileLock,
- LockRequest(..),
-
- fdClose,
- createPipe,
- dup,
- dupTo,
-
- fdRead,
- fdWrite,
- fdSeek,
-
- queryFdOption,
- setFdOption,
-
- getLock, setLock,
- waitToSetLock,
-
- -- Handle <-> Fd
- handleToFd, fdToHandle,
- ) where
-
-import GlaExts
-import PrelIOBase
-import PrelHandle (newHandle, getBMode__, getHandleFd,
- freeFileObject, freeStdFileObject )
-import IO
-import Addr
-import Foreign
-import Weak ( addForeignFinalizer )
-import CString ( freeze, allocChars, packStringIO, unpackNBytesBAIO )
-
-import PosixUtil
-import PosixFiles ( stdInput, stdOutput, stdError )
-
-
-createPipe :: IO (Fd, Fd)
-createPipe = do
- bytes <- allocChars ``(2*sizeof(int))''
- rc <- _casm_ ``%r = pipe((int *)%0);'' bytes
- if rc /= ((-1)::Int)
- then do
- rd <- _casm_ ``%r = ((int *)%0)[0];'' bytes
- wd <- _casm_ ``%r = ((int *)%0)[1];'' bytes
- return (rd, wd)
- else
- syserr "createPipe"
-
-dup :: Fd -> IO Fd
-dup fd =
- _ccall_ dup fd >>= \ fd2@(I# fd2#) ->
- if fd2 /= -1 then
- return (FD# fd2#)
- else
- syserr "dup"
-
-dupTo :: Fd -> Fd -> IO ()
-dupTo fd1 fd2 = minusone_error (_ccall_ dup2 fd1 fd2) "dupTo"
-
-fdClose :: Fd -> IO ()
-fdClose fd = minusone_error (_ccall_ close fd) "fdClose"
-
-handleToFd :: Handle -> IO Fd
-handleToFd h = do
- fd <- getHandleFd h
- let (I# fd#) = fd
- return (FD# fd#)
-
--- default is no buffering.
-fdToHandle :: Fd -> IO Handle
-fdToHandle fd@(FD# fd#) = do
- -- first find out what kind of file desc. this is..
- flags <- _ccall_ fcntl fd (``F_GETFL''::Int) (0::Int)
- if flags /= ((-1)::Int)
- then do
- let
- (I# flags#) = flags
-
- wH = (int2Word# flags# `and#` (case ``O_WRONLY'' of { W# x -> x}))
- `neWord#` int2Word# 0#
- aH = (int2Word# flags# `and#` (case ``O_APPEND'' of { W# x -> x}))
- `neWord#` int2Word# 0#
- rwH = (int2Word# flags# `and#` (case ``O_RDWR'' of { W# x -> x }))
- `neWord#` int2Word# 0#
-
- (handle_t, flush_on_close)
- | wH && aH = (AppendHandle, 1)
- | wH = (WriteHandle, 1)
- | rwH = (ReadWriteHandle, 1)
- | otherwise = (ReadHandle, 0)
-
- fo <- _ccall_ openFd fd flags (flush_on_close::Int)
- if fo /= nullAddr then do
- {-
- A distinction is made here between std{Input,Output,Error} Fds
- and all others. The standard descriptors have a finaliser
- that will not close the underlying fd, the others have one
- that will.
-
- Delaying the closing of the standard descriptors until the process
- exits is necessary since the RTS is likely to require these after
- (or as a result of) program termination.
- -}
-#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
- if fd == stdInput || fd == stdOutput || fd == stdError then
- addForeignFinalizer fo (freeStdFileObject fo)
- else
- addForeignFinalizer fo (freeFileObject fo)
-#endif
- (bm, bf_size) <- getBMode__ fo
- mkBuffer__ fo bf_size
- newHandle (Handle__ fo handle_t bm fd_str)
- else
- syserr "fdToHandle"
- else
- syserr "fdToHandle"
- where
- fd_str = "<file descriptor: " ++ show (I# fd#) ++ ">"
-
-fdRead :: Fd -> ByteCount -> IO (String, ByteCount)
-fdRead _fd 0 = return ("", 0)
-fdRead fd nbytes = do
- bytes <- allocChars nbytes
- rc <- _ccall_ read fd bytes nbytes
- case rc of
- -1 -> syserr "fdRead"
- 0 -> ioError (IOError Nothing EOF "fdRead" "EOF")
- n | n == nbytes -> do
- buf <- freeze bytes
- s <- unpackNBytesBAIO buf n
- return (s, n)
- | otherwise -> do
- -- Let go of the excessively long ByteArray# by copying to a
- -- shorter one. Maybe we need a new primitive, shrinkCharArray#?
- bytes' <- allocChars n
- _casm_ ``do {I_ i; for(i = 0; i < %2; i++) ((B_)%0)[i] = ((B_)%1)[i];
- } while(0);'' bytes' bytes n
- buf <- freeze bytes'
- s <- unpackNBytesBAIO buf n
- return (s, n)
-
-fdWrite :: Fd -> String -> IO ByteCount
-fdWrite fd str = do
- buf <- packStringIO str
- rc <- _ccall_ write fd buf (length str)
- if rc /= ((-1)::Int)
- then return rc
- else syserr "fdWrite"
-
-data FdOption = AppendOnWrite
- | CloseOnExec
- | NonBlockingRead
-
-queryFdOption :: Fd -> FdOption -> IO Bool
-queryFdOption fd CloseOnExec =
- _ccall_ fcntl fd (``F_GETFD''::Int) (0::Int) >>= \ (I# flags#) ->
- if flags# /=# -1# then
- return ((int2Word# flags# `and#` fd_cloexec#) `neWord#` int2Word# 0#)
- else
- syserr "queryFdOption"
- where
- fd_cloexec# = case (``FD_CLOEXEC'') of { W# x -> x }
-queryFdOption fd other =
- _ccall_ fcntl fd (``F_GETFL''::Int) (0::Int) >>= \ (I# flags#) ->
- if flags# >=# 0# then
- return ((int2Word# flags# `and#` opt#) `neWord#` int2Word# 0#)
- else
- syserr "queryFdOption"
- where
- opt# = case (
- case other of
- AppendOnWrite -> ``O_APPEND''
- NonBlockingRead -> ``O_NONBLOCK'' ) of { W# x -> x }
-
-setFdOption :: Fd -> FdOption -> Bool -> IO ()
-setFdOption fd CloseOnExec val = do
- flags <- _ccall_ fcntl fd (``F_GETFD''::Int) (0::Int)
- if flags /= ((-1)::Int) then do
- rc <- (if val then
- _casm_ ``%r = fcntl(%0, F_SETFD, %1 | FD_CLOEXEC);'' fd flags
- else do
- _casm_ ``%r = fcntl(%0, F_SETFD, %1 & ~FD_CLOEXEC);'' fd flags)
- if rc /= ((-1)::Int)
- then return ()
- else fail
- else fail
- where
- fail = syserr "setFdOption"
-
-setFdOption fd other val = do
- flags <- _ccall_ fcntl fd (``F_GETFL''::Int) (0::Int)
- if flags >= (0::Int) then do
- rc <- (if val then
- _casm_ ``%r = fcntl(%0, F_SETFL, %1 | %2);'' fd flags opt
- else do
- _casm_ ``%r = fcntl(%0, F_SETFL, %1 & ~(%2));'' fd flags opt)
- if rc /= ((-1)::Int)
- then return ()
- else fail
- else fail
- where
- fail = syserr "setFdOption"
- opt =
- case other of
- AppendOnWrite -> (``O_APPEND''::Word)
- NonBlockingRead -> (``O_NONBLOCK''::Word)
-
-data LockRequest = ReadLock
- | WriteLock
- | Unlock
-
-type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
-
-getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
-getLock fd lock = do
- flock <- lock2Bytes lock
- rc <- _ccall_ fcntl fd (``F_GETLK''::Int) flock
- if rc /= ((-1)::Int)
- then do
- result <- bytes2ProcessIDAndLock flock
- return (maybeResult result)
- else syserr "getLock"
- where
- maybeResult (_, (Unlock, _, _, _)) = Nothing
- maybeResult x = Just x
-
-setLock :: Fd -> FileLock -> IO ()
-setLock fd lock = do
- flock <- lock2Bytes lock
- minusone_error (_ccall_ fcntl fd (``F_SETLK''::Int) flock) "setLock"
-
-waitToSetLock :: Fd -> FileLock -> IO ()
-waitToSetLock fd lock = do
- flock <- lock2Bytes lock
- minusone_error (_ccall_ fcntl fd (``F_SETLKW''::Int) flock) "waitToSetLock"
-
-fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
-fdSeek fd mode offset = do
- rc <- _ccall_ lseek fd offset (mode2Int mode)
- if rc /= ((-1)::Int)
- then return rc
- else syserr "fdSeek"
-
-\end{code}
-
-Local utility functions
-
-\begin{code}
-
--- Convert a Haskell SeekMode to an int
-
-mode2Int :: SeekMode -> Int
-mode2Int AbsoluteSeek = ``SEEK_SET''
-mode2Int RelativeSeek = ``SEEK_CUR''
-mode2Int SeekFromEnd = ``SEEK_END''
-
--- Convert a Haskell FileLock to an flock structure
-lockRequest2Int :: LockRequest -> Int
-lockRequest2Int kind =
- case kind of
- ReadLock -> ``F_RDLCK''
- WriteLock -> ``F_WRLCK''
- Unlock -> ``F_UNLCK''
-
-lock2Bytes :: FileLock -> IO (MutableByteArray RealWorld Int)
-lock2Bytes (kind, mode, start, len) = do
- bytes <- allocChars ``sizeof(struct flock)''
- _casm_ ``do { struct flock *fl = (struct flock *)%0;
- fl->l_type = %1;
- fl->l_whence = %2;
- fl->l_start = %3;
- fl->l_len = %4;
- } while(0);''
- bytes (lockRequest2Int kind) (mode2Int mode) start len
- return bytes
--- where
-
-bytes2ProcessIDAndLock :: MutableByteArray s Int -> IO (ProcessID, FileLock)
-bytes2ProcessIDAndLock bytes = do
- ltype <- _casm_ ``%r = ((struct flock *)%0)->l_type;'' bytes
- lwhence <- _casm_ ``%r = ((struct flock *)%0)->l_whence;'' bytes
- lstart <- _casm_ ``%r = ((struct flock *)%0)->l_start;'' bytes
- llen <- _casm_ ``%r = ((struct flock *)%0)->l_len;'' bytes
- lpid <- _casm_ ``%r = ((struct flock *)%0)->l_pid;'' bytes
- return (lpid, (kind ltype, mode lwhence, lstart, llen))
-
-kind :: Int -> LockRequest
-kind x
- | x == ``F_RDLCK'' = ReadLock
- | x == ``F_WRLCK'' = WriteLock
- | x == ``F_UNLCK'' = Unlock
-
-mode :: Int -> SeekMode
-mode x
- | x == ``SEEK_SET'' = AbsoluteSeek
- | x == ``SEEK_CUR'' = RelativeSeek
- | x == ``SEEK_END'' = SeekFromEnd
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
-%
-\section[PosixProcEnv]{Haskell 1.3 POSIX Process Environment}
-
-\begin{code}
-
-#include "config.h"
-
-module PosixProcEnv (
- ProcessTimes,
- SysVar(..),
- SystemID,
- childSystemTime,
- childUserTime,
- createProcessGroup,
- createSession,
- elapsedTime,
- epochTime,
-#if !defined(cygwin32_TARGET_OS)
- getControllingTerminalName,
-#endif
- getEffectiveGroupID,
- getEffectiveUserID,
- getEffectiveUserName,
-#if !defined(cygwin32_TARGET_OS)
- getGroups,
-#endif
- getLoginName,
- getParentProcessID,
- getProcessGroupID,
- getProcessID,
- getProcessTimes,
- getRealGroupID,
- getRealUserID,
- getSysVar,
- getSystemID,
- getTerminalName,
- joinProcessGroup,
- machine,
- nodeName,
- queryTerminal,
- release,
- setGroupID,
- setProcessGroupID,
- setUserID,
- systemName,
- systemTime,
- userTime,
- version
- ) where
-
-import GlaExts
-import PrelArr (ByteArray(..)) -- see internals
-import PrelIOBase
-import IO
-import Addr ( nullAddr )
-
-import PosixErr
-import PosixUtil
-import CString ( strcpy, allocWords, freeze, allocChars )
-
-\end{code}
-
-\begin{code}
-getProcessID :: IO ProcessID
-getProcessID = _ccall_ getpid
-
-getParentProcessID :: IO ProcessID
-getParentProcessID = _ccall_ getppid
-
-getRealUserID :: IO UserID
-getRealUserID = _ccall_ getuid
-
-getEffectiveUserID :: IO UserID
-getEffectiveUserID = _ccall_ geteuid
-
-setUserID :: UserID -> IO ()
-setUserID uid = nonzero_error (_ccall_ setuid uid) "setUserID"
-
-getLoginName :: IO String
-getLoginName = do
- str <- _ccall_ getlogin
- if str == nullAddr
- then syserr "getLoginName"
- else strcpy str
-
-getRealGroupID :: IO GroupID
-getRealGroupID = _ccall_ getgid
-
-getEffectiveGroupID :: IO GroupID
-getEffectiveGroupID = _ccall_ getegid
-
-setGroupID :: GroupID -> IO ()
-setGroupID gid = nonzero_error (_ccall_ setgid gid) "setGroupID"
-
--- getgroups() is not supported in beta18 of
--- cygwin32
-#if !defined(cygwin32_TARGET_OS)
-getGroups :: IO [GroupID]
-getGroups = do
- ngroups <- _ccall_ getgroups (0::Int) nullAddr
- words <- allocWords ngroups
- ngroups <- _casm_ ``%r = getgroups(%0,(gid_t *)%1);'' ngroups words
- if ngroups /= ((-1)::Int)
- then do
- arr <- freeze words
- return (map (extract arr) [0..(ngroups-1)])
- else
- syserr "getGroups"
- where
- extract (ByteArray _ _ barr#) (I# n#) =
- case indexIntArray# barr# n# of
- r# -> (I# r#)
-#endif
-
-getEffectiveUserName :: IO String
-getEffectiveUserName = do
- {- cuserid() is deprecated, using getpwuid() instead. -}
- euid <- getEffectiveUserID
- ptr <- _ccall_ getpwuid euid
- str <- _casm_ ``%r = ((struct passwd *)%0)->pw_name;'' (ptr::Addr)
- strcpy str
-
-{- OLD:
- str <- _ccall_ cuserid nullAddr
- if str == nullAddr
- then syserr "getEffectiveUserName"
- else strcpy str
--}
-
-getProcessGroupID :: IO ProcessGroupID
-getProcessGroupID = _ccall_ getpgrp
-
-createProcessGroup :: ProcessID -> IO ProcessGroupID
-createProcessGroup pid = do
- pgid <- _ccall_ setpgid pid (0::Int)
- if pgid == (0::Int)
- then return pgid
- else syserr "createProcessGroup"
-
-joinProcessGroup :: ProcessGroupID -> IO ()
-joinProcessGroup pgid =
- nonzero_error (_ccall_ setpgid (0::Int) pgid) "joinProcessGroupID"
-
-setProcessGroupID :: ProcessID -> ProcessGroupID -> IO ()
-setProcessGroupID pid pgid =
- nonzero_error (_ccall_ setpgid pid pgid) "setProcessGroupID"
-
-createSession :: IO ProcessGroupID
-createSession = do
- pgid <- _ccall_ setsid
- if pgid /= ((-1)::Int)
- then return pgid
- else syserr "createSession"
-
-type SystemID = ByteArray Int
-
-systemName :: SystemID -> String
-systemName sid = unsafePerformIO $ do
- str <-_casm_ ``%r = ((struct utsname *)%0)->sysname;'' sid
- strcpy str
-
-nodeName :: SystemID -> String
-nodeName sid = unsafePerformIO $ do
- str <- _casm_ ``%r = ((struct utsname *)%0)->nodename;'' sid
- strcpy str
-
-release :: SystemID -> String
-release sid = unsafePerformIO $ do
- str <- _casm_ ``%r = ((struct utsname *)%0)->release;'' sid
- strcpy str
-
-version :: SystemID -> String
-version sid = unsafePerformIO $ do
- str <- _casm_ ``%r = ((struct utsname *)%0)->version;'' sid
- strcpy str
-
-machine :: SystemID -> String
-machine sid = unsafePerformIO $ do
- str <- _casm_ ``%r = ((struct utsname *)%0)->machine;'' sid
- strcpy str
-
-getSystemID :: IO SystemID
-getSystemID = do
- bytes <- allocChars (``sizeof(struct utsname)''::Int)
- rc <- _casm_ ``%r = uname((struct utsname *)%0);'' bytes
- if rc /= ((-1)::Int)
- then freeze bytes
- else syserr "getSystemID"
-
-epochTime :: IO EpochTime
-epochTime = do
- secs <- _ccall_ time nullAddr
- if secs /= ((-1)::Int)
- then return secs
- else syserr "epochTime"
-
--- All times in clock ticks (see getClockTick)
-
-type ProcessTimes = (ClockTick, ByteArray Int)
-
-elapsedTime :: ProcessTimes -> ClockTick
-elapsedTime (realtime, _) = realtime
-
-userTime :: ProcessTimes -> ClockTick
-userTime (_, times) = unsafePerformIO $
- _casm_ ``%r = ((struct tms *)%0)->tms_utime;'' times
-
-systemTime :: ProcessTimes -> ClockTick
-systemTime (_, times) = unsafePerformIO $
- _casm_ ``%r = ((struct tms *)%0)->tms_stime;'' times
-
-childUserTime :: ProcessTimes -> ClockTick
-childUserTime (_, times) = unsafePerformIO $
- _casm_ ``%r = ((struct tms *)%0)->tms_cutime;'' times
-
-childSystemTime :: ProcessTimes -> ClockTick
-childSystemTime (_, times) = unsafePerformIO $
- _casm_ ``%r = ((struct tms *)%0)->tms_cstime;'' times
-
-getProcessTimes :: IO ProcessTimes
-getProcessTimes = do
- bytes <- allocChars (``sizeof(struct tms)''::Int)
- elapsed <- _casm_ ``%r = times((struct tms *)%0);'' bytes
- if elapsed /= ((-1)::Int)
- then do
- times <- freeze bytes
- return (elapsed, times)
- else
- syserr "getProcessTimes"
-
-#if !defined(cygwin32_TARGET_OS)
-getControllingTerminalName :: IO FilePath
-getControllingTerminalName = do
- str <- _ccall_ ctermid nullAddr
- if str == nullAddr
- then ioError (IOError Nothing NoSuchThing "getControllingTerminalName" "no controlling terminal")
- else strcpy str
-#endif
-
-getTerminalName :: Fd -> IO FilePath
-getTerminalName fd = do
- str <- _ccall_ ttyname fd
- if str == nullAddr
- then do
- err <- try (queryTerminal fd)
- either (\ _err -> syserr "getTerminalName")
- (\ succ -> if succ then ioError (IOError Nothing NoSuchThing
- "getTerminalName" "no name")
- else ioError (IOError Nothing InappropriateType
- "getTerminalName" "not a terminal"))
- err
- else strcpy str
-
-queryTerminal :: Fd -> IO Bool
-queryTerminal (FD# fd) = do
- rc <- _ccall_ isatty fd
- case (rc::Int) of
- -1 -> syserr "queryTerminal"
- 0 -> return False
- 1 -> return True
-
-data SysVar = ArgumentLimit
- | ChildLimit
- | ClockTick
- | GroupLimit
- | OpenFileLimit
- | PosixVersion
- | HasSavedIDs
- | HasJobControl
-
-getSysVar :: SysVar -> IO Limit
-getSysVar v =
- case v of
- ArgumentLimit -> sysconf ``_SC_ARG_MAX''
- ChildLimit -> sysconf ``_SC_CHILD_MAX''
- ClockTick -> sysconf ``_SC_CLK_TCK''
- GroupLimit -> sysconf ``_SC_NGROUPS_MAX''
- OpenFileLimit -> sysconf ``_SC_OPEN_MAX''
- PosixVersion -> sysconf ``_SC_VERSION''
- HasSavedIDs -> sysconf ``_SC_SAVED_IDS''
- HasJobControl -> sysconf ``_SC_JOB_CONTROL''
--- where
-
-sysconf :: Int -> IO Limit
-sysconf n = do
- rc <- _ccall_ sysconf n
- if rc /= (-1::Int)
- then return rc
- else ioError (IOError Nothing NoSuchThing
- "getSysVar"
- "no such system limit or option")
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1997
-%
-\section[PosixProcPrim]{Haskell 1.3 POSIX Process Primitives}
-
-\begin{code}
-
-#include "config.h"
-
-module PosixProcPrim (
- Handler(..),
- SignalSet,
- Signal,
- ProcessStatus(..),
-
- addSignal,
-#ifndef cygwin32_TARGET_OS
- awaitSignal,
-#endif
- backgroundRead,
- backgroundWrite,
- blockSignals,
-#ifndef cygwin32_TARGET_OS
- continueProcess,
-#endif
- deleteSignal,
- emptySignalSet,
- executeFile,
- exitImmediately,
- floatingPointException,
- forkProcess,
- fullSignalSet,
- getAnyProcessStatus,
- getEnvVar,
- getEnvironment,
- getGroupProcessStatus,
- getPendingSignals,
- getProcessStatus,
- getSignalMask,
- illegalInstruction,
- inSignalSet,
- installHandler,
- internalAbort,
- keyboardSignal,
- keyboardStop,
- keyboardTermination,
- killProcess,
- lostConnection,
- nullSignal,
- openEndedPipe,
- processStatusChanged,
- queryStoppedChildFlag,
- raiseSignal,
- realTimeAlarm,
- removeEnvVar,
- scheduleAlarm,
- segmentationViolation,
- setEnvVar,
- setEnvironment,
- setSignalMask,
- setStoppedChildFlag,
- sigABRT,
- sigALRM,
- sigCHLD,
-#ifndef cygwin32_TARGET_OS
- sigCONT,
-#endif
- sigFPE,
- sigHUP,
- sigILL,
- sigINT,
- sigKILL,
- sigPIPE,
- sigProcMask,
- sigQUIT,
- sigSEGV,
- sigSTOP,
- sigSetSize,
- sigTERM,
- sigTSTP,
- sigTTIN,
- sigTTOU,
- sigUSR1,
- sigUSR2,
- signalProcess,
- signalProcessGroup,
- sleep,
- softwareStop,
- softwareTermination,
- unBlockSignals,
- userDefinedSignal1,
- userDefinedSignal2,
-
- ExitCode
-
- ) where
-
-import GlaExts
-import IO
-import PrelIOBase
-import Foreign ( makeStablePtr, StablePtr, deRefStablePtr )
-import Addr ( nullAddr )
-
-import PosixErr
-import PosixUtil
-import CString ( unvectorize, packStringIO,
- allocChars, freeze, vectorize,
- allocWords, strcpy
- )
-
-import System(ExitCode(..))
-import PosixProcEnv (getProcessID)
-
-forkProcess :: IO (Maybe ProcessID)
-forkProcess = do
- pid <-_ccall_ fork
- case (pid::Int) of
- -1 -> syserr "forkProcess"
- 0 -> return Nothing
- _ -> return (Just pid)
-
-executeFile :: FilePath -- Command
- -> Bool -- Search PATH?
- -> [String] -- Arguments
- -> Maybe [(String, String)] -- Environment
- -> IO ()
-executeFile path search args Nothing = do
- prog <- packStringIO path
- argv <- vectorize (basename path:args)
- (if search then
- _casm_ ``execvp(%0,(char **)%1);'' prog argv
- else
- _casm_ ``execv(%0,(char **)%1);'' prog argv
- )
- syserr "executeFile"
-
-executeFile path search args (Just env) = do
- prog <- packStringIO path
- argv <- vectorize (basename path:args)
- envp <- vectorize (map (\ (name, val) -> name ++ ('=' : val)) env)
- (if search then
- _casm_ `` execvpe(%0,(char **)%1,(char **)%2);'' prog argv envp
- else
- _casm_ `` execve(%0,(char **)%1,(char **)%2);'' prog argv envp
- )
- syserr "executeFile"
-
-data ProcessStatus = Exited ExitCode
- | Terminated Signal
- | Stopped Signal
- deriving (Eq, Ord, Show)
-
-getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
-getProcessStatus block stopped pid = do
- wstat <- allocWords 1
- pid <-_casm_ ``%r = waitpid(%0, (int *)%1, %2);'' pid wstat
- (waitOptions block stopped)
- case (pid::Int) of
- -1 -> syserr "getProcessStatus"
- 0 -> return Nothing
- _ -> do ps <- decipherWaitStatus wstat
- return (Just ps)
-
-getGroupProcessStatus :: Bool
- -> Bool
- -> ProcessGroupID
- -> IO (Maybe (ProcessID, ProcessStatus))
-getGroupProcessStatus block stopped pgid = do
- wstat <- allocWords 1
- pid <-_casm_ ``%r = waitpid(%0, (int *)%1, %2);'' (-pgid) wstat
- (waitOptions block stopped)
- case (pid::Int) of
- -1 -> syserr "getGroupProcessStatus"
- 0 -> return Nothing
- _ -> do ps <- decipherWaitStatus wstat
- return (Just (pid, ps))
-
-getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
-getAnyProcessStatus block stopped =
- getGroupProcessStatus block stopped 1 `catch`
- \ _err -> syserr "getAnyProcessStatus"
-
-exitImmediately :: ExitCode -> IO ()
-exitImmediately exitcode = do
- _casm_ ``_exit(%0);'' (exitcode2Int exitcode)
- syserr "exitImmediately"
- where
- exitcode2Int ExitSuccess = 0
- exitcode2Int (ExitFailure n) = n
-
-getEnvironment :: IO [(String, String)]
-getEnvironment = do
- --WAS: env <- unvectorize ``environ'' 0
- -- does not work too well, since the lit-lit
- -- is turned into an Addr that is only evaluated
- -- once (environ is changed to point the most
- -- current env. block after the addition of new entries).
- envp <- _casm_ `` %r=environ; ''
- env <- unvectorize (envp::Addr) 0
- return (map (split "") env)
- where
- split :: String -> String -> (String, String)
- split x [] = error ("PosixProcPrim.getEnvironment:no `='? in: "++reverse x)
- split x ('=' : xs) = (reverse x, xs)
- split x (c:cs) = split (c:x) cs
-
-setEnvironment :: [(String, String)] -> IO ()
-setEnvironment pairs = do
- env <- vectorize (map (\ (var,val) -> var ++ ('=' : val)) pairs)
- nonzero_error (_casm_ ``%r = setenviron((char **)%0);'' env)
- "setEnvironment"
-
-getEnvVar :: String -> IO String
-getEnvVar name = do
- str <- packStringIO name
- str <- _ccall_ getenv str
- if str == nullAddr
- then ioError (IOError Nothing NoSuchThing "getEnvVar" "no such environment variable")
- else strcpy str
-
-setEnvVar :: String -> String -> IO ()
-setEnvVar name value = do
- str <- packStringIO (name ++ ('=' : value))
- nonzero_error (_casm_ ``%r = _setenv(%0);'' str) "setEnvVar"
-
-removeEnvVar :: String -> IO ()
-removeEnvVar name = do
- str <- packStringIO name
- nonzero_error (_ccall_ delenv str) "removeEnvVar"
-
-type Signal = Int
-
-nullSignal :: Signal
-nullSignal = 0
-
-backgroundRead, sigTTIN :: Signal
-backgroundRead = ``SIGTTIN''
-sigTTIN = ``SIGTTIN''
-
-backgroundWrite, sigTTOU :: Signal
-backgroundWrite = ``SIGTTOU''
-sigTTOU = ``SIGTTOU''
-
-#ifndef cygwin32_TARGET_OS
-continueProcess, sigCONT :: Signal
-continueProcess = ``SIGCONT''
-sigCONT = ``SIGCONT''
-#endif
-
-floatingPointException, sigFPE :: Signal
-floatingPointException = ``SIGFPE''
-sigFPE = ``SIGFPE''
-
-illegalInstruction, sigILL :: Signal
-illegalInstruction = ``SIGILL''
-sigILL = ``SIGILL''
-
-internalAbort, sigABRT ::Signal
-internalAbort = ``SIGABRT''
-sigABRT = ``SIGABRT''
-
-keyboardSignal, sigINT :: Signal
-keyboardSignal = ``SIGINT''
-sigINT = ``SIGINT''
-
-keyboardStop, sigTSTP :: Signal
-keyboardStop = ``SIGTSTP''
-sigTSTP = ``SIGTSTP''
-
-keyboardTermination, sigQUIT :: Signal
-keyboardTermination = ``SIGQUIT''
-sigQUIT = ``SIGQUIT''
-
-killProcess, sigKILL :: Signal
-killProcess = ``SIGKILL''
-sigKILL = ``SIGKILL''
-
-lostConnection, sigHUP :: Signal
-lostConnection = ``SIGHUP''
-sigHUP = ``SIGHUP''
-
-openEndedPipe, sigPIPE :: Signal
-openEndedPipe = ``SIGPIPE''
-sigPIPE = ``SIGPIPE''
-
-processStatusChanged, sigCHLD :: Signal
-processStatusChanged = ``SIGCHLD''
-sigCHLD = ``SIGCHLD''
-
-realTimeAlarm, sigALRM :: Signal
-realTimeAlarm = ``SIGALRM''
-sigALRM = ``SIGALRM''
-
-segmentationViolation, sigSEGV :: Signal
-segmentationViolation = ``SIGSEGV''
-sigSEGV = ``SIGSEGV''
-
-softwareStop, sigSTOP :: Signal
-softwareStop = ``SIGSTOP''
-sigSTOP = ``SIGSTOP''
-
-softwareTermination, sigTERM :: Signal
-softwareTermination = ``SIGTERM''
-sigTERM = ``SIGTERM''
-
-userDefinedSignal1, sigUSR1 :: Signal
-userDefinedSignal1 = ``SIGUSR1''
-sigUSR1 = ``SIGUSR1''
-
-userDefinedSignal2, sigUSR2 :: Signal
-userDefinedSignal2 = ``SIGUSR2''
-sigUSR2 = ``SIGUSR2''
-
-signalProcess :: Signal -> ProcessID -> IO ()
-signalProcess int pid =
- nonzero_error (_ccall_ kill pid int) "signalProcess"
-
-raiseSignal :: Signal -> IO ()
-raiseSignal int = getProcessID >>= signalProcess int
-
-signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
-signalProcessGroup int pgid = signalProcess int (-pgid)
-
-setStoppedChildFlag :: Bool -> IO Bool
-setStoppedChildFlag b = do
- rc <- _casm_ ``%r = nocldstop; nocldstop = %0;'' (x::Int)
- return (rc == (0::Int))
- where
- x = case b of {True -> 0; False -> 1}
-
-queryStoppedChildFlag :: IO Bool
-queryStoppedChildFlag = do
- rc <- _casm_ ``%r = nocldstop;''
- return (rc == (0::Int))
-
-data Handler = Default
- | Ignore
- | Catch (IO ())
-
-type SignalSet = ByteArray Int
-
-sigSetSize :: Int
-sigSetSize = ``sizeof(sigset_t)''
-
-emptySignalSet :: SignalSet
-emptySignalSet = unsafePerformPrimIO $ do
- bytes <- allocChars sigSetSize
- _casm_ ``(void) sigemptyset((sigset_t *)%0);'' bytes
- freeze bytes
-
-fullSignalSet :: SignalSet
-fullSignalSet = unsafePerformPrimIO $ do
- bytes <- allocChars sigSetSize
- _casm_ ``(void) sigfillset((sigset_t *)%0);'' bytes
- freeze bytes
-
-addSignal :: Signal -> SignalSet -> SignalSet
-addSignal int oldset = unsafePerformPrimIO $ do
- bytes <- allocChars sigSetSize
- _ccall_ stg_sigaddset bytes oldset int
- freeze bytes
-
-inSignalSet :: Signal -> SignalSet -> Bool
-inSignalSet int sigset = unsafePerformPrimIO $ do
- rc <- _casm_ ``%r = sigismember((sigset_t *)%0, %1);'' sigset int
- return (rc == (1::Int))
-
-deleteSignal :: Signal -> SignalSet -> SignalSet
-deleteSignal int oldset = unsafePerformPrimIO $ do
- bytes <- allocChars sigSetSize
- _ccall_ stg_sigdelset bytes oldset int
- freeze bytes
-
-installHandler :: Signal
- -> Handler
- -> Maybe SignalSet -- other signals to block
- -> IO Handler -- old handler
-
-#ifdef __PARALLEL_HASKELL__
-installHandler = ioError (userError "installHandler: not available for Parallel Haskell")
-#else
-installHandler int handler maybe_mask = (
- case handler of
- Default -> _ccall_ stg_sig_default int mask
- Ignore -> _ccall_ stg_sig_ignore int mask
- Catch m -> do
- sptr <- makeStablePtr (ioToPrimIO m)
- _ccall_ stg_sig_catch int sptr mask
- ) >>= \rc ->
-
- if rc >= (0::Int) then do
- osptr <- _casm_ ``%r = (StgStablePtr) (%0);'' rc
- m <- deRefStablePtr osptr
- return (Catch m)
- else if rc == ``STG_SIG_DFL'' then
- return Default
- else if rc == ``STG_SIG_IGN'' then
- return Ignore
- else
- syserr "installHandler"
- where
- mask = case maybe_mask of
- Nothing -> emptySignalSet
- Just x -> x
-
-#endif {-!__PARALLEL_HASKELL__-}
-
-getSignalMask :: IO SignalSet
-getSignalMask = do
- bytes <- allocChars sigSetSize
- rc <- _casm_ ``%r = sigprocmask(0, NULL, (sigset_t *)%0);'' bytes
- if rc == (0::Int)
- then freeze bytes
- else syserr "getSignalMask"
-
-sigProcMask :: String -> Int -> SignalSet -> IO SignalSet
-sigProcMask name how sigset = do
- bytes <- allocChars sigSetSize
- rc <- _casm_ ``%r = sigprocmask(%0, (sigset_t *)%1, (sigset_t *)%2);''
- how sigset bytes
- if rc == (0::Int)
- then freeze bytes
- else syserr name
-
-setSignalMask :: SignalSet -> IO SignalSet
-setSignalMask = sigProcMask "setSignalMask" ``SIG_SETMASK''
-
-blockSignals :: SignalSet -> IO SignalSet
-blockSignals = sigProcMask "blockSignals" ``SIG_BLOCK''
-
-unBlockSignals :: SignalSet -> IO SignalSet
-unBlockSignals = sigProcMask "unBlockSignals" ``SIG_UNBLOCK''
-
-getPendingSignals :: IO SignalSet
-getPendingSignals = do
- bytes <- allocChars sigSetSize
- rc <- _casm_ ``%r = sigpending((sigset_t *)%0);'' bytes
- if rc == (0::Int)
- then freeze bytes
- else syserr "getPendingSignals"
-
-#ifndef cygwin32_TARGET_OS
-awaitSignal :: Maybe SignalSet -> IO ()
-awaitSignal maybe_sigset = do
- pause maybe_sigset
- err <- getErrorCode
- if err == interruptedOperation
- then return ()
- else syserr "awaitSignal"
-
-pause :: Maybe SignalSet -> IO ()
-pause maybe_sigset =
- case maybe_sigset of
- Nothing -> _casm_ ``(void) pause();''
- Just sigset -> _casm_ ``(void) sigsuspend((sigset_t *)%0);'' sigset
-#endif
-
-scheduleAlarm :: Int -> IO Int
-scheduleAlarm (I# secs#) =
- _ccall_ alarm (W# (int2Word# secs#)) >>= \ (W# w#) ->
- return (I# (word2Int# w#))
-
-sleep :: Int -> IO ()
-sleep 0 = return ()
-sleep (I# secs#) = do
- _ccall_ sleep (W# (int2Word# secs#))
- return ()
-\end{code}
-
-Local utility functions
-
-\begin{code}
-
--- Get the trailing component of a path
-
-basename :: String -> String
-basename "" = ""
-basename (c:cs)
- | c == '/' = basename cs
- | otherwise = c : basename cs
-
--- Convert wait options to appropriate set of flags
-
-waitOptions :: Bool -> Bool -> Int
--- block stopped
-waitOptions False False = ``WNOHANG''
-waitOptions False True = ``(WNOHANG|WUNTRACED)''
-waitOptions True False = 0
-waitOptions True True = ``WUNTRACED''
-
--- Turn a (ptr to a) wait status into a ProcessStatus
-
-decipherWaitStatus :: MutableByteArray s x -> IO ProcessStatus
-decipherWaitStatus wstat = do
- exited <- _casm_ ``%r = WIFEXITED(*(int *)%0);'' wstat
- if exited /= (0::Int)
- then do
- exitstatus <- _casm_ ``%r = WEXITSTATUS(*(int *)%0);'' wstat
- if exitstatus == (0::Int)
- then return (Exited ExitSuccess)
- else return (Exited (ExitFailure exitstatus))
- else do
- signalled <- _casm_ ``%r = WIFSIGNALED(*(int *)%0);'' wstat
- if signalled /= (0::Int)
- then do
- termsig <- _casm_ ``%r = WTERMSIG(*(int *)%0);'' wstat
- return (Terminated termsig)
- else do
- stopsig <-_casm_ ``%r = WSTOPSIG(*(int *)%0);'' wstat
- return (Stopped stopsig)
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
-%
-\section[PosixTTY]{Haskell 1.3 POSIX Device-Specific Functions}
-
-\begin{code}
-module PosixTTY (
- BaudRate(..),
- ControlCharacter(..),
- FlowAction(..),
- QueueSelector(..),
- TerminalAttributes,
- TerminalMode(..),
- TerminalState(..),
- bitsPerByte,
- controlChar,
- controlFlow,
- discardData,
- drainOutput,
- getTerminalAttributes,
- getTerminalProcessGroupID,
- inputSpeed,
- inputTime,
- minInput,
- outputSpeed,
- sendBreak,
- setTerminalAttributes,
- setTerminalProcessGroupID,
- terminalMode,
- withBits,
- withCC,
- withInputSpeed,
- withMinInput,
- withMode,
- withOutputSpeed,
- withTime,
- withoutCC,
- withoutMode
- ) where
-
-import GlaExts
-import IOExts ( unsafePerformIO )
-
-import IO
-import Foreign
-
-import PosixUtil
-import PosixErr
-import CString ( freeze, allocChars )
-
-\end{code}
-
-\begin{code}
-type TerminalAttributes = ByteArray Int
-
-data TerminalMode = InterruptOnBreak
- | MapCRtoLF
- | IgnoreBreak
- | IgnoreCR
- | IgnoreParityErrors
- | MapLFtoCR
- | CheckParity
- | StripHighBit
- | StartStopInput
- | StartStopOutput
- | MarkParityErrors
- | ProcessOutput
- | LocalMode
- | ReadEnable
- | TwoStopBits
- | HangupOnClose
- | EnableParity
- | OddParity
- | EnableEcho
- | EchoErase
- | EchoKill
- | EchoLF
- | ProcessInput
- | ExtendedFunctions
- | KeyboardInterrupts
- | NoFlushOnInterrupt
- | BackgroundWriteInterrupt
-
-withoutMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
-withoutMode termios InterruptOnBreak = clearInputFlag ``BRKINT'' termios
-withoutMode termios MapCRtoLF = clearInputFlag ``ICRNL'' termios
-withoutMode termios IgnoreBreak = clearInputFlag ``IGNBRK'' termios
-withoutMode termios IgnoreCR = clearInputFlag ``IGNCR'' termios
-withoutMode termios IgnoreParityErrors = clearInputFlag ``IGNPAR'' termios
-withoutMode termios MapLFtoCR = clearInputFlag ``INLCR'' termios
-withoutMode termios CheckParity = clearInputFlag ``INPCK'' termios
-withoutMode termios StripHighBit = clearInputFlag ``ISTRIP'' termios
-withoutMode termios StartStopInput = clearInputFlag ``IXOFF'' termios
-withoutMode termios StartStopOutput = clearInputFlag ``IXON'' termios
-withoutMode termios MarkParityErrors = clearInputFlag ``PARMRK'' termios
-withoutMode termios ProcessOutput = unsafePerformIO $
- allocChars ``sizeof(struct termios)'' >>= \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_oflag &= ~OPOST;'' bytes termios
- >>= \ () ->
- freeze bytes
-withoutMode termios LocalMode = clearControlFlag ``CLOCAL'' termios
-withoutMode termios ReadEnable = clearControlFlag ``CREAD'' termios
-withoutMode termios TwoStopBits = clearControlFlag ``CSTOPB'' termios
-withoutMode termios HangupOnClose = clearControlFlag ``HUPCL'' termios
-withoutMode termios EnableParity = clearControlFlag ``PARENB'' termios
-withoutMode termios OddParity = clearControlFlag ``PARODD'' termios
-withoutMode termios EnableEcho = clearLocalFlag ``ECHO'' termios
-withoutMode termios EchoErase = clearLocalFlag ``ECHOE'' termios
-withoutMode termios EchoKill = clearLocalFlag ``ECHOK'' termios
-withoutMode termios EchoLF = clearLocalFlag ``ECHONL'' termios
-withoutMode termios ProcessInput = clearLocalFlag ``ICANON'' termios
-withoutMode termios ExtendedFunctions = clearLocalFlag ``IEXTEN'' termios
-withoutMode termios KeyboardInterrupts = clearLocalFlag ``ISIG'' termios
-withoutMode termios NoFlushOnInterrupt = setLocalFlag ``NOFLSH'' termios
-withoutMode termios BackgroundWriteInterrupt = clearLocalFlag ``TOSTOP'' termios
-
-withMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
-withMode termios InterruptOnBreak = setInputFlag ``BRKINT'' termios
-withMode termios MapCRtoLF = setInputFlag ``ICRNL'' termios
-withMode termios IgnoreBreak = setInputFlag ``IGNBRK'' termios
-withMode termios IgnoreCR = setInputFlag ``IGNCR'' termios
-withMode termios IgnoreParityErrors = setInputFlag ``IGNPAR'' termios
-withMode termios MapLFtoCR = setInputFlag ``INLCR'' termios
-withMode termios CheckParity = setInputFlag ``INPCK'' termios
-withMode termios StripHighBit = setInputFlag ``ISTRIP'' termios
-withMode termios StartStopInput = setInputFlag ``IXOFF'' termios
-withMode termios StartStopOutput = setInputFlag ``IXON'' termios
-withMode termios MarkParityErrors = setInputFlag ``PARMRK'' termios
-withMode termios ProcessOutput = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_oflag |= OPOST;'' bytes termios
- freeze bytes
-withMode termios LocalMode = setControlFlag ``CLOCAL'' termios
-withMode termios ReadEnable = setControlFlag ``CREAD'' termios
-withMode termios TwoStopBits = setControlFlag ``CSTOPB'' termios
-withMode termios HangupOnClose = setControlFlag ``HUPCL'' termios
-withMode termios EnableParity = setControlFlag ``PARENB'' termios
-withMode termios OddParity = setControlFlag ``PARODD'' termios
-withMode termios EnableEcho = setLocalFlag ``ECHO'' termios
-withMode termios EchoErase = setLocalFlag ``ECHOE'' termios
-withMode termios EchoKill = setLocalFlag ``ECHOK'' termios
-withMode termios EchoLF = setLocalFlag ``ECHONL'' termios
-withMode termios ProcessInput = setLocalFlag ``ICANON'' termios
-withMode termios ExtendedFunctions = setLocalFlag ``IEXTEN'' termios
-withMode termios KeyboardInterrupts = setLocalFlag ``ISIG'' termios
-withMode termios NoFlushOnInterrupt = clearLocalFlag ``NOFLSH'' termios
-withMode termios BackgroundWriteInterrupt = setLocalFlag ``TOSTOP'' termios
-
-terminalMode :: TerminalMode -> TerminalAttributes -> Bool
-terminalMode InterruptOnBreak = testInputFlag ``BRKINT''
-terminalMode MapCRtoLF = testInputFlag ``ICRNL''
-terminalMode IgnoreBreak = testInputFlag ``IGNBRK''
-terminalMode IgnoreCR = testInputFlag ``IGNCR''
-terminalMode IgnoreParityErrors = testInputFlag ``IGNPAR''
-terminalMode MapLFtoCR = testInputFlag ``INLCR''
-terminalMode CheckParity = testInputFlag ``INPCK''
-terminalMode StripHighBit = testInputFlag ``ISTRIP''
-terminalMode StartStopInput = testInputFlag ``IXOFF''
-terminalMode StartStopOutput = testInputFlag ``IXON''
-terminalMode MarkParityErrors = testInputFlag ``PARMRK''
-terminalMode ProcessOutput = \ termios -> unsafePerformIO $
- _casm_ ``%r = ((struct termios *)%0)->c_oflag & OPOST;'' termios
- >>= \ (W# flags#) ->
- return (flags# `neWord#` int2Word# 0#)
-terminalMode LocalMode = testControlFlag ``CLOCAL''
-terminalMode ReadEnable = testControlFlag ``CREAD''
-terminalMode TwoStopBits = testControlFlag ``CSTOPB''
-terminalMode HangupOnClose = testControlFlag ``HUPCL''
-terminalMode EnableParity = testControlFlag ``PARENB''
-terminalMode OddParity = testControlFlag ``PARODD''
-terminalMode EnableEcho = testLocalFlag ``ECHO''
-terminalMode EchoErase = testLocalFlag ``ECHOE''
-terminalMode EchoKill = testLocalFlag ``ECHOK''
-terminalMode EchoLF = testLocalFlag ``ECHONL''
-terminalMode ProcessInput = testLocalFlag ``ICANON''
-terminalMode ExtendedFunctions = testLocalFlag ``IEXTEN''
-terminalMode KeyboardInterrupts = testLocalFlag ``ISIG''
-terminalMode NoFlushOnInterrupt = not . testLocalFlag ``NOFLSH''
-terminalMode BackgroundWriteInterrupt = testLocalFlag ``TOSTOP''
-
-bitsPerByte :: TerminalAttributes -> Int
-bitsPerByte termios = unsafePerformIO $ do
- w <- _casm_ ``%r = ((struct termios *)%0)->c_cflag & CSIZE;'' termios
- return (word2Bits w)
- where
- word2Bits :: Word -> Int
- word2Bits x =
- if x == ``CS5'' then 5
- else if x == ``CS6'' then 6
- else if x == ``CS7'' then 7
- else if x == ``CS8'' then 8
- else 0
-
-withBits :: TerminalAttributes -> Int -> TerminalAttributes
-withBits termios bits = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cflag =
- (((struct termios *)%1)->c_cflag & ~CSIZE) | %2;''
- bytes termios (mask bits)
- freeze bytes
- where
- mask :: Int -> Word
- mask 5 = ``CS5''
- mask 6 = ``CS6''
- mask 7 = ``CS7''
- mask 8 = ``CS8''
- mask _ = error "withBits bit value out of range [5..8]"
-
-data ControlCharacter = EndOfFile
- | EndOfLine
- | Erase
- | Interrupt
- | Kill
- | Quit
- | Suspend
- | Start
- | Stop
-
-controlChar :: TerminalAttributes -> ControlCharacter -> Maybe Char
-controlChar termios cc = unsafePerformIO $ do
- val <- _casm_ ``%r = ((struct termios *)%0)->c_cc[%1];''
- termios (cc2Word cc)
- if val == (``_POSIX_VDISABLE''::Int)
- then return Nothing
- else return (Just (toEnum val))
-
-withCC :: TerminalAttributes
- -> (ControlCharacter, Char)
- -> TerminalAttributes
-withCC termios (cc, c) = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cc[%2] = %3;''
- bytes termios (cc2Word cc) c
- freeze bytes
-
-withoutCC :: TerminalAttributes
- -> ControlCharacter
- -> TerminalAttributes
-withoutCC termios cc = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cc[%2] = _POSIX_VDISABLE;''
- bytes termios (cc2Word cc)
- freeze bytes
-
-inputTime :: TerminalAttributes -> Int
-inputTime termios = unsafePerformIO $ do
- _casm_ ``%r = ((struct termios *)%0)->c_cc[VTIME];'' termios
-
-withTime :: TerminalAttributes -> Int -> TerminalAttributes
-withTime termios time = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cc[VTIME] = %2;'' bytes termios time
- freeze bytes
-
-minInput :: TerminalAttributes -> Int
-minInput termios = unsafePerformIO $ do
- _casm_ ``%r = ((struct termios *)%0)->c_cc[VMIN];'' termios
-
-withMinInput :: TerminalAttributes -> Int -> TerminalAttributes
-withMinInput termios count = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cc[VMIN] = %2;'' bytes termios count
- freeze bytes
-
-data BaudRate = B0
- | B50
- | B75
- | B110
- | B134
- | B150
- | B200
- | B300
- | B600
- | B1200
- | B1800
- | B2400
- | B4800
- | B9600
- | B19200
- | B38400
-
-inputSpeed :: TerminalAttributes -> BaudRate
-inputSpeed termios = unsafePerformIO $ do
- w <-_casm_ ``%r = cfgetispeed((struct termios *)%0);'' termios
- return (word2Baud w)
-
-withInputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
-withInputSpeed termios br = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- cfsetispeed((struct termios *)%0, %2);'' bytes termios (baud2Word br)
- freeze bytes
-
-outputSpeed :: TerminalAttributes -> BaudRate
-outputSpeed termios = unsafePerformIO $ do
- w <- _casm_ ``%r = cfgetospeed((struct termios *)%0);'' termios
- return (word2Baud w)
-
-withOutputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
-withOutputSpeed termios br = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- cfsetospeed((struct termios *)%0, %2);'' bytes termios (baud2Word br)
- freeze bytes
-
-getTerminalAttributes :: Fd -> IO TerminalAttributes
-getTerminalAttributes (FD# fd) = do
- bytes <- allocChars ``sizeof(struct termios)''
- rc <- _casm_ ``%r = tcgetattr(%0,(struct termios *)%1);'' fd bytes
- if rc /= ((-1)::Int)
- then freeze bytes
- else syserr "getTerminalAttributes"
-
-data TerminalState = Immediately
- | WhenDrained
- | WhenFlushed
-
-setTerminalAttributes :: Fd
- -> TerminalAttributes
- -> TerminalState
- -> IO ()
-setTerminalAttributes (FD# fd) termios state = do
- rc <- _casm_ ``%r = tcsetattr(%0,%1,(struct termios *)%2);''
- fd (state2Int state) termios
- if rc /= ((-1)::Int)
- then return ()
- else syserr "setTerminalAttributes"
- where
- state2Int :: TerminalState -> Int
- state2Int Immediately = ``TCSANOW''
- state2Int WhenDrained = ``TCSADRAIN''
- state2Int WhenFlushed = ``TCSAFLUSH''
-
-sendBreak :: Fd -> Int -> IO ()
-sendBreak (FD# fd) duration =
- nonzero_error (_ccall_ tcsendbreak fd duration) "sendBreak"
-
-drainOutput :: Fd -> IO ()
-drainOutput (FD# fd) =
- nonzero_error (_ccall_ tcdrain fd) "drainOutput"
-
-data QueueSelector = InputQueue
- | OutputQueue
- | BothQueues
-
-discardData :: Fd -> QueueSelector -> IO ()
-discardData (FD# fd) queue =
- minusone_error (_ccall_ tcflush fd (queue2Int queue)) "discardData"
- where
- queue2Int :: QueueSelector -> Int
- queue2Int InputQueue = ``TCIFLUSH''
- queue2Int OutputQueue = ``TCOFLUSH''
- queue2Int BothQueues = ``TCIOFLUSH''
-
-data FlowAction = SuspendOutput
- | RestartOutput
- | TransmitStop
- | TransmitStart
-
-controlFlow :: Fd -> FlowAction -> IO ()
-controlFlow (FD# fd) action =
- minusone_error (_ccall_ tcflow fd (action2Int action)) "controlFlow"
- where
- action2Int :: FlowAction -> Int
- action2Int SuspendOutput = ``TCOOFF''
- action2Int RestartOutput = ``TCOON''
- action2Int TransmitStop = ``TCIOFF''
- action2Int TransmitStart = ``TCION''
-
-getTerminalProcessGroupID :: Fd -> IO ProcessGroupID
-getTerminalProcessGroupID (FD# fd) = do
- pgid <- _ccall_ tcgetpgrp fd
- if pgid /= ((-1)::Int)
- then return pgid
- else syserr "getTerminalProcessGroupID"
-
-setTerminalProcessGroupID :: Fd -> ProcessGroupID -> IO ()
-setTerminalProcessGroupID (FD# fd) pgid =
- nonzero_error (_ccall_ tcsetpgrp fd pgid) "setTerminalProcessGroupID"
-
-\end{code}
-
-Local utility functions
-
-\begin{code}
-
--- Convert Haskell ControlCharacter to Int
-
-cc2Word :: ControlCharacter -> Word
-cc2Word EndOfFile = ``VEOF''
-cc2Word EndOfLine = ``VEOL''
-cc2Word Erase = ``VERASE''
-cc2Word Interrupt = ``VINTR''
-cc2Word Kill = ``VKILL''
-cc2Word Quit = ``VQUIT''
-cc2Word Suspend = ``VSUSP''
-cc2Word Start = ``VSTART''
-cc2Word Stop = ``VSTOP''
-
--- Convert Haskell BaudRate to unsigned integral type (Word)
-
-baud2Word :: BaudRate -> Word
-baud2Word B0 = ``B0''
-baud2Word B50 = ``B50''
-baud2Word B75 = ``B75''
-baud2Word B110 = ``B110''
-baud2Word B134 = ``B134''
-baud2Word B150 = ``B150''
-baud2Word B200 = ``B200''
-baud2Word B300 = ``B300''
-baud2Word B600 = ``B600''
-baud2Word B1200 = ``B1200''
-baud2Word B1800 = ``B1800''
-baud2Word B2400 = ``B2400''
-baud2Word B4800 = ``B4800''
-baud2Word B9600 = ``B9600''
-baud2Word B19200 = ``B19200''
-baud2Word B38400 = ``B38400''
-
--- And convert a word back to a baud rate
--- We really need some cpp macros here.
-
-word2Baud :: Word -> BaudRate
-word2Baud x =
- if x == ``B0'' then B0
- else if x == ``B50'' then B50
- else if x == ``B75'' then B75
- else if x == ``B110'' then B110
- else if x == ``B134'' then B134
- else if x == ``B150'' then B150
- else if x == ``B200'' then B200
- else if x == ``B300'' then B300
- else if x == ``B600'' then B600
- else if x == ``B1200'' then B1200
- else if x == ``B1800'' then B1800
- else if x == ``B2400'' then B2400
- else if x == ``B4800'' then B4800
- else if x == ``B9600'' then B9600
- else if x == ``B19200'' then B19200
- else if x == ``B38400'' then B38400
- else error "unknown baud rate"
-
--- Clear termios i_flag
-
-clearInputFlag :: Word -> TerminalAttributes -> TerminalAttributes
-clearInputFlag flag termios = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_iflag &= ~%2;'' bytes termios flag
- freeze bytes
-
--- Set termios i_flag
-
-setInputFlag :: Word -> TerminalAttributes -> TerminalAttributes
-setInputFlag flag termios = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_iflag |= %2;'' bytes termios flag
- freeze bytes
-
--- Examine termios i_flag
-
-testInputFlag :: Word -> TerminalAttributes -> Bool
-testInputFlag flag termios = unsafePerformIO $
- _casm_ ``%r = ((struct termios *)%0)->c_iflag & %1;'' termios flag
- >>= \ (W# flags#) ->
- return (flags# `neWord#` int2Word# 0#)
-
--- Clear termios c_flag
-
-clearControlFlag :: Word -> TerminalAttributes -> TerminalAttributes
-clearControlFlag flag termios = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cflag &= ~%2;'' bytes termios flag
- freeze bytes
-
--- Set termios c_flag
-
-setControlFlag :: Word -> TerminalAttributes -> TerminalAttributes
-setControlFlag flag termios = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cflag |= %2;'' bytes termios flag
- freeze bytes
-
--- Examine termios c_flag
-
-testControlFlag :: Word -> TerminalAttributes -> Bool
-testControlFlag flag termios = unsafePerformIO $
- _casm_ ``%r = ((struct termios *)%0)->c_cflag & %1;'' termios flag
- >>= \ (W# flags#) ->
- return (flags# `neWord#` int2Word# 0#)
-
--- Clear termios l_flag
-
-clearLocalFlag :: Word -> TerminalAttributes -> TerminalAttributes
-clearLocalFlag flag termios = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_lflag &= ~%2;'' bytes termios flag
- freeze bytes
-
--- Set termios l_flag
-
-setLocalFlag :: Word -> TerminalAttributes -> TerminalAttributes
-setLocalFlag flag termios = unsafePerformIO $ do
- bytes <- allocChars ``sizeof(struct termios)''
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_lflag |= %2;'' bytes termios flag
- freeze bytes
-
--- Examine termios l_flag
-
-testLocalFlag :: Word -> TerminalAttributes -> Bool
-testLocalFlag flag termios = unsafePerformIO $
- _casm_ ``%r = ((struct termios *)%0)->c_iflag & %1;'' termios flag
- >>= \ (W# flags#) ->
- return (flags# `neWord#` int2Word# 0#)
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1999
-%
-\section[PosixUtil]{(Glasgow) Haskell POSIX utilities}
-
-\begin{code}
-module PosixUtil where
-
-import GlaExts
-import PrelIOBase -- IOError representation
-\end{code}
-
-First, all of the major Posix data types, out here
-to avoid any recursive dependencies
-
-\begin{code}
-type ByteCount = Int
-type ClockTick = Int
-type EpochTime = Int
-type FileOffset = Int
-type GroupID = Int
-type Limit = Int
-type LinkCount = Int
-type ProcessID = Int
-type ProcessGroupID = ProcessID
-type UserID = Int
-data Fd = FD# Int#
-instance CCallable Fd
-instance CReturnable Fd
-
-instance Eq Fd where
- (FD# x#) == (FD# y#) = x# ==# y#
-
--- use with care.
-intToFd :: Int -> Fd
-intToFd (I# fd#) = FD# fd#
-
-fdToInt :: Fd -> Int
-fdToInt (FD# x#) = I# x#
-\end{code}
-
-Now some local functions that shouldn't go outside this library.
-
-Fail with a SystemError. Normally, we do not try to re-interpret
-POSIX error numbers, so most routines in this file will only fail
-with SystemError. The only exceptions are (1) those routines where
-failure of some kind may be considered ``normal''...e.g. getpwnam()
-for a non-existent user, or (2) those routines which do not set
-errno.
-
-\begin{code}
-syserr :: String -> IO a
-syserr str = ioError (IOError Nothing -- ToDo: better
- SystemError
- str
- "")
-
--- common templates for system calls
-
-nonzero_error :: IO Int -> String -> IO ()
-nonzero_error io err = do
- rc <- io
- if rc == 0
- then return ()
- else syserr err
-
-minusone_error :: IO Int -> String -> IO ()
-minusone_error io err = do
- rc <- io
- if rc /= -1
- then return ()
- else syserr err
-
-\end{code}
+++ /dev/null
-#
-# Makefile for cbits subdirectory
-#
-TOP=../../..
-include $(TOP)/mk/boilerplate.mk
-override WAYS=
-
-# Hack!
-SRC_CC_OPTS += -I$(GHC_INCLUDE_DIR)
-
-CC=$(GHC)
-C_SRCS=$(wildcard *.c)
-LIBRARY=libHSposix_cbits.a
-LIBOBJS=$(C_OBJS)
-INSTALL_LIBS += $(LIBRARY)
-
-include $(TOP)/mk/target.mk
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
- *
- * \subsection[env.lc]{Environment Handling for LibPosix}
- *
- * Many useful environment functions are not necessarily provided by libc.
- * To get around this problem, we introduce our own. The first time that
- * you modify your environment, we copy the environment wholesale into
- * malloc'ed locations, so that subsequent modifications can do proper
- * memory management. The $environ$ variable is updated with a pointer
- * to the current environment so that the normal $getenv$ and $exec*$ functions
- * should continue to work properly.
- */
-
-#include "Rts.h"
-#include "libposix.h"
-
-/* Switch this on once we've moved the environment to the malloc arena */
-int dirtyEnv = 0;
-
-/*
- * For some reason, OSF turns off the prototype for this if we're
- * _POSIX_SOURCE. Seems to me that this ought to be an ANSI-ism
- * rather than a POSIX-ism, but no matter. (JSM(?))
- */
-
-char *
-strDup(const char *src)
-{
- int len = strlen(src) + 1;
- char *dst;
-
- if ((dst = malloc(len)) != NULL)
- memcpy(dst, src, len);
- return dst;
-}
-
-/* Replace the entire environment */
-int
-setenviron(char **envp)
-{
- char **old = environ;
- int dirtyOld = dirtyEnv;
- int i;
-
- /* A quick hack to move the strings out of the heap */
- environ = envp;
- if (copyenv() != 0) {
- environ = old;
- return -1;
- }
- /* Release the old space if we allocated it ourselves earlier */
- if (dirtyOld) {
- for (i = 0; old[i] != NULL; i++)
- free(old[i]);
- free(old);
- }
- return 0;
-}
-
-/* Copy initial environment into malloc arena */
-int
-copyenv(void)
-{
- char **new;
- int i;
-
- for (i = 0; environ[i] != NULL; i++)
- ;
-
- if ((new = (char **) malloc((i + 1) * sizeof(char *))) == NULL)
- return -1;
-
- new[i] = NULL;
-
- while (--i >= 0) {
- if ((new[i] = strDup(environ[i])) == NULL) {
- while (new[++i] != NULL)
- free(new[i]);
- free(new);
- return -1;
- }
- }
- environ = new;
- dirtyEnv = 1;
- return 0;
-}
-
-/* Set or replace an environment variable
- * simonm 14/2/96 - this is different to the standard C library
- * implementation and the prototypes clash, so I'm calling it _setenv.
- */
-int
-_setenv(char *mapping)
-{
- int i, keylen;
- char *p;
- char **new;
-
- /* We must have a non-empty key and an '=' */
- if (mapping[0] == '=' || (p = strchr(mapping, '=')) == NULL) {
- errno = EINVAL;
- return -1;
- }
- /* Include through the '=' for matching */
- keylen = p - mapping + 1;
-
- if (!dirtyEnv && copyenv() != 0)
- return -1;
-
- if ((p = strDup(mapping)) == NULL)
- return -1;
-
- /* Look for an existing key that matches */
- for (i = 0; environ[i] != NULL && strncmp(environ[i], p, keylen) != 0; i++);
-
- if (environ[i] != NULL) {
- free(environ[i]);
- environ[i] = p;
- } else {
- /* We want to grow the table by *two*, one for the new entry, one for the terminator */
- if ((new = (char **) realloc((void*)environ, (i + 2) * sizeof(char *))) == NULL) {
- free(p);
- return -1;
- }
- new[i] = p;
- new[i + 1] = NULL;
- environ = new;
- }
- return 0;
-}
-
-/* Delete a variable from the environment */
-int
-delenv(char *name)
-{
- int i, keylen;
-
- if (strchr(name, '=') != NULL) {
- errno = EINVAL;
- return -1;
- }
- keylen = strlen(name);
-
- if (!dirtyEnv && copyenv() != 0)
- return -1;
-
- /* Look for a matching key */
- for (i = 0; environ[i] != NULL &&
- (strncmp(environ[i], name, keylen) != 0 || environ[i][keylen] != '='); i++);
-
- /* Don't complain if it wasn't there to begin with */
- if (environ[i] == NULL) {
- return 0;
- }
- free(environ[i]);
-
- do {
- environ[i] = environ[i + 1];
- i++;
- } while (environ[i] != NULL);
-
- return 0;
-}
+++ /dev/null
-/*
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
-%
-\subsection[posix.lc]{executeFile Runtime Support}
-
-\begin{code}
-*/
-#if !defined(_AIX)
-#define NON_POSIX_SOURCE
-#endif
-
-#include "Rts.h"
-#include "libposix.h"
-
-/*
- * We want the search semantics of execvp, but we want to provide our
- * own environment, like execve. The following copyright applies to
- * this code, as it is a derivative of execvp:
- *-
- * Copyright (c) 1991 The Regents of the University of California.
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- * 3. All advertising materials mentioning features or use of this software
- * must display the following acknowledgement:
- * This product includes software developed by the University of
- * California, Berkeley and its contributors.
- * 4. Neither the name of the University nor the names of its contributors
- * may be used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
- * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
- * SUCH DAMAGE.
- */
-
-int
-execvpe(char *name, char **argv, char **envp)
-{
- register int lp, ln;
- register char *p;
- int eacces, etxtbsy;
- char *bp, *cur, *path, *buf;
-
- /* If it's an absolute or relative path name, it's easy. */
- if (strchr(name, '/')) {
- bp = (char *) name;
- cur = path = buf = NULL;
- goto retry;
- }
-
- /* Get the path we're searching. */
- if (!(path = getenv("PATH"))) {
-#ifdef HAVE_CONFSTR
- ln = confstr(_CS_PATH, NULL, 0);
- if ((cur = path = malloc(ln + 1)) != NULL) {
- path[0] = ':';
- (void) confstr (_CS_PATH, path + 1, ln);
- }
-#else
- if ((cur = path = malloc(1 + 1)) != NULL) {
- path[0] = ':';
- path[1] = '\0';
- }
-#endif
- } else
- cur = path = strDup(path);
-
- if (path == NULL || (bp = buf = malloc(strlen(path)+strlen(name)+2)) == NULL)
- goto done;
-
- eacces = etxtbsy = 0;
- while (cur != NULL) {
- p = cur;
- if ((cur = strchr(cur, ':')) != NULL)
- *cur++ = '\0';
-
- /*
- * It's a SHELL path -- double, leading and trailing colons mean the current
- * directory.
- */
- if (!*p) {
- p = ".";
- lp = 1;
- } else
- lp = strlen(p);
- ln = strlen(name);
-
- memcpy(buf, p, lp);
- buf[lp] = '/';
- memcpy(buf + lp + 1, name, ln);
- buf[lp + ln + 1] = '\0';
-
- retry:
- (void) execve(bp, argv, envp);
- switch (errno) {
- case EACCES:
- eacces = 1;
- break;
- case ENOENT:
- break;
- case ENOEXEC:
- {
- register size_t cnt;
- register char **ap;
-
- for (cnt = 0, ap = (char **) argv; *ap; ++ap, ++cnt)
- ;
- if ((ap = malloc((cnt + 2) * sizeof(char *))) != NULL) {
- memcpy(ap + 2, argv + 1, cnt * sizeof(char *));
-
- ap[0] = "sh";
- ap[1] = bp;
- (void) execve("/bin/sh", ap, envp);
- free(ap);
- }
- goto done;
- }
- case ETXTBSY:
- if (etxtbsy < 3)
- (void) sleep(++etxtbsy);
- goto retry;
- default:
- goto done;
- }
- }
- if (eacces)
- errno = EACCES;
- else if (!errno)
- errno = ENOENT;
- done:
- if (path)
- free(path);
- if (buf)
- free(buf);
- return (-1);
-}
+++ /dev/null
-#ifndef LIBPOSIX_H
-#ifdef HAVE_SYS_WAIT_H
-#include <sys/wait.h>
-#endif /* HAVE_SYS_WAIT_H */
-
-#ifdef HAVE_SIGNAL_H
-#include <signal.h>
-#endif /* HAVE_SIGNAL_H */
-
-#ifdef HAVE_SYS_UTSNAME_H
-#include <sys/utsname.h>
-#endif /* HAVE_SYS_UTSNAME_H */
-
-#ifdef HAVE_SYS_TIMES_H
-#include <sys/times.h>
-#endif /* HAVE_SYS_TIMES_H */
-
-#ifdef HAVE_DIRENT_H
-#include <dirent.h>
-#endif /* HAVE_DIRENT_H */
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif /* HAVE_SYS_STAT_H */
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif /* HAVE_FCNTL_H */
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif /* HAVE_UNISTD_H */
-
-#ifdef HAVE_UTIME_H
-#include <utime.h>
-#endif /* HAVE_UTIME_H */
-
-#ifdef HAVE_TERMIOS_H
-#include <termios.h>
-#endif /* HAVE_TERMIOS_H */
-
-#ifdef HAVE_GRP_H
-#include <grp.h>
-#endif /* HAVE_GRP_H */
-
-#ifdef HAVE_PWD_H
-#include <pwd.h>
-#endif /* HAVE_PWD_H */
-
-#if TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-#else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-#endif
-
-#ifndef _POSIX_VDISABLE
-#define _POSIX_VDISABLE '\0' /* Just a guess...but it works for Suns */
-#endif
-
-extern I_ nocldstop;
-
-char *strDup (const char *);
-int setenviron (char **);
-int copyenv (void);
-int _setenv (char *);
-int delenv (char *);
-int execvpe (char *, char **, char **);
-void stg_sigaddset(StgByteArray newset, StgByteArray oldset, int signum);
-void stg_sigdelset(StgByteArray newset, StgByteArray oldset, int signum);
-
-#define LIBPOSIX_H
-#endif
+++ /dev/null
-/*
- * (c) Juan Quintela, Universidade da Corunha 1998
- *
- * wrappers for signal funcions
- *
- * sigset_t is a struct in some UNIXes (LINUX/glibc for instance)
- * and it is not posible to do the inline (_casm_). These functions
- * aren't inline because it causes gcc to run out of registers on x86.
- *
- * Ugly casting added by SUP to avoid C compiler warnings about
- * incompatible pointer types.
- */
-
-#include "Rts.h"
-#include "libposix.h"
-
-void
-stg_sigaddset(StgByteArray newset, StgByteArray oldset, int signum)
-{
- *((sigset_t *)newset) = *((sigset_t *)oldset);
- sigaddset((sigset_t *)newset, signum);
-}
-
-void
-stg_sigdelset(StgByteArray newset, StgByteArray oldset, int signum)
-{
- *((sigset_t *)newset) = *((sigset_t *)oldset);
- sigdelset((sigset_t *)newset, signum);
-}
} elsif ( /^-syslib$/ ) {
push(@Syslibs, &grab_arg_arg(*Args,$_,''));
} elsif ( /^-fglasgow-exts$/ ) {
- push(@Syslibs, 'exts');
+ push(@Syslibs, 'lang');
} elsif ( /^-concurrent$/ ) {
push(@Syslibs, 'concurrent');
} elsif (/^-#include(.*)/) {
local($dir);
# Yuck ^ 2
+ if ( $lib eq 'text' && ! $INSTALLING ) {
+ push(@Import_dirs, "${TopPwd}/hslibs/${lib}/html");
+ }
+ if ( $lib eq 'data' && ! $INSTALLING ) {
+ push(@Import_dirs, "${TopPwd}/hslibs/${lib}/edison");
+ push(@Import_dirs, "${TopPwd}/hslibs/${lib}/edison/Assoc");
+ push(@Import_dirs, "${TopPwd}/hslibs/${lib}/edison/Coll");
+ push(@Import_dirs, "${TopPwd}/hslibs/${lib}/edison/Seq");
+ }
+
+ # Yuck ^ 3
if ( $lib eq 'win32' && ! $INSTALLING ) {
$dir = "${TopPwd}/hslibs/${lib}/src";
} elsif ( $lib eq 'com' && ! $INSTALLING ) {
- $dir = "${TopPwd}/hdirect/lib";
+ $dir = "${TopPwd}/hslibs/lib";
} else {
$dir = ($INSTALLING) ? "${InstLibDirGhc}/imports/${lib}"
- : "${TopPwd}/ghc/lib/${lib}";
+ : "${TopPwd}/hslibs/${lib}";
}
if (!$Include_prelude) {
push(@Ignore_dirs,$dir);
projects / ghc-hetmet.git / commitdiff