for the Debian
+system (but may be used by others).
+
+
diff --git a/docs/design b/docs/design
new file mode 100644
--- /dev/null
+++ b/docs/design
@@ -0,0 +1,29 @@
+Design for hspp
+
+First pass:
+-----------
+ * traverse the file,
+ - processing #if's and #ifdef's
+ - reading #include's and recursively doing this pass on them
+ - leaving #line's behind
+ - whilst taking account of #define's and #undef's
+ * only needs to look at lines beginning with a #
+ * should discard C-style comments? (no)
+ * DO NOT gather the #define's for macros - their sequence matters!
+
+pass1 :: SymTab -> String -> String
+
+Second pass:
+------------
+ * traverse the residual file,
+ - keeping track of #define'd macros
+ - expanding #define'd macros when an instance is encountered
+ * needs a whitespace-preserving tokeniser with odd rules to
+ cover e.g. token concatenation. Within Haskell, quotation marks start
+ strings, haskell comments are preserved. Within a cpp directive,
+ quotation marks do not start a string, and C-style comments are
+ converted to whitespace.
+ * Line continuation characters are tricky; probably should only
+ be recognised within a macro definition, not in ordinary code.
+
+pass2 :: SymTab -> String -> String
diff --git a/docs/index.html b/docs/index.html
new file mode 100644
--- /dev/null
+++ b/docs/index.html
@@ -0,0 +1,484 @@
+
+
+
+
+ cpphs
+
+
+
+
+
+
+cpphs
+
+
+
+
+
+
+cpphs is a liberalised re-implementation of
+cpp,
+the C pre-processor, in Haskell.
+
+
+Why re-implement cpp? Rightly or wrongly, the C pre-processor is
+widely used in Haskell source code. It enables conditional compilation
+for different compilers, different versions of the same compiler,
+and different OS platforms. It is also occasionally used for its
+macro language, which can enable certain forms of platform-specific
+detail-filling, such as the tedious boilerplate generation of instance
+definitions and FFI declarations. However, there are two problems with
+cpp, aside from the obvious aesthetic ones:
+
+ - For some Haskell systems, notably Hugs on Windows, a true cpp
+ is not available by default.
+
- Even for the other Haskell systems, the common cpp provided by
+ the gcc 3.x and 4.x series has changed subtly in ways that are
+ incompatible with Haskell's syntax. There have always been
+ problems with, for instance, string gaps, and prime characters
+ in identifiers. These problems are only going to get worse.
+
+So, it seemed right to provide an alternative to cpp, both more
+compatible with Haskell, and itself written in Haskell so that it
+can be distributed with compilers.
+
+
+This version of the C pre-processor is pretty-much feature-complete,
+and compatible with the -traditional style.
+It has two main modes:
+
+ - conditional compilation only (--nomacro),
+
- and full macro-expansion (default).
+
+In --nomacro mode, cpphs performs only conditional
+compilation actions, namely #include's, #if's,
+and #ifdef's are processed according to text-replacement
+definitions (both command-line and internal), but no parameterised
+macro expansion is performed. In full compatibility mode (the
+default), textual replacements and macro expansions are also processed
+in the remaining body of non-cpp text.
+
+
+Source language features:
+
+| #ifdef | simple conditional compilation |
+| #if | the full boolean language of defined(),
+ &&, ||, ==, etc. |
+| #elif | chained conditionals |
+| #define | in-line definitions (text replacements and macros) |
+| #undef | in-line revocation of definitions |
+| #include | file inclusion |
+| #line | line number directives |
+| \\n | line continuations within all # directives |
+| /**/ | token catenation within a macro definition |
+| ## | ANSI-style token catenation |
+| # | ANSI-style token stringisation |
+| __FILE__ | special text replacement for DIY error messages |
+| __LINE__ | special text replacement for DIY error messages |
+| __DATE__ | special text replacement |
+| __TIME__ | special text replacement |
+
+
+
+Macro expansion is recursive. Redefinition of a macro name does not
+generate a warning. Macros can be defined on the command-line with
+-D just like textual replacements. Macro names are permitted to be
+Haskell identifiers e.g. with the prime ' and backtick ` characters,
+which is slightly looser than in C, but they still may not include
+operator symbols.
+
+
+Numbering of lines in the output is preserved so that any later
+processor can give meaningful error messages. When a file is
+#include'd, cpphs inserts #line directives for the
+same reason. Numbering should be correct even in the presence of
+line continuations. If you don't want #line directives in
+the final output, use the --noline option.
+
+
+Any syntax error in a cpp directive gives a warning message to stderr.
+Failure to find a #include'd file also produces a warning to stderr. In
+both cases, processing continues on the rest of the input.
+
+
+
+
+
+Usage: cpphs [ filename | -Dsym | -Dsym=val | -Ipath ]+ [-Ofile]
+ [--nomacro|--noline|--strip|--text|--hashes|--layout|--unlit]*
+ [ --cpp compatopts ]
+ cpphs --version
+
+
+You can give any number of filenames on the command-line. The results
+are catenated on standard output. (Macro definitions in one file do not
+carry over into the next.) If no filename is given, cpphs reads from
+standard input.
+
+
+Options:
+
+| -Dsym |
+ define a textual replacement (default value is 1) |
+| -Dsym=val |
+ define a textual replacement with a specific value |
+| -Dsym(args)=val |
+ define a macro with arguments |
+| -Ipath |
+ add a directory to the search path for #include's |
+| -Ofile |
+ specify a file for output (default is stdout) |
+| --nomacro |
+ only process #ifdef's and #include's, do not expand macros |
+| --noline |
+ remove #line droppings from the output |
+| --strip |
+ convert C-style comments to whitespace, even outside
+ cpp directives |
+| --hashes |
+ recognise the ANSI # stringise operator, and ## for
+ token catenation, within macros |
+| --text |
+ treat input as plain text, not Haskell code |
+| --layout |
+ preserve newlines within macro expansions |
+| --unlit |
+ unlit literate source code |
+| --cpp compatopts |
+ accept standard cpp options: -o, -x, -ansi, -traditional,
+ -P, -C, -A, etc |
+| --version |
+ report version number of cpphs and stop |
+
+
+
+There are NO textual replacements defined by default. (Normal cpp
+usually has definitions for machine, OS, etc. You can easily create
+a wrapper script if you need these.) The search path is searched in
+order of the -I options, except that the directory of the calling file,
+then the current directory, are always searched first. Again, there
+is no default search path (unless you define one via a wrapper script).
+
+
+
+
+
+
+Current stable version:
+
+cpphs-1.3, release date 2006.10.09
+By HTTP:
+.tar.gz,
+.zip.
+Windows binary,
+Fedora package,
+Gentoo package,
+FreeBSD port,
+OpenBSD port.
+
+- Added a "--cpp" option for drop-in compatibility with standard cpp.
+ It causes cpphs to accept standard cpp flags and translate
+ them to cpphs equivalents. Compatibility options include: -o, -ansi,
+ -traditional, -stdc, -x, -include, -P, -C, -CC, -A. The file
+ behaviour is different too - if two filenames are given on the
+ commandline, then the second is treated as the output location.
+
- Fixed a corner-case bug in evaluating chained and overlapping #ifdefs.
+
+
+
+Development:
+
+The current darcs repository of
+cpphs is available at
+
+ darcs get http://www.cs.york.ac.uk/fp/darcs/cpphs
+
+(Users on Windows or MacOS filesystems need to use the
+--partial flag.) The source tree and version history can
+be browsed on-line through
+darcsweb.
+
+
+Older versions:
+
+cpphs-1.2, release date 2006.05.04
+By HTTP:
+.tar.gz,
+.zip,
+Windows binary.
+
+- Re-arranged the source files into hierarchical libraries.
+
- Exposed the library interface as an installable Cabal package, with
+ Haddock documentation.
+
- Added the --unlit option, for removing literate-style comments.
+
+
+
+cpphs-1.1, release date 2005.10.14
+By HTTP:
+.tar.gz,
+.zip.
+
+- Fixed the .cabal way of building cpphs.
+
- Update the --version reported (forgotten in 1.0, which still
+ mistakenly reports 0.9).
+
- No longer throws an error on an empty file.
+
+
+
+cpphs-1.0, release date 2005.10.05
+By HTTP:
+.tar.gz,
+.zip.
+
+- Included the cpphs.compat script for argument
+ compatibility with the original cpp.
+
- Placed quotes around replacements for special macros __FILE__, __DATE__,
+ and __TIME__.
+
- If no files are specified, read from stdin.
+
- Ignore #! lines (e.g. in scripts)
+
- Parse -D commandline options consistently with cpp,
+ i.e. -Dfoo means foo=1
+
- Fix compatibility with preprocessors like hsc2hs, which use
+ non-cpp directives like #def. They are now passed through to the
+ output with a warning to stderr.
+
+
+
+cpphs-0.9, release date 2005.03.17
+By HTTP:
+.tar.gz,
+.zip.
+
+- Bugfix for ghc-6.4 -O: flush output buffer.
+
+
+
+cpphs-0.8, release date 2004.11.14
+By HTTP:
+.tar.gz,
+.zip.
+
+- Added the --text option, to signify the input should not
+ be lexed as Haskell. This causes macros to be defined or expanded
+ regardless of their location within comments, string delimiters, etc.
+
- Shuffled some source files around - there is now a runhugs script
+ to invoke cpphs nicely.
+
+
+
+cpphs-0.7, release date 2004.09.01
+By HTTP:
+.tar.gz,
+.zip.
+
+- Enable the __FILE__, __LINE__, __DATE__,
+ and __TIME__ specials, which can be useful for creating
+ DIY error messages.
+
+
+
+cpphs-0.6, release date 2004.07.30
+By HTTP:
+.tar.gz,
+.zip.
+
+
+
+cpphs-0.5, release date 2004.06.07
+By HTTP:
+.tar.gz,
+.zip.
+
+- Added a --version flag to report the version number.
+
- Renamed --stringise to --hashes, and use it to turn on ## catenation
+ as well.
+
- Bugfix for #if 1, previously interpreted as false.
+
- Bugfix for --nolines: it no longer adds extra spurious newlines.
+
- File inclusion now looks in the directory of the calling file.
+
- Failure to find an include file is now merely a warning to stderr
+ rather than an error.
+
- Added a --layout flag. Previously, line continuations in a macro
+ definition were always preserved in the output, permitting use
+ of the Haskell layout rule even inside a macro. The default is now
+ to remove line continuations for conformance with cpp, but the option
+ of using --layout is still possible.
+
+
+
+cpphs-0.4, release date 2004.05.19
+By HTTP:
+.tar.gz,
+.zip.
+
+- New flag -Ofile to redirect output
+
- Bugfix for precedence of ! in #if !False && False
+
- Bugfix for whitespace permitted between # and if
+
- Bugfix for #define F "blah"; #include F
+
+
+
+cpphs-0.3, release date 2004.05.18
+By HTTP:
+.tar.gz,
+.zip.
+
+Fix recursive macro expansion bug. Added option to strip C comments.
+Added option to recognise the # stringise operator.
+
+
+cpphs-0.2, release date 2004.05.15
+By HTTP:
+.tar.gz,
+.zip.
+
+Implements textual replacement and macro expansion.
+
+
+cpphs-0.1, release date 2004.04.07
+By HTTP:
+.tar.gz,
+.zip.
+
+Initial release: implements conditional compilation and file inclusion only.
+
+
+
+Building instructions
+
+To build cpphs, use
+
hmake cpphs [-package base]
+
+or
+ ghc --make cpphs [-o cpphs]
+
+or
+ mv cpphs.hugs cpphs # a simple runhugs script
+
+
+
+You will notice that the command-line arguments for cpphs
+are not the same as for the original cpp. If you want
+to use cpphs as a completely drop-in replacement for
+the real cpp, that is, to accept the same arguments, and
+have broadly the same behaviour in response to them, then use the
+--cpp compatibility option as the first commandline flag.
+
+
+
+
+
+In general, cpphs is based on the -traditional behaviour, not
+ANSI C, and has the following main differences from the standard cpp.
+
+
+General
+
+- The # that introduces any cpp directive must be in the first
+ column of a line (whereas ANSI permits whitespace before the #).
+
- Generates the #line n "filename" syntax, not the # n
+ "filename" variant.
+
- C comments are only removed from within cpp directives. They are
+ not stripped from other text. Consider for instance that in
+ Haskell, all of the following are valid operator symbols: /*
+ */ */* However, you can turn on C-comment removal with the
+ --strip option.
+
- Macros are never expanded within Haskell comments, strings,
+ or character constants, unless you give the --text option to
+ disable lexing the input as Haskell.
+
- Macros are always expanded recursively, unlike ANSI, which detects
+ and prevents self-recursion. For instance, #define foo x:foo
+ expands foo once only to x:foo in ANSI, but in cpphs
+ it becomes an infinite list x:x:x:x:..., i.e. cpphs does not
+ terminate.
+
+
+Macro definition language
+
+- Accepts /**/ for token-pasting in a macro definition.
+ However, /* */ (with any text between the open/close
+ comment) inserts whitespace.
+
- The ANSI ## token-pasting operator is available with
+ the --hashes flag. This is to avoid misinterpreting
+ any valid Haskell operator of the same name.
+
- Replaces a macro formal parameter with the actual, even inside a
+ string (double or single quoted). This is -traditional behaviour,
+ not supported in ANSI.
+
- Recognises the # stringisation operator in a macro
+ definition only if you use the --hashes option. (It is
+ an ANSI addition, only needed because quoted stringisation (above)
+ is prohibited by ANSI.)
+
- Preserves whitespace within a textual replacement definition
+ exactly (modulo newlines), but leading and trailing space is eliminated.
+
- Preserves whitespace within a macro definition (and trailing it)
+ exactly (modulo newlines), but leading space is eliminated.
+
- Preserves whitespace within macro call arguments exactly
+ (including newlines), but leading and trailing space is eliminated.
+
- With the --layout option, line continuations in a textual
+ replacement or macro definition are preserved as line-breaks in the
+ macro call. (Useful for layout-sensitive code in Haskell.)
+
+
+
+
+
+You can use cpphs as a library from within a Haskell program. The main
+interface is in Language.Preprocessor.Cpphs. Haddock
+documentation is here. To make the library
+available to your haskell compiler, you must install the cpphs package
+using Cabal.
+
+
+
+
+I am interested in hearing your feedback on cpphs. Bug reports
+especially welcome. You can send feature requests too, but I won't
+guarantee to implement them if they depart much from the ordinary
+cpp's behaviour. Please mail
+
+
+Copyright: © 2004-2006 Malcolm Wallace,
+except for ParseLib (Copyright © 1995 Graham Hutton and Erik Meijer)
+
+
License: The library modules in cpphs are distributed under
+the terms of the LGPL (see file LICENCE-LGPL
+for more details). If that's a problem for you, contact me to make
+other arrangements. The application module 'cpphs.hs' itself is GPL
+(see file LICENCE-GPL).
+
+
+This software comes with no warranty. Use at your own risk.
+
+
+
+
+
diff --git a/tests/Arr.lhs b/tests/Arr.lhs
new file mode 100644
--- /dev/null
+++ b/tests/Arr.lhs
@@ -0,0 +1,683 @@
+\begin{code}
+{-# OPTIONS_GHC -fno-implicit-prelude -fno-bang-patterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Arr
+-- Copyright : (c) The University of Glasgow, 1994-2000
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC extensions)
+--
+-- GHC\'s array implementation.
+--
+-----------------------------------------------------------------------------
+
+-- #hide
+module GHC.Arr where
+
+import {-# SOURCE #-} GHC.Err ( error )
+import GHC.Enum
+import GHC.Num
+import GHC.ST
+import GHC.Base
+import GHC.List
+import GHC.Show
+
+infixl 9 !, //
+
+default ()
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The @Ix@ class}
+%* *
+%*********************************************************
+
+\begin{code}
+-- | The 'Ix' class is used to map a contiguous subrange of values in
+-- a type onto integers. It is used primarily for array indexing
+-- (see "Data.Array", "Data.Array.IArray" and "Data.Array.MArray").
+--
+-- The first argument @(l,u)@ of each of these operations is a pair
+-- specifying the lower and upper bounds of a contiguous subrange of values.
+--
+-- An implementation is entitled to assume the following laws about these
+-- operations:
+--
+-- * @'inRange' (l,u) i == 'elem' i ('range' (l,u))@
+--
+-- * @'range' (l,u) '!!' 'index' (l,u) i == i@, when @'inRange' (l,u) i@
+--
+-- * @'map' ('index' (l,u)) ('range' (l,u))) == [0..'rangeSize' (l,u)-1]@
+--
+-- * @'rangeSize' (l,u) == 'length' ('range' (l,u))@
+--
+-- Minimal complete instance: 'range', 'index' and 'inRange'.
+--
+class (Ord a) => Ix a where
+ -- | The list of values in the subrange defined by a bounding pair.
+ range :: (a,a) -> [a]
+ -- | The position of a subscript in the subrange.
+ index :: (a,a) -> a -> Int
+ -- | Like 'index', but without checking that the value is in range.
+ unsafeIndex :: (a,a) -> a -> Int
+ -- | Returns 'True' the given subscript lies in the range defined
+ -- the bounding pair.
+ inRange :: (a,a) -> a -> Bool
+ -- | The size of the subrange defined by a bounding pair.
+ rangeSize :: (a,a) -> Int
+ -- | like 'rangeSize', but without checking that the upper bound is
+ -- in range.
+ unsafeRangeSize :: (a,a) -> Int
+
+ -- Must specify one of index, unsafeIndex
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = error "Error in array index"
+ unsafeIndex b i = index b i
+
+ rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1
+ | otherwise = 0 -- This case is only here to
+ -- check for an empty range
+ -- NB: replacing (inRange b h) by (l <= h) fails for
+ -- tuples. E.g. (1,2) <= (2,1) but the range is empty
+
+ unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1
+\end{code}
+
+Note that the following is NOT right
+ rangeSize (l,h) | l <= h = index b h + 1
+ | otherwise = 0
+
+Because it might be the case that l (a,a) -> a -> String -> b
+indexError rng i tp
+ = error (showString "Ix{" . showString tp . showString "}.index: Index " .
+ showParen True (showsPrec 0 i) .
+ showString " out of range " $
+ showParen True (showsPrec 0 rng) "")
+
+----------------------------------------------------------------------
+instance Ix Char where
+ {-# INLINE range #-}
+ range (m,n) = [m..n]
+
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex (m,_n) i = fromEnum i - fromEnum m
+
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = indexError b i "Char"
+
+ inRange (m,n) i = m <= i && i <= n
+
+----------------------------------------------------------------------
+instance Ix Int where
+ {-# INLINE range #-}
+ -- The INLINE stops the build in the RHS from getting inlined,
+ -- so that callers can fuse with the result of range
+ range (m,n) = [m..n]
+
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex (m,_n) i = i - m
+
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = indexError b i "Int"
+
+ {-# INLINE inRange #-}
+ inRange (I# m,I# n) (I# i) = m <=# i && i <=# n
+
+----------------------------------------------------------------------
+instance Ix Integer where
+ {-# INLINE range #-}
+ range (m,n) = [m..n]
+
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex (m,_n) i = fromInteger (i - m)
+
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = indexError b i "Integer"
+
+ inRange (m,n) i = m <= i && i <= n
+
+----------------------------------------------------------------------
+instance Ix Bool where -- as derived
+ {-# INLINE range #-}
+ range (m,n) = [m..n]
+
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex (l,_) i = fromEnum i - fromEnum l
+
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = indexError b i "Bool"
+
+ inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u
+
+----------------------------------------------------------------------
+instance Ix Ordering where -- as derived
+ {-# INLINE range #-}
+ range (m,n) = [m..n]
+
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex (l,_) i = fromEnum i - fromEnum l
+
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = indexError b i "Ordering"
+
+ inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u
+
+----------------------------------------------------------------------
+instance Ix () where
+ {-# INLINE range #-}
+ range ((), ()) = [()]
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex ((), ()) () = 0
+ {-# INLINE inRange #-}
+ inRange ((), ()) () = True
+ {-# INLINE index #-}
+ index b i = unsafeIndex b i
+
+----------------------------------------------------------------------
+instance (Ix a, Ix b) => Ix (a, b) where -- as derived
+ {-# SPECIALISE instance Ix (Int,Int) #-}
+
+ {- INLINE range #-}
+ range ((l1,l2),(u1,u2)) =
+ [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ]
+
+ {- INLINE unsafeIndex #-}
+ unsafeIndex ((l1,l2),(u1,u2)) (i1,i2) =
+ unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2
+
+ {- INLINE inRange #-}
+ inRange ((l1,l2),(u1,u2)) (i1,i2) =
+ inRange (l1,u1) i1 && inRange (l2,u2) i2
+
+ -- Default method for index
+
+----------------------------------------------------------------------
+instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where
+ {-# SPECIALISE instance Ix (Int,Int,Int) #-}
+
+ range ((l1,l2,l3),(u1,u2,u3)) =
+ [(i1,i2,i3) | i1 <- range (l1,u1),
+ i2 <- range (l2,u2),
+ i3 <- range (l3,u3)]
+
+ unsafeIndex ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =
+ unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (
+ unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (
+ unsafeIndex (l1,u1) i1))
+
+ inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =
+ inRange (l1,u1) i1 && inRange (l2,u2) i2 &&
+ inRange (l3,u3) i3
+
+ -- Default method for index
+
+----------------------------------------------------------------------
+instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where
+ range ((l1,l2,l3,l4),(u1,u2,u3,u4)) =
+ [(i1,i2,i3,i4) | i1 <- range (l1,u1),
+ i2 <- range (l2,u2),
+ i3 <- range (l3,u3),
+ i4 <- range (l4,u4)]
+
+ unsafeIndex ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) =
+ unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (
+ unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (
+ unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (
+ unsafeIndex (l1,u1) i1)))
+
+ inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) =
+ inRange (l1,u1) i1 && inRange (l2,u2) i2 &&
+ inRange (l3,u3) i3 && inRange (l4,u4) i4
+
+ -- Default method for index
+
+instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where
+ range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) =
+ [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1),
+ i2 <- range (l2,u2),
+ i3 <- range (l3,u3),
+ i4 <- range (l4,u4),
+ i5 <- range (l5,u5)]
+
+ unsafeIndex ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) =
+ unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (
+ unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (
+ unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (
+ unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (
+ unsafeIndex (l1,u1) i1))))
+
+ inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) =
+ inRange (l1,u1) i1 && inRange (l2,u2) i2 &&
+ inRange (l3,u3) i3 && inRange (l4,u4) i4 &&
+ inRange (l5,u5) i5
+
+ -- Default method for index
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{The @Array@ types}
+%* *
+%*********************************************************
+
+\begin{code}
+type IPr = (Int, Int)
+
+-- | The type of immutable non-strict (boxed) arrays
+-- with indices in @i@ and elements in @e@.
+data Ix i => Array i e = Array !i !i (Array# e)
+
+-- | Mutable, boxed, non-strict arrays in the 'ST' monad. The type
+-- arguments are as follows:
+--
+-- * @s@: the state variable argument for the 'ST' type
+--
+-- * @i@: the index type of the array (should be an instance of 'Ix')
+--
+-- * @e@: the element type of the array.
+--
+data STArray s i e = STArray !i !i (MutableArray# s e)
+ -- No Ix context for STArray. They are stupid,
+ -- and force an Ix context on the equality instance.
+
+-- Just pointer equality on mutable arrays:
+instance Eq (STArray s i e) where
+ STArray _ _ arr1# == STArray _ _ arr2# =
+ sameMutableArray# arr1# arr2#
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Operations on immutable arrays}
+%* *
+%*********************************************************
+
+\begin{code}
+{-# NOINLINE arrEleBottom #-}
+arrEleBottom :: a
+arrEleBottom = error "(Array.!): undefined array element"
+
+-- | Construct an array with the specified bounds and containing values
+-- for given indices within these bounds.
+--
+-- The array is undefined (i.e. bottom) if any index in the list is
+-- out of bounds. The Haskell 98 Report further specifies that if any
+-- two associations in the list have the same index, the value at that
+-- index is undefined (i.e. bottom). However in GHC's implementation,
+-- the value at such an index is the value part of the last association
+-- with that index in the list.
+--
+-- Because the indices must be checked for these errors, 'array' is
+-- strict in the bounds argument and in the indices of the association
+-- list, but nonstrict in the values. Thus, recurrences such as the
+-- following are possible:
+--
+-- > a = array (1,100) ((1,1) : [(i, i * a!(i-1)) | i <- [2..100]])
+--
+-- Not every index within the bounds of the array need appear in the
+-- association list, but the values associated with indices that do not
+-- appear will be undefined (i.e. bottom).
+--
+-- If, in any dimension, the lower bound is greater than the upper bound,
+-- then the array is legal, but empty. Indexing an empty array always
+-- gives an array-bounds error, but 'bounds' still yields the bounds
+-- with which the array was constructed.
+{-# INLINE array #-}
+array :: Ix i
+ => (i,i) -- ^ a pair of /bounds/, each of the index type
+ -- of the array. These bounds are the lowest and
+ -- highest indices in the array, in that order.
+ -- For example, a one-origin vector of length
+ -- '10' has bounds '(1,10)', and a one-origin '10'
+ -- by '10' matrix has bounds '((1,1),(10,10))'.
+ -> [(i, e)] -- ^ a list of /associations/ of the form
+ -- (/index/, /value/). Typically, this list will
+ -- be expressed as a comprehension. An
+ -- association '(i, x)' defines the value of
+ -- the array at index 'i' to be 'x'.
+ -> Array i e
+array (l,u) ies = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE unsafeArray #-}
+unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> Array i e
+unsafeArray (l,u) ies = runST (ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) ->
+ foldr (fill marr#) (done l u marr#) ies s2# }})
+
+{-# INLINE fill #-}
+fill :: MutableArray# s e -> (Int, e) -> STRep s a -> STRep s a
+fill marr# (I# i#, e) next s1# =
+ case writeArray# marr# i# e s1# of { s2# ->
+ next s2# }
+
+{-# INLINE done #-}
+done :: Ix i => i -> i -> MutableArray# s e -> STRep s (Array i e)
+done l u marr# s1# =
+ case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) ->
+ (# s2#, Array l u arr# #) }
+
+-- This is inefficient and I'm not sure why:
+-- listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es)
+-- The code below is better. It still doesn't enable foldr/build
+-- transformation on the list of elements; I guess it's impossible
+-- using mechanisms currently available.
+
+-- | Construct an array from a pair of bounds and a list of values in
+-- index order.
+{-# INLINE listArray #-}
+listArray :: Ix i => (i,i) -> [e] -> Array i e
+listArray (l,u) es = runST (ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) ->
+ let fillFromList i# xs s3# | i# ==# n# = s3#
+ | otherwise = case xs of
+ [] -> s3#
+ y:ys -> case writeArray# marr# i# y s3# of { s4# ->
+ fillFromList (i# +# 1#) ys s4# } in
+ case fillFromList 0# es s2# of { s3# ->
+ done l u marr# s3# }}})
+
+-- | The value at the given index in an array.
+{-# INLINE (!) #-}
+(!) :: Ix i => Array i e -> i -> e
+arr@(Array l u _) ! i = unsafeAt arr (index (l,u) i)
+
+{-# INLINE unsafeAt #-}
+unsafeAt :: Ix i => Array i e -> Int -> e
+unsafeAt (Array _ _ arr#) (I# i#) =
+ case indexArray# arr# i# of (# e #) -> e
+
+-- | The bounds with which an array was constructed.
+{-# INLINE bounds #-}
+bounds :: Ix i => Array i e -> (i,i)
+bounds (Array l u _) = (l,u)
+
+-- | The list of indices of an array in ascending order.
+{-# INLINE indices #-}
+indices :: Ix i => Array i e -> [i]
+indices (Array l u _) = range (l,u)
+
+-- | The list of elements of an array in index order.
+{-# INLINE elems #-}
+elems :: Ix i => Array i e -> [e]
+elems arr@(Array l u _) =
+ [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]]
+
+-- | The list of associations of an array in index order.
+{-# INLINE assocs #-}
+assocs :: Ix i => Array i e -> [(i, e)]
+assocs arr@(Array l u _) =
+ [(i, unsafeAt arr (unsafeIndex (l,u) i)) | i <- range (l,u)]
+
+-- | The 'accumArray' deals with repeated indices in the association
+-- list using an /accumulating function/ which combines the values of
+-- associations with the same index.
+-- For example, given a list of values of some index type, @hist@
+-- produces a histogram of the number of occurrences of each index within
+-- a specified range:
+--
+-- > hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b
+-- > hist bnds is = accumArray (+) 0 bnds [(i, 1) | i<-is, inRange bnds i]
+--
+-- If the accumulating function is strict, then 'accumArray' is strict in
+-- the values, as well as the indices, in the association list. Thus,
+-- unlike ordinary arrays built with 'array', accumulated arrays should
+-- not in general be recursive.
+{-# INLINE accumArray #-}
+accumArray :: Ix i
+ => (e -> a -> e) -- ^ accumulating function
+ -> e -- ^ initial value
+ -> (i,i) -- ^ bounds of the array
+ -> [(i, a)] -- ^ association list
+ -> Array i e
+accumArray f init (l,u) ies =
+ unsafeAccumArray f init (l,u) [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE unsafeAccumArray #-}
+unsafeAccumArray :: Ix i => (e -> a -> e) -> e -> (i,i) -> [(Int, a)] -> Array i e
+unsafeAccumArray f init (l,u) ies = runST (ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# init s1# of { (# s2#, marr# #) ->
+ foldr (adjust f marr#) (done l u marr#) ies s2# }})
+
+{-# INLINE adjust #-}
+adjust :: (e -> a -> e) -> MutableArray# s e -> (Int, a) -> STRep s b -> STRep s b
+adjust f marr# (I# i#, new) next s1# =
+ case readArray# marr# i# s1# of { (# s2#, old #) ->
+ case writeArray# marr# i# (f old new) s2# of { s3# ->
+ next s3# }}
+
+-- | Constructs an array identical to the first argument except that it has
+-- been updated by the associations in the right argument.
+-- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then
+--
+-- > m//[((i,i), 0) | i <- [1..n]]
+--
+-- is the same matrix, except with the diagonal zeroed.
+--
+-- Repeated indices in the association list are handled as for 'array':
+-- Haskell 98 specifies that the resulting array is undefined (i.e. bottom),
+-- but GHC's implementation uses the last association for each index.
+{-# INLINE (//) #-}
+(//) :: Ix i => Array i e -> [(i, e)] -> Array i e
+arr@(Array l u _) // ies =
+ unsafeReplace arr [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE unsafeReplace #-}
+unsafeReplace :: Ix i => Array i e -> [(Int, e)] -> Array i e
+unsafeReplace arr@(Array l u _) ies = runST (do
+ STArray _ _ marr# <- thawSTArray arr
+ ST (foldr (fill marr#) (done l u marr#) ies))
+
+-- | @'accum' f@ takes an array and an association list and accumulates
+-- pairs from the list into the array with the accumulating function @f@.
+-- Thus 'accumArray' can be defined using 'accum':
+--
+-- > accumArray f z b = accum f (array b [(i, z) | i <- range b])
+--
+{-# INLINE accum #-}
+accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e
+accum f arr@(Array l u _) ies =
+ unsafeAccum f arr [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE unsafeAccum #-}
+unsafeAccum :: Ix i => (e -> a -> e) -> Array i e -> [(Int, a)] -> Array i e
+unsafeAccum f arr@(Array l u _) ies = runST (do
+ STArray _ _ marr# <- thawSTArray arr
+ ST (foldr (adjust f marr#) (done l u marr#) ies))
+
+{-# INLINE amap #-}
+amap :: Ix i => (a -> b) -> Array i a -> Array i b
+amap f arr@(Array l u _) =
+ unsafeArray (l,u) [(i, f (unsafeAt arr i)) | i <- [0 .. rangeSize (l,u) - 1]]
+
+-- | 'ixmap' allows for transformations on array indices.
+-- It may be thought of as providing function composition on the right
+-- with the mapping that the original array embodies.
+--
+-- A similar transformation of array values may be achieved using 'fmap'
+-- from the 'Array' instance of the 'Functor' class.
+{-# INLINE ixmap #-}
+ixmap :: (Ix i, Ix j) => (i,i) -> (i -> j) -> Array j e -> Array i e
+ixmap (l,u) f arr =
+ unsafeArray (l,u) [(unsafeIndex (l,u) i, arr ! f i) | i <- range (l,u)]
+
+{-# INLINE eqArray #-}
+eqArray :: (Ix i, Eq e) => Array i e -> Array i e -> Bool
+eqArray arr1@(Array l1 u1 _) arr2@(Array l2 u2 _) =
+ if rangeSize (l1,u1) == 0 then rangeSize (l2,u2) == 0 else
+ l1 == l2 && u1 == u2 &&
+ and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. rangeSize (l1,u1) - 1]]
+
+{-# INLINE cmpArray #-}
+cmpArray :: (Ix i, Ord e) => Array i e -> Array i e -> Ordering
+cmpArray arr1 arr2 = compare (assocs arr1) (assocs arr2)
+
+{-# INLINE cmpIntArray #-}
+cmpIntArray :: Ord e => Array Int e -> Array Int e -> Ordering
+cmpIntArray arr1@(Array l1 u1 _) arr2@(Array l2 u2 _) =
+ if rangeSize (l1,u1) == 0 then if rangeSize (l2,u2) == 0 then EQ else LT else
+ if rangeSize (l2,u2) == 0 then GT else
+ case compare l1 l2 of
+ EQ -> foldr cmp (compare u1 u2) [0 .. rangeSize (l1, min u1 u2) - 1]
+ other -> other
+ where
+ cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of
+ EQ -> rest
+ other -> other
+
+{-# RULES "cmpArray/Int" cmpArray = cmpIntArray #-}
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Array instances}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Ix i => Functor (Array i) where
+ fmap = amap
+
+instance (Ix i, Eq e) => Eq (Array i e) where
+ (==) = eqArray
+
+instance (Ix i, Ord e) => Ord (Array i e) where
+ compare = cmpArray
+
+instance (Ix a, Show a, Show b) => Show (Array a b) where
+ showsPrec p a =
+ showParen (p > appPrec) $
+ showString "array " .
+ showsPrec appPrec1 (bounds a) .
+ showChar ' ' .
+ showsPrec appPrec1 (assocs a)
+ -- Precedence of 'array' is the precedence of application
+
+-- The Read instance is in GHC.Read
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Operations on mutable arrays}
+%* *
+%*********************************************************
+
+Idle ADR question: What's the tradeoff here between flattening these
+datatypes into @STArray ix ix (MutableArray# s elt)@ and using
+it as is? As I see it, the former uses slightly less heap and
+provides faster access to the individual parts of the bounds while the
+code used has the benefit of providing a ready-made @(lo, hi)@ pair as
+required by many array-related functions. Which wins? Is the
+difference significant (probably not).
+
+Idle AJG answer: When I looked at the outputted code (though it was 2
+years ago) it seems like you often needed the tuple, and we build
+it frequently. Now we've got the overloading specialiser things
+might be different, though.
+
+\begin{code}
+{-# INLINE newSTArray #-}
+newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e)
+newSTArray (l,u) init = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# init s1# of { (# s2#, marr# #) ->
+ (# s2#, STArray l u marr# #) }}
+
+{-# INLINE boundsSTArray #-}
+boundsSTArray :: STArray s i e -> (i,i)
+boundsSTArray (STArray l u _) = (l,u)
+
+{-# INLINE readSTArray #-}
+readSTArray :: Ix i => STArray s i e -> i -> ST s e
+readSTArray marr@(STArray l u _) i =
+ unsafeReadSTArray marr (index (l,u) i)
+
+{-# INLINE unsafeReadSTArray #-}
+unsafeReadSTArray :: Ix i => STArray s i e -> Int -> ST s e
+unsafeReadSTArray (STArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ readArray# marr# i# s1#
+
+{-# INLINE writeSTArray #-}
+writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s ()
+writeSTArray marr@(STArray l u _) i e =
+ unsafeWriteSTArray marr (index (l,u) i) e
+
+{-# INLINE unsafeWriteSTArray #-}
+unsafeWriteSTArray :: Ix i => STArray s i e -> Int -> e -> ST s ()
+unsafeWriteSTArray (STArray _ _ marr#) (I# i#) e = ST $ \s1# ->
+ case writeArray# marr# i# e s1# of { s2# ->
+ (# s2#, () #) }
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Moving between mutable and immutable}
+%* *
+%*********************************************************
+
+\begin{code}
+freezeSTArray :: Ix i => STArray s i e -> ST s (Array i e)
+freezeSTArray (STArray l u marr#) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# arrEleBottom s1# of { (# s2#, marr'# #) ->
+ let copy i# s3# | i# ==# n# = s3#
+ | otherwise =
+ case readArray# marr# i# s3# of { (# s4#, e #) ->
+ case writeArray# marr'# i# e s4# of { s5# ->
+ copy (i# +# 1#) s5# }} in
+ case copy 0# s2# of { s3# ->
+ case unsafeFreezeArray# marr'# s3# of { (# s4#, arr# #) ->
+ (# s4#, Array l u arr# #) }}}}
+
+{-# INLINE unsafeFreezeSTArray #-}
+unsafeFreezeSTArray :: Ix i => STArray s i e -> ST s (Array i e)
+unsafeFreezeSTArray (STArray l u marr#) = ST $ \s1# ->
+ case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) ->
+ (# s2#, Array l u arr# #) }
+
+thawSTArray :: Ix i => Array i e -> ST s (STArray s i e)
+thawSTArray (Array l u arr#) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) ->
+ let copy i# s3# | i# ==# n# = s3#
+ | otherwise =
+ case indexArray# arr# i# of { (# e #) ->
+ case writeArray# marr# i# e s3# of { s4# ->
+ copy (i# +# 1#) s4# }} in
+ case copy 0# s2# of { s3# ->
+ (# s3#, STArray l u marr# #) }}}
+
+{-# INLINE unsafeThawSTArray #-}
+unsafeThawSTArray :: Ix i => Array i e -> ST s (STArray s i e)
+unsafeThawSTArray (Array l u arr#) = ST $ \s1# ->
+ case unsafeThawArray# arr# s1# of { (# s2#, marr# #) ->
+ (# s2#, STArray l u marr# #) }
+\end{code}
diff --git a/tests/HsOpenGLExt.h b/tests/HsOpenGLExt.h
new file mode 100644
--- /dev/null
+++ b/tests/HsOpenGLExt.h
@@ -0,0 +1,31 @@
+/* -----------------------------------------------------------------------------
+ *
+ * Module : GL extension support for Graphics.Rendering.OpenGL
+ * Copyright : (c) Sven Panne 2002-2004
+ * License : BSD-style (see the file libraries/OpenGL/LICENSE)
+ *
+ * Maintainer : sven.panne@aedion.de
+ * Stability : provisional
+ * Portability : portable
+ *
+ * This header should only define preprocessor macros!
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef HSOPENGLEXT_H
+#define HSOPENGLEXT_H
+
+/* NOTE: The macro must immediately start with the foreign declaration,
+ otherwise the magic mangler (hack_foreign) in the Hugs build system
+ doesn't recognize it. */
+#define EXTENSION_ENTRY(_msg,_entry,_ty) \
+foreign import CALLCONV unsafe "dynamic" dyn_/**/_entry :: Graphics.Rendering.OpenGL.GL.Extensions.Invoker (_ty) ; \
+_entry :: (_ty) ; \
+_entry = dyn_##_entry ptr_##_entry ; \
+ptr_/**/_entry :: FunPtr a ; \
+ptr_/**/_entry = unsafePerformIO (Graphics.Rendering.OpenGL.GL.Extensions.getProcAddress (_msg) ("_entry")) ; \
+{-# NOINLINE ptr_/**/_entry #-}
+
+#endif
+
+EXTENSION_ENTRY("GL_EXT_fog_coord or OpenGL 1.4",glFogCoorddEXT,GLdouble -> IO ())
diff --git a/tests/MachDeps.h b/tests/MachDeps.h
new file mode 100644
--- /dev/null
+++ b/tests/MachDeps.h
diff --git a/tests/Storable.hs b/tests/Storable.hs
new file mode 100644
--- /dev/null
+++ b/tests/Storable.hs
@@ -0,0 +1,246 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Foreign.Storable
+-- Copyright : (c) The FFI task force 2001
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- The module "Foreign.Storable" provides most elementary support for
+-- marshalling and is part of the language-independent portion of the
+-- Foreign Function Interface (FFI), and will normally be imported via
+-- the "Foreign" module.
+--
+-----------------------------------------------------------------------------
+
+module Foreign.Storable
+ ( Storable(
+ sizeOf, -- :: a -> Int
+ alignment, -- :: a -> Int
+ peekElemOff, -- :: Ptr a -> Int -> IO a
+ pokeElemOff, -- :: Ptr a -> Int -> a -> IO ()
+ peekByteOff, -- :: Ptr b -> Int -> IO a
+ pokeByteOff, -- :: Ptr b -> Int -> a -> IO ()
+ peek, -- :: Ptr a -> IO a
+ poke) -- :: Ptr a -> a -> IO ()
+ ) where
+
+
+#ifdef __NHC__
+import NHC.FFI (Storable(..),Ptr,FunPtr,StablePtr
+ ,Int8,Int16,Int32,Int64,Word8,Word16,Word32,Word64)
+#else
+
+import Control.Monad ( liftM )
+
+#include "MachDeps.h"
+#include "config.h"
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Storable
+import GHC.Stable ( StablePtr )
+import GHC.Num
+import GHC.Int
+import GHC.Word
+import GHC.Stable
+import GHC.Ptr
+import GHC.Float
+import GHC.Err
+import GHC.IOBase
+import GHC.Base
+#else
+import Data.Int
+import Data.Word
+import Foreign.Ptr
+import Foreign.StablePtr
+#endif
+
+#ifdef __HUGS__
+import Hugs.Prelude
+import Hugs.Storable
+#endif
+
+{- |
+The member functions of this class facilitate writing values of
+primitive types to raw memory (which may have been allocated with the
+above mentioned routines) and reading values from blocks of raw
+memory. The class, furthermore, includes support for computing the
+storage requirements and alignment restrictions of storable types.
+
+Memory addresses are represented as values of type @'Ptr' a@, for some
+@a@ which is an instance of class 'Storable'. The type argument to
+'Ptr' helps provide some valuable type safety in FFI code (you can\'t
+mix pointers of different types without an explicit cast), while
+helping the Haskell type system figure out which marshalling method is
+needed for a given pointer.
+
+All marshalling between Haskell and a foreign language ultimately
+boils down to translating Haskell data structures into the binary
+representation of a corresponding data structure of the foreign
+language and vice versa. To code this marshalling in Haskell, it is
+necessary to manipulate primtive data types stored in unstructured
+memory blocks. The class 'Storable' facilitates this manipulation on
+all types for which it is instantiated, which are the standard basic
+types of Haskell, the fixed size @Int@ types ('Int8', 'Int16',
+'Int32', 'Int64'), the fixed size @Word@ types ('Word8', 'Word16',
+'Word32', 'Word64'), 'StablePtr', all types from "Foreign.C.Types",
+as well as 'Ptr'.
+
+Minimal complete definition: 'sizeOf', 'alignment', one of 'peek',
+'peekElemOff' and 'peekByteOff', and one of 'poke', 'pokeElemOff' and
+'pokeByteOff'.
+-}
+
+class Storable a where
+
+ sizeOf :: a -> Int
+ -- ^ Computes the storage requirements (in bytes) of the argument.
+ -- The value of the argument is not used.
+
+ alignment :: a -> Int
+ -- ^ Computes the alignment constraint of the argument. An
+ -- alignment constraint @x@ is fulfilled by any address divisible
+ -- by @x@. The value of the argument is not used.
+
+ peekElemOff :: Ptr a -> Int -> IO a
+ -- ^ Read a value from a memory area regarded as an array
+ -- of values of the same kind. The first argument specifies
+ -- the start address of the array and the second the index into
+ -- the array (the first element of the array has index
+ -- @0@). The following equality holds,
+ --
+ -- > peekElemOff addr idx = IOExts.fixIO $ \result ->
+ -- > peek (addr `plusPtr` (idx * sizeOf result))
+ --
+ -- Note that this is only a specification, not
+ -- necessarily the concrete implementation of the
+ -- function.
+
+ pokeElemOff :: Ptr a -> Int -> a -> IO ()
+ -- ^ Write a value to a memory area regarded as an array of
+ -- values of the same kind. The following equality holds:
+ --
+ -- > pokeElemOff addr idx x =
+ -- > poke (addr `plusPtr` (idx * sizeOf x)) x
+
+ peekByteOff :: Ptr b -> Int -> IO a
+ -- ^ Read a value from a memory location given by a base
+ -- address and offset. The following equality holds:
+ --
+ -- > peekByteOff addr off = peek (addr `plusPtr` off)
+
+ pokeByteOff :: Ptr b -> Int -> a -> IO ()
+ -- ^ Write a value to a memory location given by a base
+ -- address and offset. The following equality holds:
+ --
+ -- > pokeByteOff addr off x = poke (addr `plusPtr` off) x
+
+ peek :: Ptr a -> IO a
+ -- ^ Read a value from the given memory location.
+ --
+ -- Note that the peek and poke functions might require properly
+ -- aligned addresses to function correctly. This is architecture
+ -- dependent; thus, portable code should ensure that when peeking or
+ -- poking values of some type @a@, the alignment
+ -- constraint for @a@, as given by the function
+ -- 'alignment' is fulfilled.
+
+ poke :: Ptr a -> a -> IO ()
+ -- ^ Write the given value to the given memory location. Alignment
+ -- restrictions might apply; see 'peek'.
+
+ -- circular default instances
+#ifdef __GLASGOW_HASKELL__
+ peekElemOff = peekElemOff_ undefined
+ where peekElemOff_ :: a -> Ptr a -> Int -> IO a
+ peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef)
+#else
+ peekElemOff ptr off = peekByteOff ptr (off * sizeOfPtr ptr undefined)
+#endif
+ pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf val) val
+
+ peekByteOff ptr off = peek (ptr `plusPtr` off)
+ pokeByteOff ptr off = poke (ptr `plusPtr` off)
+
+ peek ptr = peekElemOff ptr 0
+ poke ptr = pokeElemOff ptr 0
+
+#ifndef __GLASGOW_HASKELL__
+sizeOfPtr :: Storable a => Ptr a -> a -> Int
+sizeOfPtr px x = sizeOf x
+#endif
+
+-- System-dependent, but rather obvious instances
+
+instance Storable Bool where
+ sizeOf _ = sizeOf (undefined::HTYPE_INT)
+ alignment _ = alignment (undefined::HTYPE_INT)
+ peekElemOff p i = liftM (/= (0::HTYPE_INT)) $ peekElemOff (castPtr p) i
+ pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::HTYPE_INT)
+
+#define STORABLE(T,size,align,read,write) \
+instance Storable (T) where { \
+ sizeOf _ = size; \
+ alignment _ = align; \
+ peekElemOff = read; \
+ pokeElemOff = write }
+
+#ifdef __GLASGOW_HASKELL__
+STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32,
+ readWideCharOffPtr,writeWideCharOffPtr)
+#elif defined(__HUGS__)
+STORABLE(Char,SIZEOF_HSCHAR,ALIGNMENT_HSCHAR,
+ readCharOffPtr,writeCharOffPtr)
+#endif
+
+STORABLE(Int,SIZEOF_HSINT,ALIGNMENT_HSINT,
+ readIntOffPtr,writeIntOffPtr)
+
+#ifdef __GLASGOW_HASKELL__
+STORABLE(Word,SIZEOF_HSWORD,ALIGNMENT_HSWORD,
+ readWordOffPtr,writeWordOffPtr)
+#endif
+
+STORABLE((Ptr a),SIZEOF_HSPTR,ALIGNMENT_HSPTR,
+ readPtrOffPtr,writePtrOffPtr)
+
+STORABLE((FunPtr a),SIZEOF_HSFUNPTR,ALIGNMENT_HSFUNPTR,
+ readFunPtrOffPtr,writeFunPtrOffPtr)
+
+STORABLE((StablePtr a),SIZEOF_HSSTABLEPTR,ALIGNMENT_HSSTABLEPTR,
+ readStablePtrOffPtr,writeStablePtrOffPtr)
+
+STORABLE(Float,SIZEOF_HSFLOAT,ALIGNMENT_HSFLOAT,
+ readFloatOffPtr,writeFloatOffPtr)
+
+STORABLE(Double,SIZEOF_HSDOUBLE,ALIGNMENT_HSDOUBLE,
+ readDoubleOffPtr,writeDoubleOffPtr)
+
+STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8,
+ readWord8OffPtr,writeWord8OffPtr)
+
+STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16,
+ readWord16OffPtr,writeWord16OffPtr)
+
+STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32,
+ readWord32OffPtr,writeWord32OffPtr)
+
+STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64,
+ readWord64OffPtr,writeWord64OffPtr)
+
+STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8,
+ readInt8OffPtr,writeInt8OffPtr)
+
+STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16,
+ readInt16OffPtr,writeInt16OffPtr)
+
+STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32,
+ readInt32OffPtr,writeInt32OffPtr)
+
+STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,
+ readInt64OffPtr,writeInt64OffPtr)
+
+#endif
diff --git a/tests/Test.hsc b/tests/Test.hsc
new file mode 100644
--- /dev/null
+++ b/tests/Test.hsc
@@ -0,0 +1,11 @@
+module Test where
+
+main :: IO ()
+main = putStrLn "shows a cpphs+hsc2hs bug with comments"
+
+#def inline int that_one_will_work(void) {return 42;}
+
+{-
+#def inline int cpphs_will_stumble(void) {return 42;}
+-}
+
diff --git a/tests/chains b/tests/chains
new file mode 100644
--- /dev/null
+++ b/tests/chains
@@ -0,0 +1,16 @@
+For this test, assume that all of e,f,g,h are defined.
+Also that c,d are defined, a,b are not.
+If cpphs does operator precedence wrongly in infix chains, the final
+conditional will be interpreted wrongly.
+
+#if defined(a) || defined(b) || defined(c) || defined(d)
+chained || OK
+#endif
+#if defined(e) && defined(f) && defined(g) && defined(h)
+chained && OK
+#endif
+#if defined(a) && defined(b) || defined(c) && defined(d)
+mixed chain of || and && OK
+#else
+mixed chain of || and && BROKEN
+#endif
diff --git a/tests/config.h b/tests/config.h
new file mode 100644
--- /dev/null
+++ b/tests/config.h
diff --git a/tests/cpp b/tests/cpp
new file mode 100644
--- /dev/null
+++ b/tests/cpp
@@ -0,0 +1,9 @@
+#define /**/ ++ `mplus` // not expected to work
+#define 0 mzero // not expected to work
+#define x0 X' // should work
+#define x' Xprime // should work
+#define `foo` .(foo)/**/, // bizarreness
+
+x ++ y = x0 * 0 * y `foo` x'
+
+// /*
diff --git a/tests/elif b/tests/elif
new file mode 100644
--- /dev/null
+++ b/tests/elif
@@ -0,0 +1,10 @@
+#if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
+ ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
+import System.IO.Unsafe (unsafePerformIO)
+#elif defined(__GLASGOW_HASKELL__)
+import IOExts (unsafePerformIO)
+#elif defined(__NHC__)
+import IOExtras (unsafePerformIO)
+#elif defined(__HBC__)
+import UnsafePerformIO
+#endif
diff --git a/tests/expect1 b/tests/expect1
new file mode 100644
--- /dev/null
+++ b/tests/expect1
@@ -0,0 +1,36 @@
+#line 1 "testfile"
+1 top of file
+
+3
+
+5 X is defined
+
+7
+
+
+
+11
+
+
+
+15
+
+
+
+19
+
+
+
+23 no inclusion, this is an else clause
+
+25
+
+
+
+
+
+31 third branch of elif
+
+33
+34 end of file
+
diff --git a/tests/expect10 b/tests/expect10
new file mode 100644
--- /dev/null
+++ b/tests/expect10
@@ -0,0 +1,16 @@
+#line 1 "multiline"
+
+
+
+
+5 back to ordinary text.
+#line 1 "./inclusion"
+hello world, this is an inclusion
+
+#line 6 "multiline"
+
+7 hello again
+8 some more
+9 aLongMacroDefinition(a,b)
+10 end
+
diff --git a/tests/expect11 b/tests/expect11
new file mode 100644
--- /dev/null
+++ b/tests/expect11
@@ -0,0 +1,3 @@
+#line 1 "stringise"
+
+This is "abcd ef" foo abcd ef
diff --git a/tests/expect12 b/tests/expect12
new file mode 100644
--- /dev/null
+++ b/tests/expect12
@@ -0,0 +1,5 @@
+#line 1 "recursive"
+
+
+
+D D D D D D D D
diff --git a/tests/expect13 b/tests/expect13
new file mode 100644
--- /dev/null
+++ b/tests/expect13
@@ -0,0 +1,20 @@
+#line 1 "ross"
+
+
+
+
+
+
+f = 4
+
+
+
+
+
+
+g = do { putStr "Hello "; putStrLn "World" }
+
+
+
+
+h = 4
diff --git a/tests/expect14 b/tests/expect14
new file mode 100644
--- /dev/null
+++ b/tests/expect14
@@ -0,0 +1,4 @@
+#line 1 "precedence"
+
+
+
diff --git a/tests/expect15 b/tests/expect15
new file mode 100644
--- /dev/null
+++ b/tests/expect15
@@ -0,0 +1,7 @@
+#line 1 "indirect"
+
+#line 1 "./inclusion"
+hello world, this is an inclusion
+
+#line 2 "indirect"
+
diff --git a/tests/expect16 b/tests/expect16
new file mode 100644
--- /dev/null
+++ b/tests/expect16
@@ -0,0 +1,30 @@
+#line 1 "numbers"
+
+number (1) in if
+
+
+
+
+
+
+
+number (0) in if
+
+
+
+
+
+rejected false hex number in if
+
+
+
+real hex number (0x1) in if
+
+
+
+
+
+
+
+hex number (0x00) in if
+
diff --git a/tests/expect17 b/tests/expect17
new file mode 100644
--- /dev/null
+++ b/tests/expect17
@@ -0,0 +1,2 @@
+#line 1 "pragma"
+
diff --git a/tests/expect18 b/tests/expect18
new file mode 100644
--- /dev/null
+++ b/tests/expect18
@@ -0,0 +1,1 @@
+
diff --git a/tests/expect19 b/tests/expect19
new file mode 100644
--- /dev/null
+++ b/tests/expect19
@@ -0,0 +1,5 @@
+#line 1 "parens"
+
+
+
+yes
diff --git a/tests/expect2 b/tests/expect2
new file mode 100644
--- /dev/null
+++ b/tests/expect2
@@ -0,0 +1,36 @@
+#line 1 "testfile"
+1 top of file
+
+3
+
+5 X is defined
+
+7
+
+
+
+11
+
+
+
+15
+
+
+
+19
+
+
+
+23 no inclusion, this is an else clause
+
+25
+
+27 no elif
+
+
+
+
+
+33
+34 end of file
+
diff --git a/tests/expect20 b/tests/expect20
new file mode 100644
--- /dev/null
+++ b/tests/expect20
@@ -0,0 +1,17 @@
+#line 1 "chains"
+For this test, assume that all of 1,1,1,1 are defined.
+Also that 1,1 are defined, a,b are not.
+If cpphs does operator precedence wrongly in infix chains, the final
+conditional will be interpreted wrongly.
+
+
+chained || OK
+
+
+chained && OK
+
+
+mixed chain of || and && OK
+
+
+
diff --git a/tests/expect21 b/tests/expect21
new file mode 100644
--- /dev/null
+++ b/tests/expect21
@@ -0,0 +1,6 @@
+#line 1 "specials"
+
+line 2
+line 3
+line 4 Error "horrible" at line 4 of file "specials"
+line 5
diff --git a/tests/expect22 b/tests/expect22
new file mode 100644
--- /dev/null
+++ b/tests/expect22
@@ -0,0 +1,14 @@
+#line 1 "specialinclude"
+1
+2
+#line 1 "./specials"
+
+line 2
+line 3
+line 4 Error "horrible" at line 4 of file "./specials"
+line 5
+
+#line 3 "specialinclude"
+
+4
+5
diff --git a/tests/expect23 b/tests/expect23
new file mode 100644
--- /dev/null
+++ b/tests/expect23
@@ -0,0 +1,2 @@
+#line 1 "incomplete"
+incomplete
diff --git a/tests/expect24 b/tests/expect24
new file mode 100644
--- /dev/null
+++ b/tests/expect24
@@ -0,0 +1,15 @@
+#line 1 "text"
+Here is some ordinary text with embedded Haskell-ish constructs,
+that should however /not/ be interpreted as Haskell if the --text
+option is given to cpphs. For instance, here is a Haskell comment
+including a cpp definition: {-
+# define FOO bar
+and now we end the comment: -} and try out the definition: FOO
+Likewise, double and single quotes no longer delimit strings or chars: "
+# define BAZ FOO
+and what do we have here?: " ' BAZ '
+
+
+Also, in text-mode, macros should be expanded inside Haskell comments:
+ -- expand(this,other,that)
+and strings "expand(this,other,that)".
diff --git a/tests/expect25 b/tests/expect25
new file mode 100644
--- /dev/null
+++ b/tests/expect25
@@ -0,0 +1,15 @@
+#line 1 "text"
+Here is some ordinary text with embedded Haskell-ish constructs,
+that should however /not/ be interpreted as Haskell if the --text
+option is given to cpphs. For instance, here is a Haskell comment
+including a cpp definition: {-
+
+and now we end the comment: -} and try out the definition: bar
+Likewise, double and single quotes no longer delimit strings or chars: "
+
+and what do we have here?: " ' bar '
+
+
+Also, in text-mode, macros should be expanded inside Haskell comments:
+ -- Some text including this, the other, and that.
+and strings "Some text including this, the other, and that.".
diff --git a/tests/expect26 b/tests/expect26
new file mode 100644
--- /dev/null
+++ b/tests/expect26
@@ -0,0 +1,17 @@
+#line 1 "nastyhack"
+
+-- hackery to convice cpp to splice 6.2.2 into a string
+version :: String
+version = tail "\
+ \ 6.2.2"
+
+version2 = "6.2.2"
+
+
+version3 = "6.2.2"
+
+
+version4 = #6.2.2
+
+
+version5 = "6.2.2"
diff --git a/tests/expect27 b/tests/expect27
new file mode 100644
--- /dev/null
+++ b/tests/expect27
@@ -0,0 +1,17 @@
+#line 1 "nastyhack"
+
+-- hackery to convice cpp to splice GHC_PKG_VERSION into a string
+version :: String
+version = tail "\
+ \ GHC_PKG_VERSION"
+
+version2 = "GHC_PKG_VERSION"
+
+
+version3 = "GHC_PKG_VERSION"
+
+
+version4 = #6.2.2
+
+
+version5 = "GHC_PKG_VERSION"
diff --git a/tests/expect28 b/tests/expect28
new file mode 100644
--- /dev/null
+++ b/tests/expect28
@@ -0,0 +1,4 @@
+#line 1 "symbolvalue"
+
+the symbol is defined as 1
+
diff --git a/tests/expect29 b/tests/expect29
new file mode 100644
--- /dev/null
+++ b/tests/expect29
@@ -0,0 +1,12 @@
+#line 1 "Test.hsc"
+module Test where
+
+main :: IO ()
+main = putStrLn "shows a cpphs+hsc2hs bug with comments"
+
+
+
+{-
+#def inline int cpphs_will_stumble(void) {return 42;}
+-}
+
diff --git a/tests/expect3 b/tests/expect3
new file mode 100644
--- /dev/null
+++ b/tests/expect3
@@ -0,0 +1,36 @@
+#line 1 "testfile"
+1 top of file
+
+3
+
+5 X is defined
+
+7
+
+
+
+11
+
+
+
+15
+
+
+
+19
+
+
+
+23 no inclusion, this is an else clause
+
+25
+
+
+
+29 this is an elif
+
+
+
+33
+34 end of file
+
diff --git a/tests/expect30 b/tests/expect30
new file mode 100644
--- /dev/null
+++ b/tests/expect30
@@ -0,0 +1,685 @@
+#line 1 "Arr.lhs"
+
+{-# OPTIONS_GHC -fno-implicit-prelude -fno-bang-patterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Arr
+-- Copyright : (c) The University of Glasgow, 1994-2000
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC extensions)
+--
+-- GHC\'s array implementation.
+--
+-----------------------------------------------------------------------------
+
+-- #hide
+module GHC.Arr where
+
+import {-# SOURCE #-} GHC.Err ( error )
+import GHC.Enum
+import GHC.Num
+import GHC.ST
+import GHC.Base
+import GHC.List
+import GHC.Show
+
+infixl 9 !, //
+
+default ()
+
+
+
+
+
+
+
+
+
+
+-- | The 'Ix' class is used to map a contiguous subrange of values in
+-- a type onto integers. It is used primarily for array indexing
+-- (see "Data.Array", "Data.Array.IArray" and "Data.Array.MArray").
+--
+-- The first argument @(l,u)@ of each of these operations is a pair
+-- specifying the lower and upper bounds of a contiguous subrange of values.
+--
+-- An implementation is entitled to assume the following laws about these
+-- operations:
+--
+-- * @'inRange' (l,u) i == 'elem' i ('range' (l,u))@
+--
+-- * @'range' (l,u) '!!' 'index' (l,u) i == i@, when @'inRange' (l,u) i@
+--
+-- * @'map' ('index' (l,u)) ('range' (l,u))) == [0..'rangeSize' (l,u)-1]@
+--
+-- * @'rangeSize' (l,u) == 'length' ('range' (l,u))@
+--
+-- Minimal complete instance: 'range', 'index' and 'inRange'.
+--
+class (Ord a) => Ix a where
+ -- | The list of values in the subrange defined by a bounding pair.
+ range :: (a,a) -> [a]
+ -- | The position of a subscript in the subrange.
+ index :: (a,a) -> a -> Int
+ -- | Like 'index', but without checking that the value is in range.
+ unsafeIndex :: (a,a) -> a -> Int
+ -- | Returns 'True' the given subscript lies in the range defined
+ -- the bounding pair.
+ inRange :: (a,a) -> a -> Bool
+ -- | The size of the subrange defined by a bounding pair.
+ rangeSize :: (a,a) -> Int
+ -- | like 'rangeSize', but without checking that the upper bound is
+ -- in range.
+ unsafeRangeSize :: (a,a) -> Int
+
+ -- Must specify one of index, unsafeIndex
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = error "Error in array index"
+ unsafeIndex b i = index b i
+
+ rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1
+ | otherwise = 0 -- This case is only here to
+ -- check for an empty range
+ -- NB: replacing (inRange b h) by (l <= h) fails for
+ -- tuples. E.g. (1,2) <= (2,1) but the range is empty
+
+ unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+-- abstract these errors from the relevant index functions so that
+-- the guts of the function will be small enough to inline.
+
+{-# NOINLINE indexError #-}
+indexError :: Show a => (a,a) -> a -> String -> b
+indexError rng i tp
+ = error (showString "Ix{" . showString tp . showString "}.index: Index " .
+ showParen True (showsPrec 0 i) .
+ showString " out of range " $
+ showParen True (showsPrec 0 rng) "")
+
+----------------------------------------------------------------------
+instance Ix Char where
+ {-# INLINE range #-}
+ range (m,n) = [m..n]
+
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex (m,_n) i = fromEnum i - fromEnum m
+
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = indexError b i "Char"
+
+ inRange (m,n) i = m <= i && i <= n
+
+----------------------------------------------------------------------
+instance Ix Int where
+ {-# INLINE range #-}
+ -- The INLINE stops the build in the RHS from getting inlined,
+ -- so that callers can fuse with the result of range
+ range (m,n) = [m..n]
+
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex (m,_n) i = i - m
+
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = indexError b i "Int"
+
+ {-# INLINE inRange #-}
+ inRange (I# m,I# n) (I# i) = m <=# i && i <=# n
+
+----------------------------------------------------------------------
+instance Ix Integer where
+ {-# INLINE range #-}
+ range (m,n) = [m..n]
+
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex (m,_n) i = fromInteger (i - m)
+
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = indexError b i "Integer"
+
+ inRange (m,n) i = m <= i && i <= n
+
+----------------------------------------------------------------------
+instance Ix Bool where -- as derived
+ {-# INLINE range #-}
+ range (m,n) = [m..n]
+
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex (l,_) i = fromEnum i - fromEnum l
+
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = indexError b i "Bool"
+
+ inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u
+
+----------------------------------------------------------------------
+instance Ix Ordering where -- as derived
+ {-# INLINE range #-}
+ range (m,n) = [m..n]
+
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex (l,_) i = fromEnum i - fromEnum l
+
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = indexError b i "Ordering"
+
+ inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u
+
+----------------------------------------------------------------------
+instance Ix () where
+ {-# INLINE range #-}
+ range ((), ()) = [()]
+ {-# INLINE unsafeIndex #-}
+ unsafeIndex ((), ()) () = 0
+ {-# INLINE inRange #-}
+ inRange ((), ()) () = True
+ {-# INLINE index #-}
+ index b i = unsafeIndex b i
+
+----------------------------------------------------------------------
+instance (Ix a, Ix b) => Ix (a, b) where -- as derived
+ {-# SPECIALISE instance Ix (Int,Int) #-}
+
+ {- INLINE range #-}
+ range ((l1,l2),(u1,u2)) =
+ [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ]
+
+ {- INLINE unsafeIndex #-}
+ unsafeIndex ((l1,l2),(u1,u2)) (i1,i2) =
+ unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2
+
+ {- INLINE inRange #-}
+ inRange ((l1,l2),(u1,u2)) (i1,i2) =
+ inRange (l1,u1) i1 && inRange (l2,u2) i2
+
+ -- Default method for index
+
+----------------------------------------------------------------------
+instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where
+ {-# SPECIALISE instance Ix (Int,Int,Int) #-}
+
+ range ((l1,l2,l3),(u1,u2,u3)) =
+ [(i1,i2,i3) | i1 <- range (l1,u1),
+ i2 <- range (l2,u2),
+ i3 <- range (l3,u3)]
+
+ unsafeIndex ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =
+ unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (
+ unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (
+ unsafeIndex (l1,u1) i1))
+
+ inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =
+ inRange (l1,u1) i1 && inRange (l2,u2) i2 &&
+ inRange (l3,u3) i3
+
+ -- Default method for index
+
+----------------------------------------------------------------------
+instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where
+ range ((l1,l2,l3,l4),(u1,u2,u3,u4)) =
+ [(i1,i2,i3,i4) | i1 <- range (l1,u1),
+ i2 <- range (l2,u2),
+ i3 <- range (l3,u3),
+ i4 <- range (l4,u4)]
+
+ unsafeIndex ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) =
+ unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (
+ unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (
+ unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (
+ unsafeIndex (l1,u1) i1)))
+
+ inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) =
+ inRange (l1,u1) i1 && inRange (l2,u2) i2 &&
+ inRange (l3,u3) i3 && inRange (l4,u4) i4
+
+ -- Default method for index
+
+instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where
+ range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) =
+ [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1),
+ i2 <- range (l2,u2),
+ i3 <- range (l3,u3),
+ i4 <- range (l4,u4),
+ i5 <- range (l5,u5)]
+
+ unsafeIndex ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) =
+ unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (
+ unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (
+ unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (
+ unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (
+ unsafeIndex (l1,u1) i1))))
+
+ inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) =
+ inRange (l1,u1) i1 && inRange (l2,u2) i2 &&
+ inRange (l3,u3) i3 && inRange (l4,u4) i4 &&
+ inRange (l5,u5) i5
+
+ -- Default method for index
+
+
+
+
+
+
+
+
+
+type IPr = (Int, Int)
+
+-- | The type of immutable non-strict (boxed) arrays
+-- with indices in @i@ and elements in @e@.
+data Ix i => Array i e = Array !i !i (Array# e)
+
+-- | Mutable, boxed, non-strict arrays in the 'ST' monad. The type
+-- arguments are as follows:
+--
+-- * @s@: the state variable argument for the 'ST' type
+--
+-- * @i@: the index type of the array (should be an instance of 'Ix')
+--
+-- * @e@: the element type of the array.
+--
+data STArray s i e = STArray !i !i (MutableArray# s e)
+ -- No Ix context for STArray. They are stupid,
+ -- and force an Ix context on the equality instance.
+
+-- Just pointer equality on mutable arrays:
+instance Eq (STArray s i e) where
+ STArray _ _ arr1# == STArray _ _ arr2# =
+ sameMutableArray# arr1# arr2#
+
+
+
+
+
+
+
+
+
+
+{-# NOINLINE arrEleBottom #-}
+arrEleBottom :: a
+arrEleBottom = error "(Array.!): undefined array element"
+
+-- | Construct an array with the specified bounds and containing values
+-- for given indices within these bounds.
+--
+-- The array is undefined (i.e. bottom) if any index in the list is
+-- out of bounds. The Haskell 98 Report further specifies that if any
+-- two associations in the list have the same index, the value at that
+-- index is undefined (i.e. bottom). However in GHC's implementation,
+-- the value at such an index is the value part of the last association
+-- with that index in the list.
+--
+-- Because the indices must be checked for these errors, 'array' is
+-- strict in the bounds argument and in the indices of the association
+-- list, but nonstrict in the values. Thus, recurrences such as the
+-- following are possible:
+--
+-- > a = array (1,100) ((1,1) : [(i, i * a!(i-1)) | i <- [2..100]])
+--
+-- Not every index within the bounds of the array need appear in the
+-- association list, but the values associated with indices that do not
+-- appear will be undefined (i.e. bottom).
+--
+-- If, in any dimension, the lower bound is greater than the upper bound,
+-- then the array is legal, but empty. Indexing an empty array always
+-- gives an array-bounds error, but 'bounds' still yields the bounds
+-- with which the array was constructed.
+{-# INLINE array #-}
+array :: Ix i
+ => (i,i) -- ^ a pair of /bounds/, each of the index type
+ -- of the array. These bounds are the lowest and
+ -- highest indices in the array, in that order.
+ -- For example, a one-origin vector of length
+ -- '10' has bounds '(1,10)', and a one-origin '10'
+ -- by '10' matrix has bounds '((1,1),(10,10))'.
+ -> [(i, e)] -- ^ a list of /associations/ of the form
+ -- (/index/, /value/). Typically, this list will
+ -- be expressed as a comprehension. An
+ -- association '(i, x)' defines the value of
+ -- the array at index 'i' to be 'x'.
+ -> Array i e
+array (l,u) ies = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE unsafeArray #-}
+unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> Array i e
+unsafeArray (l,u) ies = runST (ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) ->
+ foldr (fill marr#) (done l u marr#) ies s2# }})
+
+{-# INLINE fill #-}
+fill :: MutableArray# s e -> (Int, e) -> STRep s a -> STRep s a
+fill marr# (I# i#, e) next s1# =
+ case writeArray# marr# i# e s1# of { s2# ->
+ next s2# }
+
+{-# INLINE done #-}
+done :: Ix i => i -> i -> MutableArray# s e -> STRep s (Array i e)
+done l u marr# s1# =
+ case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) ->
+ (# s2#, Array l u arr# #) }
+
+-- This is inefficient and I'm not sure why:
+-- listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es)
+-- The code below is better. It still doesn't enable foldr/build
+-- transformation on the list of elements; I guess it's impossible
+-- using mechanisms currently available.
+
+-- | Construct an array from a pair of bounds and a list of values in
+-- index order.
+{-# INLINE listArray #-}
+listArray :: Ix i => (i,i) -> [e] -> Array i e
+listArray (l,u) es = runST (ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) ->
+ let fillFromList i# xs s3# | i# ==# n# = s3#
+ | otherwise = case xs of
+ [] -> s3#
+ y:ys -> case writeArray# marr# i# y s3# of { s4# ->
+ fillFromList (i# +# 1#) ys s4# } in
+ case fillFromList 0# es s2# of { s3# ->
+ done l u marr# s3# }}})
+
+-- | The value at the given index in an array.
+{-# INLINE (!) #-}
+(!) :: Ix i => Array i e -> i -> e
+arr@(Array l u _) ! i = unsafeAt arr (index (l,u) i)
+
+{-# INLINE unsafeAt #-}
+unsafeAt :: Ix i => Array i e -> Int -> e
+unsafeAt (Array _ _ arr#) (I# i#) =
+ case indexArray# arr# i# of (# e #) -> e
+
+-- | The bounds with which an array was constructed.
+{-# INLINE bounds #-}
+bounds :: Ix i => Array i e -> (i,i)
+bounds (Array l u _) = (l,u)
+
+-- | The list of indices of an array in ascending order.
+{-# INLINE indices #-}
+indices :: Ix i => Array i e -> [i]
+indices (Array l u _) = range (l,u)
+
+-- | The list of elements of an array in index order.
+{-# INLINE elems #-}
+elems :: Ix i => Array i e -> [e]
+elems arr@(Array l u _) =
+ [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]]
+
+-- | The list of associations of an array in index order.
+{-# INLINE assocs #-}
+assocs :: Ix i => Array i e -> [(i, e)]
+assocs arr@(Array l u _) =
+ [(i, unsafeAt arr (unsafeIndex (l,u) i)) | i <- range (l,u)]
+
+-- | The 'accumArray' deals with repeated indices in the association
+-- list using an /accumulating function/ which combines the values of
+-- associations with the same index.
+-- For example, given a list of values of some index type, @hist@
+-- produces a histogram of the number of occurrences of each index within
+-- a specified range:
+--
+-- > hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b
+-- > hist bnds is = accumArray (+) 0 bnds [(i, 1) | i<-is, inRange bnds i]
+--
+-- If the accumulating function is strict, then 'accumArray' is strict in
+-- the values, as well as the indices, in the association list. Thus,
+-- unlike ordinary arrays built with 'array', accumulated arrays should
+-- not in general be recursive.
+{-# INLINE accumArray #-}
+accumArray :: Ix i
+ => (e -> a -> e) -- ^ accumulating function
+ -> e -- ^ initial value
+ -> (i,i) -- ^ bounds of the array
+ -> [(i, a)] -- ^ association list
+ -> Array i e
+accumArray f init (l,u) ies =
+ unsafeAccumArray f init (l,u) [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE unsafeAccumArray #-}
+unsafeAccumArray :: Ix i => (e -> a -> e) -> e -> (i,i) -> [(Int, a)] -> Array i e
+unsafeAccumArray f init (l,u) ies = runST (ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# init s1# of { (# s2#, marr# #) ->
+ foldr (adjust f marr#) (done l u marr#) ies s2# }})
+
+{-# INLINE adjust #-}
+adjust :: (e -> a -> e) -> MutableArray# s e -> (Int, a) -> STRep s b -> STRep s b
+adjust f marr# (I# i#, new) next s1# =
+ case readArray# marr# i# s1# of { (# s2#, old #) ->
+ case writeArray# marr# i# (f old new) s2# of { s3# ->
+ next s3# }}
+
+-- | Constructs an array identical to the first argument except that it has
+-- been updated by the associations in the right argument.
+-- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then
+--
+-- > m//[((i,i), 0) | i <- [1..n]]
+--
+-- is the same matrix, except with the diagonal zeroed.
+--
+-- Repeated indices in the association list are handled as for 'array':
+-- Haskell 98 specifies that the resulting array is undefined (i.e. bottom),
+-- but GHC's implementation uses the last association for each index.
+{-# INLINE (//) #-}
+(//) :: Ix i => Array i e -> [(i, e)] -> Array i e
+arr@(Array l u _) // ies =
+ unsafeReplace arr [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE unsafeReplace #-}
+unsafeReplace :: Ix i => Array i e -> [(Int, e)] -> Array i e
+unsafeReplace arr@(Array l u _) ies = runST (do
+ STArray _ _ marr# <- thawSTArray arr
+ ST (foldr (fill marr#) (done l u marr#) ies))
+
+-- | @'accum' f@ takes an array and an association list and accumulates
+-- pairs from the list into the array with the accumulating function @f@.
+-- Thus 'accumArray' can be defined using 'accum':
+--
+-- > accumArray f z b = accum f (array b [(i, z) | i <- range b])
+--
+{-# INLINE accum #-}
+accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e
+accum f arr@(Array l u _) ies =
+ unsafeAccum f arr [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE unsafeAccum #-}
+unsafeAccum :: Ix i => (e -> a -> e) -> Array i e -> [(Int, a)] -> Array i e
+unsafeAccum f arr@(Array l u _) ies = runST (do
+ STArray _ _ marr# <- thawSTArray arr
+ ST (foldr (adjust f marr#) (done l u marr#) ies))
+
+{-# INLINE amap #-}
+amap :: Ix i => (a -> b) -> Array i a -> Array i b
+amap f arr@(Array l u _) =
+ unsafeArray (l,u) [(i, f (unsafeAt arr i)) | i <- [0 .. rangeSize (l,u) - 1]]
+
+-- | 'ixmap' allows for transformations on array indices.
+-- It may be thought of as providing function composition on the right
+-- with the mapping that the original array embodies.
+--
+-- A similar transformation of array values may be achieved using 'fmap'
+-- from the 'Array' instance of the 'Functor' class.
+{-# INLINE ixmap #-}
+ixmap :: (Ix i, Ix j) => (i,i) -> (i -> j) -> Array j e -> Array i e
+ixmap (l,u) f arr =
+ unsafeArray (l,u) [(unsafeIndex (l,u) i, arr ! f i) | i <- range (l,u)]
+
+{-# INLINE eqArray #-}
+eqArray :: (Ix i, Eq e) => Array i e -> Array i e -> Bool
+eqArray arr1@(Array l1 u1 _) arr2@(Array l2 u2 _) =
+ if rangeSize (l1,u1) == 0 then rangeSize (l2,u2) == 0 else
+ l1 == l2 && u1 == u2 &&
+ and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. rangeSize (l1,u1) - 1]]
+
+{-# INLINE cmpArray #-}
+cmpArray :: (Ix i, Ord e) => Array i e -> Array i e -> Ordering
+cmpArray arr1 arr2 = compare (assocs arr1) (assocs arr2)
+
+{-# INLINE cmpIntArray #-}
+cmpIntArray :: Ord e => Array Int e -> Array Int e -> Ordering
+cmpIntArray arr1@(Array l1 u1 _) arr2@(Array l2 u2 _) =
+ if rangeSize (l1,u1) == 0 then if rangeSize (l2,u2) == 0 then EQ else LT else
+ if rangeSize (l2,u2) == 0 then GT else
+ case compare l1 l2 of
+ EQ -> foldr cmp (compare u1 u2) [0 .. rangeSize (l1, min u1 u2) - 1]
+ other -> other
+ where
+ cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of
+ EQ -> rest
+ other -> other
+
+{-# RULES "cmpArray/Int" cmpArray = cmpIntArray #-}
+
+
+
+
+
+
+
+
+
+
+instance Ix i => Functor (Array i) where
+ fmap = amap
+
+instance (Ix i, Eq e) => Eq (Array i e) where
+ (==) = eqArray
+
+instance (Ix i, Ord e) => Ord (Array i e) where
+ compare = cmpArray
+
+instance (Ix a, Show a, Show b) => Show (Array a b) where
+ showsPrec p a =
+ showParen (p > appPrec) $
+ showString "array " .
+ showsPrec appPrec1 (bounds a) .
+ showChar ' ' .
+ showsPrec appPrec1 (assocs a)
+ -- Precedence of 'array' is the precedence of application
+
+-- The Read instance is in GHC.Read
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+{-# INLINE newSTArray #-}
+newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e)
+newSTArray (l,u) init = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# init s1# of { (# s2#, marr# #) ->
+ (# s2#, STArray l u marr# #) }}
+
+{-# INLINE boundsSTArray #-}
+boundsSTArray :: STArray s i e -> (i,i)
+boundsSTArray (STArray l u _) = (l,u)
+
+{-# INLINE readSTArray #-}
+readSTArray :: Ix i => STArray s i e -> i -> ST s e
+readSTArray marr@(STArray l u _) i =
+ unsafeReadSTArray marr (index (l,u) i)
+
+{-# INLINE unsafeReadSTArray #-}
+unsafeReadSTArray :: Ix i => STArray s i e -> Int -> ST s e
+unsafeReadSTArray (STArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ readArray# marr# i# s1#
+
+{-# INLINE writeSTArray #-}
+writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s ()
+writeSTArray marr@(STArray l u _) i e =
+ unsafeWriteSTArray marr (index (l,u) i) e
+
+{-# INLINE unsafeWriteSTArray #-}
+unsafeWriteSTArray :: Ix i => STArray s i e -> Int -> e -> ST s ()
+unsafeWriteSTArray (STArray _ _ marr#) (I# i#) e = ST $ \s1# ->
+ case writeArray# marr# i# e s1# of { s2# ->
+ (# s2#, () #) }
+
+
+
+
+
+
+
+
+
+
+freezeSTArray :: Ix i => STArray s i e -> ST s (Array i e)
+freezeSTArray (STArray l u marr#) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# arrEleBottom s1# of { (# s2#, marr'# #) ->
+ let copy i# s3# | i# ==# n# = s3#
+ | otherwise =
+ case readArray# marr# i# s3# of { (# s4#, e #) ->
+ case writeArray# marr'# i# e s4# of { s5# ->
+ copy (i# +# 1#) s5# }} in
+ case copy 0# s2# of { s3# ->
+ case unsafeFreezeArray# marr'# s3# of { (# s4#, arr# #) ->
+ (# s4#, Array l u arr# #) }}}}
+
+{-# INLINE unsafeFreezeSTArray #-}
+unsafeFreezeSTArray :: Ix i => STArray s i e -> ST s (Array i e)
+unsafeFreezeSTArray (STArray l u marr#) = ST $ \s1# ->
+ case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) ->
+ (# s2#, Array l u arr# #) }
+
+thawSTArray :: Ix i => Array i e -> ST s (STArray s i e)
+thawSTArray (Array l u arr#) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) ->
+ let copy i# s3# | i# ==# n# = s3#
+ | otherwise =
+ case indexArray# arr# i# of { (# e #) ->
+ case writeArray# marr# i# e s3# of { s4# ->
+ copy (i# +# 1#) s4# }} in
+ case copy 0# s2# of { s3# ->
+ (# s3#, STArray l u marr# #) }}}
+
+{-# INLINE unsafeThawSTArray #-}
+unsafeThawSTArray :: Ix i => Array i e -> ST s (STArray s i e)
+unsafeThawSTArray (Array l u arr#) = ST $ \s1# ->
+ case unsafeThawArray# arr# s1# of { (# s2#, marr# #) ->
+ (# s2#, STArray l u marr# #) }
+
+
diff --git a/tests/expect31 b/tests/expect31
new file mode 100644
--- /dev/null
+++ b/tests/expect31
@@ -0,0 +1,10 @@
+#line 1 "elif"
+
+import System.IO.Unsafe (unsafePerformIO)
+
+
+
+
+
+
+
diff --git a/tests/expect4 b/tests/expect4
new file mode 100644
--- /dev/null
+++ b/tests/expect4
@@ -0,0 +1,40 @@
+#line 1 "testfile"
+1 top of file
+
+3
+
+5 X is defined
+
+7
+
+
+
+11
+
+
+
+15
+
+
+
+19
+
+#line 1 "./inclusion"
+hello world, this is an inclusion
+
+#line 21 "testfile"
+
+
+
+
+25
+
+
+
+
+
+31 third branch of elif
+
+33
+34 end of file
+
diff --git a/tests/expect5 b/tests/expect5
new file mode 100644
--- /dev/null
+++ b/tests/expect5
@@ -0,0 +1,36 @@
+1 top of file
+
+3
+
+5 0 is defined
+
+7
+
+
+
+11
+
+
+
+15
+
+
+
+19
+
+hello world, this is an inclusion
+
+
+
+
+
+25
+
+
+
+
+
+31 third branch of elif
+
+33
+34 end of file
diff --git a/tests/expect6 b/tests/expect6
new file mode 100644
--- /dev/null
+++ b/tests/expect6
@@ -0,0 +1,10 @@
+#line 1 "cpp"
+
+
+
+
+
+
+x ++ y = X' * 0 * y .(foo), Xprime
+
+// /*
diff --git a/tests/expect7 b/tests/expect7
new file mode 100644
--- /dev/null
+++ b/tests/expect7
@@ -0,0 +1,299 @@
+#line 1 "Storable.hs"
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Foreign.Storable
+-- Copyright : (c) The FFI task force 2001
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- The module "Foreign.Storable" provides most elementary support for
+-- marshalling and is part of the language-independent portion of the
+-- Foreign Function Interface (FFI), and will normally be imported via
+-- the "Foreign" module.
+--
+-----------------------------------------------------------------------------
+
+module Foreign.Storable
+ ( Storable(
+ sizeOf, -- :: a -> Int
+ alignment, -- :: a -> Int
+ peekElemOff, -- :: Ptr a -> Int -> IO a
+ pokeElemOff, -- :: Ptr a -> Int -> a -> IO ()
+ peekByteOff, -- :: Ptr b -> Int -> IO a
+ pokeByteOff, -- :: Ptr b -> Int -> a -> IO ()
+ peek, -- :: Ptr a -> IO a
+ poke) -- :: Ptr a -> a -> IO ()
+ ) where
+
+
+
+
+
+
+
+import Control.Monad ( liftM )
+
+#line 1 "./MachDeps.h"
+#line 39 "Storable.hs"
+
+#line 1 "./config.h"
+#line 40 "Storable.hs"
+
+
+
+import GHC.Storable
+import GHC.Stable ( StablePtr )
+import GHC.Num
+import GHC.Int
+import GHC.Word
+import GHC.Stable
+import GHC.Ptr
+import GHC.Float
+import GHC.Err
+import GHC.IOBase
+import GHC.Base
+
+
+
+
+
+
+
+
+
+
+
+
+{- |
+The member functions of this class facilitate writing values of
+primitive types to raw memory (which may have been allocated with the
+above mentioned routines) and reading values from blocks of raw
+memory. The class, furthermore, includes support for computing the
+storage requirements and alignment restrictions of storable types.
+
+Memory addresses are represented as values of type @'Ptr' a@, for some
+@a@ which is an instance of class 'Storable'. The type argument to
+'Ptr' helps provide some valuable type safety in FFI code (you can\'t
+mix pointers of different types without an explicit cast), while
+helping the Haskell type system figure out which marshalling method is
+needed for a given pointer.
+
+All marshalling between Haskell and a foreign language ultimately
+boils down to translating Haskell data structures into the binary
+representation of a corresponding data structure of the foreign
+language and vice versa. To code this marshalling in Haskell, it is
+necessary to manipulate primtive data types stored in unstructured
+memory blocks. The class 'Storable' facilitates this manipulation on
+all types for which it is instantiated, which are the standard basic
+types of Haskell, the fixed size @Int@ types ('Int8', 'Int16',
+'Int32', 'Int64'), the fixed size @Word@ types ('Word8', 'Word16',
+'Word32', 'Word64'), 'StablePtr', all types from "Foreign.C.Types",
+as well as 'Ptr'.
+
+Minimal complete definition: 'sizeOf', 'alignment', one of 'peek',
+'peekElemOff' and 'peekByteOff', and one of 'poke', 'pokeElemOff' and
+'pokeByteOff'.
+-}
+
+class Storable a where
+
+ sizeOf :: a -> Int
+ -- ^ Computes the storage requirements (in bytes) of the argument.
+ -- The value of the argument is not used.
+
+ alignment :: a -> Int
+ -- ^ Computes the alignment constraint of the argument. An
+ -- alignment constraint @x@ is fulfilled by any address divisible
+ -- by @x@. The value of the argument is not used.
+
+ peekElemOff :: Ptr a -> Int -> IO a
+ -- ^ Read a value from a memory area regarded as an array
+ -- of values of the same kind. The first argument specifies
+ -- the start address of the array and the second the index into
+ -- the array (the first element of the array has index
+ -- @0@). The following equality holds,
+ --
+ -- > peekElemOff addr idx = IOExts.fixIO $ \result ->
+ -- > peek (addr `plusPtr` (idx * sizeOf result))
+ --
+ -- Note that this is only a specification, not
+ -- necessarily the concrete implementation of the
+ -- function.
+
+ pokeElemOff :: Ptr a -> Int -> a -> IO ()
+ -- ^ Write a value to a memory area regarded as an array of
+ -- values of the same kind. The following equality holds:
+ --
+ -- > pokeElemOff addr idx x =
+ -- > poke (addr `plusPtr` (idx * sizeOf x)) x
+
+ peekByteOff :: Ptr b -> Int -> IO a
+ -- ^ Read a value from a memory location given by a base
+ -- address and offset. The following equality holds:
+ --
+ -- > peekByteOff addr off = peek (addr `plusPtr` off)
+
+ pokeByteOff :: Ptr b -> Int -> a -> IO ()
+ -- ^ Write a value to a memory location given by a base
+ -- address and offset. The following equality holds:
+ --
+ -- > pokeByteOff addr off x = poke (addr `plusPtr` off) x
+
+ peek :: Ptr a -> IO a
+ -- ^ Read a value from the given memory location.
+ --
+ -- Note that the peek and poke functions might require properly
+ -- aligned addresses to function correctly. This is architecture
+ -- dependent; thus, portable code should ensure that when peeking or
+ -- poking values of some type @a@, the alignment
+ -- constraint for @a@, as given by the function
+ -- 'alignment' is fulfilled.
+
+ poke :: Ptr a -> a -> IO ()
+ -- ^ Write the given value to the given memory location. Alignment
+ -- restrictions might apply; see 'peek'.
+
+ -- circular default instances
+
+ peekElemOff = peekElemOff_ undefined
+ where peekElemOff_ :: a -> Ptr a -> Int -> IO a
+ peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef)
+
+
+
+ pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf val) val
+
+ peekByteOff ptr off = peek (ptr `plusPtr` off)
+ pokeByteOff ptr off = poke (ptr `plusPtr` off)
+
+ peek ptr = peekElemOff ptr 0
+ poke ptr = pokeElemOff ptr 0
+
+
+
+
+
+
+-- System-dependent, but rather obvious instances
+
+instance Storable Bool where
+ sizeOf _ = sizeOf (undefined::HTYPE_INT)
+ alignment _ = alignment (undefined::HTYPE_INT)
+ peekElemOff p i = liftM (/= (0::HTYPE_INT)) $ peekElemOff (castPtr p) i
+ pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::HTYPE_INT)
+
+
+
+
+
+
+
+
+
+instance Storable (Char) where {
+ sizeOf _ = SIZEOF_INT32;
+ alignment _ = ALIGNMENT_INT32;
+ peekElemOff = readWideCharOffPtr;
+ pokeElemOff = writeWideCharOffPtr }
+
+
+
+
+
+instance Storable (Int) where {
+ sizeOf _ = SIZEOF_HSINT;
+ alignment _ = ALIGNMENT_HSINT;
+ peekElemOff = readIntOffPtr;
+ pokeElemOff = writeIntOffPtr }
+
+
+instance Storable (Word) where {
+ sizeOf _ = SIZEOF_HSWORD;
+ alignment _ = ALIGNMENT_HSWORD;
+ peekElemOff = readWordOffPtr;
+ pokeElemOff = writeWordOffPtr }
+
+
+instance Storable ((Ptr a)) where {
+ sizeOf _ = SIZEOF_HSPTR;
+ alignment _ = ALIGNMENT_HSPTR;
+ peekElemOff = readPtrOffPtr;
+ pokeElemOff = writePtrOffPtr }
+
+instance Storable ((FunPtr a)) where {
+ sizeOf _ = SIZEOF_HSFUNPTR;
+ alignment _ = ALIGNMENT_HSFUNPTR;
+ peekElemOff = readFunPtrOffPtr;
+ pokeElemOff = writeFunPtrOffPtr }
+
+instance Storable ((StablePtr a)) where {
+ sizeOf _ = SIZEOF_HSSTABLEPTR;
+ alignment _ = ALIGNMENT_HSSTABLEPTR;
+ peekElemOff = readStablePtrOffPtr;
+ pokeElemOff = writeStablePtrOffPtr }
+
+instance Storable (Float) where {
+ sizeOf _ = SIZEOF_HSFLOAT;
+ alignment _ = ALIGNMENT_HSFLOAT;
+ peekElemOff = readFloatOffPtr;
+ pokeElemOff = writeFloatOffPtr }
+
+instance Storable (Double) where {
+ sizeOf _ = SIZEOF_HSDOUBLE;
+ alignment _ = ALIGNMENT_HSDOUBLE;
+ peekElemOff = readDoubleOffPtr;
+ pokeElemOff = writeDoubleOffPtr }
+
+instance Storable (Word8) where {
+ sizeOf _ = SIZEOF_WORD8;
+ alignment _ = ALIGNMENT_WORD8;
+ peekElemOff = readWord8OffPtr;
+ pokeElemOff = writeWord8OffPtr }
+
+instance Storable (Word16) where {
+ sizeOf _ = SIZEOF_WORD16;
+ alignment _ = ALIGNMENT_WORD16;
+ peekElemOff = readWord16OffPtr;
+ pokeElemOff = writeWord16OffPtr }
+
+instance Storable (Word32) where {
+ sizeOf _ = SIZEOF_WORD32;
+ alignment _ = ALIGNMENT_WORD32;
+ peekElemOff = readWord32OffPtr;
+ pokeElemOff = writeWord32OffPtr }
+
+instance Storable (Word64) where {
+ sizeOf _ = SIZEOF_WORD64;
+ alignment _ = ALIGNMENT_WORD64;
+ peekElemOff = readWord64OffPtr;
+ pokeElemOff = writeWord64OffPtr }
+
+instance Storable (Int8) where {
+ sizeOf _ = SIZEOF_INT8;
+ alignment _ = ALIGNMENT_INT8;
+ peekElemOff = readInt8OffPtr;
+ pokeElemOff = writeInt8OffPtr }
+
+instance Storable (Int16) where {
+ sizeOf _ = SIZEOF_INT16;
+ alignment _ = ALIGNMENT_INT16;
+ peekElemOff = readInt16OffPtr;
+ pokeElemOff = writeInt16OffPtr }
+
+instance Storable (Int32) where {
+ sizeOf _ = SIZEOF_INT32;
+ alignment _ = ALIGNMENT_INT32;
+ peekElemOff = readInt32OffPtr;
+ pokeElemOff = writeInt32OffPtr }
+
+instance Storable (Int64) where {
+ sizeOf _ = SIZEOF_INT64;
+ alignment _ = ALIGNMENT_INT64;
+ peekElemOff = readInt64OffPtr;
+ pokeElemOff = writeInt64OffPtr }
+
+
diff --git a/tests/expect8 b/tests/expect8
new file mode 100644
--- /dev/null
+++ b/tests/expect8
@@ -0,0 +1,37 @@
+#line 1 "HsOpenGLExt.h"
+/* -----------------------------------------------------------------------------
+ *
+ * Module : GL extension support for Graphics.Rendering.OpenGL
+ * Copyright : (c) Sven Panne 2002-2004
+ * License : BSD-style (see the file libraries/OpenGL/LICENSE)
+ *
+ * Maintainer : sven.panne@aedion.de
+ * Stability : provisional
+ * Portability : portable
+ *
+ * This header should only define preprocessor macros!
+ *
+ * -------------------------------------------------------------------------- */
+
+
+
+
+/* NOTE: The macro must immediately start with the foreign declaration,
+ otherwise the magic mangler (hack_foreign) in the Hugs build system
+ doesn't recognize it. */
+
+
+
+
+
+
+
+
+
+
+foreign import ccall unsafe "dynamic" dyn_glFogCoorddEXT :: Graphics.Rendering.OpenGL.GL.Extensions.Invoker (GLdouble -> IO ()) ;
+glFogCoorddEXT :: (GLdouble -> IO ()) ;
+glFogCoorddEXT = dyn_glFogCoorddEXT ptr_glFogCoorddEXT ;
+ptr_glFogCoorddEXT :: FunPtr a ;
+ptr_glFogCoorddEXT = unsafePerformIO (Graphics.Rendering.OpenGL.GL.Extensions.getProcAddress ("GL_EXT_fog_coord or OpenGL 1.4") ("glFogCoorddEXT")) ;
+{-# NOINLINE ptr_glFogCoorddEXT #-}
diff --git a/tests/expect9 b/tests/expect9
new file mode 100644
--- /dev/null
+++ b/tests/expect9
@@ -0,0 +1,17 @@
+#line 1 "multiline"
+
+
+
+
+5 back to ordinary text.
+#line 1 "./inclusion"
+hello world, this is an inclusion
+
+#line 6 "multiline"
+
+7 hello again
+8 some more
+9 some line here;
+ and some more;
+ finish now
+10 end
diff --git a/tests/inclusion b/tests/inclusion
new file mode 100644
--- /dev/null
+++ b/tests/inclusion
@@ -0,0 +1,1 @@
+hello world, this is an inclusion
diff --git a/tests/incomplete b/tests/incomplete
new file mode 100644
--- /dev/null
+++ b/tests/incomplete
@@ -0,0 +1,1 @@
+incomplete
diff --git a/tests/indirect b/tests/indirect
new file mode 100644
--- /dev/null
+++ b/tests/indirect
@@ -0,0 +1,2 @@
+#define F "inclusion"
+#include F
diff --git a/tests/multiline b/tests/multiline
new file mode 100644
--- /dev/null
+++ b/tests/multiline
@@ -0,0 +1,10 @@
+#define aLongMacroDefinition(x,y) \
+ some line here; \
+ and some more; \
+ finish now
+5 back to ordinary text.
+#include "inclusion"
+7 hello again
+8 some more
+9 aLongMacroDefinition(a,b)
+10 end
diff --git a/tests/nastyhack b/tests/nastyhack
new file mode 100644
--- /dev/null
+++ b/tests/nastyhack
@@ -0,0 +1,16 @@
+#define GHC_PKG_VERSION 6.2.2
+-- hackery to convice cpp to splice GHC_PKG_VERSION into a string
+version :: String
+version = tail "\
+ \ GHC_PKG_VERSION"
+
+version2 = "GHC_PKG_VERSION"
+
+#define v3 "GHC_PKG_VERSION"
+version3 = v3
+
+#define stringify(s) #s
+version4 = stringify(GHC_PKG_VERSION)
+
+#define stringify2(s) "s"
+version5 = stringify2(GHC_PKG_VERSION)
diff --git a/tests/numbers b/tests/numbers
new file mode 100644
--- /dev/null
+++ b/tests/numbers
@@ -0,0 +1,29 @@
+#if 1
+number (1) in if
+#else
+rejected number (1) in if
+#endif
+
+#if 0
+wrongly accepted number (0) in if
+#else
+number (0) in if
+#endif
+
+#if eaf
+false hex number in if
+#else
+rejected false hex number in if
+#endif
+
+#if 0x1
+real hex number (0x1) in if
+#else
+rejected real hex number (0x1) in if
+#endif
+
+#if 0x00
+wrongly accepted real hex number (0x00) in if
+#else
+hex number (0x00) in if
+#endif
diff --git a/tests/parens b/tests/parens
new file mode 100644
--- /dev/null
+++ b/tests/parens
@@ -0,0 +1,5 @@
+#if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 600 ) \
+ || ( defined(__NHC__) && __NHC__ >= 117 )
+#define FINALIZERPTR yes
+#endif
+FINALIZERPTR
diff --git a/tests/pragma b/tests/pragma
new file mode 100644
--- /dev/null
+++ b/tests/pragma
@@ -0,0 +1,1 @@
+#pragma ident "@(#)time.h 1.39 99/08/10 SMI" /* SVr4.0 1.18 */
diff --git a/tests/precedence b/tests/precedence
new file mode 100644
--- /dev/null
+++ b/tests/precedence
@@ -0,0 +1,3 @@
+#if !0 && 0
+boolean operator precedence is wrong
+#endif
diff --git a/tests/recursive b/tests/recursive
new file mode 100644
--- /dev/null
+++ b/tests/recursive
@@ -0,0 +1,4 @@
+#define C D D
+#define B C C
+#define A B B
+A
diff --git a/tests/ross b/tests/ross
new file mode 100644
--- /dev/null
+++ b/tests/ross
@@ -0,0 +1,19 @@
+/* 1. C comments should be deleted by the preprocessor */
+
+/* 2. repeated expansion */
+#define FOO 4
+#define BAR FOO
+
+f = BAR
+
+/* 3. continuation lines in macros shouldn't give newlines */
+#define LONG_MACRO \
+{ putStr "Hello "; \
+ putStrLn "World" }
+
+g = do LONG_MACRO
+
+/* 4. projection macros */
+#define MACRO(x) x
+
+h = MACRO(FOO)
diff --git a/tests/runtests b/tests/runtests
new file mode 100644
--- /dev/null
+++ b/tests/runtests
@@ -0,0 +1,46 @@
+#!/bin/sh
+CPPHS=${1:-"../cpphs"}
+FAIL=0
+
+runtest() {
+ if $1 >out 2>/dev/null && diff $2 out >/dev/null
+ then echo "passed: " $1
+ else FAIL=$?
+ echo "FAILED: ($2) " $1
+ fi
+}
+
+if $CPPHS