diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,7 @@ +Version 1.17 +------------ + * recursively evaluate #if expressions after macro expansion (fix) + Version 1.16 ------------ * fix interaction of runCpphsReturningSymTab with --nomacro diff --git a/Language/Preprocessor/Cpphs/CppIfdef.hs b/Language/Preprocessor/Cpphs/CppIfdef.hs --- a/Language/Preprocessor/Cpphs/CppIfdef.hs +++ b/Language/Preprocessor/Cpphs/CppIfdef.hs @@ -265,7 +265,7 @@ case lookupST sym st of Nothing -> sym Just (a@SymbolReplacement{}) -> recursivelyExpand st (replacement a) - Just (a@MacroExpansion{}) -> expandMacro a args False + Just (a@MacroExpansion{}) -> recursivelyExpand st (expandMacro a args False) Just (a@AntiDefined{}) -> name a recursivelyExpand :: SymTab HashDefine -> String -> String diff --git a/Language/Preprocessor/Cpphs/Options.hs b/Language/Preprocessor/Cpphs/Options.hs --- a/Language/Preprocessor/Cpphs/Options.hs +++ b/Language/Preprocessor/Cpphs/Options.hs @@ -17,6 +17,7 @@ , parseOptions , defaultCpphsOptions , defaultBoolOptions + , trailing ) where import Data.Maybe @@ -28,7 +29,7 @@ , outfiles :: [FilePath] , defines :: [(String,String)] , includes :: [String] - , preInclude:: [FilePath] -- ^ Files to #include before anything else + , preInclude:: [FilePath] -- ^ Files to \#include before anything else , boolopts :: BoolOptions } @@ -42,9 +43,9 @@ -- | Options representable as Booleans. data BoolOptions = BoolOptions { macros :: Bool -- ^ Leave \#define and \#undef in output of ifdef? - , locations :: Bool -- ^ Place #line droppings in output? - , hashline :: Bool -- ^ Write #line or {-# LINE #-} ? - , pragma :: Bool -- ^ Keep #pragma in final output? + , locations :: Bool -- ^ Place \#line droppings in output? + , hashline :: Bool -- ^ Write \#line or {-\# LINE \#-} ? + , pragma :: Bool -- ^ Keep \#pragma in final output? , stripEol :: Bool -- ^ Remove C eol (\/\/) comments everywhere? , stripC89 :: Bool -- ^ Remove C inline (\/**\/) comments everywhere? , lang :: Bool -- ^ Lex input as Haskell code? @@ -110,6 +111,9 @@ = Just $ PreInclude (drop 10 xs) rawOption _ = Nothing +-- | Trim trailing elements of the second list that match any from +-- the first list. Typically used to remove trailing forward\/back +-- slashes from a directory path. trailing :: (Eq a) => [a] -> [a] -> [a] trailing xs = reverse . dropWhile (`elem`xs) . reverse diff --git a/Language/Preprocessor/Cpphs/RunCpphs.hs b/Language/Preprocessor/Cpphs/RunCpphs.hs --- a/Language/Preprocessor/Cpphs/RunCpphs.hs +++ b/Language/Preprocessor/Cpphs/RunCpphs.hs @@ -10,13 +10,15 @@ import Language.Preprocessor.Cpphs.CppIfdef (cppIfdef) import Language.Preprocessor.Cpphs.MacroPass(macroPass,macroPassReturningSymTab) -import Language.Preprocessor.Cpphs.Options (CpphsOptions(..), BoolOptions(..)) +import Language.Preprocessor.Cpphs.Options (CpphsOptions(..), BoolOptions(..) + ,trailing) import Language.Preprocessor.Cpphs.Tokenise (deWordStyle, tokenise) import Language.Preprocessor.Unlit as Unlit (unlit) runCpphs :: CpphsOptions -> FilePath -> String -> IO String -runCpphs options filename input = do +runCpphs options' filename input = do + let options= options'{ includes= map (trailing "\\/") (includes options') } let bools = boolopts options preInc = case preInclude options of [] -> "" @@ -39,7 +41,8 @@ runCpphsReturningSymTab :: CpphsOptions -> FilePath -> String -> IO (String,[(String,String)]) -runCpphsReturningSymTab options filename input = do +runCpphsReturningSymTab options' filename input = do + let options= options'{ includes= map (trailing "\\/") (includes options') } let bools = boolopts options preInc = case preInclude options of [] -> "" diff --git a/Makefile b/Makefile deleted file mode 100644 --- a/Makefile +++ /dev/null @@ -1,56 +0,0 @@ -LIBRARY = cpphs -VERSION = 1.16 - -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,6 +1,6 @@ Name: cpphs -Version: 1.16 -Copyright: 2004-2012, Malcolm Wallace +Version: 1.17 +Copyright: 2004-2013, Malcolm Wallace License: LGPL License-File: LICENCE-LGPL Cabal-Version: >= 1.6 diff --git a/cpphs.compat b/cpphs.compat deleted file mode 100644 --- a/cpphs.compat +++ /dev/null @@ -1,48 +0,0 @@ -#!/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.hugs b/cpphs.hugs deleted file mode 100644 --- a/cpphs.hugs +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -runhugs cpphs.hs --noline -D__HASKELL98__ -D__HUGS__ "$@" diff --git a/docs/design b/docs/design deleted file mode 100644 --- a/docs/design +++ /dev/null @@ -1,29 +0,0 @@ -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,12 @@ Current stable version:

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

