diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,7 @@ Version 1.17 ------------ * recursively evaluate #if expressions after macro expansion (fix) + * (1.17.1): report the right version with cpphs --version Version 1.16 ------------ diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,56 @@ +LIBRARY = cpphs +VERSION = 1.17.1 + +DIRS = Language/Preprocessor/Cpphs \ + Text/ParserCombinators + +SRCS = Language/Preprocessor/Cpphs.hs \ + Language/Preprocessor/Cpphs/CppIfdef.hs \ + Language/Preprocessor/Cpphs/HashDefine.hs \ + Language/Preprocessor/Cpphs/MacroPass.hs \ + Language/Preprocessor/Cpphs/Options.hs \ + Language/Preprocessor/Cpphs/Position.hs \ + Language/Preprocessor/Cpphs/ReadFirst.hs \ + Language/Preprocessor/Cpphs/RunCpphs.hs \ + Language/Preprocessor/Cpphs/SymTab.hs \ + Language/Preprocessor/Cpphs/Tokenise.hs \ + Language/Preprocessor/Unlit.hs \ + Text/ParserCombinators/HuttonMeijer.hs \ + cpphs.hs + +AUX = README LICENCE* CHANGELOG $(LIBRARY).cabal Setup.hs Makefile \ + cpphs.hugs cpphs.compat \ + tests/[A-BD-Z]* tests/[a-np-z]* \ + docs/[a-z]* + +HC = ghc +HFLAGS = +HEAP = +HOSTSTRIP = strip + +all: $(LIBRARY) +package: + tar cf tmp.tar $(SRCS) $(AUX) + mkdir $(LIBRARY)-$(VERSION) + cd $(LIBRARY)-$(VERSION); tar xf ../tmp.tar + tar zcf $(LIBRARY)-$(VERSION).tar.gz $(LIBRARY)-$(VERSION) + zip -r $(LIBRARY)-$(VERSION).zip $(LIBRARY)-$(VERSION) + rm -r tmp.tar $(LIBRARY)-$(VERSION) +haddock: $(SRCS) + mkdir -p docs/$(LIBRARY) + for dir in $(DIRS); do mkdir -p docs/$(LIBRARY)/$$dir; done + for file in $(SRCS); \ + do HsColour -anchor -html $$file \ + >docs/$(LIBRARY)/`dirname $$file`/`basename $$file .hs`.html;\ + done + haddock --html --title=$(LIBRARY) \ + --odir=docs/$(LIBRARY) --package=$(LIBRARY) \ + --source-module="%{MODULE/.//}.html" \ + --source-entity="%{MODULE/.//}.html#%{NAME}" \ + $(SRCS) + + + +$(LIBRARY): $(SRCS) + $(HC) $(HFLAGS) $(HEAP) -o $@ $(SRCS) + $(HOSTSTRIP) $@ diff --git a/cpphs.cabal b/cpphs.cabal --- a/cpphs.cabal +++ b/cpphs.cabal @@ -1,5 +1,5 @@ Name: cpphs -Version: 1.17 +Version: 1.17.1 Copyright: 2004-2013, Malcolm Wallace License: LGPL License-File: LICENCE-LGPL diff --git a/cpphs.compat b/cpphs.compat new file mode 100644 --- /dev/null +++ b/cpphs.compat @@ -0,0 +1,48 @@ +#!/bin/sh +# A minimal compatibility script to make cpphs accept the same +# arguments as real cpp, wherever possible. +CPPHS=/usr/malcolm/Haskell/cpphs/cpphs + +processArgs () { + TRADITIONAL=no + STRIP=yes + INFILE="-" + OUTFILE="-" + while test "$1" != "" + do + case $1 in + -D) shift; echo -D$1 ;; + -D*) echo $1 ;; + -U) shift; echo -U$1 ;; + -U*) echo $1 ;; + -I) shift; echo -I$1 ;; + -I*) echo $1 ;; + -o) shift; echo -O$1 ;; + -o*) echo -O`echo $1 | cut -c3-` ;; + -std*) ;; # ignore language spec + -x) shift ;; # ignore language spec + -ansi*) TRADITIONAL=no ;; + -traditional*) TRADITIONAL=yes ;; + -include) shift; echo $1 ;; + -P) echo --noline ;; + -C) STRIP=no ;; + -CC) STRIP=no ;; + -A) shift ;; # strip assertions + --help) echo $1 ;; + -version) echo -$1 ;; + --version) echo $1 ;; + -*) ;; # strip all other flags + *) if [ "$INFILE" = "-" ] + then INFILE=$1 + else OUTFILE=$1 + fi ;; + esac + if test "$1" != ""; then shift; fi + done + if [ "$TRADITIONAL" = "no" ]; then echo "--hashes"; fi + if [ "$STRIP" = "yes" ]; then echo "--strip"; fi + echo $INFILE + if [ "$OUTFILE" != "-" ]; then echo "-O$OUTFILE"; fi +} + +exec $CPPHS `processArgs "$@"` diff --git a/cpphs.hs b/cpphs.hs --- a/cpphs.hs +++ b/cpphs.hs @@ -20,7 +20,7 @@ import Data.List ( isPrefixOf ) version :: String -version = "1.16" +version = "1.17.1" main :: IO () main = do diff --git a/cpphs.hugs b/cpphs.hugs new file mode 100644 --- /dev/null +++ b/cpphs.hugs @@ -0,0 +1,2 @@ +#!/bin/sh +runhugs cpphs.hs --noline -D__HASKELL98__ -D__HUGS__ "$@" 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 --- a/docs/index.html +++ b/docs/index.html @@ -198,12 +198,11 @@ Current stable version:

-cpphs-1.17, release date 2013.08.16
+cpphs-1.17.1, release date 2013.08.18
By HTTP: -.tar.gz, Hackage.

@@ -227,6 +226,15 @@ Older versions: + +

+cpphs-1.17, release date 2013.08.16
+By HTTP: +.tar.gz, +Hackage. +

cpphs-1.16, release date 2013.01.22
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/ballard b/tests/ballard new file mode 100644 --- /dev/null +++ b/tests/ballard @@ -0,0 +1,10 @@ +#define MAJOR_VERSION 4 +#define MINOR_VERSION 5 +#define PATCH_LEVEL 0 +#define MIN_VERSION_base(x,y,z) MAJOR_VERSION > x || MAJOR_VERSION == x && MINOR_VERSION > y || MAJOR_VERSION == x && MINOR_VERSION == y && PATCH_LEVEL >= z + +MIN_VERSION_base(4,5,0) +#if MIN_VERSION_base(4,5,0) +this text is only included when expression evaluates to true +#endif +done 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/comments b/tests/comments new file mode 100644 --- /dev/null +++ b/tests/comments @@ -0,0 +1,3 @@ +here is an ordinary C comment: /* comment here */ +and here is a C++-style end-of-line comment: // comment here +this line has no comments 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/emptyhashes b/tests/emptyhashes new file mode 100644 --- /dev/null +++ b/tests/emptyhashes @@ -0,0 +1,5 @@ +this is a test with a hash on a line of its own +# +with no command after it. +#define FOO +and ending here diff --git a/tests/endcode-a b/tests/endcode-a new file mode 100644 --- /dev/null +++ b/tests/endcode-a @@ -0,0 +1,3 @@ +\hidden{ +\begin{code} +\end{code}} diff --git a/tests/endcode-b b/tests/endcode-b new file mode 100644 --- /dev/null +++ b/tests/endcode-b @@ -0,0 +1,4 @@ +\hidden{ +\begin{code} +\end{code} +} 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,15 @@ +#line 1 "multiline" + + + + +5 back to ordinary text. +#line 1 "./inclusion" +hello world, this is an inclusion + +#line 7 "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,6 @@ +#line 1 "indirect" + +#line 1 "./inclusion" +hello world, this is an inclusion + +#line 3 "indirect" diff --git a/tests/expect15a b/tests/expect15a new file mode 100644 --- /dev/null +++ b/tests/expect15a @@ -0,0 +1,6 @@ +#line 1 "indirect-a" + +#line 1 "./inclusion" +hello world, this is an inclusion + +#line 3 "indirect-a" 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,6 @@ +#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,13 @@ +#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 4 "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 = "6.2.2" 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,11 @@ +#line 1 "elif" + + +import System.IO.Unsafe (unsafePerformIO) + + + + + + + diff --git a/tests/expect32 b/tests/expect32 new file mode 100644 --- /dev/null +++ b/tests/expect32 @@ -0,0 +1,2 @@ +#line 1 "pragma" +#pragma ident "@(#)time.h 1.39 99/08/10 SMI" diff --git a/tests/expect33 b/tests/expect33 new file mode 100644 --- /dev/null +++ b/tests/expect33 @@ -0,0 +1,1 @@ +#pragma ident "@(#)time.h 1.39 99/08/10 SMI" diff --git a/tests/expect34 b/tests/expect34 new file mode 100644 --- /dev/null +++ b/tests/expect34 @@ -0,0 +1,11 @@ +#line 1 "igloo" + + + +1 + + +foo + + + diff --git a/tests/expect35 b/tests/expect35 new file mode 100644 --- /dev/null +++ b/tests/expect35 @@ -0,0 +1,12 @@ +#line 1 "igloo2" + + + +baz +1 + + +foo + + + diff --git a/tests/expect36 b/tests/expect36 new file mode 100644 --- /dev/null +++ b/tests/expect36 @@ -0,0 +1,12 @@ +#line 1 "igloo3" + + + +quux +FOOFOO + + + + +bar + diff --git a/tests/expect36a b/tests/expect36a new file mode 100644 --- /dev/null +++ b/tests/expect36a @@ -0,0 +1,12 @@ +#line 1 "igloo3a" + + + +quux +FOOFOO + + + + +bar + diff --git a/tests/expect36b b/tests/expect36b new file mode 100644 --- /dev/null +++ b/tests/expect36b @@ -0,0 +1,13 @@ +#line 1 "igloo3b" + + + + +quux +11 + + +foo + + + diff --git a/tests/expect37 b/tests/expect37 new file mode 100644 --- /dev/null +++ b/tests/expect37 @@ -0,0 +1,11 @@ +#line 1 "igloo4" + + +wibble +11 + + +foo + + + diff --git a/tests/expect37a b/tests/expect37a new file mode 100644 --- /dev/null +++ b/tests/expect37a @@ -0,0 +1,11 @@ +#line 1 "igloo4a" + + +wibble +11 + + +foo + + + diff --git a/tests/expect38 b/tests/expect38 new file mode 100644 --- /dev/null +++ b/tests/expect38 @@ -0,0 +1,8 @@ +#line 1 "mauke" + + + + + + +main = print 7 -- should print 7 diff --git a/tests/expect39 b/tests/expect39 new file mode 100644 --- /dev/null +++ b/tests/expect39 @@ -0,0 +1,5 @@ +#line 1 "mauke2" + + + +4 diff --git a/tests/expect4 b/tests/expect4 new file mode 100644 --- /dev/null +++ b/tests/expect4 @@ -0,0 +1,39 @@ +#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 22 "testfile" + + + +25 + + + + + +31 third branch of elif + +33 +34 end of file + diff --git a/tests/expect40 b/tests/expect40 new file mode 100644 --- /dev/null +++ b/tests/expect40 @@ -0,0 +1,8 @@ +#line 1 "fasta" + + + + + + +b7 = unsafeVisualize(foo) diff --git a/tests/expect40a b/tests/expect40a new file mode 100644 --- /dev/null +++ b/tests/expect40a @@ -0,0 +1,7 @@ +#line 1 "fasta2" + + + + + +b6 = unsafeVisualize(foo) diff --git a/tests/expect41 b/tests/expect41 new file mode 100644 --- /dev/null +++ b/tests/expect41 @@ -0,0 +1,6 @@ +#line 1 "hashjoin" + + + + +2 diff --git a/tests/expect42 b/tests/expect42 new file mode 100644 --- /dev/null +++ b/tests/expect42 @@ -0,0 +1,5 @@ +#line 1 "wrongline" + +2 +#line 20 "foo" +20 diff --git a/tests/expect43 b/tests/expect43 new file mode 100644 --- /dev/null +++ b/tests/expect43 @@ -0,0 +1,6 @@ +#line 1 "param" + + + + +11 -- gcc gives BARBAR, cpphs gives 11 diff --git a/tests/expect44 b/tests/expect44 new file mode 100644 --- /dev/null +++ b/tests/expect44 @@ -0,0 +1,4 @@ +#line 1 "comments" +here is an ordinary C comment: +and here is a C++-style end-of-line comment: // comment here +this line has no comments diff --git a/tests/expect44a b/tests/expect44a new file mode 100644 --- /dev/null +++ b/tests/expect44a @@ -0,0 +1,4 @@ +#line 1 "comments" +here is an ordinary C comment: +and here is a C++-style end-of-line comment: +this line has no comments diff --git a/tests/expect45 b/tests/expect45 new file mode 100644 --- /dev/null +++ b/tests/expect45 @@ -0,0 +1,8 @@ +#line 1 "nestcomment" +{- + +foo + + + +-} diff --git a/tests/expect46 b/tests/expect46 new file mode 100644 --- /dev/null +++ b/tests/expect46 @@ -0,0 +1,7 @@ +#line 1 "preinclude" +#line 1 "./inclusion" +hello world, this is an inclusion + +#line 2 "preinclude" +#line 1 "preinclude" +something arbitrary diff --git a/tests/expect47 b/tests/expect47 new file mode 100644 --- /dev/null +++ b/tests/expect47 @@ -0,0 +1,5 @@ +#line 1 "endcode-a" + + + + diff --git a/tests/expect48 b/tests/expect48 new file mode 100644 --- /dev/null +++ b/tests/expect48 @@ -0,0 +1,6 @@ +#line 1 "endcode-b" + + + + + diff --git a/tests/expect49 b/tests/expect49 new file mode 100644 --- /dev/null +++ b/tests/expect49 @@ -0,0 +1,5 @@ +#line 1 "undef.hs" + +wibble 3 + +this is FOO diff --git a/tests/expect5 b/tests/expect5 new file mode 100644 --- /dev/null +++ b/tests/expect5 @@ -0,0 +1,35 @@ +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/expect50 b/tests/expect50 new file mode 100644 --- /dev/null +++ b/tests/expect50 @@ -0,0 +1,9 @@ +{-# LINE 1 "linepragma" #-} +{-# LINE 1 "./inclusion" #-} +hello world, this is an inclusion + +{-# LINE 2 "linepragma" #-} +{-# LINE 2 "linepragma" #-} + +{-# LINE 3 "linepragma" #-} + diff --git a/tests/expect51 b/tests/expect51 new file mode 100644 --- /dev/null +++ b/tests/expect51 @@ -0,0 +1,7 @@ +#line 1 "nomacro" +This file is intended to show the interaction of --nomacro with --strip +which was broken up until cpphs-1.14. + +Here is a line with some comment // to eol +Here is a line with some C89 comment /* inlined */ with more text after it. +Here is a line that uses 1 but it should look like uppercase foo, not 1. diff --git a/tests/expect52 b/tests/expect52 new file mode 100644 --- /dev/null +++ b/tests/expect52 @@ -0,0 +1,8 @@ +#line 1 "nomacro" +This file is intended to show the interaction of --nomacro with --strip +which was broken up until cpphs-1.14. + +Here is a line with some comment // to eol +Here is a line with some C89 comment /* inlined */ with more text after it. +Here is a line that uses FOO but it should look like uppercase foo, not 1. + diff --git a/tests/expect53 b/tests/expect53 new file mode 100644 --- /dev/null +++ b/tests/expect53 @@ -0,0 +1,7 @@ +#line 1 "nomacro" +This file is intended to show the interaction of --nomacro with --strip +which was broken up until cpphs-1.14. + +Here is a line with some comment +Here is a line with some C89 comment with more text after it. +Here is a line that uses FOO but it should look like uppercase foo, not 1. diff --git a/tests/expect54 b/tests/expect54 new file mode 100644 --- /dev/null +++ b/tests/expect54 @@ -0,0 +1,7 @@ +#line 1 "nomacro" +This file is intended to show the interaction of --nomacro with --strip +which was broken up until cpphs-1.14. + +Here is a line with some comment +Here is a line with some C89 comment with more text after it. +Here is a line that uses 1 but it should look like uppercase foo, not 1. diff --git a/tests/expect55 b/tests/expect55 new file mode 100644 --- /dev/null +++ b/tests/expect55 @@ -0,0 +1,11 @@ +#line 1 "ballard" + + + + + +4 > 4 || 4 == 4 && 5 > 5 || 4 == 4 && 5 == 5 && 0 >= 0 + +this text is only included when expression evaluates to true + +done 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,297 @@ +#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 40 "Storable.hs" +#line 1 "./config.h" +#line 41 "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,16 @@ +#line 1 "multiline" + + + + +5 back to ordinary text. +#line 1 "./inclusion" +hello world, this is an inclusion + +#line 7 "multiline" +7 hello again +8 some more +9 some line here; + and some more; + finish now +10 end diff --git a/tests/fasta b/tests/fasta new file mode 100644 --- /dev/null +++ b/tests/fasta @@ -0,0 +1,7 @@ +#define XCONCAT(a, b) a##b +#define CONCAT(a, b) XCONCAT(a, b) +#define PS(val) () <- trace (val) (return ()) +#define VIS(ioaction) let CONCAT(b, __LINE__) = unsafeVisualize(ioaction) +#define V(ioaction) CONCAT(b, __LINE__) = unsafeVisualize(ioaction) + +V(foo) diff --git a/tests/fasta2 b/tests/fasta2 new file mode 100644 --- /dev/null +++ b/tests/fasta2 @@ -0,0 +1,6 @@ +#define XCONCAT(a, b) a##b +#define CONCAT(a, b) XCONCAT(a, b) +#define PS(val) () <- trace (val) (return ()) +#define VIS(ioaction) let CONCAT(b, __LINE__) = unsafeVisualize(ioaction) +#define V(ioaction) CONCAT(b, __LINE__) = unsafeVisualize(ioaction) +V(foo) diff --git a/tests/hashjoin b/tests/hashjoin new file mode 100644 --- /dev/null +++ b/tests/hashjoin @@ -0,0 +1,5 @@ +#define FOO 1 +#define BAR FOO##FOO +#define FOOFOO 2 + +BAR diff --git a/tests/igloo b/tests/igloo new file mode 100644 --- /dev/null +++ b/tests/igloo @@ -0,0 +1,10 @@ +#define FOO 1 +#define BAR FOO + +BAR + +#if BAR == 1 +foo +#else +bar +#endif diff --git a/tests/igloo2 b/tests/igloo2 new file mode 100644 --- /dev/null +++ b/tests/igloo2 @@ -0,0 +1,11 @@ +#define FOO 1 +#define BAZ(x) x + +baz +BAZ(1) + +#if BAZ(1) == 1 +foo +#else +bar +#endif diff --git a/tests/igloo3 b/tests/igloo3 new file mode 100644 --- /dev/null +++ b/tests/igloo3 @@ -0,0 +1,11 @@ +#define FOO 1 +#define QUUX FOO ## FOO + +quux +QUUX + +#if QUUX == 11 +foo +#else +bar +#endif diff --git a/tests/igloo3a b/tests/igloo3a new file mode 100644 --- /dev/null +++ b/tests/igloo3a @@ -0,0 +1,11 @@ +#define FOO 1 +#define QUUX FOO##FOO + +quux +QUUX + +#if QUUX == 11 +foo +#else +bar +#endif diff --git a/tests/igloo3b b/tests/igloo3b new file mode 100644 --- /dev/null +++ b/tests/igloo3b @@ -0,0 +1,12 @@ +#define FOO 1 +#define QUUX(a) a ## a +#define WIBBLE QUUX(FOO) + +quux +WIBBLE + +#if WIBBLE == 11 +foo +#else +bar +#endif diff --git a/tests/igloo4 b/tests/igloo4 new file mode 100644 --- /dev/null +++ b/tests/igloo4 @@ -0,0 +1,10 @@ +#define WIBBLE 1 ## 1 + +wibble +WIBBLE + +#if WIBBLE == 11 +foo +#else +bar +#endif diff --git a/tests/igloo4a b/tests/igloo4a new file mode 100644 --- /dev/null +++ b/tests/igloo4a @@ -0,0 +1,10 @@ +#define WIBBLE 1##1 + +wibble +WIBBLE + +#if WIBBLE == 11 +foo +#else +bar +#endif 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/indirect-a b/tests/indirect-a new file mode 100644 --- /dev/null +++ b/tests/indirect-a @@ -0,0 +1,2 @@ +#define F(f) in##f +#include F(clusion) diff --git a/tests/linepragma b/tests/linepragma new file mode 100644 --- /dev/null +++ b/tests/linepragma @@ -0,0 +1,5 @@ +#include "inclusion" +#line 2 "linepragma" + +#line 3 "linepragma" + diff --git a/tests/mauke b/tests/mauke new file mode 100644 --- /dev/null +++ b/tests/mauke @@ -0,0 +1,7 @@ +#define X /\ +* comment */ main + +#define Y _\ +_LINE__ + +X = print Y -- should print 7 diff --git a/tests/mauke2 b/tests/mauke2 new file mode 100644 --- /dev/null +++ b/tests/mauke2 @@ -0,0 +1,4 @@ +#define foo _\ +_LINE__ + +foo 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/nestcomment b/tests/nestcomment new file mode 100644 --- /dev/null +++ b/tests/nestcomment @@ -0,0 +1,7 @@ +{- +#if 1 +foo +#else +bar +#endif +-} diff --git a/tests/nomacro b/tests/nomacro new file mode 100644 --- /dev/null +++ b/tests/nomacro @@ -0,0 +1,6 @@ +This file is intended to show the interaction of --nomacro with --strip +which was broken up until cpphs-1.14. +#define FOO 1 +Here is a line with some comment // to eol +Here is a line with some C89 comment /* inlined */ with more text after it. +Here is a line that uses FOO but it should look like uppercase foo, not 1. 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/param b/tests/param new file mode 100644 --- /dev/null +++ b/tests/param @@ -0,0 +1,5 @@ +#define FOO 1 +#define BAR FOO +#define JOIN(f) f##f + +JOIN(BAR) -- gcc gives BARBAR, cpphs gives 11 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/preinclude b/tests/preinclude new file mode 100644 --- /dev/null +++ b/tests/preinclude @@ -0,0 +1,1 @@ +something arbitrary 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,76 @@ +#!/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