@@ -226,6 +226,16 @@

Older versions: + + +

+cpphs-1.16, release date 2013.01.22
+By HTTP: +.tar.gz, +Hackage. +

cpphs-1.15, release date 2012.11.30
diff --git a/tests/Arr.lhs b/tests/Arr.lhs deleted file mode 100644 --- a/tests/Arr.lhs +++ /dev/null @@ -1,683 +0,0 @@ -\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 deleted file mode 100644 --- a/tests/HsOpenGLExt.h +++ /dev/null @@ -1,31 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * 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 deleted file mode 100644 --- a/tests/MachDeps.h +++ /dev/null diff --git a/tests/Storable.hs b/tests/Storable.hs deleted file mode 100644 --- a/tests/Storable.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/Test.hsc +++ /dev/null @@ -1,11 +0,0 @@ -module Test where - -main :: IO () -main = putStrLn "shows a cpphs+hsc2hs bug with comments" - -#def inline int that_one_will_work(void) {return 42;} - -{- -#def inline int cpphs_will_stumble(void) {return 42;} --} - diff --git a/tests/chains b/tests/chains deleted file mode 100644 --- a/tests/chains +++ /dev/null @@ -1,16 +0,0 @@ -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 deleted file mode 100644 --- a/tests/comments +++ /dev/null @@ -1,3 +0,0 @@ -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 deleted file mode 100644 --- a/tests/config.h +++ /dev/null diff --git a/tests/cpp b/tests/cpp deleted file mode 100644 --- a/tests/cpp +++ /dev/null @@ -1,9 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/elif +++ /dev/null @@ -1,10 +0,0 @@ -#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/endcode-a b/tests/endcode-a deleted file mode 100644 --- a/tests/endcode-a +++ /dev/null @@ -1,3 +0,0 @@ -\hidden{ -\begin{code} -\end{code}} diff --git a/tests/endcode-b b/tests/endcode-b deleted file mode 100644 --- a/tests/endcode-b +++ /dev/null @@ -1,4 +0,0 @@ -\hidden{ -\begin{code} -\end{code} -} diff --git a/tests/expect1 b/tests/expect1 deleted file mode 100644 --- a/tests/expect1 +++ /dev/null @@ -1,36 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect10 +++ /dev/null @@ -1,15 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect11 +++ /dev/null @@ -1,3 +0,0 @@ -#line 1 "stringise" - -This is "abcd ef" foo abcd ef diff --git a/tests/expect12 b/tests/expect12 deleted file mode 100644 --- a/tests/expect12 +++ /dev/null @@ -1,5 +0,0 @@ -#line 1 "recursive" - - - -D D D D D D D D diff --git a/tests/expect13 b/tests/expect13 deleted file mode 100644 --- a/tests/expect13 +++ /dev/null @@ -1,20 +0,0 @@ -#line 1 "ross" - - - - - - -f = 4 - - - - - - -g = do { putStr "Hello "; putStrLn "World" } - - - - -h = 4 diff --git a/tests/expect14 b/tests/expect14 deleted file mode 100644 --- a/tests/expect14 +++ /dev/null @@ -1,4 +0,0 @@ -#line 1 "precedence" - - - diff --git a/tests/expect15 b/tests/expect15 deleted file mode 100644 --- a/tests/expect15 +++ /dev/null @@ -1,6 +0,0 @@ -#line 1 "indirect" - -#line 1 "./inclusion" -hello world, this is an inclusion - -#line 3 "indirect" diff --git a/tests/expect15a b/tests/expect15a deleted file mode 100644 --- a/tests/expect15a +++ /dev/null @@ -1,6 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect16 +++ /dev/null @@ -1,30 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect17 +++ /dev/null @@ -1,2 +0,0 @@ -#line 1 "pragma" - diff --git a/tests/expect18 b/tests/expect18 deleted file mode 100644 --- a/tests/expect18 +++ /dev/null @@ -1,1 +0,0 @@ - diff --git a/tests/expect19 b/tests/expect19 deleted file mode 100644 --- a/tests/expect19 +++ /dev/null @@ -1,6 +0,0 @@ -#line 1 "parens" - - - - -yes diff --git a/tests/expect2 b/tests/expect2 deleted file mode 100644 --- a/tests/expect2 +++ /dev/null @@ -1,36 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect20 +++ /dev/null @@ -1,17 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect21 +++ /dev/null @@ -1,6 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect22 +++ /dev/null @@ -1,13 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect23 +++ /dev/null @@ -1,2 +0,0 @@ -#line 1 "incomplete" -incomplete diff --git a/tests/expect24 b/tests/expect24 deleted file mode 100644 --- a/tests/expect24 +++ /dev/null @@ -1,15 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect25 +++ /dev/null @@ -1,15 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect26 +++ /dev/null @@ -1,17 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect27 +++ /dev/null @@ -1,17 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect28 +++ /dev/null @@ -1,4 +0,0 @@ -#line 1 "symbolvalue" - -the symbol is defined as 1 - diff --git a/tests/expect29 b/tests/expect29 deleted file mode 100644 --- a/tests/expect29 +++ /dev/null @@ -1,12 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect3 +++ /dev/null @@ -1,36 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect30 +++ /dev/null @@ -1,685 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect31 +++ /dev/null @@ -1,11 +0,0 @@ -#line 1 "elif" - - -import System.IO.Unsafe (unsafePerformIO) - - - - - - - diff --git a/tests/expect32 b/tests/expect32 deleted file mode 100644 --- a/tests/expect32 +++ /dev/null @@ -1,2 +0,0 @@ -#line 1 "pragma" -#pragma ident "@(#)time.h 1.39 99/08/10 SMI" diff --git a/tests/expect33 b/tests/expect33 deleted file mode 100644 --- a/tests/expect33 +++ /dev/null @@ -1,1 +0,0 @@ -#pragma ident "@(#)time.h 1.39 99/08/10 SMI" diff --git a/tests/expect34 b/tests/expect34 deleted file mode 100644 --- a/tests/expect34 +++ /dev/null @@ -1,11 +0,0 @@ -#line 1 "igloo" - - - -1 - - -foo - - - diff --git a/tests/expect35 b/tests/expect35 deleted file mode 100644 --- a/tests/expect35 +++ /dev/null @@ -1,12 +0,0 @@ -#line 1 "igloo2" - - - -baz -1 - - -foo - - - diff --git a/tests/expect36 b/tests/expect36 deleted file mode 100644 --- a/tests/expect36 +++ /dev/null @@ -1,12 +0,0 @@ -#line 1 "igloo3" - - - -quux -FOOFOO - - - - -bar - diff --git a/tests/expect36a b/tests/expect36a deleted file mode 100644 --- a/tests/expect36a +++ /dev/null @@ -1,12 +0,0 @@ -#line 1 "igloo3a" - - - -quux -FOOFOO - - - - -bar - diff --git a/tests/expect36b b/tests/expect36b deleted file mode 100644 --- a/tests/expect36b +++ /dev/null @@ -1,13 +0,0 @@ -#line 1 "igloo3b" - - - - -quux -11 - - -foo - - - diff --git a/tests/expect37 b/tests/expect37 deleted file mode 100644 --- a/tests/expect37 +++ /dev/null @@ -1,11 +0,0 @@ -#line 1 "igloo4" - - -wibble -11 - - -foo - - - diff --git a/tests/expect37a b/tests/expect37a deleted file mode 100644 --- a/tests/expect37a +++ /dev/null @@ -1,11 +0,0 @@ -#line 1 "igloo4a" - - -wibble -11 - - -foo - - - diff --git a/tests/expect38 b/tests/expect38 deleted file mode 100644 --- a/tests/expect38 +++ /dev/null @@ -1,8 +0,0 @@ -#line 1 "mauke" - - - - - - -main = print 7 -- should print 7 diff --git a/tests/expect39 b/tests/expect39 deleted file mode 100644 --- a/tests/expect39 +++ /dev/null @@ -1,5 +0,0 @@ -#line 1 "mauke2" - - - -4 diff --git a/tests/expect4 b/tests/expect4 deleted file mode 100644 --- a/tests/expect4 +++ /dev/null @@ -1,39 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect40 +++ /dev/null @@ -1,8 +0,0 @@ -#line 1 "fasta" - - - - - - -b7 = unsafeVisualize(foo) diff --git a/tests/expect40a b/tests/expect40a deleted file mode 100644 --- a/tests/expect40a +++ /dev/null @@ -1,7 +0,0 @@ -#line 1 "fasta2" - - - - - -b6 = unsafeVisualize(foo) diff --git a/tests/expect41 b/tests/expect41 deleted file mode 100644 --- a/tests/expect41 +++ /dev/null @@ -1,6 +0,0 @@ -#line 1 "hashjoin" - - - - -2 diff --git a/tests/expect42 b/tests/expect42 deleted file mode 100644 --- a/tests/expect42 +++ /dev/null @@ -1,5 +0,0 @@ -#line 1 "wrongline" - -2 -#line 20 "foo" -20 diff --git a/tests/expect43 b/tests/expect43 deleted file mode 100644 --- a/tests/expect43 +++ /dev/null @@ -1,6 +0,0 @@ -#line 1 "param" - - - - -11 -- gcc gives BARBAR, cpphs gives 11 diff --git a/tests/expect44 b/tests/expect44 deleted file mode 100644 --- a/tests/expect44 +++ /dev/null @@ -1,4 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect44a +++ /dev/null @@ -1,4 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect45 +++ /dev/null @@ -1,8 +0,0 @@ -#line 1 "nestcomment" -{- - -foo - - - --} diff --git a/tests/expect46 b/tests/expect46 deleted file mode 100644 --- a/tests/expect46 +++ /dev/null @@ -1,7 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect47 +++ /dev/null @@ -1,5 +0,0 @@ -#line 1 "endcode-a" - - - - diff --git a/tests/expect48 b/tests/expect48 deleted file mode 100644 --- a/tests/expect48 +++ /dev/null @@ -1,6 +0,0 @@ -#line 1 "endcode-b" - - - - - diff --git a/tests/expect49 b/tests/expect49 deleted file mode 100644 --- a/tests/expect49 +++ /dev/null @@ -1,5 +0,0 @@ -#line 1 "undef.hs" - -wibble 3 - -this is FOO diff --git a/tests/expect5 b/tests/expect5 deleted file mode 100644 --- a/tests/expect5 +++ /dev/null @@ -1,35 +0,0 @@ -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 deleted file mode 100644 --- a/tests/expect50 +++ /dev/null @@ -1,9 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/expect51 +++ /dev/null @@ -1,7 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect52 +++ /dev/null @@ -1,8 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect53 +++ /dev/null @@ -1,7 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect54 +++ /dev/null @@ -1,7 +0,0 @@ -#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/expect6 b/tests/expect6 deleted file mode 100644 --- a/tests/expect6 +++ /dev/null @@ -1,10 +0,0 @@ -#line 1 "cpp" - - - - - - -x ++ y = X' * 0 * y .(foo), Xprime - -// /* diff --git a/tests/expect7 b/tests/expect7 deleted file mode 100644 --- a/tests/expect7 +++ /dev/null @@ -1,297 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect8 +++ /dev/null @@ -1,37 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/expect9 +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/fasta +++ /dev/null @@ -1,7 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/fasta2 +++ /dev/null @@ -1,6 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/hashjoin +++ /dev/null @@ -1,5 +0,0 @@ -#define FOO 1 -#define BAR FOO##FOO -#define FOOFOO 2 - -BAR diff --git a/tests/igloo b/tests/igloo deleted file mode 100644 --- a/tests/igloo +++ /dev/null @@ -1,10 +0,0 @@ -#define FOO 1 -#define BAR FOO - -BAR - -#if BAR == 1 -foo -#else -bar -#endif diff --git a/tests/igloo2 b/tests/igloo2 deleted file mode 100644 --- a/tests/igloo2 +++ /dev/null @@ -1,11 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/igloo3 +++ /dev/null @@ -1,11 +0,0 @@ -#define FOO 1 -#define QUUX FOO ## FOO - -quux -QUUX - -#if QUUX == 11 -foo -#else -bar -#endif diff --git a/tests/igloo3a b/tests/igloo3a deleted file mode 100644 --- a/tests/igloo3a +++ /dev/null @@ -1,11 +0,0 @@ -#define FOO 1 -#define QUUX FOO##FOO - -quux -QUUX - -#if QUUX == 11 -foo -#else -bar -#endif diff --git a/tests/igloo3b b/tests/igloo3b deleted file mode 100644 --- a/tests/igloo3b +++ /dev/null @@ -1,12 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/igloo4 +++ /dev/null @@ -1,10 +0,0 @@ -#define WIBBLE 1 ## 1 - -wibble -WIBBLE - -#if WIBBLE == 11 -foo -#else -bar -#endif diff --git a/tests/igloo4a b/tests/igloo4a deleted file mode 100644 --- a/tests/igloo4a +++ /dev/null @@ -1,10 +0,0 @@ -#define WIBBLE 1##1 - -wibble -WIBBLE - -#if WIBBLE == 11 -foo -#else -bar -#endif diff --git a/tests/inclusion b/tests/inclusion deleted file mode 100644 --- a/tests/inclusion +++ /dev/null @@ -1,1 +0,0 @@ -hello world, this is an inclusion diff --git a/tests/incomplete b/tests/incomplete deleted file mode 100644 --- a/tests/incomplete +++ /dev/null @@ -1,1 +0,0 @@ -incomplete diff --git a/tests/indirect b/tests/indirect deleted file mode 100644 --- a/tests/indirect +++ /dev/null @@ -1,2 +0,0 @@ -#define F "inclusion" -#include F diff --git a/tests/indirect-a b/tests/indirect-a deleted file mode 100644 --- a/tests/indirect-a +++ /dev/null @@ -1,2 +0,0 @@ -#define F(f) in##f -#include F(clusion) diff --git a/tests/linepragma b/tests/linepragma deleted file mode 100644 --- a/tests/linepragma +++ /dev/null @@ -1,5 +0,0 @@ -#include "inclusion" -#line 2 "linepragma" - -#line 3 "linepragma" - diff --git a/tests/mauke b/tests/mauke deleted file mode 100644 --- a/tests/mauke +++ /dev/null @@ -1,7 +0,0 @@ -#define X /\ -* comment */ main - -#define Y _\ -_LINE__ - -X = print Y -- should print 7 diff --git a/tests/mauke2 b/tests/mauke2 deleted file mode 100644 --- a/tests/mauke2 +++ /dev/null @@ -1,4 +0,0 @@ -#define foo _\ -_LINE__ - -foo diff --git a/tests/multiline b/tests/multiline deleted file mode 100644 --- a/tests/multiline +++ /dev/null @@ -1,10 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/nastyhack +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/nestcomment +++ /dev/null @@ -1,7 +0,0 @@ -{- -#if 1 -foo -#else -bar -#endif --} diff --git a/tests/nomacro b/tests/nomacro deleted file mode 100644 --- a/tests/nomacro +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 --- a/tests/numbers +++ /dev/null @@ -1,29 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/param +++ /dev/null @@ -1,5 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/parens +++ /dev/null @@ -1,5 +0,0 @@ -#if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 600 ) \ - || ( defined(__NHC__) && __NHC__ >= 117 ) -#define FINALIZERPTR yes -#endif -FINALIZERPTR diff --git a/tests/pragma b/tests/pragma deleted file mode 100644 --- a/tests/pragma +++ /dev/null @@ -1,1 +0,0 @@ -#pragma ident "@(#)time.h 1.39 99/08/10 SMI" /* SVr4.0 1.18 */ diff --git a/tests/precedence b/tests/precedence deleted file mode 100644 --- a/tests/precedence +++ /dev/null @@ -1,3 +0,0 @@ -#if !0 && 0 -boolean operator precedence is wrong -#endif diff --git a/tests/preinclude b/tests/preinclude deleted file mode 100644 --- a/tests/preinclude +++ /dev/null @@ -1,1 +0,0 @@ -something arbitrary diff --git a/tests/recursive b/tests/recursive deleted file mode 100644 --- a/tests/recursive +++ /dev/null @@ -1,4 +0,0 @@ -#define C D D -#define B C C -#define A B B -A diff --git a/tests/ross b/tests/ross deleted file mode 100644 --- a/tests/ross +++ /dev/null @@ -1,19 +0,0 @@ -/* 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 deleted file mode 100644 --- a/tests/runtests +++ /dev/null @@ -1,75 +0,0 @@ -#!/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