c2hs-0.28.1/0000755000000000000000000000000012677513065010643 5ustar0000000000000000c2hs-0.28.1/Setup.hs0000644000000000000000000000011212677513064012270 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain c2hs-0.28.1/INSTALL0000644000000000000000000000365612677513065011706 0ustar0000000000000000 C->Haskell Installation Instructions -*-text-*- ------------------------------------ Prerequisites ~~~~~~~~~~~~~ You need GHC, the Haskell compiler. Currently, this has to be GHC 6.8 upwards, which you can get from http://haskell.org/ghc Simple install procedure ~~~~~~~~~~~~~~~~~~~~~~~~ % tar -xzf .tar.gz # unpack the sources % cd # change to the toplevel directory % runghc Setup.hs configure # configure the build system % runghc Setup.hs build # build everything [ Become root if necessary ] % runghc Setup.hs install # install c2hs The Nitty-Gritty ~~~~~~~~~~~~~~~~ The './Setup.hs configure' command understands the following options: * --prefix=PREFIX install architecture-independent files in PREFIX [ Defaults to /usr/local ] * --with-compiler=HC use Haskell compiler HC This needs to be the full path to the compiler executable. * --with-happy=HAPPY ditto for parser generator Happy * --with-alex=ALEX ditto for lexer generator Alex * --user allow the use of packages from user database * --global only allow packages from the global database Documentation ~~~~~~~~~~~~~ Documentation can be formatted with $ make -C doc Currently there is no support for installing the documentation. That step has to be done manually. The generated html pages for the user guide live in: docs/user_guide/* The man page is: docs/man1/c2hs.1 Supported Systems and Porting ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Tested with GHC version 6.8.2 and 6.10.1. In principle it should work with any 6.x version since 6.4.2 however the current releases of the language-c package only work with ghc-6.8 and later. The actual c2hs sources might also compile with nhc98, but Cabal doesn't fully support nhc98 yet. c2hs-0.28.1/C2HS.hs0000644000000000000000000002243112677513064011677 0ustar0000000000000000-- C->Haskell Compiler: Marshalling library -- -- Copyright (c) [1999...2005] Manuel M T Chakravarty -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met: -- -- 1. Redistributions of source code must retain the above copyright notice, -- this list of conditions and the following disclaimer. -- 2. Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- 3. The name of the author may not be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR -- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES -- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN -- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- --- Description --------------------------------------------------------------- -- -- Language: Haskell 98 -- -- This module provides the marshaling routines for Haskell files produced by -- C->Haskell for binding to C library interfaces. It exports all of the -- low-level FFI (language-independent plus the C-specific parts) together -- with the C->HS-specific higher-level marshalling routines. -- module C2HS {-# DEPRECATED "The C2HS module should no longer be used." #-} ( -- * Re-export the language-independent component of the FFI module Foreign, -- * Re-export the C language component of the FFI module Foreign.C, -- * Composite marshalling functions withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv, peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum, -- * Conditional results using 'Maybe' nothingIf, nothingIfNull, -- * Bit masks combineBitMasks, containsBitMask, extractBitMasks, -- * Conversion between C and Haskell types cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum ) where import Foreign import Foreign.C import Monad (liftM) -- Composite marshalling functions -- ------------------------------- -- Strings with explicit length -- withCStringLenIntConv :: Num n => String -> ((CString, n) -> IO a) -> IO a withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, fromIntegral n) peekCStringLenIntConv :: Integral n => (CString, n) -> IO String peekCStringLenIntConv (s, n) = peekCStringLen (s, fromIntegral n) -- Marshalling of numerals -- withIntConv :: (Storable b, Integral a, Integral b) => a -> (Ptr b -> IO c) -> IO c withIntConv = with . fromIntegral withFloatConv :: (Storable b, RealFloat a, RealFloat b) => a -> (Ptr b -> IO c) -> IO c withFloatConv = with . realToFrac peekIntConv :: (Storable a, Integral a, Integral b) => Ptr a -> IO b peekIntConv = liftM fromIntegral . peek peekFloatConv :: (Storable a, RealFloat a, RealFloat b) => Ptr a -> IO b peekFloatConv = liftM realToFrac . peek -- Everything else below is deprecated. -- These functions are not used by code generated by c2hs. {-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED peekBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED withEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED peekEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED nothingIf "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED nothingIfNull "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED combineBitMasks "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED containsBitMask "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED extractBitMasks "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cIntConv "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cFloatConv "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cFromBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cToBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cToEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cFromEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} -- Passing Booleans by reference -- withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b withBool = with . fromBool peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool peekBool = liftM toBool . peek -- Passing enums by reference -- withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c withEnum = with . cFromEnum peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a peekEnum = liftM cToEnum . peek -- Storing of 'Maybe' values -- ------------------------- --TODO: kill off this orphan instance! instance Storable a => Storable (Maybe a) where sizeOf _ = sizeOf (undefined :: Ptr ()) alignment _ = alignment (undefined :: Ptr ()) peek p = do ptr <- peek (castPtr p) if ptr == nullPtr then return Nothing else liftM Just $ peek ptr poke p v = do ptr <- case v of Nothing -> return nullPtr Just v' -> new v' poke (castPtr p) ptr -- Conditional results using 'Maybe' -- --------------------------------- -- Wrap the result into a 'Maybe' type. -- -- * the predicate determines when the result is considered to be non-existing, -- ie, it is represented by `Nothing' -- -- * the second argument allows to map a result wrapped into `Just' to some -- other domain -- nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b nothingIf p f x = if p x then Nothing else Just $ f x -- |Instance for special casing null pointers. -- nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b nothingIfNull = nothingIf (== nullPtr) -- Support for bit masks -- --------------------- -- Given a list of enumeration values that represent bit masks, combine these -- masks using bitwise disjunction. -- combineBitMasks :: (Enum a, Bits b) => [a] -> b combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum) -- Tests whether the given bit mask is contained in the given bit pattern -- (i.e., all bits set in the mask are also set in the pattern). -- containsBitMask :: (Bits a, Enum b) => a -> b -> Bool bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm in bm' .&. bits == bm' -- |Given a bit pattern, yield all bit masks that it contains. -- -- * This does *not* attempt to compute a minimal set of bit masks that when -- combined yield the bit pattern, instead all contained bit masks are -- produced. -- extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b] extractBitMasks bits = [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm] -- Conversion routines -- ------------------- -- |Integral conversion -- cIntConv :: (Integral a, Integral b) => a -> b cIntConv = fromIntegral -- |Floating conversion -- cFloatConv :: (RealFloat a, RealFloat b) => a -> b cFloatConv = realToFrac -- |Obtain C value from Haskell 'Bool'. -- cFromBool :: Num a => Bool -> a cFromBool = fromBool -- |Obtain Haskell 'Bool' from C value. -- cToBool :: Num a => a -> Bool cToBool = toBool -- |Convert a C enumeration to Haskell. -- cToEnum :: (Integral i, Enum e) => i -> e cToEnum = toEnum . fromIntegral -- |Convert a Haskell enumeration to C. -- cFromEnum :: (Enum e, Integral i) => e -> i cFromEnum = fromIntegral . fromEnum c2hs-0.28.1/README0000644000000000000000000000414112677513065011523 0ustar0000000000000000`c2hs` is a interfacing tool that eases Haskell access to C libraries. The tool gets information about the C data type definitions and function signatures by analysing the C header files of the library. It uses this information to compute the missing details in the template of a Haskell module — called the binding file — that implements a Haskell binding to the C library. Hooks embedded in the binding file signal where, which, and how C objects are accessed from Haskell. The Haskell code in the binding file determines Haskell types signatures and marshaling details. Further information is on the [wiki](https://github.com/haskell/c2hs/wiki/Home). Also see the [user guide](https://github.com/haskell/c2hs/wiki/User-Guide) (also available in the `doc` directory of the repository). ## Installing See the file `INSTALL`. ## Copyleft This system is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This system is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this system; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. > **NOTE HOWEVER**, all code included into generated bindings is under > a BSD-style license that does not place any restrictions on the > license of the inteface produced with `c2hs` (ie, closed proprietary > licenses are possible, too). In other words, I do not care what you > use `c2hs` for or to whom you are giving `c2hs` or any interfaces > generated with `c2hs`, only if you modify or improve `c2hs` itself, > you have to contribute your changes back to the community. > Nevertheless, I will of course be particularly delighted if you > choose to make your work freely available. ## Credits See the file `AUTHORS`. c2hs-0.28.1/ChangeLog.old0000644000000000000000000010661012677513065013176 0ustar0000000000000000CHANGES ABOVE THIS POINT ARE FOR VERSIONS AFTER THE MOVE OF THE REPOSITORY TO GITHUB AND ARE DESCRIBED IN THE MAIN ChangeLog FILE. 2005-12-12 Manuel M T Chakravarty * c2hs/gen/GenBind.hs: When translating the target type of a pointer hook into a Haskell type, don't take the pointer hook alias map into account. * c2hs.cabal: version 0.14.5 * c2hs/gen/GenBind.hs: Suppress code generation if requested * c2hs/chs/CHS.hs: Added `nocode' to pointer hooks * c2hs/chs/CHSLexer.hs: Added `nocode' 2005-12-05 Jelmer Vernooij * c2hs/c/CTrav.hs: only match in `checkForOneCUName' if there are no indirections 2005-12-05 Jelmer Vernooij * c2hs/gen/GenBind.hs: support mapping struct and union names to haskell types * c2hs/c/CTrav.hs: added `checkForOneCUName' Fri Nov 25 10:54:56 EST 2005 Jelmer Vernooij * add prettify functions for structs, enums and unions 2005-08-10 Manuel M T Chakravarty * c2hs/gen/GBMonad.hs: apply `upcaseFirstLetter' and `downcaseFirstLetter' if specified * c2hs/chs/CHS.hs: added `upcaseFirstLetter' and `downcaseFirstLetter' 2005-08-09 Manuel M T Chakravarty * c2hs/gen/CInfo.hs: exports `getPlatform' 2005-08-08 Manuel M T Chakravarty * c2hs/toplevel/Main.hs: Added --platform switch for cross compilation * c2hs.cabal: 0.14.3 2005-08-08 Manuel M T Chakravarty * c2hs.cabal: 0.14.2 * Support asm construct (Duncon Coutts) * Hierachical modules (Duncon Coutts) 2005-07-13 Duncan Coutts * Remove old C lexer & parser and replace them with new ones using alex and happy 2005-07-14 Manuel M. T. Chakravarty * C2HS library as a single file added to the generated binding code 2005-07-13 Manuel M. T. Chakravarty * Cabal-ised the build system * c2hs.cabal (Version): 0.14.0 2005-05-18 Manuel M. T. Chakravarty * toplevel/Version.hs (versnum): 0.13.6 2005-03-14 Manuel M. T. Chakravarty * c/CParser.hs: Allow lists of GNU C attributes (patch contributed by Duncan Coutts ) * chs/CHSLexer.hs (instr): Allow 8-bit characters (Volker Wysk requested support for umlauts in strings) * toplevel/Version.hs (versnum): 0.13.5 2004-10-18 Manuel M. T. Chakravarty * chs/CHS.hs (showCHSModule): Don't add extra '\n' after directive during pretty printing * chs/CHSLexer.hs (cpp): forgot to adapt lexing of #c to the new situation where directives don't consume the following '\n' 2004-10-17 Manuel M. T. Chakravarty * c2hs.conf.in: Modernised package deps and options * gen/GenBind.hs (expandHook): We use the shadow identifier for generating the Haskell name. * chs/CHSLexer.hs (identOrKW): Identifier may be put in single quotes * toplevel/Version.hs (versnum): 0.13.4 2004-10-13 Manuel M. T. Chakravarty * chs/CHSLexer.hs (cpp): fixed lexing of directives such that they don't consume the '\n' that ends them * toplevel/Version.hs (versnum): 0.13.3 * toplevel/Main.hs (Flag): Added `--output-dir' option and removed `--old-ffi'. * gen/GenBind.hs (noDftMarshErr): better error message when default marshallers are not available (isIntegralCPrimType): handle C chars as integral types for marshalling * toplevel/Main.hs (process): if there is no explicit output file specified, the header file is put in the same directory as the binding file; otherwise, it goes in the directory where the output file is put 2004-10-09 Manuel M. T. Chakravarty * toplevel/Main.hs (process): store header file name in switch board * state/Switches.hs: Store the name of the generated header file (needed to generate complete foreign import declarations) * gen/GenBind.hs (foreignImport): Add name of header file to extent strings of generated foreign import declarations * c/CAttrs.hs (applyPrefix): never create empty shadow identifiers 2004-10-08 Manuel M. T. Chakravarty * chs/CHS.hs (dumpCHS): Header doesn't contain the "-- **" sequence anymore that Haddock dislikes. * c/CParser.hs (parseCStructUnion): We allow structs and unions with no declarations, as GNU C does * toplevel/Version.hs (versnum): 0.13.2 2004-08-21 Manuel M. T. Chakravarty * tests/Makefile: use configured $HC (courtesy Don Stewart ) 2004-06-11 Manuel M. T. Chakravarty * gen/GenBind.hs (pointerDef): Adapted to the standard interface for foreign pointers 2004-06-10 Manuel M. T. Chakravarty * c/CParser.hs: Added parsing of function bodies * c/CLexer.hs: Added tokens occuring in the statement syntax 2004-06-09 Manuel M. T. Chakravarty * c/CAST.hs: Added function bodies * c/CPretty.hs: Added `auto' and `register' storage specifiers * c/CLexer.hs: Added tokens for `auto' and `register' keywords * toplevel/Version.hs (versnum): 0.13.1 2004-05-15 Manuel M. T. Chakravarty * c/CParser.hs (parseCHeader): Duncan Coutts identified a space (and time) leak in the old typedef-name morphing setup; this has been rewritten now 2004-05-14 Manuel M. T. Chakravarty * toplevel/Version.hs (versnum): 0.13.0 "Pressing Forward" 2003-10-20 Manuel M T Chakravarty * gen/GenBind.hs (foreignImport): brought generated foreign import declarations in line with FFI Addendum * toplevel/C2HSConfig.hs.in: removed legacy FFI support * configure.in: removed legacy FFI support * mk/config.mk.in: removed legacy FFI support * lib/Makefile: Removed all deprecated code and support code for old versions of the FFI * toplevel/Version.hs (versnum): 0.12.1 2003-10-19 Manuel M T Chakravarty * c2hs.spec.in: Contributions by Jens Petersen : specify ghc version to build with; don't redundantly provide c2hs; separate library out into separate ghc version specific subpackage; put docs into separate subpackage; disable empty debuginfo subpackage generation - remove buildroot before installing; remove installed doc files, since they're explicitly listed * c/CLexer.hs (linedir): allow an arbitrary number of ints after the filename in a #line directive; problem was first reported by Sean Seefried * gen/GBMonad.hs (delayCode): Generate appropriate line numbers for delayed code; problem reported by Sean Seefried * chs/CHS.hs (showCHSModule): Never generate negative line numbers * toplevel/Version.hs (versnum): 0.12.0 "Springtime" 2003-06-10 Manuel M T Chakravarty * toplevel/Version.hs (versnum): 0.11.5 2003-05-30 Jens Petersen * configure.in: Search for compiler named HC too. 2003-05-30 Jens Petersen * c2hs.spec.in (Version): Set directly. (Release): Ditto. (%prep): Quieten setup. (%build): Use configure macro. (%install): Use makeinstall macro. (%post): Use _bindir. (%files): Make root own files. Use _bindir, _libdir and _mandir. 2003-05-22 Manuel M T Chakravarty * gen/GenBind.hs (Ord): Need instance for `<=' for indirectly defined `compare'; bug reported by Ian Lynagh * toplevel/Version.hs (versnum): 0.11.4 2003-04-16 Manuel M T Chakravarty * gen/GenHeader.hs (ghFrag): sentries for conditionals must not be turned into internal identifiers, as this spoils later equality tests with identifiers read from the pre-processed header file; bug reported by Axel Simon * toplevel/Version.hs (versnum): 0.11.3 2003-03-04 Manuel M T Chakravarty * gen/GenBind.hs (evalConstCExpr): supporting enumerators in constant expressions * toplevel/Version.hs (versnum): 0.11.2 2003-02-13 Manuel M T Chakravarty * chs/CHS.hs: removed the "header" tag (we now support the CPP #include directive) * Configuration-related patch by Ian Lynagh that removes issues with GHC 5.05 2003-02-12 Manuel M T Chakravarty * gen/GenBind.hs (expandFrag): Expanding conditionals * chs/CHSLexer.hs (haskell): the lexeme for one-line comments shouldn't include the terminating newline, as this removes the newline for following lexemes (eg, CPP directives) and is not really necessary due to the Principle of the Longest Match * gen/GenHeader.hs: debugging 2003-02-05 Manuel M T Chakravarty * gen/GenHeader.hs: New module extracting CPP directives and inline-C from a .chs file * toplevel/Main.hs (process): Integrated generation of custom C header * c/CParser.hs (parseCHeader): Header file may be empty 2003-02-01 Manuel M T Chakravarty * chs/CHS.hs (showCHSModule): emitting GHC line pragmas (CHSFrag): added representations for cpp directives and inline-C code, and adapted the functions processind the representations * chs/CHSLexer.hs: Added support for pre-processor directives and inline-C code 2003-01-31 Manuel M T Chakravarty * toplevel/Main.hs (process): Now reading the binding module before the C header 2003-01-30 Manuel M T Chakravarty * c/CParser.hs: Allow more GNU attributes contributed by Axel Simon 2002-09-17 Manuel M T Chakravarty * gen/GBMonad.hs (HsObject): working around a problem with deriving Read in GHC 5.04.1 2002-09-16 Manuel M T Chakravarty * Makefile (ghci): target to load all of c2hs into GHCi 2002-09-13 Manuel M T Chakravarty * toplevel/c2hs_config.c: removed the `signed' modifier on suggestion of Seth Kurtzberg as it apparently confuses the Solaris 8 C compiler 2002-09-07 Manuel M T Chakravarty * c2hs.spec.in: add post install and uninstall scripts to register and deregister the package with GHC * configure.in: fixed REQUIRES_HASKELL for ghc * toplevel/Version.hs (versnum): 0.10.17 2002-09-06 Manuel M T Chakravarty * toplevel/C2HSConfig.hs.in (cppopts): Added "-x c" on suggestion by Axel Simon * Makefile (install): using --update-package instead of --add-package * configure.in: Fixed some nhc98 related issues * toplevel/Version.hs (versnum): 0.10.16 2002-07-12 Manuel M T Chakravarty * c2hs-config.in: added the system for which the package was compiled to the output of the --version option * c/CParser.hs (parseCStructUnion): Allow __extension__ in structure declarations and added `inline'. * c/CAST.hs: Added `inline' * c/CLexer.hs: Added support for `inline' keyword 2002-07-06 Manuel M T Chakravarty * toplevel/Version.hs (versnum): 0.10.15 2002-05-16 Manuel M T Chakravarty * lib/C2HSMarsh.hs: added support for bit masks * toplevel/Version.hs (versnum): 0.10.14 2002-05-10 Manuel M T Chakravarty * gen/GenBind.hs (setGet): corrected bug in bit fiddling 2002-05-02 Manuel M T Chakravarty * toplevel/Version.hs (versnum): 0.10.13 2002-04-16 Manuel M T Chakravarty * toplevel/Version.hs (versnum): 0.10.12 2002-03-20 Manuel M T Chakravarty * chs/CHSLexer.hs (haskell): Debug the handling of character literals * toplevel/Version.hs (versnum): 0.10.11 2002-03-12 Manuel M T Chakravarty * c2hs.spec.in: we now require the Haskell compiler to be the one for which the package was build * Makefile: adapted to revised build system * toplevel/Version.hs (versnum): 0.10.10 2002-03-06 Manuel M T Chakravarty * chs/CHSLexer.hs (haskell): Escape characters in Haskell strings haven't been handled correctly in all cases as reported by Volker Wysk ; we also have to handle character constants specially, because '"' is a legal Haskell character constant 2002-03-03 Manuel M T Chakravarty * configure.in: Package handling fix by Jens Petersen * toplevel/Version.hs (versnum): 0.10.9 2002-02-25 Manuel M T Chakravarty * gen/GenBind.hs: debugging 2002-02-24 Manuel M T Chakravarty * chs/CHS.hs (parseOptAs): `^' as synonym for previous identifier, but with underscores rewritten to caps * chs/CHSLexer.hs: added `CHSTokHat' 2002-02-23 Manuel M T Chakravarty * lib/C2HSMarsh.hs: added some more convenience functions 2002-02-21 Manuel M T Chakravarty * gen/GenBind.hs: Completed processing of function hooks 2002-02-18 Manuel M T Chakravarty * chs/CHSLexer.hs: Added `CHSTokMinus' * chs/CHS.hs: Revised the syntax of fun hooks * chs/CHSLexer.hs: Added `CHSTokAmp' (representing `&') * gen/GenBind.hs (foreignImport): factorised the code for call hook generation to make those portions that are also useful for fun hooks reusable (expandHook): implemented fun hooks * gen/GBMonad.hs: extracted monad-related code from `GenBind.hs' * gen/GenBind.hs: split off the monad definition and operations into `GBMonad.hs' 2002-02-17 Manuel M T Chakravarty * chs/CHSLexer.hs: introduced `hsverb' tokens * chs/CHS.hs: `pure' instead of `fun' to indicate calls to pure C functions (`fun' retained for backwards compatibility) * chs/CHSLexer.hs: introduced the keyword `pure' 2002-02-13 Manuel M T Chakravarty * Makefile: adapted to using GHC package management 2002-02-11 Manuel M T Chakravarty * lib/Makefile (depend): increase portability 2002-02-06 Manuel M T Chakravarty * configure.in: probe for `grep' 2002-02-05 Manuel M T Chakravarty * aclocal.m4 (CTK_GHC_VERSION): no \+ in sed on Solaris * toplevel/Version.hs (versnum): 0.10.7 2002-01-15 Manuel M T Chakravarty * gen/GenBind.hs (mergeMaps): now, the read map overrides any entires for shared keys in the map that is already in the monad; this is so that, if multiple import hooks add entries for shared keys, the textually latest prevails; any local entries are entered after all import hooks anyway * toplevel/Version.hs (versnum): 0.10.6 2002-01-10 Jens Petersen * c/CParser.hs (parseC): corrected "contained contained" in proceeding comments. * ../doc/c2hs/c2hs.sgml (Set Hooks): correct #get to #set * ../doc/c2hs/Makefile (TOP): "../../.." to "../.." 2002-01-10 Manuel M T Chakravarty * toplevel/Version.hs (versnum): 0.10.5 2001-12-20 Manuel M T Chakravarty * gen/GenBind.hs (expandHook): fixed a sizeof bug pointed out by Jens Petersen * toplevel/Version.hs (versnum): 0.10.4 2001-12-11 Manuel M. T. Chakravarty * toplevel/c2hs_config.c: now conforms to ISO C * toplevel/Version.hs (versnum): 0.10.3 2001-11-14 Manuel M. T. Chakravarty * gen/GenBind.hs (setGet): debugged 2001-11-13 Manuel M. T. Chakravarty * gen/GenBind.hs (setGet): reading and writing of bitfields (alignOffset): now handles alignment of bit fields (extractCompType): debugging 2001-11-12 Manuel M. T. Chakravarty * gen/GenBind.hs (specType): added bitfield handling (BitSize): introduced size specs for partially filled storage units * toplevel/C2HSConfig.hs.in (bitfieldDirection): added (bitfieldPadding): added (bitfieldIntSigned): added * toplevel/c2hs_config.c: runtime configuration query functions * gen/CInfo.hs (CPrimType): extended by variants for bitfields (size): now a function instead of an array (alignment): now a function instead of an array * gen/GenBind.hs (showExtType): simplified `showExtType' again; the brace level idea doen't work for `DefinedET' anyway; so, let's simplify the code 2001-11-08 Manuel M. T. Chakravarty * toplevel/Version.hs (versnum): 0.10.2 2001-10-17 Manuel M. T. Chakravarty * c/CParser.hs (parseCDecl): corrected the precise locatio where an __attribute__ annotation may occur. 2001-10-16 Manuel M. T. Chakravarty * gen/GenBind.hs (evalConstCExpr): added `alignof' * c/CNames.hs (naCExpr): added `alignof' * c/CAST.hs: added `alignof' * c/CParser.hs (parseCUnaryExpr): added `alignof' expressions * c/CLexer.hs: added keyword `alignof' * toplevel/Version.hs (versnum): 0.10.1 2001-10-08 Manuel M. T. Chakravarty * chs/CHS.hs: debugged 2001-10-07 Manuel M. T. Chakravarty * gen/GenBind.hs: handling class hooks * Makefile: improved cleaning targets * chs/CHS.hs (parseClass): added class hooks * chs/CHSLexer.hs: added tokens `class' and `=>' * gen/GenBind.hs (isFunExtType): IO types are function types * toplevel/Version.hs (versnum): 0.10.0 "Altocumulus Stratiformis Perlucidus Undulatus" 2001-08-26 Manuel M. T. Chakravarty * gen/GenBind.hs (foreignImport): `libName' removed until the new FFI conventions for libs are implemented in GHC * c/CTrav.hs (dropPtrDeclr): fixed pointer to pointer case * c/CPretty.hs: implemented pretty-printing for part of the C AST 2001-08-25 Manuel M. T. Chakravarty * gen/GenBind.hs (setGet): missed ";" in code generation * c/CParser.hs (cidOrTN): after struct or union tag we may have a normal idenifier or a type name; spotted by Simon Bowden and Michael Zinn 2001-08-23 Manuel M. T. Chakravarty * gen/GenBind.hs (expandHook): adding parenthesis around the generated type; problem pointed out by Matthew Tarnawsky * toplevel/Version.hs (versnum): 0.9.9 2001-06-20 Manuel M. T. Chakravarty * gen/GenBind.hs (expandHook): added sizeof hook (sizeAlignOf): corrected size computation for structures to conform to [K&R A7.4.8] (sizeAlignOf): improved handling of `DefinedET', which led to an endless loop * chs/CHS.hs: added sizeof hook * chs/CHSLexer.hs: added keyword `sizeof' * gen/GenBind.hs (evalConstCExpr): sizeof now supported * lib/C2HSDeprecated.hs: includes Storable methods of the new Storable in addition to those of the old * toplevel/Version.hs (versnum): 0.9.8 2001-06-18 Manuel M. T. Chakravarty * c/CParser.hs (parseCExpr): `CComma' requires at least two expressions; patch by Armin Sander * toplevel/Version.hs (versnum): 0.9.7 2001-06-16 Manuel M. T. Chakravarty * chs/CHS.hs: local prefix for enum hooks; courtesy of Armin Sander * gen/GenBind.hs (expandHook): correctly uses a `FunPtr' for pointers to functional types (setGet): no deep check required as set/get do not perform a deep copy; bug reported by Armin Sander (expandHook): local prefix for enum hooks; courtesy of Armin Sander * toplevel/Version.hs (versnum): 0.9.6 2001-05-20 Manuel M. T. Chakravarty * gen/GenBind.hs (enumInst): Fix for avoiding warnings when generated bindings are compiled with -Wall contributed by Armin Sander 2001-05-14 Axel Simon * toplevel/Main.hs, state/Switchboard.hs, chs/CHS.hs: add -i flag which takes a colon separated list of search paths for .chi files. * fixed some bugs in parsing import hooks 2001-05-13 Manuel M. T. Chakravarty * toplevel/Version.hs (versnum): 0.9.5 * gen/GenBind.hs (expandHook): revised to properly handle struct, union, and enum tags as C identifiers in pointer hooks; also handles non-abstract pointers with explicit "*" now better; the problems were pointed out by Marcin Kowalczyk * c/CTrav.hs (findTypeObjMaybe): added (lookupDeclOrTag): added (enumName): added (tagName): added * c/CLexer.hs (charconst): Patch from Armin Sander regarding character constants 2001-05-11 Manuel M. T. Chakravarty * c2hs-config.in: Patch from Jens-Ulrik Petersen fixes $sys variable setting * toplevel/Version.hs (versnum): 0.9.4 2001-05-06 Manuel M. T. Chakravarty * gen/GenBind.hs (extractCompType): rewrote that thing again * c/CTrav.hs (checkForOneAliasName): added 2001-05-05 Manuel M. T. Chakravarty * c/CTrav.hs (chaseDecl): simplified * gen/GenBind.hs (expandHook): debugged the pointer hook * c/CTrav.hs (findAndChaseDecl): correction * toplevel/Version.hs (versnum): 0.9.3 2001-05-03 Manuel M. T. Chakravarty * gen/GenBind.hs (expandHook): added import hook (mergePtrMap): added (dumpPtrMap): added * chs/CHS.hs (loadCHI): added (dumpCHI): added (CHSHook): added `import' hook * chs/CHSLexer.hs: Added the keywords `import' and `qualified' * toplevel/Version.hs (versnum): 0.9.2 2001-05-02 Manuel M. T. Chakravarty * gen/GenBind.hs (extractCompType): as pointed out by Axel Simon, we can't return `ForeignPtr's from imported foreign functions (setGet): the `accessType' story is largely redundant with the new formulation of `extractCompType', but we still need to check the marshaled type (setGet): `DefinedET' now takes a declaration rather than an identifier as its first argument; this is necessary for anonymous declerators (extractCompType): functions are now extracted correctly * c/CTrav.hs (isPtrDecl): works on identifiers now and chases declarations (dropPtrDeclr): added * gen/GenBind.hs (extractCompType): completely rewrote this function to properly handle pointer and function types and honour aliases introduced by pointer hooks 2001-05-01 Manuel M. T. Chakravarty * c/CTrav.hs (isPtrDeclr): functions types without an explizit pointer constructor are no longer regarded as pointers * gen/CInfo.hs: renamed `CAddrPT' and `CFunAddrPT' to `CPtrPT' and `CFunPtrPT', respectively * gen/GenBind.hs (extractCompType): revised for pointer hooks 2001-04-30 Manuel M. T. Chakravarty * gen/GenBind.hs (setGet): uses FunPtr for functions (extractPtrType): added 2001-04-28 Manuel M. T. Chakravarty * gen/GenBind.hs (expandHook): rewrote `alias'hook into `pointer' hook * chs/CHS.hs: rewrote the `alias' hook into the `pointer' hook * chs/CHSLexer.hs: removed `alias' token and added `pointer' and `newtype' * toplevel/Version.hs (versnum): 0.9.1 * gen/GenBind.hs: clean up 2001-04-21 Manuel M. T. Chakravarty * chs/CHSLexer.hs: Added `(' and `)' * chs/CHS.hs: Added code implementing the `alias' hook and the `deriving' option for the `enum' hook. This code was contributed by Axel Simon (also related code in CHSLexer.hs); but added parenthesis to `deriving' * c/CTrav.hs: Added code implementing the `alias' hook, which was contributed by Axel Simon * gen/GenBind.hs: The following patch was contributed by Axel Simon : `extractCompType' generates addresses of type `Ptr ' instead of `Addr' (if `--old-ffi=no', which is the default) * configure.in: Adapted for ghc 5.00 * toplevel/Version.hs (versnum): 0.9.0 "Blue Ginger" 2001-02-22 Manuel M. T. Chakravarty * lib/C2HSDeprecated.hs: Corrected String marshalling for 4.11; suggested by Marcin 'Qrczak' Kowalczyk 2001-02-19 Manuel M. T. Chakravarty * c2hs-config.in: generated code needs -package lang for compilation and linking * toplevel/Version.hs (versnum): 0.8.3 "Gentle Moon" 2001-02-13 Manuel M. T. Chakravarty * lib/NewStablePtr.hs.in: Adaptation layer for StablePtr for the legacy FFI interface 2001-02-12 Manuel M. T. Chakravarty * lib/C2HS.hs: Forgot to export `FunPtr' and associated functions * lib/C2HSDeprecated.hs: Some exports had been missing * c/CTrav.hs: Handle `CAttrs.BuiltinCO' * c/CNames.hs (nameAnalysis): add builtin type definitions * c/CBuiltin.hs: predefine `__builtin_va_list' as a typedef'd name * c/CParser.hs (parseCHeader): use `CBuiltin' * toplevel/Version.hs (versnum): 0.8.2 2001-02-11 Manuel M. T. Chakravarty * releasing version 0.8.1 "Gentle Moon" * ../doc/c2hs/: Documentation updated & added the Haskell FFI Marshalling Library specification 2001-02-09 Manuel M. T. Chakravarty * lib/Makefile: Debugging for 4.11 2001-02-05 Manuel M. T. Chakravarty * toplevel/C2HSConfig.hs.in: Moved the primitive characteristics table to `CInfo' (it is based now on getting the information from the FFI of the Haskell compiler compiling c2hs) * gen/CInfo.hs: Added 2001-02-04 Manuel M. T. Chakravarty * lib/C2HSMarsh.hs: Moved almost everything to `C2HSDeprecated' * lib/C2HSBase.hs: Much simplified conversion routines and the old `Storable' definition died 2001-02-03 Manuel M. T. Chakravarty * configure.in: Removed all the stuff that had to be there for the late `lib/C2HSConfig.hs.in' * lib/C2HSConfig.hs.in: RIP - All the relevant information is now available from the Standard FFI * C2HSDeprecated.hs: Added old C type names * lib/C2HS.hs: Added support for the New FFI Libraries (so that they are also useable with Haskell systems only supporting the old libraries) 2000-08-22 Manuel M. T. Chakravarty * lib/C2HSDeprecated.hs: contains a compatibility interface to the "Afterthought" series 2000-08-18 Manuel M. T. Chakravarty * toplevel/Version.hs (versnum): 0.8.0 "Gentle Moon" ** WARNING: Only the FFI of GHC 4.08 upwards is supported ** ** WARNING: Code breaking changes to the marshalling library ** ** Compatibility library provided ** 2000-08-12 Manuel M. T. Chakravarty * lib/C2HSBase.hs (IntConv): instances for Int8, Word8, and Char * toplevel/Version.hs (versnum): 0.7.10 2000-08-06 Manuel M. T. Chakravarty * chs/CHS.hs (showCHSTrans): corrected syntax (parseTrans): comma now correctly required after underscoreToCase * gen/GenBind.hs (transTabToTransFun): properly handles prefixes in the translation function (enumDef): prefixes are now generally removed from enumerators without the constraint that the prefix has to be removed from all enumerators or none 2000-08-04 Manuel M. T. Chakravarty * gen/GenBind.hs (usualArithConv): forgot a case; patch contributed by Axel Simon * toplevel/Version.hs (versnum): 0.7.9 2000-07-06 Manuel M. T. Chakravarty * gen/GenBind.hs (specType.matches): forgot a case; bug spotted by Axel Simon * lib/C2HSBase.hs (plusAddr): ugly kludge for GHC 4.08 (doesn't work with any older version for the moment) * toplevel/Version.hs (versnum): 0.7.8 2000-04-15 Manuel M. T. Chakravarty * c/CLexer.hs (pragma): ignores `#pragma's * toplevel/Version.hs (versnum): 0.7.7 2000-04-09 Manuel M. T. Chakravarty * mk/config.mk.in: added * gen/GenBind.hs: added `long long's (specType): added error message for unsupported types * lib/C2HSConfig.hs.in: added `long long's * toplevel/C2HSConfig.hs.in: added `long long's * toplevel/Version.hs (versnum): 0.7.6 2000-04-08 Manuel M. T. Chakravarty * configure.in: corrected sed expression for Solaris 2000-03-02 Manuel M. T. Chakravarty * tests/Makefile: added & revised all the tests * configure.in: debugging 2000-03-01 Manuel M. T. Chakravarty * lib/C2HSMarsh.hs (addrWithMarkerToList): debugged 2000-02-28 Manuel M. T. Chakravarty * gen/GenBind.hs (expandHook): adapted to new `CHSContext' def * c/CParser.hs: Using `Utils.Tag' class to make `CToken' an instance of `Token' * c/CLexer.hs: Making `CToken' an instance of `Utils.Tag' instead of `Eq' 2000-02-25 Manuel M. T. Chakravarty * chs/CHS.hs: added `header' tag in context hook * chs/CHSLexer.hs: added keyword `header' * c/CLexer.hs, c/CParser.hs, c/CAST.hs: added C99 type qualifier `restrict'; thanks to "Marcin 'Qrczak' Kowalczyk" for pointing this out 2000-02-24 Manuel M. T. Chakravarty * gen/GenBind.hs (foreignImport): system-dependent library suffix * configure.in,toplevel/C2HSConfig.hs.in: DLSUFFIX 2000-02-23 Manuel M. T. Chakravarty * toplevel/Version.hs (versnum): 0.7.5 1999-12-04 Manuel M. T. Chakravarty * lib/C2HSBase.hs (BoolConv): added 1999-11-24 Manuel M. T. Chakravarty * ../doc/c2hs/Makefile: corrections by Michael Weber 1999-11-17 Manuel M. T. Chakravarty * Man pages and debianisation, courtesy of Michael Weber * c/CNames.hs: no new range for tag definitions is started when entering a struct declaration list or a parameter list; thanks to Volker Wysk for the bug report * c/CAttrs.hs (enterNewObjRangeC): added (leaveObjRangeC): added 1999-11-16 Manuel M. T. Chakravarty * c/CTrav.hs (extractAlias): now correctly handles anonymous declarations; introduced new function `declaredDeclr'; thanks to Michael Weber for the bug report * toplevel/Version.hs (versnum): 0.7.4 1999-11-07 Manuel M. T. Chakravarty * lib/C2HSBase.hs: adapted to new `assign' and `deref' routines * gen/GenBind.hs: debugged * c/CTrav.hs (extractStruct): takes care that forward declerations of structs are followed to the full definition * lib/C2HSMarsh.hs: added `nothingIf', `nothingIfNull'; generalised string handling to `listToAddrWithLen' and `addrWithLenToList' 1999-11-06 Manuel M. T. Chakravarty * toplevel/Main.hs: Header file search in standard directories and directories passed in `-IDIR' options to cpp. * c2hs-config.in: Added `--c2hs' option to `c2hs-config' * lib/C2HSMarsh.hs: Michael's `Int'/`Word' patch 1999-11-03 Manuel M. T. Chakravarty * lib/C2HSMarsh.hs: more instances for `ToAddr' & `FromAddr' * toplevel/Version.hs (versnum): 0.7.3 1999-10-30 Manuel M. T. Chakravarty * Makefile: adapted to modularised CTK and added installation support * c2hs-config.in: added * toplevel/Version.hs (versnum): 0.7.2 1999-10-28 Manuel M. T. Chakravarty * c/CNames.hs: multiple declarations for the same object are now allowed (thanx Michael) * lib/C2HSMarsh.hs: added some suggestions from Michael Weber * c/CLexer.hs: #line directives 1999-10-26 Manuel M. T. Chakravarty * configure.in: no sizeof or align tests for char 1999-10-25 Manuel M. T. Chakravarty * gen/GenBind.hs: some clean up and improved error message with more position information * chs/CHS.hs: Positions are maintained for improved error messages. * toplevel/Main.hs: removes intermediate file (but it can be retained on explicit request) * toplevel/Version.hs (versnum): 0.7.1 1999-10-24 Manuel M. T. Chakravarty * examples/libghttpHS/Ghttp.chs: adapted to new syntax & features * configure.in: Solaris patch from Michael Weber * gen/GenBind.hs: new hook syntax * chs/CHS.hs (and friends): grok new hook syntax 1999-10-23 Manuel M. T. Chakravarty * toplevel/Version.hs (versnum): 0.7.0 (align hook syntax with paper) * c/CTrav.hs: routines from `CNames' and `GenBind' generalised and exported from `CTrav' (defTag): handles enum tags now correctly 1999-10-22 Manuel M. T. Chakravarty * c/CNames.hs: sets up the object associations for usage positions 1999-10-21 Manuel M. T. Chakravarty * c/CTrav.hs (defTag): handles refined struct definitions * toplevel/Main.hs: Command line option patch from Michael Weber * c/CNames.hs: computes the object reference attributes now * c/CTrav.hs (isTypedef): added * toplevel/Version.hs (versnum): 0.6.2 1999-10-20 Manuel M. T. Chakravarty * examples/libghttpHS/Ghttp.chs: uses `C2HS's exception handling * lib/C2HSMarsh.hs: debugging * toplevel/Version.hs (versnum): 0.6.1 1999-10-18 Manuel M. T. Chakravarty * c/CLexer.hs: computes attributes for identifiers 1999-10-17 Manuel M. T. Chakravarty * c/CNames.hs: moved gathering of definitions from `C', starting a more standard name analysis pass * c/CTrav.hs: basic traversal support for name space and definition attribute operations * c/CAttrs.hs: C definition attribute data type and operations * toplevel/Version.hs: 0.6.0 1999-10-16 Manuel M. T. Chakravarty * lib/C2HSMarsh.hs: Marshaling idioms & exception handling 1999-10-13 Manuel M. T. Chakravarty * examples/libghttpHS/Ghttp.chs: compiles * toplevel/Main.hs (execute): debugged * lib/C2HS.hs: Advanced marshaling support Pre-GNU style change log ------------------------ 0.5.1 ~~~~~ 12Oct99 lib/C2HSMarsh -> lib/C2HSBase; lib/C2HSMarsh new 0.5.0 ~~~~~ 08Oct99 Debugging 06Oct99 (# ... #) to {# ... #}; extended `C2HSMarsh'; `Ghttp' example 0.4.1 ~~~~~ 01Oct99 Improved autoconf support for computing the information necessary for determining struct offsets & corresponding changes in `GenBind' plus full struct and union support 0.4.0 ~~~~~ 29Sep99 Debugging 28Sep99 Improving marshaling lib 27Sep99 Autoconf support 26Sep99 More lexer debugging, typedef chasing & field hooks with indirections; preprocessing of the C header implemented 21Sep99 Debugged CHS lexer (Haskell comments etc) 0.3.0 ~~~~~ 06Sep99 Enums correctly lead to `CInt's in foreign import declarations 01Sep99 Added dot syntax for field hooks 0.2.2 ~~~~~ 01Sep99 Added support for explicit tag values in enumerations 31Aug99 added tag objects to `CAttrs.hs' and `C.hs'; enumeration hooks are partial functional 0.2.1 ~~~~~ 30Aug99 context and call hooks are functional 0.2.0 ~~~~~ 29Aug99 full path completed 19Aug99 started `lib' part 17Aug99 started `gen' part 17Aug99 finished the CHS parser and printing routines in `CHS.hs' 16Aug99 finished first version of CHS lexer; added `CHS.hs' 15Aug99 started `chs' part 0.1.1 ~~~~~ 12Aug99 Various fixes to the C lexer and parser; added toplevel/Main.hs and c/C.hs 0.1.0 ~~~~~ 03Apr99 Finished first complete version of C lexer and parser 27Feb99 starting project c2hs-0.28.1/AUTHORS0000644000000000000000000000205112677513065011711 0ustar0000000000000000Manuel M T Chakravarty Duncan Coutts with contributions from (alphabetical order) Bertram Felgenhauer Benedikt Huber John Lato Ian Lynagh AndrĂ© Pang Jens-Ulrik Petersen Armin Sander Sean Seefried Udo Stenzel Axel Simon Michael Weber Thanks for comments and suggestions to Roman Leshchinskiy Jan Kort Seth Kurtzberg Simon Marlow Matthias Neubauer Sven Panne Simon L. Peyton Jones Volker Wysk c2hs-0.28.1/COPYING0000644000000000000000000004362612677513064011710 0ustar0000000000000000This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. c2hs-0.28.1/c2hs.cabal0000644000000000000000000002101012677513064012457 0ustar0000000000000000Name: c2hs Version: 0.28.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty 2005-2013 Duncan Coutts 2008 Benedikt Huber Author: Manuel M T Chakravarty Maintainer: chak@cse.unsw.edu.au, duncan@community.haskell.org, ian@skybluetrades.net Stability: Stable Homepage: https://github.com/haskell/c2hs Bug-Reports: https://github.com/haskell/c2hs/issues Synopsis: C->Haskell FFI tool that gives some cross-language type safety Description: C->Haskell assists in the development of Haskell bindings to C libraries. It extracts interface information from C header files and generates Haskell code with foreign imports and marshaling. Unlike writing foreign imports by hand (or using hsc2hs), this ensures that C functions are imported with the correct Haskell types. Category: Development Tested-With: GHC==6.12.3, GHC==7.0.4, GHC==7.6.1, GHC==7.6.3, GHC==7.8.3, GHC==7.10.1 Cabal-Version: >= 1.8 Build-Type: Simple --TODO: Cabal should allow 'Data-Files' in the executable stanza Data-Files: C2HS.hs Extra-Source-Files: src/C2HS/config.h AUTHORS INSTALL README ChangeLog ChangeLog.old doc/c2hs.xml doc/c2hs.css doc/man1/c2hs.1 doc/Makefile tests/system/calls/*.chs tests/system/calls/*.h tests/system/cpp/*.chs tests/system/enums/*.chs tests/system/enums/*.h tests/system/enums/*.c tests/system/marsh/*.chs tests/system/marsh/*.h tests/system/pointer/*.chs tests/system/pointer/*.h tests/system/pointer/*.c tests/system/simple/*.chs tests/system/simple/*.h tests/system/simple/*.c tests/system/sizeof/*.chs tests/system/sizeof/*.h tests/system/sizeof/*.c tests/system/structs/*.chs tests/system/structs/*.h tests/system/structs/*.c tests/system/Makefile tests/bugs/call_capital/*.chs tests/bugs/call_capital/*.h tests/bugs/call_capital/*.c tests/bugs/issue-7/*.chs tests/bugs/issue-7/*.h tests/bugs/issue-9/*.chs tests/bugs/issue-9/*.h tests/bugs/issue-9/*.c tests/bugs/issue-10/*.chs tests/bugs/issue-10/*.h tests/bugs/issue-10/*.c tests/bugs/issue-15/*.chs tests/bugs/issue-15/*.h tests/bugs/issue-15/*.c tests/bugs/issue-16/*.chs tests/bugs/issue-16/*.h tests/bugs/issue-16/*.c tests/bugs/issue-19/*.chs tests/bugs/issue-19/*.h tests/bugs/issue-19/*.c tests/bugs/issue-20/*.chs tests/bugs/issue-20/*.h tests/bugs/issue-20/*.c tests/bugs/issue-22/*.chs tests/bugs/issue-22/*.h tests/bugs/issue-22/*.c tests/bugs/issue-23/*.chs tests/bugs/issue-23/*.h tests/bugs/issue-23/*.c tests/bugs/issue-25/*.chs tests/bugs/issue-29/*.chs tests/bugs/issue-29/*.h tests/bugs/issue-30/*.chs tests/bugs/issue-30/*.h tests/bugs/issue-30/*.c tests/bugs/issue-31/*.chs tests/bugs/issue-31/*.h tests/bugs/issue-31/*.c tests/bugs/issue-32/*.chs tests/bugs/issue-32/*.h tests/bugs/issue-32/*.c tests/bugs/issue-36/*.chs tests/bugs/issue-36/*.h tests/bugs/issue-38/*.chs tests/bugs/issue-38/*.h tests/bugs/issue-38/*.c tests/bugs/issue-43/*.chs tests/bugs/issue-43/*.h tests/bugs/issue-43/*.c tests/bugs/issue-44/*.chs tests/bugs/issue-44/*.h tests/bugs/issue-44/*.c tests/bugs/issue-45/*.chs tests/bugs/issue-45/*.h tests/bugs/issue-45/*.c tests/bugs/issue-46/*.chs tests/bugs/issue-46/*.h tests/bugs/issue-46/*.c tests/bugs/issue-47/*.chs tests/bugs/issue-47/*.h tests/bugs/issue-47/*.c tests/bugs/issue-48/*.chs tests/bugs/issue-48/*.h tests/bugs/issue-48/*.c tests/bugs/issue-51/*.chs tests/bugs/issue-51/*.h tests/bugs/issue-51/*.c tests/bugs/issue-54/*.chs tests/bugs/issue-54/*.h tests/bugs/issue-54/*.c tests/bugs/issue-60/*.chs tests/bugs/issue-60/*.h tests/bugs/issue-60/*.c tests/bugs/issue-62/*.chs tests/bugs/issue-62/*.h tests/bugs/issue-62/*.c tests/bugs/issue-65/*.chs tests/bugs/issue-65/*.h tests/bugs/issue-65/*.c tests/bugs/issue-69/*.chs tests/bugs/issue-69/*.h tests/bugs/issue-69/*.c tests/bugs/issue-70/*.chs tests/bugs/issue-70/*.h tests/bugs/issue-70/*.c tests/bugs/issue-73/*.chs tests/bugs/issue-73/*.h tests/bugs/issue-73/*.c tests/bugs/issue-75/*.chs tests/bugs/issue-75/*.h tests/bugs/issue-75/*.c tests/bugs/issue-79/*.chs tests/bugs/issue-79/*.h tests/bugs/issue-79/*.c tests/bugs/issue-80/*.chs tests/bugs/issue-80/*.h tests/bugs/issue-80/*.c tests/bugs/issue-82/*.chs tests/bugs/issue-83/*.chs tests/bugs/issue-93/*.chs tests/bugs/issue-93/*.h tests/bugs/issue-93/*.c tests/bugs/issue-95/*.chs tests/bugs/issue-95/*.h tests/bugs/issue-95/*.c tests/bugs/issue-96/*.chs tests/bugs/issue-96/*.h tests/bugs/issue-96/*.c tests/bugs/issue-97/*.chs tests/bugs/issue-97/*.h tests/bugs/issue-97/*.c tests/bugs/issue-98/*.chs tests/bugs/issue-98/*.h tests/bugs/issue-98/*.c tests/bugs/issue-102/*.chs tests/bugs/issue-103/*.chs tests/bugs/issue-103/*.h tests/bugs/issue-103/*.c tests/bugs/issue-107/*.chs tests/bugs/issue-113/*.chs tests/bugs/issue-113/*.h tests/bugs/issue-113/*.c tests/bugs/issue-115/*.chs tests/bugs/issue-115/*.h tests/bugs/issue-115/*.c tests/bugs/issue-116/*.chs tests/bugs/issue-116/*.h tests/bugs/issue-116/*.c tests/bugs/issue-117/*.chs tests/bugs/issue-117/*.h tests/bugs/issue-117/*.c tests/bugs/issue-123/*.chs tests/bugs/issue-123/*.h tests/bugs/issue-123/*.c tests/bugs/issue-127/*.chs tests/bugs/issue-127/*.h tests/bugs/issue-127/*.c tests/bugs/issue-128/*.chs tests/bugs/issue-128/*.h tests/bugs/issue-128/*.c tests/bugs/issue-130/*.chs tests/bugs/issue-130/*.h tests/bugs/issue-130/*.c tests/bugs/issue-131/*.chs tests/bugs/issue-131/*.h tests/bugs/issue-131/*.c tests/bugs/issue-133/*.chs tests/bugs/issue-133/*.h tests/bugs/issue-134/*.chs tests/bugs/issue-134/*.h tests/bugs/issue-136/*.chs tests/bugs/issue-136/*.h tests/bugs/issue-136/*.c tests/bugs/issue-140/*.chs tests/bugs/issue-140/*.h tests/bugs/issue-140/*.c tests/bugs/issue-141/*.chs tests/bugs/issue-141/*.h tests/bugs/issue-149/*.chs tests/bugs/issue-149/*.h tests/bugs/issue-149/*.c tests/bugs/issue-151/*.chs tests/bugs/issue-151/*.h tests/bugs/issue-152/*.chs tests/bugs/issue-152/*.h tests/bugs/issue-155/*.chs tests/bugs/issue-155/*.h source-repository head type: git location: git://github.com/haskell/c2hs.git flag base3 Executable c2hs Build-Depends: base >= 2 && < 5, bytestring, language-c >= 0.5 && < 0.6, filepath, dlist if flag(base3) Build-Depends: base >= 3, process, directory, array, containers, pretty else Build-Depends: base < 3 hs-source-dirs: src main-is: Main.hs other-modules: C2HS.C C2HS.C.Attrs C2HS.C.Builtin C2HS.C.Info C2HS.C.Names C2HS.C.Trav C2HS.CHS C2HS.CHS.Lexer C2HS.Gen.Monad C2HS.Gen.Bind C2HS.Gen.Header C2HS.Gen.Wrapper C2HS.State C2HS.Switches C2HS.Config C2HS.Version Control.StateBase Control.State Control.StateTrans Data.Attributes Data.Errors Data.NameSpaces System.CIO Text.Lexers extensions: ForeignFunctionInterface c-sources: src/C2HS/config.c --TODO: eliminate the need to suppress these warnings: ghc-options: -Wall -fno-warn-incomplete-patterns -fwarn-tabs Test-Suite test-bugs type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: test-bugs.hs build-tools: c2hs build-depends: base, filepath, test-framework, test-framework-hunit, HUnit, shelly >= 1.0, text, transformers Test-Suite test-system type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: test-system.hs build-tools: c2hs build-depends: base, test-framework, test-framework-hunit, HUnit, shelly >= 1.0, text, transformers Flag regression description: Enable regression suite build. default: False Executable regression-suite main-is: regression-suite.hs hs-source-dirs: tests if flag(regression) build-depends: base, filepath, shelly >= 1.0, text, yaml >= 0.8 else buildable: False c2hs-0.28.1/ChangeLog0000644000000000000000000001475312677513065012427 0ustar00000000000000000.28.1 - Switch to language-c 0.5 [#157] - Fix class hook problem with imports [#155] 0.27.1 - Alternate specification for sizes in "+" parameters [#140] - Fix regression to do with incomplete structure types [#152] - Fix pattern match error [PR #153] (deech) 0.26.2 - Missing import bug [#151] - Parameter count checking for {#fun ...#} [#149] - Error message for "incomplete types" [#141] 0.26.1 - Better error messages [PR #139] (Noam Lewis) - Fix for OS X block syntax [#138] (Anthony Cowley) - Minimal support for va_list [PR #137] (Andy Adams-Moran) - Reorganise treatment of standard library imports used by C2HS [#136] (https://github.com/haskell/c2hs/blob/master/import-handling.md) - C structure tag/typedef confusion bug (caused problems for flock on OS X) [#134] - C typedefs to void pointers [#133] - Bool wrappers for unnamed parameters in C function definitions [#131] - Incorrect wrapping of some pure C functions [#130] 0.25.2 - Test fixes to work with GHC 7.10.1 0.25.1 - Marshalling for C bool values [#128] 0.24.1 - Revert bad fix for bool handling [#127] - Wrapper generation for bare structure arguments [#117] plus custom setup script to support Cabal builds on versions of Cabal without explicit support for extra C sources generated by preprocessors (@RyanGIScott) - Arrays in structuress bug [#123] - Test fixes for Windows 0.23.1 - Typedef and default marshalling hooks [#20, #25, #48] - Test fixes for 32-bit platforms (JĂ¼rgen Keck: @j-keck) - Multi-character constants for OS X [#15] - Better support for binding to variadic functions [#102] 0.22.1 - First (not very good) implementation of support for variadic functions [#102] - Default marshallers for Char types [#98] - Improve sizeof computations [#9, #10] 0.21.1 - Parametrized pointer types in pointer hooks [#36] - Special "+" parameters for efficient foreign pointer marshalling [#46] - Add default marshallers for C types [#83] - Fix treatment of arrays within structs [#115] - Add ability to omit given enum values [#116] - Regression suite tidy-ups 0.20.1 - Get CUDA Travis tests working again (hopefully...) - Modify approach for defining C2HS_MIN_VERSION macro to work with NVIDIA's nvcc CUDA compiler [#111] - Fix problem with parser for {#enum ...#} renamings [#113] 0.19.1 - Add {#const ...#} hook for accessing #defined constants [#65] - Persist enumeration definitions across modules [#103] - Add nocode keyword for enumeration definitions [#70] - Bump version for language-c to fix OS X problems [#82, #85] (thanks to Anthony Cowley and Benedikt Huber for help with this) - Add finalizer support to foreign pointer definitions [#73] - Comment parsing cleanups (Sivert Berg: @sivertb) 0.18.2 - Add C2HS_MIN_VERSION(major,minor,revision) preprocessor macro - Suppress regression suite build (and associated dependency installation) for non-Travis cases - Fix Cabal file to include previously missing tests 0.18.1 - Numerous improvements to Enum handling [#78] (Philipp Balzarek: @Philonous) - Handle Haddock comments within C2HS hook definitions [#62] (@tangboyun) - Better error messages for missing files (Zejun Wu: @watashi) - Write CHS dump files to output directory (Zejun Wu: @watashi) - Handle C calling conventions within function pointer declarations [#88] (Michael Steele: @mikesteele81) - Fix FreeBSD libssh2 problem [#87] (Cindy Wang: @CindyLinz) - Better error messages for hook syntax errors (Ryan Scott: @RyanGIScott) - Fixes for GHC 7.9 [#100] (@int-index) - Fix test suite to use C2HS from dist directory [#81] - Allow free intermixing of command line options and input files [#86] - Treat CLang "block" syntax and other "non-GNU" issues differently: always undefine __BLOCKS__ CPP symbol to avoid problems with blocks; add nonGNU directive to trigger undefine of GNU-specific pre-processor symbols [#77] - Handle indented CPP directives correctly [#80] - Handle #sizeof and #alignof on non-typedef's structures [#95] - Fix #get and #set hooks to access newtyped pointers [#96] - Fix round-trip problem for interface files caused by changes in language-c [#87] - Treat "with" specially so that it can appear both as a marshaller identifier in an input parameter definition and as a keyword in enum definitions [#93] - Temporarily disable CUDA regression suite examples (CUDA install problems on Travis) 0.17.2 - Fix more regressions from 0.16.6 (affected packages included gnome-keyring, hsndfile and cuda) - Add regression suite tests to reduce chances of future regressions 0.17.1 - Fix regressions from 0.16.6 (caused by fix for issue #45) - Version number bump (should have been done in the last release) 0.16.6 - Trivial integer casts in enum defines supporting typedefs [Anton Dessiatov] - Allow forward definition of enums (issue #23) - Binding of C enums with aliases (issue #38) - Default marshallers for enum and pointer hooks (issue #31) - Remove dependencies on C2HS module from marshalling code (issue #37) - Problem with MacOS blocks notation (issue #29) - Include directive on first line produces invalid Haskell (issue #16) - Add command-line switch to suppress GNU preprocessor symbols (issue #60) - Fix size and alignment computation of bitfields [Facundo Dominguez] - Allow prefixes to be replaced, not just removed (issue #19) - Allow reference to structure tags from accessors (issue #54) For access paths for {#get#}, {#set#}, etc., one can now specify that structure tags are to be searched preferentially by saying, for example, {#get struct _point->y#} instead of {#get _point->y#}. The latter case will search for typedef names first and only then structure tags. - Support for anonymous enums (issue #43) - with... unwrapper type declarations for pointer hooks (issue #44) - {#fun...#} indentation for use in where clauses (issue #45) - incorrect method names from terminal class in superclass instances (issue #21) - "offsetof" directive (issue #22) - --include flag cannot handle windows paths (issue #30) Now uses System.FilePath splitSearchPath function, which should be platform-agnostic. - Void functions produce "defined but not used" warning (issue #47) Handle fun hooks with a void result using ">>" instead of ">>=". - Add CPP undefine flags for Gnu compiler defines (issue #51) - Cabal test suite 0.16.5 - Migration to GitHub; documentation changes. CHANGES ABOVE THIS POINT ARE FOR VERSIONS AFTER THE MOVE OF THE REPOSITORY TO GITHUB. FOR EARLIER CHANGES SEE ChangeLog.old. c2hs-0.28.1/tests/0000755000000000000000000000000012677513064012004 5ustar0000000000000000c2hs-0.28.1/tests/regression-suite.hs0000644000000000000000000001562012677513064015653 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Main where import Control.Applicative ((<$>), (<*>)) import Control.Monad import Shelly hiding (FilePath) import Data.Char import Data.List (nub) import Data.Text (Text) import Data.Monoid import qualified Data.Text as T import Data.Yaml default (T.Text) data RegressionTest = RegressionTest { name :: Text , cabal :: Bool , flags :: [Text] , aptPPA :: [Text] , aptPackages :: [Text] , cabalBuildTools :: [Text] , specialSetup :: [Text] , extraPath :: [Text] , extraSOPath :: [Text] , extraIncludeDirs :: [Text] , extraLibDirs :: [Text] , onTravis :: Bool , runTests :: Bool } deriving (Eq, Show) instance FromJSON RegressionTest where parseJSON (Object v) = RegressionTest <$> v .: "name" <*> v .:? "cabal" .!= True <*> v .:? "flags" .!= [] <*> v .:? "apt-ppa" .!= [] <*> v .:? "apt-packages" .!= [] <*> v .:? "cabal-build-tools" .!= [] <*> v .:? "special-setup" .!= [] <*> v .:? "extra-path" .!= [] <*> v .:? "extra-so-path" .!= [] <*> v .:? "extra-include-dirs" .!= [] <*> v .:? "extra-lib-dirs" .!= [] <*> v .:? "on-travis" .!= True <*> v .:? "run-tests" .!= False parseJSON _ = mzero data Code = TestOK | DepsFailed | ConfFailed | BuildFailed | TestsFailed deriving Eq instance Show Code where show TestOK = "OK" show DepsFailed = "dependencies" show ConfFailed = "configuration" show BuildFailed = "build" show TestsFailed = "tests" makeCode :: (Int, Int, Int, Int) -> Code makeCode (0, 0, 0, 0) = TestOK makeCode (0, 0, 0, _) = TestsFailed makeCode (0, 0, _, _) = BuildFailed makeCode (0, _, _, _) = ConfFailed makeCode (_, _, _, _) = DepsFailed readTests :: FilePath -> IO [RegressionTest] readTests fp = maybe [] id <$> decodeFile fp checkApt :: Sh () checkApt = do apt <- which "apt-get" case apt of Nothing -> errorExit "Can't find apt-get. Are you sure this is Ubuntu?" _ -> return () main :: IO () main = shelly $ do travis <- maybe False (const True) <$> get_env "TRAVIS" enabled <- maybe False (const True) <$> get_env "C2HS_REGRESSION_SUITE" when (not (travis || enabled)) $ do echo "REGRESSION SUITE IS DISABLED" exit 0 when travis checkApt let travisCheck t = case travis of False -> True True -> onTravis t tests <- liftIO $ filter travisCheck <$> readTests "tests/regression-suite.yaml" let ppas = nub $ concatMap aptPPA tests pkgs = nub $ concatMap aptPackages tests buildTools = nub $ concatMap cabalBuildTools tests specials = concatMap specialSetup tests extraPaths = concatMap extraPath tests extraSOPaths = concatMap extraSOPath tests when (not travis) $ echo "ASSUMING THAT ALL NECESSARY LIBRARIES ALREADY INSTALLED!\n" home <- fromText <$> get_env_text "HOME" appendToPath $ home ".cabal/bin" when travis $ do when (not (null ppas)) $ do echo "SETTING UP APT PPAS\n" forM_ ppas $ \ppa -> run_ "sudo" $ ["apt-add-repository", "ppa:" <> ppa] run_ "sudo" $ ["apt-get", "update"] echo "\n" when (not (null pkgs)) $ do echo "INSTALLING APT PACKAGES\n" run_ "sudo" $ ["apt-get", "install", "-y"] ++ pkgs echo "\n" when (not (null specials)) $ do echo "SPECIAL INSTALL STEPS\n" forM_ specials $ \s -> let (c:as) = escapedWords s in run_ (fromText c) as echo "\n" when (not (null extraPaths)) $ do echo "ADDING PATHS\n" forM_ extraPaths $ \p -> do echo p appendToPath $ fromText p echo "\n" when (not (null extraSOPaths)) $ do echo "ADDING SHARED LIBRARY PATHS\n" forM_ extraSOPaths $ \p -> do echo p appendToSOPath p echo "\n" codes <- forM (filter cabal tests) $ \t -> do let n = name t tst = runTests t infs = concatMap (\f -> ["-f", f]) $ flags t extralibs = map (\f -> "--extra-lib-dirs=" <> f) $ extraLibDirs t extraincs = map (\f -> "--extra-include-dirs=" <> f) $ extraIncludeDirs t mefs <- get_env $ "C2HS_REGRESSION_FLAGS_" <> n let fs = if tst then ["--enable-tests"] else [] ++ case mefs of Nothing -> infs Just efs -> infs ++ concatMap (\f -> ["-f", f]) (T.splitOn "," efs) echo $ "\nREGRESSION TEST: " <> n <> "\n" errExit False $ do unpack <- run "cabal" ["unpack", n] let d = T.drop (T.length "Unpacking to ") $ T.init $ last $ T.lines unpack chdir (fromText d) $ do run_ "cabal" $ ["sandbox", "init"] run_ "cabal" $ ["install", "--only-dep", "-v"] ++ fs dep <- lastExitCode run_ "cabal" $ ["configure"] ++ extraincs ++ extralibs ++ fs conf <- lastExitCode run_ "cabal" $ ["build"] build <- lastExitCode test <- if tst then do run_ "cabal" ["test"] lastExitCode else return 0 return $ makeCode (dep, conf, build, test) if all (== TestOK) codes then exit 0 else do echo "\n\nSOME TESTS FAILED\n" let failed = filter (\(c, _) -> c /= TestOK) $ zip codes (filter cabal tests) forM_ failed $ \(c, t) -> echo $ "FAILED: " <> name t <> " (" <> T.pack (show c) <> ")" exit 1 escapedWords :: Text -> [Text] escapedWords = map (T.pack . reverse) . escWords False "" . T.unpack where escWords :: Bool -> String -> String -> [String] -- End of string: just return the accumulator if there is one. escWords _ acc "" = case acc of "" -> [] _ -> [acc] -- Not escaping. escWords False acc (c:cs) | isSpace c = acc : escWords False "" cs | c == '\'' = case acc of "" -> escWords True "" cs _ -> acc : escWords True "" cs | otherwise = escWords False (c:acc) cs -- Escaping. escWords True acc (c:cs) | c == '\'' = acc : escWords False "" cs | otherwise = escWords True (c:acc) cs appendToSOPath :: Text -> Sh () appendToSOPath tp = do pe <- get_env_text "LD_LIBRARY_PATH" setenv "LD_LIBRARY_PATH" $ pe <> ":" <> tp c2hs-0.28.1/tests/test-bugs.hs0000644000000000000000000004051412677513064014261 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, assert) import System.FilePath (searchPathSeparator) import System.Info (os) import Prelude hiding (FilePath) import Control.Monad (forM) import Control.Monad.IO.Class import Shelly import Data.List (sort) import Data.Text (Text) import Data.Monoid import qualified Data.Text as T import Paths_c2hs default (T.Text) main :: IO () main = defaultMain tests c2hsShelly :: MonadIO m => Sh a -> m a c2hsShelly as = shelly $ do oldpath <- get_env_text "PATH" let newpath = "../../../dist/build/c2hs:" <> oldpath setenv "PATH" newpath as cc :: FilePath cc = if os == "cygwin32" || os == "mingw32" then "gcc" else "cc" tests :: [Test] tests = [ testGroup "Bugs" $ [ testCase "call_capital (issue #??)" call_capital , testCase "Issue #7" issue07 , testCase "Issue #9" issue09 , testCase "Issue #10" issue10 , testCase "Issue #15" issue15 , testCase "Issue #16" issue16 , testCase "Issue #19" issue19 , testCase "Issue #20" issue20 , testCase "Issue #22" issue22 , testCase "Issue #23" issue23 , testCase "Issue #25" issue25 , testCase "Issue #29" issue29 , testCase "Issue #30" issue30 , testCase "Issue #31" issue31 , testCase "Issue #32" issue32 , testCase "Issue #36" issue36 , testCase "Issue #38" issue38 , testCase "Issue #43" issue43 , testCase "Issue #44" issue44 , testCase "Issue #45" issue45 , testCase "Issue #46" issue46 , testCase "Issue #47" issue47 , testCase "Issue #51" issue51 , testCase "Issue #54" issue54 , testCase "Issue #60" issue60 , testCase "Issue #62" issue62 , testCase "Issue #65" issue65 , testCase "Issue #69" issue69 , testCase "Issue #70" issue70 , testCase "Issue #73" issue73 , testCase "Issue #75" issue75 , testCase "Issue #79" issue79 , testCase "Issue #80" issue80 , testCase "Issue #82" issue82 , testCase "Issue #93" issue93 , testCase "Issue #95" issue95 , testCase "Issue #96" issue96 , testCase "Issue #97" issue97 , testCase "Issue #98" issue98 , testCase "Issue #103" issue103 , testCase "Issue #107" issue107 , testCase "Issue #113" issue113 , testCase "Issue #115" issue115 , testCase "Issue #116" issue116 , testCase "Issue #117" issue117 , testCase "Issue #123" issue123 , testCase "Issue #127" issue127 , testCase "Issue #128" issue128 , testCase "Issue #130" issue130 , testCase "Issue #131" issue131 , testCase "Issue #133" issue133 , testCase "Issue #134" issue134 , testCase "Issue #136" issue136 , testCase "Issue #140" issue140 , testCase "Issue #141" issue141 , testCase "Issue #149" issue149 , testCase "Issue #151" issue151 , testCase "Issue #152" issue152 , testCase "Issue #155" issue155 ] ++ -- Some tests that won't work on Windows. if os /= "cygwin32" && os /= "mingw32" then [ testCase "Issue #48" issue48 , testCase "Issue #83" issue83 , testCase "Issue #102" issue102 ] else [ ] ] call_capital :: Assertion call_capital = c2hsShelly $ chdir "tests/bugs/call_capital" $ do mapM_ rm_f ["Capital.hs", "Capital.chs.h", "Capital.chi", "Capital_c.o", "Capital"] cmd "c2hs" "-d" "genbind" "Capital.chs" cmd cc "-c" "-o" "Capital_c.o" "Capital.c" cmd "ghc" "--make" "-cpp" "Capital_c.o" "Capital.hs" res <- absPath "./Capital" >>= cmd let expected = ["upper C();", "lower c();", "upper C();"] liftIO $ assertBool "" (T.lines res == expected) issue155 :: Assertion issue155 = c2hsShelly $ chdir "tests/bugs/issue-155" $ do mapM_ rm_f ["Issue155.hs", "Issue155.chs.h", "Issue155.chs.c", "Issue155.chi", "Issue155.chs.o", "Issue155", "Types.chi", "Types.chs.h", "Types.hs"] cmd "c2hs" "Types.chs" cmd "c2hs" "Issue155.chs" cmd "ghc" "--make" "Issue155.hs" res <- absPath "./Issue155" >>= cmd let expected = ["OK"] liftIO $ assertBool "" (T.lines res == expected) issue152 :: Assertion issue152 = hs_only_build_issue 152 issue151 :: Assertion issue151 = hs_only_build_issue 151 issue149 :: Assertion issue149 = build_issue_fails 149 issue141 :: Assertion issue141 = c2hsShelly $ chdir "tests/bugs/issue-141" $ do mapM_ rm_f ["Issue141A.hs", "Issue141A.chs.h", "Issue141A.chi", "Issue141B.hs", "Issue141B.chs.h", "Issue141B.chi", "Issue141C.hs", "Issue141C.chs.h", "Issue141C.chi"] codes <- forM ["A", "B", "C"] $ \suff -> do errExit False $ cmd "c2hs" $ "Issue141" <> suff <> ".chs" lastExitCode liftIO $ assertBool "" (all (/= 0) codes) issue140 :: Assertion issue140 = expect_issue 140 ["123", "456", "789"] issue136 :: Assertion issue136 = build_issue_tolerant 136 issue134 :: Assertion issue134 = hs_only_build_issue 134 issue133 :: Assertion issue133 = hs_only_build_issue 133 issue131 :: Assertion issue131 = c2hsShelly $ chdir "tests/bugs/issue-131" $ do mapM_ rm_f ["Issue131.hs", "Issue131.chs.h", "Issue131.chs.c", "Issue131.chi", "issue131_c.o", "Issue131.chs.o", "Issue131"] cmd "c2hs" "Issue131.chs" cmd cc "-c" "-o" "issue131_c.o" "issue131.c" cmd cc "-c" "Issue131.chs.c" cmd "ghc" "--make" "issue131_c.o" "Issue131.chs.o" "Issue131.hs" res <- absPath "./Issue131" >>= cmd let expected = ["5", "3", "True", "False"] liftIO $ assertBool "" (T.lines res == expected) issue130 :: Assertion issue130 = expect_issue 130 ["3", "3"] issue128 :: Assertion issue128 = c2hsShelly $ chdir "tests/bugs/issue-128" $ do mapM_ rm_f ["Issue128.hs", "Issue128.chs.h", "Issue128.chs.c", "Issue128.chi", "issue128_c.o", "Issue128.chs.o", "Issue128"] cmd "c2hs" "Issue128.chs" cmd cc "-c" "-o" "issue128_c.o" "issue128.c" cmd cc "-c" "Issue128.chs.c" cmd "ghc" "--make" "issue128_c.o" "Issue128.chs.o" "Issue128.hs" res <- absPath "./Issue128" >>= cmd let expected = ["5", "3", "True", "False", "10", "False", "12", "True", "7", "False", "8", "True"] liftIO $ assertBool "" (T.lines res == expected) issue127 :: Assertion issue127 = expect_issue 127 ["True", "False"] issue125 :: Assertion issue125 = expect_issue 125 ["NYI"] issue123 :: Assertion issue123 = expect_issue 123 ["[8,43,94]", "[7,42,93]", "[2,4,8]", "[3,9,27]"] issue117 :: Assertion issue117 = c2hsShelly $ chdir "tests/bugs/issue-117" $ do mapM_ rm_f ["Issue117.hs", "Issue117.chs.h", "Issue117.chs.c", "Issue117.chi", "issue117_c.o", "Issue117.chs.o", "Issue117"] cmd "c2hs" "Issue117.chs" cmd cc "-c" "-o" "issue117_c.o" "issue117.c" cmd cc "-c" "Issue117.chs.c" cmd "ghc" "--make" "issue117_c.o" "Issue117.chs.o" "Issue117.hs" res <- absPath "./Issue117" >>= cmd let expected = ["5"] liftIO $ assertBool "" (T.lines res == expected) issue116 :: Assertion issue116 = build_issue 116 issue115 :: Assertion issue115 = expect_issue 115 ["[8,43,94]", "[7,42,93]"] issue113 :: Assertion issue113 = build_issue 113 issue107 :: Assertion issue107 = hs_only_expect_issue 107 True ["True"] issue103 :: Assertion issue103 = c2hsShelly $ chdir "tests/bugs/issue-103" $ do mapM_ rm_f ["Issue103.hs", "Issue103.chs.h", "Issue103.chi", "Issue103A.hs", "Issue103A.chs.h", "Issue103A.chi", "issue103_c.o", "Issue103"] cmd "c2hs" "Issue103A.chs" cmd "c2hs" "Issue103.chs" cmd cc "-c" "-o" "issue103_c.o" "issue103.c" cmd "ghc" "--make" "issue103_c.o" "Issue103A.hs" "Issue103.hs" res <- absPath "./Issue103" >>= cmd let expected = ["1", "2", "3"] liftIO $ assertBool "" (T.lines res == expected) issue102 :: Assertion issue102 = hs_only_expect_issue 102 False ["TST 1: 1234", "TST 2: 13 47", "TST 3: testing", "Unlocked"] issue98 :: Assertion issue98 = build_issue 98 issue97 :: Assertion issue97 = c2hsShelly $ chdir "tests/bugs/issue-97" $ do mapM_ rm_f ["Issue97.hs", "Issue97.chs.h", "Issue97.chi", "Issue97A.hs", "Issue97A.chs.h", "Issue97A.chi", "issue97_c.o", "Issue97"] cmd "c2hs" "Issue97A.chs" cmd "c2hs" "Issue97.chs" cmd cc "-c" "-o" "issue97_c.o" "issue97.c" cmd "ghc" "--make" "issue97_c.o" "Issue97A.hs" "Issue97.hs" res <- absPath "./Issue97" >>= cmd let expected = ["42"] liftIO $ assertBool "" (T.lines res == expected) issue96 :: Assertion issue96 = build_issue 96 issue95 :: Assertion issue95 = build_issue 95 issue93 :: Assertion issue93 = build_issue_tolerant 93 issue82 :: Assertion issue82 = hs_only_build_issue 82 issue83 :: Assertion issue83 = hs_only_expect_issue 83 True ["(True,True)", "TEST_VAL", "8415", "8415", "TESTING"] issue80 :: Assertion issue80 = build_issue 80 issue79 :: Assertion issue79 = expect_issue 79 ["A=1", "B=2", "C=2", "D=3"] issue75 :: Assertion issue75 = build_issue 75 issue73 :: Assertion issue73 = unordered_expect_issue 73 [ "Allocated struct3" , "Foreign pointer: 3" , "Allocated struct3" , "Foreign pointer: 3" , "Allocated struct4" , "Foreign newtype pointer: 4" , "Allocated struct4" , "Foreign newtype pointer: 4" , "Freeing struct3" , "Freeing struct4" ] issue70 :: Assertion issue70 = build_issue 70 issue69 :: Assertion issue69 = build_issue 69 issue65 :: Assertion issue65 = expect_issue 65 ["123", "3.14", "\"hello\""] issue62 :: Assertion issue62 = build_issue 62 issue60 :: Assertion issue60 = build_issue 60 issue54 :: Assertion issue54 = expect_issue 54 ["2", "0.2", "2", "0.2", "3", "0.3", "3", "0.3", "3", "0.3", "3", "0.3"] issue51 :: Assertion issue51 = do expect_issue_with True True 51 "nonGNU" [] ["0"] expect_issue_with True True 51 "GNU" [] ["1"] issue48 :: Assertion issue48 = expect_issue 48 ["2", "5"] issue47 :: Assertion issue47 = build_issue 47 issue46 :: Assertion issue46 = expect_issue 46 ["(1,2.5)"] issue45 :: Assertion issue45 = build_issue 45 issue44 :: Assertion issue44 = build_issue 44 issue43 :: Assertion issue43 = expect_issue 43 ["Test1A=0", "Test1B=1", "Test1C=5", "Test1D=6", "AnonA=8", "AnonB=9", "AnonC=15", "AnonD=16"] issue38 :: Assertion issue38 = expect_issue 38 ["Enum OK"] issue36 :: Assertion issue36 = hs_only_build_issue 36 issue32 :: Assertion issue32 = expect_issue 32 ["1234", "1", "523"] issue31 :: Assertion issue31 = expect_issue 31 ["Enum OK", "Pointer 1: 1 1", "Pointer 2: 2", "Foreign pointer: 3", "Foreign newtype pointer: 4"] -- This is tricky to test since it's Windows-specific, but we can at -- least make sure that paths with spaces work OK. issue30 :: Assertion issue30 = c2hsShelly $ chdir "tests/bugs/issue-30" $ do mkdir_p "test 1" mkdir_p "test 2" mapM_ rm_f ["Issue30.hs", "Issue30.chs.h", "Issue30.chi", "Issue30Aux1.hs", "Issue30Aux1.chs.h", "test 1/Issue30Aux1.chi", "Issue30Aux2.hs", "Issue30Aux2.chs.h", "test 2/Issue30Aux2.chi", "issue30_c.o", "issue30aux1_c.o", "issue30aux2_c.o", "Issue30"] cmd "c2hs" "Issue30Aux1.chs" mv "Issue30Aux1.chi" "test 1" cmd "c2hs" "Issue30Aux2.chs" mv "Issue30Aux2.chi" "test 2" let sp = T.pack $ "test 1" ++ [searchPathSeparator] ++ "test 2" cmd "c2hs" "--include" sp "Issue30.chs" cmd cc "-c" "-o" "issue30_c.o" "issue30.c" cmd cc "-c" "-o" "issue30aux1_c.o" "issue30aux1.c" cmd cc "-c" "-o" "issue30aux2_c.o" "issue30aux2.c" cmd "ghc" "--make" "issue30_c.o" "issue30aux1_c.o" "issue30aux2_c.o" "Issue30Aux1.hs" "Issue30Aux2.hs" "Issue30.hs" res <- absPath "./Issue30" >>= cmd let expected = ["3", "2", "4"] liftIO $ assertBool "" (T.lines res == expected) issue29 :: Assertion issue29 = c2hsShelly $ do errExit False $ do cd "tests/bugs/issue-29" mapM_ rm_f ["Issue29.hs", "Issue29.chs.h", "Issue29.chi"] run "c2hs" [toTextIgnore "Issue29.chs"] code <- lastExitCode liftIO $ assertBool "" (code == 0) issue25 :: Assertion issue25 = hs_only_expect_issue 25 True ["-1", "abcdef"] issue23 :: Assertion issue23 = expect_issue 23 ["H1"] issue22 :: Assertion issue22 = expect_issue 22 ["abcdef", "2", "20"] issue20 :: Assertion issue20 = expect_issue 20 ["4"] issue19 :: Assertion issue19 = expect_issue 19 ["Did it!"] issue16 :: Assertion issue16 = build_issue 16 issue15 :: Assertion issue15 = expect_issue 15 ["True"] issue10 :: Assertion issue10 = expect_issue 10 ["SAME", "SAME", "SAME", "SAME", "SAME"] issue09 :: Assertion issue09 = expect_issue 9 $ archdep ++ ["(32,64)", "64", "OK"] where archdep | (maxBound::Int) == 2147483647 = ["PTA:4", "AOP:16"] -- 32 bit | otherwise = ["PTA:8", "AOP:32"] -- 64 bit issue07 :: Assertion issue07 = c2hsShelly $ do errExit False $ do cd "tests/bugs/issue-7" mapM_ rm_f ["Issue7.hs", "Issue7.chs.h", "Issue7.chi"] setenv "LANG" "zh_CN.utf8" run "c2hs" [toTextIgnore "Issue7.chs"] code <- lastExitCode liftIO $ assertBool "" (code == 0) do_issue_build :: Bool -> Bool -> Int -> String -> String -> [Text] -> Sh () do_issue_build strict cbuild n suff ext c2hsargs = let wdir = "tests/bugs" ("issue-" <> show n) lc = "issue" <> show n lcc = lc <> "_c" uc = fromText $ T.pack $ "Issue" <> show n <> suff <> (if ext == "" then "" else "_" <> ext) in do cd wdir mapM_ rm_f [uc <.> "hs", uc <.> "chs.h", uc <.> "chi", lcc <.> "o", uc] run "c2hs" $ c2hsargs ++ [toTextIgnore $ uc <.> "chs"] code <- lastExitCode when (code == 0) $ do when cbuild $ cmd cc "-c" "-o" (lcc <.> "o") (lc <.> "c") code <- lastExitCode when (code == 0) $ case (strict, cbuild) of (True, True) -> cmd "ghc" "-Wall" "-Werror" "--make" (lcc <.> "o") (uc <.> "hs") (False, True) -> cmd "ghc" "--make" (lcc <.> "o") (uc <.> "hs") (True, False) -> cmd "ghc" "-Wall" "-Werror" "--make" (uc <.> "hs") (False, False) -> cmd "ghc" "--make" (uc <.> "hs") expect_issue :: Int -> [Text] -> Assertion expect_issue n expected = expect_issue_with True True n "" [] expected unordered_expect_issue :: Int -> [Text] -> Assertion unordered_expect_issue n expected = expect_issue_with False True n "" [] expected hs_only_expect_issue :: Int -> Bool -> [Text] -> Assertion hs_only_expect_issue n ordered expected = expect_issue_with ordered False n "" [] expected expect_issue_with :: Bool -> Bool -> Int -> String -> [Text] -> [Text] -> Assertion expect_issue_with ordered cbuild n ext c2hsargs expected = c2hsShelly $ do do_issue_build True cbuild n "" ext c2hsargs res <- absPath ("." (fromText $ T.pack $ "Issue" <> show n <> (if ext == "" then "" else "_" <> ext))) >>= cmd liftIO $ assertBool "" $ case ordered of True -> T.lines res == expected False -> sort (T.lines res) == sort expected build_issue_with :: Bool -> Bool -> Int -> [Text] -> Assertion build_issue_with strict cbuild n c2hsargs = c2hsShelly $ do errExit False $ do_issue_build strict cbuild n "" "" c2hsargs code <- lastExitCode liftIO $ assertBool "" (code == 0) build_issue :: Int -> Assertion build_issue n = build_issue_with True True n [] build_issue_tolerant :: Int -> Assertion build_issue_tolerant n = build_issue_with False True n [] hs_only_build_issue :: Int -> Assertion hs_only_build_issue n = build_issue_with True False n [] build_issue_fails_with :: Bool -> Bool -> Int -> [Text] -> Assertion build_issue_fails_with strict cbuild n c2hsargs = c2hsShelly $ do errExit False $ do_issue_build strict cbuild n "" "" c2hsargs code <- lastExitCode liftIO $ assertBool "" (code /= 0) build_issue_fails :: Int -> Assertion build_issue_fails n = build_issue_fails_with True True n [] hs_only_build_issue_fails :: Int -> Assertion hs_only_build_issue_fails n = build_issue_fails_with True False n [] c2hs-0.28.1/tests/test-system.hs0000644000000000000000000001007512677513064014644 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, assert) import Control.Monad.IO.Class import Shelly import qualified Shelly as Sh import Prelude hiding (FilePath) import Control.Monad (forM_) import Data.Text (Text) import Data.Monoid import System.Info (os) import qualified Data.Text as T import Paths_c2hs default (T.Text) main :: IO () main = defaultMain tests c2hsShelly :: MonadIO m => Sh a -> m a c2hsShelly as = shelly $ do oldpath <- get_env_text "PATH" let newpath = "../../../dist/build/c2hs:" <> oldpath setenv "PATH" newpath as cc :: FilePath cc = if os == "cygwin32" || os == "mingw32" then "gcc" else "cc" tests :: [Test] tests = [ testGroup "System" [ testCase "Calls" test_calls , testCase "Cpp" test_cpp , testCase "Enums" test_enums , testCase "Marsh" test_marsh , testCase "Pointer" test_pointer , testCase "Simple" test_simple -- , testCase "Sizeof" test_sizeof -- KNOWN FAILURE: ISSUE #10 , testCase "Structs" test_structs ] ] run_test_exit_code :: Sh.FilePath -> [(Sh.FilePath, [Text])] -> Assertion run_test_exit_code dir cmds = c2hsShelly $ chdir dir $ do forM_ (init cmds) $ \(c, as) -> run c as errExit False $ run (fst $ last cmds) (snd $ last cmds) code <- lastExitCode liftIO $ assertBool "" (code == 0) run_test_expect :: Sh.FilePath -> [(Sh.FilePath, [Text])] -> Sh.FilePath -> [Text] -> Assertion run_test_expect dir cmds expcmd expected = c2hsShelly $ chdir dir $ do forM_ cmds $ \(c, as) -> run c as res <- absPath expcmd >>= cmd liftIO $ assertBool "" (T.lines res == expected) test_calls :: Assertion test_calls = run_test_exit_code "tests/system/calls" [("c2hs", ["calls.h", "Calls.chs"]), ("ghc", ["-c", "Calls.hs"])] test_cpp :: Assertion test_cpp = run_test_exit_code "tests/system/cpp" [("c2hs", ["Cpp.chs"]), ("ghc", ["-c", "Cpp.hs"])] test_enums :: Assertion test_enums = run_test_expect "tests/system/enums" [("c2hs", ["enums.h", "Enums.chs"]), (cc, ["-o", "enums_c.o", "-c", "enums.c"]), ("ghc", ["-o", "enums", "enums_c.o", "Enums.hs"])] "./enums" ["Did it!"] test_marsh :: Assertion test_marsh = run_test_expect "tests/system/marsh" [("c2hs", ["marsh.h", "Marsh.chs"]), ("ghc", ["-o", "marsh", "Marsh.hs"])] "./marsh" ["Hello World!", "[5,3,7]"] -- Issue #21 test_pointer :: Assertion test_pointer = run_test_exit_code "tests/system/pointer" [("c2hs", ["pointer.h", "Pointer.chs"]), (cc, ["-o", "pointer_c.o", "-c", "pointer.c"]), ("ghc", ["-o", "pointer", "pointer_c.o", "Pointer.hs"])] test_simple :: Assertion test_simple = run_test_expect "tests/system/simple" [("c2hs", ["simple.h", "Simple.chs"]), ("ghc", ["-c", "-o", "Simple_hs.o", "Simple.hs"]), (cc, ["-c", "simple.c"]), ("ghc", ["-o", "simple", "simple.o", "Simple_hs.o"])] "./simple" ["I am the mighty foo!"] -- Issue #10 test_sizeof :: Assertion test_sizeof = run_test_expect "tests/system/sizeof" [("c2hs", ["sizeof.h", "Sizeof.chs"]), ("ghc", ["-c", "-o", "Sizeof.o", "Sizeof.hs"]), (cc, ["-o", "sizeof_c.o", "-c", "sizeof.c"]), ("ghc", ["-o", "sizeof", "sizeof_c.o", "Sizeof.o"])] "./sizeof" ["16 & 64 & 4 & 10", "8 & 8 & 4 & 4"] test_structs :: Assertion test_structs = run_test_expect "tests/system/structs" [("c2hs", ["structs.h", "Structs.chs"]), ("ghc", ["-c", "-o", "Structs.o", "Structs.hs"]), (cc, ["-o", "structs_c.o", "-c", "structs.c"]), ("ghc", ["-o", "structs", "structs_c.o", "Structs.o"])] "./structs" ["42 & -1 & 2 & 200 & ' '"] c2hs-0.28.1/tests/bugs/0000755000000000000000000000000012677513065012745 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-80/0000755000000000000000000000000012677513065014322 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-80/issue80.h0000644000000000000000000000006112677513065015770 0ustar0000000000000000enum foo { A = 1, B = 2, C = 2, D = 3 }; c2hs-0.28.1/tests/bugs/issue-80/issue80.c0000644000000000000000000000000012677513065015754 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-80/Issue80.chs0000644000000000000000000000043712677513065016265 0ustar0000000000000000module Main where import Control.Monad (forM_) #ifdef DUMMY #include "rubbish.h" #else #include "issue80.h" #endif {#enum foo as Foo {underscoreToCase} deriving (Eq, Show)#} main :: IO () main = do forM_ [A, B, C, D] $ \v -> putStrLn $ show v ++ "=" ++ (show $ fromEnum v) c2hs-0.28.1/tests/bugs/issue-131/0000755000000000000000000000000012677513065014377 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-131/issue131.h0000644000000000000000000000006712677513065016130 0ustar0000000000000000#include int f1(int, bool); bool f2(int); c2hs-0.28.1/tests/bugs/issue-131/issue131.c0000644000000000000000000000024312677513065016117 0ustar0000000000000000#include #include "issue131.h" int f1(int n, bool incr) { if (incr) return n + 1; else return n - 1; } bool f2(int n) { return n > 0; } c2hs-0.28.1/tests/bugs/issue-131/Issue131.chs0000644000000000000000000000044712677513065016420 0ustar0000000000000000module Main where import Control.Monad import Foreign.C.Types import Foreign.Marshal.Utils #include "issue131.h" {#fun f1 as ^ {`Int', `Bool'} -> `Int'#} {#fun f2 as ^ {`Int'} -> `Bool'#} main :: IO () main = do f1 4 True >>= print f1 4 False >>= print f2 4 >>= print f2 0 >>= print c2hs-0.28.1/tests/bugs/issue-107/0000755000000000000000000000000012677513065014402 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-107/Issue107.chs0000644000000000000000000000021212677513065016414 0ustar0000000000000000module Main where check :: Bool #if (C2HS_MIN_VERSION(0,19,1)) check = True #else check = False #endif main :: IO () main = print check c2hs-0.28.1/tests/bugs/issue-44/0000755000000000000000000000000012677513065014322 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-44/Issue44.chs0000644000000000000000000000016612677513065016264 0ustar0000000000000000module Main where #include "issue44.h" {#pointer *foo as ^ foreign newtype#} main :: IO () main = putStrLn "dummy" c2hs-0.28.1/tests/bugs/issue-44/issue44.c0000644000000000000000000000000012677513065015754 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-44/issue44.h0000644000000000000000000000003712677513065015773 0ustar0000000000000000typedef struct { int a; } foo; c2hs-0.28.1/tests/bugs/issue-47/0000755000000000000000000000000012677513065014325 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-47/issue47.h0000644000000000000000000000001712677513065015777 0ustar0000000000000000void foo(int); c2hs-0.28.1/tests/bugs/issue-47/Issue47.chs0000644000000000000000000000014112677513065016263 0ustar0000000000000000module Main where #include "issue47.h" {#fun foo {`Int'} -> `()'#} main :: IO () main = foo 2 c2hs-0.28.1/tests/bugs/issue-47/issue47.c0000644000000000000000000000002412677513065015770 0ustar0000000000000000void foo(int n) { } c2hs-0.28.1/tests/bugs/issue-10/0000755000000000000000000000000012677513065014313 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-10/Issue10.chs0000644000000000000000000000153712677513065016251 0ustar0000000000000000module Main where import Control.Monad #include "issue10.h" check :: Int -> Int -> IO () check sz szexpect = putStrLn $ if sz == szexpect then "SAME" else ("DIFF: " ++ show sz ++ " vs. " ++ show szexpect) main :: IO () main = do let sz1 = {# sizeof S1 #} :: Int sz1expect <- liftM fromIntegral {# call size_of_s1 #} :: IO Int let sz2 = {# sizeof S2 #} :: Int sz2expect <- liftM fromIntegral {# call size_of_s2 #} :: IO Int let sz3 = {# sizeof S3 #} :: Int sz3expect <- liftM fromIntegral {# call size_of_s3 #} :: IO Int let sz4 = {# sizeof S4 #} :: Int sz4expect <- liftM fromIntegral {# call size_of_s4 #} :: IO Int let sz5 = {# sizeof S5 #} :: Int sz5expect <- liftM fromIntegral {# call size_of_s5 #} :: IO Int check sz1 sz1expect check sz2 sz2expect check sz3 sz3expect check sz4 sz4expect check sz5 sz5expect c2hs-0.28.1/tests/bugs/issue-10/issue10.c0000644000000000000000000000040112677513065015743 0ustar0000000000000000#include "issue10.h" size_t size_of_s1(void) { return sizeof(S1); } size_t size_of_s2(void) { return sizeof(S2); } size_t size_of_s3(void) { return sizeof(S3); } size_t size_of_s4(void) { return sizeof(S4); } size_t size_of_s5(void) { return sizeof(S5); } c2hs-0.28.1/tests/bugs/issue-10/issue10.h0000644000000000000000000000072212677513065015756 0ustar0000000000000000#include size_t size_of_s1(void); size_t size_of_s2(void); size_t size_of_s3(void); size_t size_of_s4(void); size_t size_of_s5(void); typedef struct { int f1:1; int f2:1; int f3:1; int f4:1; int f5:1; } S1; typedef struct { int f1:4; int f2:3; int f3:1; int f4:8; int f5:1; } S2; typedef struct { int f1:1; } S3; typedef struct { unsigned int b0: 31; unsigned int b30: 1; } S4; typedef struct { double d; char c; } S5; c2hs-0.28.1/tests/bugs/issue-15/0000755000000000000000000000000012677513065014320 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-15/Issue15.chs0000644000000000000000000000050512677513065016255 0ustar0000000000000000module Main where import Numeric import Data.Char #include "issue15.h" {#enum Tst as ^ {underscoreToCase} deriving (Eq, Show)#} main :: IO () main = do tst <- {#call tst_val#} let chk1 = showIntAtBase 16 intToDigit tst "" chk2 = showIntAtBase 16 intToDigit (fromEnum Kclippingcreator) "" print $ chk1 == chk2 c2hs-0.28.1/tests/bugs/issue-15/issue15.c0000644000000000000000000000005512677513065015762 0ustar0000000000000000const int tst_val(void) { return 'drag'; } c2hs-0.28.1/tests/bugs/issue-15/issue15.h0000644000000000000000000000030312677513065015763 0ustar0000000000000000const int tst_val(void); enum Tst { kClippingCreator = 'drag', kClippingPictureType = 'clpp', kClippingTextType = 'clpt', kClippingSoundType = 'clps', kClippingUnknownType = 'clpu' }; c2hs-0.28.1/tests/bugs/issue-43/0000755000000000000000000000000012677513065014321 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-43/Issue43.chs0000644000000000000000000000063412677513065016262 0ustar0000000000000000module Main where import Control.Monad (forM_) #include "issue43.h" {#enum Test1 {underscoreToCase} deriving (Eq, Show)#} {#enum ANON_A as Anon {underscoreToCase} deriving (Eq, Show)#} main :: IO () main = do forM_ [Test1A, Test1B, Test1C, Test1D] $ \v -> putStrLn $ show v ++ "=" ++ (show $ fromEnum v) forM_ [AnonA, AnonB, AnonC, AnonD] $ \v -> putStrLn $ show v ++ "=" ++ (show $ fromEnum v) c2hs-0.28.1/tests/bugs/issue-43/issue43.h0000644000000000000000000000017312677513065015772 0ustar0000000000000000enum Test1 { TEST1_A, TEST1_B, TEST1_C = 5, TEST1_D }; enum { ANON_A = 8, ANON_B, ANON_C = 15, ANON_D }; c2hs-0.28.1/tests/bugs/issue-43/issue43.c0000644000000000000000000000000012677513065015752 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-46/0000755000000000000000000000000012677513065014324 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-46/issue46.h0000644000000000000000000000022212677513065015773 0ustar0000000000000000typedef struct { int a; float b; char dummy; } oid; void func(oid *obj, int aval, float bval); int oid_a(oid *obj); float oid_b(oid *obj); c2hs-0.28.1/tests/bugs/issue-46/Issue46.chs0000644000000000000000000000044712677513065016272 0ustar0000000000000000module Main where #include "issue46.h" {#pointer *oid as Oid foreign newtype#} {#fun func as ^ {+, `Int', `Float'} -> `Oid'#} {#fun oid_a as ^ {`Oid'} -> `Int'#} {#fun oid_b as ^ {`Oid'} -> `Float'#} main :: IO () main = do obj <- func 1 2.5 a <- oidA obj b <- oidB obj print (a, b) c2hs-0.28.1/tests/bugs/issue-46/issue46.c0000644000000000000000000000027412677513065015775 0ustar0000000000000000#include "issue46.h" void func(oid *obj, int aval, float bval) { obj->a = aval; obj->b = bval; } int oid_a(oid *obj) { return obj->a; } float oid_b(oid *obj) { return obj->b; } c2hs-0.28.1/tests/bugs/issue-16/0000755000000000000000000000000012677513065014321 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-16/issue16.c0000644000000000000000000000000012677513065015752 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-16/Issue16.chs0000644000000000000000000000006612677513065016261 0ustar0000000000000000#include "issue16.h" main :: IO () main = return () c2hs-0.28.1/tests/bugs/issue-16/issue16.h0000644000000000000000000000000012677513065015757 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-113/0000755000000000000000000000000012677513065014377 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-113/issue113.c0000644000000000000000000000000012677513065016106 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-113/issue113.h0000644000000000000000000000003612677513065016124 0ustar0000000000000000enum annoying { annoying_0 }; c2hs-0.28.1/tests/bugs/issue-113/Issue113.chs0000644000000000000000000000022112677513065016406 0ustar0000000000000000module Main where #include "issue113.h" {#enum annoying as Annoying {0 as Zero} with prefix = "annoying"#} main :: IO () main = putStrLn "OK" c2hs-0.28.1/tests/bugs/issue-102/0000755000000000000000000000000012677513065014375 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-102/Issue102.chs0000644000000000000000000000331712677513065016413 0ustar0000000000000000module Main where #include #include {#pointer *FILE as File foreign finalizer fclose newtype#} {#fun fopen as ^ {`String', `String'} -> `File'#} {#fun fileno as ^ {`File'} -> `Int'#} {#fun variadic fprintf[int] as fprinti {`File', `String', `Int'} -> `()'#} {#fun variadic fprintf[int, int] as fprinti2 {`File', `String', `Int', `Int'} -> `()'#} {#fun variadic fprintf[const char *] as fprints {`File', `String', `String'} -> `()'#} {#fun variadic printf[int] as printi {`String', `Int'} -> `()'#} {#fun variadic printf[int, int] as printi2 {`String', `Int', `Int'} -> `()'#} {#fun variadic printf[const char *] as prints {`String', `String'} -> `()'#} {#enum define FCntlAction {F_GETLK as GetLock, F_SETLK as SetLock} deriving (Eq, Ord, Show)#} {#enum define FCntlLockState {F_RDLCK as ReadLock, F_WRLCK as WriteLock, F_UNLCK as Unlocked} deriving (Eq, Ord, Show)#} {#pointer *flock as FLock foreign newtype#} {#fun variadic fcntl[struct flock *] as f_get_lock {`Int', `Int', +} -> `FLock'#} {#fun variadic fcntl[struct flock *] as f_set_lock {`Int', `Int', `FLock'} -> `Int'#} main :: IO () main = do f <- fopen "issue-102.txt" "w" fd <- fileno f printi "TST 1: %d\n" 1234 printi2 "TST 2: %d %d\n" 13 47 prints "TST 3: %s\n" "testing" fprinti f "TST 1: %d\n" 1234 fprinti2 f "TST 2: %d %d\n" 13 47 fprints f "TST 3: %s\n" "testing" flck <- get_lock fd withFLock flck $ \lck -> do typ <- {#get flock.l_type#} lck print (toEnum $ fromIntegral typ :: FCntlLockState) get_lock :: Int -> IO FLock get_lock fd = f_get_lock fd (fromEnum GetLock) set_lock :: Int -> FLock -> IO Int set_lock fd lck = f_set_lock fd (fromEnum SetLock) lck c2hs-0.28.1/tests/bugs/issue-93/0000755000000000000000000000000012677513065014326 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-93/Issue93.chs0000644000000000000000000000141112677513065016266 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-} module Main where import Control.Applicative import Foreign.C.Types import Foreign.Marshal.Utils import Foreign.Storable import Foreign.Ptr #include "issue93.h" data Foo data Bar = Bar Int Int instance Storable Bar where sizeOf _ = {#sizeof bar_t #} alignment _ = {#alignof bar_t #} peek p = Bar <$> (fromIntegral <$> {#get bar_t.y #} p) <*> (fromIntegral <$> {#get bar_t.z #} p) poke p (Bar y z) = ({#set bar_t.y #} p $ fromIntegral y) *> ({#set bar_t.z #} p $ fromIntegral z) {#pointer *foo_t as FooPtr -> Foo #} {#pointer *bar_t as BarPtr -> Bar #} {#fun unsafe mutate_foo as mutateFoo { `FooPtr' , with* `Bar' } -> `()' #} main :: IO () main = putStrLn "OK" c2hs-0.28.1/tests/bugs/issue-93/issue93.h0000644000000000000000000000021712677513065016003 0ustar0000000000000000typedef struct { int y; int z; } bar_t; typedef struct { int x; bar_t bar; } foo_t; void mutate_foo(foo_t *foo, bar_t *bar); c2hs-0.28.1/tests/bugs/issue-93/issue93.c0000644000000000000000000000012712677513065015776 0ustar0000000000000000#include "issue93.h" void mutate_foo(foo_t *foo, bar_t *bar) { foo->bar = *bar; } c2hs-0.28.1/tests/bugs/issue-83/0000755000000000000000000000000012677513065014325 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-83/Issue83.chs0000644000000000000000000000234112677513065016267 0ustar0000000000000000module Main where import Control.Monad import Foreign.Ptr import Foreign.C.String import Foreign.C.Types #include #include #include -- This is for testing marshalling of C... types, e.g. CInt, etc. {#fun strcmp as ^ {`CString', `CString'} -> `CInt'#} {#fun setenv as ^ {`String', `String', `Int'} -> `Int'#} {#fun getenv as ^ {`String'} -> `CString'#} {#fun sin as hsin {`Double'} -> `Double'#} {#fun sin as csin {`CDouble'} -> `CDouble'#} {#fun malloc as ^ {`CULong'} -> `Ptr ()'#} {#fun free as ^ {`Ptr ()'} -> `()'#} {#fun strcpy as ^ {`CString', `CString'} -> `()'#} main :: IO () main = do let s1 = "abc" ; s2 = "def" ; s3 = "def" res1 <- withCString s1 $ \cs1 -> withCString s2 $ \cs2 -> strcmp cs1 cs2 res2 <- withCString s2 $ \cs2 -> withCString s3 $ \cs3 -> strcmp cs2 cs3 print (res1 < 0, res2 == 0) void $ setenv "TEST_VAR" "TEST_VAL" 1 h <- getenv "TEST_VAR" peekCString h >>= putStrLn cx <- csin 1.0 print (round (10000 * cx) :: Integer) hx <- hsin 1.0 print (round (10000 * hx) :: Integer) let s = "TESTING" p <- malloc $ fromIntegral $ length s + 1 let ps = castPtr p :: CString cs <- newCString s strcpy ps cs res <- peekCString ps putStrLn res free p c2hs-0.28.1/tests/bugs/issue-149/0000755000000000000000000000000012677513065014410 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-149/issue149.h0000644000000000000000000000002412677513065016143 0ustar0000000000000000void test(int arg); c2hs-0.28.1/tests/bugs/issue-149/issue149.c0000644000000000000000000000011012677513065016132 0ustar0000000000000000#include void test(int arg) { printf("test: %d\n", arg); } c2hs-0.28.1/tests/bugs/issue-149/Issue149.chs0000644000000000000000000000017312677513065016436 0ustar0000000000000000module Main where #include "issue149.h" {#fun unsafe test as ^ {} -> `()'#} main :: IO () main = do test print "OK" c2hs-0.28.1/tests/bugs/issue-22/0000755000000000000000000000000012677513065014316 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-22/Issue22.chs0000644000000000000000000000140112677513065016245 0ustar0000000000000000module Main where import Foreign import Foreign.C #include "issue22.h" {#pointer *struct_t as Struct#} {#pointer *substruct_t as SubStruct#} ptrToField :: Struct -> Ptr CChar ptrToField p = p `plusPtr` {#offsetof struct_t->somefield#} ptrToMember :: Struct -> SubStruct ptrToMember p = p `plusPtr` {#offsetof struct_t->substruct#} ptrToMemberPtr :: Struct -> Ptr SubStruct ptrToMemberPtr p = p `plusPtr` {#offsetof struct_t->substruct_p#} {#fun foo {`Int'} -> `Struct' return* #} main :: IO () main = do p <- foo 2 let fldp = ptrToField p subp = ptrToMember p subpp <- peek $ ptrToMemberPtr p s <- peekCString fldp subval <- {#get substruct_t.field#} subp subpval <- {#get substruct_t.field#} subpp putStrLn s print subval print subpval c2hs-0.28.1/tests/bugs/issue-22/issue22.c0000644000000000000000000000033112677513065015753 0ustar0000000000000000#include #include "issue22.h" struct_t s; substruct_t subs; struct_t *foo(int n) { strcpy(s.somefield, "abcdef"); s.substruct.field = n; s.substruct_p = &subs; subs.field = n * 10; return &s; } c2hs-0.28.1/tests/bugs/issue-22/issue22.h0000644000000000000000000000026512677513065015766 0ustar0000000000000000typedef struct { int field; } substruct_t; typedef struct { char somefield[32]; substruct_t substruct; substruct_t* substruct_p; } struct_t; struct_t *foo(int n); c2hs-0.28.1/tests/bugs/issue-117/0000755000000000000000000000000012677513065014403 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-117/issue117.c0000644000000000000000000000045512677513065016134 0ustar0000000000000000#include #include "issue117.h" int coord_x(coord_t c, int dummy) { return c.x; } coord_t *make_coord(int x, int y) { coord_t *coord; coord = (coord_t *)malloc(sizeof(coord_t)); coord->x = x; coord->y = y; return coord; } void free_coord(coord_t *coord) { free(coord); } c2hs-0.28.1/tests/bugs/issue-117/Issue117.chs0000644000000000000000000000066212677513065016427 0ustar0000000000000000module Main where import Control.Monad import Foreign.Ptr import Foreign.ForeignPtr import Foreign.C.Types import System.IO.Unsafe #include "issue117.h" {#pointer *coord_t as CoordPtr foreign finalizer free_coord newtype#} {#fun pure make_coord as makeCoord {`Int', `Int'} -> `CoordPtr'#} {#fun pure coord_x as coordX {%`CoordPtr', `Int'} -> `Int'#} main :: IO () main = do let c = makeCoord 5 6 let x = coordX c 0 print x c2hs-0.28.1/tests/bugs/issue-117/issue117.h0000644000000000000000000000022612677513065016135 0ustar0000000000000000typedef struct { int x; int y; } coord_t; coord_t *make_coord(int x, int y); void free_coord(coord_t *coord); int coord_x(coord_t c, int dummy); c2hs-0.28.1/tests/bugs/issue-96/0000755000000000000000000000000012677513065014331 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-96/issue96.h0000644000000000000000000000011512677513065016006 0ustar0000000000000000typedef struct { int x; int y; } foo_t; void simple_func(foo_t *f); c2hs-0.28.1/tests/bugs/issue-96/issue96.c0000644000000000000000000000006512677513065016005 0ustar0000000000000000#include "issue96.h" void simple_func(foo_t *f) { } c2hs-0.28.1/tests/bugs/issue-96/Issue96.chs0000644000000000000000000000045512677513065016303 0ustar0000000000000000module Main where import Foreign.C.Types #include "issue96.h" {# pointer *foo_t as FooPtr newtype #} get :: FooPtr -> IO CInt get = {# get foo_t.x #} set :: FooPtr -> CInt -> IO () set = {# set foo_t.x #} call :: FooPtr -> IO () call = {# call simple_func #} main :: IO () main = putStrLn "OK" c2hs-0.28.1/tests/bugs/issue-82/0000755000000000000000000000000012677513065014324 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-82/Issue82.chs0000644000000000000000000000011312677513065016260 0ustar0000000000000000module Main where #include "string.h" main :: IO () main = putStrLn "OK" c2hs-0.28.1/tests/bugs/issue-123/0000755000000000000000000000000012677513065014400 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-123/issue123.h0000644000000000000000000000025212677513065016126 0ustar0000000000000000#pragma once typedef struct { int a[3]; /* An array of length 3. */ int *p; /* A pointer to an array. */ } array_t; array_t *get_struct(int n, int m, int o); c2hs-0.28.1/tests/bugs/issue-123/issue123.c0000644000000000000000000000044712677513065016127 0ustar0000000000000000#include "issue123.h" array_t myStruct; int other_a[3]; array_t *get_struct(int n, int m, int o) { myStruct.a[0] = n; myStruct.a[1] = m; myStruct.a[2] = o; other_a[0] = n + 1; other_a[1] = m + 1; other_a[2] = o + 1; myStruct.p = other_a; return &myStruct; } c2hs-0.28.1/tests/bugs/issue-123/Issue123.chs0000644000000000000000000000121012677513065016407 0ustar0000000000000000module Main where import Foreign #include "issue123.h" {#pointer *array_t as MyStruct#} {#fun get_struct {`Int', `Int', `Int'} -> `MyStruct' return* #} main :: IO () main = do myStruct <- get_struct 7 42 93 p1 <- {#get array_t->p#} myStruct >>= peekArray 3 print p1 a1 <- {#get array_t->a#} myStruct >>= peekArray 3 print a1 cInts <- mallocArray 3 pokeArray cInts [2, 4, 8] {#set array_t->p#} myStruct cInts p2 <- {#get array_t->p#} myStruct >>= peekArray 3 print p2 pokeArray cInts [3, 9, 27] {#set array_t->a#} myStruct cInts a2 <- {#get array_t->a#} myStruct >>= peekArray 3 print a2 c2hs-0.28.1/tests/bugs/issue-38/0000755000000000000000000000000012677513065014325 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-38/issue38.c0000644000000000000000000000025012677513065015771 0ustar0000000000000000#include "issue38.h" test_enum enum_test(test_enum n) { switch (n) { case TEST_A: return TEST_B; case TEST_B: return TEST_C; case TEST_C: return TEST_A; } } c2hs-0.28.1/tests/bugs/issue-38/issue38.h0000644000000000000000000000021712677513065016001 0ustar0000000000000000typedef enum { TEST_A, TEST_B, TEST_C, TEST_A_ALIAS = TEST_A, TEST_C_ALIAS = TEST_C } test_enum; test_enum enum_test(test_enum n); c2hs-0.28.1/tests/bugs/issue-38/Issue38.chs0000644000000000000000000000060412677513065016267 0ustar0000000000000000module Main where #include "issue38.h" {#enum test_enum as TestEnum {underscoreToCase} deriving (Eq, Show)#} {#fun enum_test {`TestEnum'} -> `TestEnum'#} main :: IO () main = do res1 <- enum_test TestA res2 <- enum_test TestB res3 <- enum_test TestC case (res1, res2, res3) of (TestB, TestC, TestA) -> putStrLn "Enum OK" _ -> putStrLn "Enum FAILED" c2hs-0.28.1/tests/bugs/issue-141/0000755000000000000000000000000012677513065014400 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-141/Issue141C.chs0000644000000000000000000000016312677513065016520 0ustar0000000000000000module Main where #include "issue141.h" main :: IO () main = do let f = {#get _p_Vec->fieldname#} print "OK" c2hs-0.28.1/tests/bugs/issue-141/Issue141A.chs0000644000000000000000000000015112677513065016513 0ustar0000000000000000module Main where #include "issue141.h" main :: IO () main = do print {#sizeof _p_Vec#} print "OK" c2hs-0.28.1/tests/bugs/issue-141/issue141.h0000644000000000000000000000003412677513065016124 0ustar0000000000000000typedef struct _p_Vec *Vec; c2hs-0.28.1/tests/bugs/issue-141/Issue141B.chs0000644000000000000000000000015212677513065016515 0ustar0000000000000000module Main where #include "issue141.h" main :: IO () main = do print {#alignof _p_Vec#} print "OK" c2hs-0.28.1/tests/bugs/issue-151/0000755000000000000000000000000012677513065014401 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-151/issue151.h0000644000000000000000000000006312677513065016130 0ustar0000000000000000typedef void (*CPLErrorHandler)(int, const char*); c2hs-0.28.1/tests/bugs/issue-151/Issue151.chs0000644000000000000000000000022312677513065016414 0ustar0000000000000000module Issue151 where {# context lib = "gdal" prefix = "CPL" #} #include "issue151.h" {#pointer ErrorHandler#} main :: IO () main = print "OK" c2hs-0.28.1/tests/bugs/issue-95/0000755000000000000000000000000012677513065014330 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-95/Issue95.chs0000644000000000000000000000023212677513065016272 0ustar0000000000000000module Main where #include "issue95.h" main :: IO () main = do let s = {# sizeof foo #} :: Int a = {# alignof foo #} :: Int print s print a c2hs-0.28.1/tests/bugs/issue-95/issue95.h0000644000000000000000000000005312677513065016005 0ustar0000000000000000struct foo { int x; int y; int z; }; c2hs-0.28.1/tests/bugs/issue-95/issue95.c0000644000000000000000000000000012677513065015770 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-25/0000755000000000000000000000000012677513065014321 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-25/Issue25.chs0000644000000000000000000000057312677513065016264 0ustar0000000000000000module Main where import Foreign.C #include {#typedef wchar_t CWchar#} {#default in `String' [wchar_t *] withCWString* #} {#default out `String' [wchar_t *] peekCWString* #} {#fun wcscmp {`String', `String'} -> `Int'#} {#fun wcscat {`String', `String'} -> `String'#} main :: IO () main = do wcscmp "abc" "def" >>= print . signum wcscat "abc" "def" >>= putStrLn c2hs-0.28.1/tests/bugs/issue-30/0000755000000000000000000000000012677513065014315 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-30/Issue30Aux1.chs0000644000000000000000000000016312677513065017006 0ustar0000000000000000module Issue30Aux1 where import Foreign import Foreign.C #include "issue30aux1.h" {#fun foo1 {`Int'} -> `Int'#} c2hs-0.28.1/tests/bugs/issue-30/issue30.h0000644000000000000000000000001612677513065015756 0ustar0000000000000000int foo(int); c2hs-0.28.1/tests/bugs/issue-30/issue30aux2.h0000644000000000000000000000001712677513065016557 0ustar0000000000000000int foo2(int); c2hs-0.28.1/tests/bugs/issue-30/Issue30.chs0000644000000000000000000000037212677513065016251 0ustar0000000000000000module Main where import Foreign import Foreign.C {#import Issue30Aux1#} {#import Issue30Aux2#} #include "issue30.h" {#fun foo {`Int'} -> `Int'#} main :: IO () main = do f <- foo 2 f1 <- foo1 1 f2 <- foo2 1 print f print f1 print f2 c2hs-0.28.1/tests/bugs/issue-30/issue30aux1.h0000644000000000000000000000001712677513065016556 0ustar0000000000000000int foo1(int); c2hs-0.28.1/tests/bugs/issue-30/issue30aux1.c0000644000000000000000000000004212677513065016547 0ustar0000000000000000int foo1(int n) { return n * 2; } c2hs-0.28.1/tests/bugs/issue-30/issue30.c0000644000000000000000000000004112677513065015747 0ustar0000000000000000int foo(int n) { return n + 1; } c2hs-0.28.1/tests/bugs/issue-30/Issue30Aux2.chs0000644000000000000000000000016312677513065017007 0ustar0000000000000000module Issue30Aux2 where import Foreign import Foreign.C #include "issue30aux2.h" {#fun foo2 {`Int'} -> `Int'#} c2hs-0.28.1/tests/bugs/issue-30/issue30aux2.c0000644000000000000000000000004212677513065016550 0ustar0000000000000000int foo2(int n) { return n * 4; } c2hs-0.28.1/tests/bugs/issue-20/0000755000000000000000000000000012677513065014314 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-20/Issue20.chs0000644000000000000000000000027612677513065016252 0ustar0000000000000000module Main where import Foreign.C #include "issue20.h" {#typedef size_t CSize#} {#fun foo {`Int'} -> `CSize'#} main :: IO () main = do s1 <- foo 1 s4 <- foo 4 print $ s4 `div` s1 c2hs-0.28.1/tests/bugs/issue-20/issue20.h0000644000000000000000000000005012677513065015752 0ustar0000000000000000#include size_t foo(int n); c2hs-0.28.1/tests/bugs/issue-20/issue20.c0000644000000000000000000000010512677513065015746 0ustar0000000000000000#include size_t foo(int n) { return n * sizeof(int); } c2hs-0.28.1/tests/bugs/issue-152/0000755000000000000000000000000012677513065014402 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-152/issue152.h0000644000000000000000000000005412677513065016132 0ustar0000000000000000struct a { int f; }; typedef struct a s_a; c2hs-0.28.1/tests/bugs/issue-152/Issue152.chs0000644000000000000000000000020212677513065016413 0ustar0000000000000000module Main where #include "issue152.h" f, g :: Int f = {# sizeof a #} g = {# sizeof s_a #} main :: IO () main = putStrLn "OK" c2hs-0.28.1/tests/bugs/issue-130/0000755000000000000000000000000012677513065014376 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-130/issue130.h0000644000000000000000000000005212677513065016120 0ustar0000000000000000void my_add(int *a, int *b, int *result); c2hs-0.28.1/tests/bugs/issue-130/Issue130.chs0000644000000000000000000000055012677513065016411 0ustar0000000000000000module Main where import Foreign.C.Types import Foreign.Marshal.Alloc import Foreign.Storable #include "issue130.h" main :: IO () main = do print (myAdd 1 2) print =<< myAddIO 1 2 {#fun pure unsafe my_add as myAdd {`CInt', `CInt', alloca- `CInt' peek* } -> `()'#} {#fun unsafe my_add as myAddIO {`CInt', `CInt', alloca- `CInt' peek* } -> `()'#} c2hs-0.28.1/tests/bugs/issue-130/issue130.c0000644000000000000000000000013112677513065016111 0ustar0000000000000000#include "issue130.h" void my_add(int *a, int *b, int *result) { *result = *a + *b; } c2hs-0.28.1/tests/bugs/issue-133/0000755000000000000000000000000012677513065014401 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-133/issue133.h0000644000000000000000000000005212677513065016126 0ustar0000000000000000typedef void *tdptst; typedef void tdtst; c2hs-0.28.1/tests/bugs/issue-133/Issue133.chs0000644000000000000000000000021612677513065016416 0ustar0000000000000000module Main where #include "issue133.h" {#pointer tdptst as VoidTest1#} {#pointer *tdtst as VoidTest2#} main :: IO () main = putStrLn "OK" c2hs-0.28.1/tests/bugs/issue-103/0000755000000000000000000000000012677513065014376 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-103/Issue103.chs0000644000000000000000000000032012677513065016404 0ustar0000000000000000module Main where import Foreign.C.Types #include "issue103.h" {#import Issue103A#} {#fun unsafe test_func as ^ { `TestEnum' } -> `()' #} main :: IO () main = do testFunc E1 testFunc E2 testFunc E3 c2hs-0.28.1/tests/bugs/issue-103/issue103.c0000644000000000000000000000031212677513065016112 0ustar0000000000000000#include "issue103.h" #include void test_func(test_enum val) { switch (val) { case E_1: printf("1\n"); return; case E_2: printf("2\n"); return; case E_3: printf("3\n"); return; } } c2hs-0.28.1/tests/bugs/issue-103/issue103.h0000644000000000000000000000012012677513065016114 0ustar0000000000000000typedef enum { E_1, E_2, E_3 } test_enum; void test_func(test_enum val); c2hs-0.28.1/tests/bugs/issue-103/Issue103A.chs0000644000000000000000000000017212677513065016512 0ustar0000000000000000module Issue103A where import Foreign.C.Types #include "issue103.h" {#enum test_enum as TestEnum {underscoreToCase} #} c2hs-0.28.1/tests/bugs/issue-51/0000755000000000000000000000000012677513065014320 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-51/Issue51_nonGNU.chs0000644000000000000000000000032412677513065017500 0ustar0000000000000000module Main where import Foreign.C {#nonGNU#} #include "issue51.h" foo :: CInt -> CInt #ifdef __GNUC__ foo = {#call pure fooGnu#} #else foo = {#call pure fooNonGnu#} #endif main :: IO () main = print $ foo 0 c2hs-0.28.1/tests/bugs/issue-51/issue51.h0000644000000000000000000000004512677513065015766 0ustar0000000000000000int fooGnu(int); int fooNonGnu(int); c2hs-0.28.1/tests/bugs/issue-51/issue51.c0000644000000000000000000000010312677513065015754 0ustar0000000000000000int fooGnu(int n) { return 1; } int fooNonGnu(int n) { return 0; } c2hs-0.28.1/tests/bugs/issue-51/Issue51_GNU.chs0000644000000000000000000000031112677513065016761 0ustar0000000000000000module Main where import Foreign.C #include "issue51.h" foo :: CInt -> CInt #ifdef __GNUC__ foo = {#call pure fooGnu#} #else foo = {#call pure fooNonGnu#} #endif main :: IO () main = print $ foo 0 c2hs-0.28.1/tests/bugs/issue-7/0000755000000000000000000000000012677513065014241 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-7/Issue7.chs0000644000000000000000000000015412677513065016117 0ustar0000000000000000module Main where #include "issue7.h" tst :: String tst = "命令行" main :: IO () main = {#call foo#} c2hs-0.28.1/tests/bugs/issue-7/issue7.h0000644000000000000000000000001512677513065015625 0ustar0000000000000000void foo (); c2hs-0.28.1/tests/bugs/issue-115/0000755000000000000000000000000012677513065014401 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-115/issue115.h0000644000000000000000000000025212677513065016130 0ustar0000000000000000#pragma once typedef struct { int a[3]; /* An array of length 3. */ int *p; /* A pointer to an array. */ } array_t; array_t *get_struct(int n, int m, int o); c2hs-0.28.1/tests/bugs/issue-115/issue115.c0000644000000000000000000000044712677513065016131 0ustar0000000000000000#include "issue115.h" array_t myStruct; int other_a[3]; array_t *get_struct(int n, int m, int o) { myStruct.a[0] = n; myStruct.a[1] = m; myStruct.a[2] = o; other_a[0] = n + 1; other_a[1] = m + 1; other_a[2] = o + 1; myStruct.p = other_a; return &myStruct; } c2hs-0.28.1/tests/bugs/issue-115/Issue115.chs0000644000000000000000000000064012677513065016417 0ustar0000000000000000module Main where import Foreign.Marshal.Array #include "issue115.h" {#pointer *array_t as MyStruct#} {#fun get_struct {`Int', `Int', `Int'} -> `MyStruct' return* #} main :: IO () main = do myStruct <- get_struct 7 42 93 p <- {#get array_t->p#} myStruct >>= peekArray 3 print p -- The following line produces a segmentation fault a <- {#get array_t->a#} myStruct >>= peekArray 3 print a c2hs-0.28.1/tests/bugs/issue-54/0000755000000000000000000000000012677513065014323 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-54/issue54.h0000644000000000000000000000020512677513065015772 0ustar0000000000000000typedef struct { int c; double d; } bar; struct foo { int a; double b; }; bar *get_bar(int n); struct foo *get_foo(int n); c2hs-0.28.1/tests/bugs/issue-54/Issue54.chs0000644000000000000000000000131312677513065016261 0ustar0000000000000000module Main where #include "issue54.h" {#pointer *bar as Bar#} {#pointer *foo as Foo#} {#fun get_bar {`Int'} -> `Bar' return* #} {#fun get_foo {`Int'} -> `Foo' return* #} main :: IO () main = do bar <- get_bar 2 c1 <- {#get bar->c#} bar d1 <- {#get bar->d#} bar print c1 print d1 c2 <- {#get bar.c#} bar d2 <- {#get bar.d#} bar print c2 print d2 foo <- get_foo 3 a1 <- {#get struct foo->a#} foo b1 <- {#get struct foo->b#} foo print a1 print b1 a2 <- {#get struct foo.a#} foo b2 <- {#get struct foo.b#} foo print a2 print b2 a3 <- {#get foo->a#} foo b3 <- {#get foo->b#} foo print a3 print b3 a4 <- {#get foo.a#} foo b4 <- {#get foo.b#} foo print a4 print b4 c2hs-0.28.1/tests/bugs/issue-54/issue54.c0000644000000000000000000000027012677513065015767 0ustar0000000000000000#include "issue54.h" bar b; struct foo f; bar *get_bar(int n) { b.c = n; b.d = n / 10.0; return &b; } struct foo *get_foo(int n) { f.a = n; f.b = n / 10.0; return &f; } c2hs-0.28.1/tests/bugs/issue-23/0000755000000000000000000000000012677513065014317 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-23/Issue23.chs0000644000000000000000000000034212677513065016252 0ustar0000000000000000module Main where #include "issue23.h" #include "issue23x.h" {#enum hello as Hello {underscoreToCase} deriving (Show)#} {#fun hello_fn {`Int'} -> `Hello'#} main :: IO () main = do res <- hello_fn 0 putStrLn $ show res c2hs-0.28.1/tests/bugs/issue-23/issue23x.h0000644000000000000000000000003312677513065016151 0ustar0000000000000000enum hello { H1, H2, H3 }; c2hs-0.28.1/tests/bugs/issue-23/issue23.c0000644000000000000000000000023612677513065015761 0ustar0000000000000000#include "issue23.h" #include "issue23x.h" enum hello hello_fn(int n) { switch (n) { case 0: return H1; case 1: return H2; default: return H3; } } c2hs-0.28.1/tests/bugs/issue-23/issue23.h0000644000000000000000000000004112677513065015760 0ustar0000000000000000extern enum hello hello_fn(int); c2hs-0.28.1/tests/bugs/issue-127/0000755000000000000000000000000012677513065014404 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-127/Issue127.chs0000644000000000000000000000021512677513065016423 0ustar0000000000000000module Main where #include "issue127.h" {#fun tst as ^ {`Int'} -> `Bool'#} main :: IO () main = do tst 5 >>= print tst (-2) >>= print c2hs-0.28.1/tests/bugs/issue-127/issue127.c0000644000000000000000000000007312677513065016132 0ustar0000000000000000#include "issue127.h" bool tst(int n) { return n > 0; } c2hs-0.28.1/tests/bugs/issue-127/issue127.h0000644000000000000000000000040212677513065016133 0ustar0000000000000000typedef unsigned char TST_BOOL; #if defined(__cplusplus) /* Use the C++ compiler's bool type */ #define TST_BOOL bool #else /* c89, c99, etc. */ /* There is no predefined bool - use our own */ #undef bool #define bool TST_BOOL #endif bool tst(int n); c2hs-0.28.1/tests/bugs/call_capital/0000755000000000000000000000000012677513065015355 5ustar0000000000000000c2hs-0.28.1/tests/bugs/call_capital/Capital.h0000644000000000000000000000002412677513065017077 0ustar0000000000000000void c(); void C(); c2hs-0.28.1/tests/bugs/call_capital/Capital.c0000644000000000000000000000016212677513065017075 0ustar0000000000000000#include "Capital.h" #include void c() { printf("lower c();\n"); } void C() { printf("upper C();\n"); } c2hs-0.28.1/tests/bugs/call_capital/Capital.chs0000644000000000000000000000016112677513065017427 0ustar0000000000000000module Main where #include "Capital.h" main = do {# call C as ^ #} {# call c as c' #} {# call C as c'' #} c2hs-0.28.1/tests/bugs/issue-128/0000755000000000000000000000000012677513065014405 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-128/issue128.c0000644000000000000000000000072012677513065016133 0ustar0000000000000000#include #include "issue128.h" int f1(int n, bool incr) { if (incr) return n + 1; else return n - 1; } bool f2(int n) { return n > 0; } tststruct *make_tststruct(int ain) { tststruct *p = (tststruct *)malloc(sizeof(tststruct)); p->a = ain; p->b = false; } void free_tststruct(tststruct *s) { free(s); } void mod_tststruct(tststruct *s, int da, bool incr) { if (incr) s->a += da; else s->a -= da; s->b = incr; } c2hs-0.28.1/tests/bugs/issue-128/issue128.h0000644000000000000000000000035712677513065016146 0ustar0000000000000000#include int f1(int n, bool incr); bool f2(int n); typedef struct { int a; bool b; } tststruct; tststruct *make_tststruct(int ain); void free_tststruct(tststruct *s); void mod_tststruct(tststruct *s, int da, bool incr); c2hs-0.28.1/tests/bugs/issue-128/Issue128.chs0000644000000000000000000000222212677513065016425 0ustar0000000000000000module Main where import Control.Monad import Foreign.Ptr import Foreign.ForeignPtr import Foreign.C.Types import Foreign.Storable import Foreign.Marshal.Utils #include "issue128.h" {#fun f1 as ^ {`Int', `Bool'} -> `Int'#} {#fun f2 as ^ {`Int'} -> `Bool'#} {#pointer *tststruct as TstStruct foreign finalizer free_tststruct newtype#} {#fun make_tststruct as makeTstStruct {`Int'} -> `TstStruct'#} {#fun mod_tststruct as modTstStruct {`TstStruct', `Int', `Bool'} -> `()'#} main :: IO () main = do f1 4 True >>= print f1 4 False >>= print f2 4 >>= print f2 0 >>= print s <- makeTstStruct 10 withTstStruct s $ \sp -> do {#get tststruct->a#} sp >>= print {#get tststruct->b#} sp >>= print modTstStruct s 2 True withTstStruct s $ \sp -> do {#get tststruct->a#} sp >>= print {#get tststruct->b#} sp >>= print modTstStruct s 5 False withTstStruct s $ \sp -> do {#get tststruct->a#} sp >>= print {#get tststruct->b#} sp >>= print withTstStruct s $ \sp -> do {#set tststruct->a#} sp 8 {#set tststruct->b#} sp True withTstStruct s $ \sp -> do {#get tststruct->a#} sp >>= print {#get tststruct->b#} sp >>= print c2hs-0.28.1/tests/bugs/issue-134/0000755000000000000000000000000012677513065014402 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-134/issue134.h0000644000000000000000000000005312677513065016131 0ustar0000000000000000struct tst { int a; }; int tst(int, int); c2hs-0.28.1/tests/bugs/issue-134/Issue134.chs0000644000000000000000000000016612677513065016424 0ustar0000000000000000module Main where #include "issue134.h" {# pointer *tst as ^ foreign newtype #} main :: IO () main = putStrLn "OK" c2hs-0.28.1/tests/bugs/issue-140/0000755000000000000000000000000012677513065014377 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-140/issue140.h0000644000000000000000000000027712677513065016133 0ustar0000000000000000typedef struct _ptr1 { int a; } ptr1; void f1(ptr1 *p, int x); typedef struct _ptr2 { int a; } ptr2; void f2(ptr2 *p, int x); typedef struct _ptr3 { int a; } ptr3; void f3(ptr3 *p, int x); c2hs-0.28.1/tests/bugs/issue-140/Issue140.chs0000644000000000000000000000130712677513065016414 0ustar0000000000000000module Main where import Foreign.Storable import Foreign.Ptr #include "issue140.h" {#pointer *ptr1 as Ptr1 foreign newtype#} {#pointer *ptr2 as Ptr2 foreign newtype#} {#pointer *ptr3 as Ptr3 foreign newtype#} instance Storable Ptr2 where sizeOf _ = 8 alignment _ = 1 peekElemOff p i = peekElemOff (castPtr p) i pokeElemOff p i x = pokeElemOff (castPtr p) i x {#fun f1 as ^ {+, `Int'} -> `Ptr1'#} {#fun f2 as ^ {+S, `Int'} -> `Ptr2'#} {#fun f3 as ^ {+16, `Int'} -> `Ptr3'#} main :: IO () main = do p1 <- f1 123 p2 <- f2 456 p3 <- f3 789 chk1 <- withPtr1 p1 {#get ptr1->a#} chk2 <- withPtr2 p2 {#get ptr2->a#} chk3 <- withPtr3 p3 {#get ptr3->a#} print chk1 print chk2 print chk3 c2hs-0.28.1/tests/bugs/issue-140/issue140.c0000644000000000000000000000021112677513065016112 0ustar0000000000000000#include "issue140.h" void f1(ptr1 *p, int x) { p->a = x; } void f2(ptr2 *p, int x) { p->a = x; } void f3(ptr3 *p, int x) { p->a = x; } c2hs-0.28.1/tests/bugs/issue-155/0000755000000000000000000000000012677513065014405 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-155/Issue155.chs0000644000000000000000000000011212677513065016421 0ustar0000000000000000module Main where {# import Types #} main :: IO () main = putStrLn "OK" c2hs-0.28.1/tests/bugs/issue-155/Types.chs0000644000000000000000000000057012677513065016212 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Types where #include "types.h" data ExampleStruct {# pointer *example_struct as ExampleStructPtr -> ExampleStruct #} {# class ExampleStructClass ExampleStructPtr #} data ChildStruct {# pointer *child_struct as ChildStructPtr -> ChildStruct #} {# class ExampleStructClass => ChildStructClass ChildStructPtr #} c2hs-0.28.1/tests/bugs/issue-155/types.h0000644000000000000000000000012712677513065015722 0ustar0000000000000000typedef struct { int a; } example_struct; typedef struct { int b; } child_struct; c2hs-0.28.1/tests/bugs/issue-98/0000755000000000000000000000000012677513065014333 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-98/Issue98.chs0000644000000000000000000000042612677513065016305 0ustar0000000000000000module Main where #include "issue98.h" {#fun pure identichar as ^ { `Char' } -> `Char' #} {#fun pure identiuchar as ^ { `Char' } -> `Char' #} {#fun pure identischar as ^ { `Char' } -> `Char' #} main :: IO () main = print $ map ($ 'A') [identichar, identiuchar, identischar] c2hs-0.28.1/tests/bugs/issue-98/issue98.h0000644000000000000000000000015512677513065016016 0ustar0000000000000000char identichar(char c); unsigned char identiuchar(unsigned char c); signed char identischar(signed char c); c2hs-0.28.1/tests/bugs/issue-98/issue98.c0000644000000000000000000000025112677513065016006 0ustar0000000000000000#include "issue98.h" char identichar(char c) { return c; } unsigned char identiuchar(unsigned char c) { return c; } signed char identischar(signed char c) { return c; } c2hs-0.28.1/tests/bugs/issue-116/0000755000000000000000000000000012677513065014402 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-116/Issue116.chs0000644000000000000000000000053212677513065016421 0ustar0000000000000000module Main where #include "issue116.h" {#enum test_enum as TestEnum {underscoreToCase} omit (TOTAL_ENUM_COUNT) deriving (Eq, Show)#} -- Force name overlap: causes compilation failure if "omit" in enum -- hook doesn't work. data Check = TotalEnumCount | Dummy main :: IO () main = print (fromEnum E1, fromEnum E2, fromEnum E3) c2hs-0.28.1/tests/bugs/issue-116/issue116.c0000644000000000000000000000000012677513065016114 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-116/issue116.h0000644000000000000000000000010412677513065016126 0ustar0000000000000000typedef enum { E_1, E_2, E_3, TOTAL_ENUM_COUNT } test_enum; c2hs-0.28.1/tests/bugs/issue-75/0000755000000000000000000000000012677513065014326 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-75/sndfile.h0000644000000000000000000005224012677513065016126 0ustar0000000000000000/* ** Copyright (C) 1999-2011Erik de Castro Lopo ** ** This program is free software; you can redistribute it and/or modify ** it under the terms of the GNU Lesser General Public License as published by ** the Free Software Foundation; either version 2.1 of the License, or ** (at your option) any later version. ** ** This program is distributed in the hope that it will be useful, ** but WITHOUT ANY WARRANTY; without even the implied warranty of ** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ** GNU Lesser General Public License for more details. ** ** You should have received a copy of the GNU Lesser General Public License ** along with this program; if not, write to the Free Software ** Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* ** sndfile.h -- system-wide definitions ** ** API documentation is in the doc/ directory of the source code tarball ** and at http://www.mega-nerd.com/libsndfile/api.html. */ #ifndef SNDFILE_H #define SNDFILE_H /* This is the version 1.0.X header file. */ #define SNDFILE_1 #include #include #ifdef __cplusplus extern "C" { #endif /* __cplusplus */ /* The following file types can be read and written. ** A file type would consist of a major type (ie SF_FORMAT_WAV) bitwise ** ORed with a minor type (ie SF_FORMAT_PCM). SF_FORMAT_TYPEMASK and ** SF_FORMAT_SUBMASK can be used to separate the major and minor file ** types. */ enum { /* Major formats. */ SF_FORMAT_WAV = 0x010000, /* Microsoft WAV format (little endian default). */ SF_FORMAT_AIFF = 0x020000, /* Apple/SGI AIFF format (big endian). */ SF_FORMAT_AU = 0x030000, /* Sun/NeXT AU format (big endian). */ SF_FORMAT_RAW = 0x040000, /* RAW PCM data. */ SF_FORMAT_PAF = 0x050000, /* Ensoniq PARIS file format. */ SF_FORMAT_SVX = 0x060000, /* Amiga IFF / SVX8 / SV16 format. */ SF_FORMAT_NIST = 0x070000, /* Sphere NIST format. */ SF_FORMAT_VOC = 0x080000, /* VOC files. */ SF_FORMAT_IRCAM = 0x0A0000, /* Berkeley/IRCAM/CARL */ SF_FORMAT_W64 = 0x0B0000, /* Sonic Foundry's 64 bit RIFF/WAV */ SF_FORMAT_MAT4 = 0x0C0000, /* Matlab (tm) V4.2 / GNU Octave 2.0 */ SF_FORMAT_MAT5 = 0x0D0000, /* Matlab (tm) V5.0 / GNU Octave 2.1 */ SF_FORMAT_PVF = 0x0E0000, /* Portable Voice Format */ SF_FORMAT_XI = 0x0F0000, /* Fasttracker 2 Extended Instrument */ SF_FORMAT_HTK = 0x100000, /* HMM Tool Kit format */ SF_FORMAT_SDS = 0x110000, /* Midi Sample Dump Standard */ SF_FORMAT_AVR = 0x120000, /* Audio Visual Research */ SF_FORMAT_WAVEX = 0x130000, /* MS WAVE with WAVEFORMATEX */ SF_FORMAT_SD2 = 0x160000, /* Sound Designer 2 */ SF_FORMAT_FLAC = 0x170000, /* FLAC lossless file format */ SF_FORMAT_CAF = 0x180000, /* Core Audio File format */ SF_FORMAT_WVE = 0x190000, /* Psion WVE format */ SF_FORMAT_OGG = 0x200000, /* Xiph OGG container */ SF_FORMAT_MPC2K = 0x210000, /* Akai MPC 2000 sampler */ SF_FORMAT_RF64 = 0x220000, /* RF64 WAV file */ /* Subtypes from here on. */ SF_FORMAT_PCM_S8 = 0x0001, /* Signed 8 bit data */ SF_FORMAT_PCM_16 = 0x0002, /* Signed 16 bit data */ SF_FORMAT_PCM_24 = 0x0003, /* Signed 24 bit data */ SF_FORMAT_PCM_32 = 0x0004, /* Signed 32 bit data */ SF_FORMAT_PCM_U8 = 0x0005, /* Unsigned 8 bit data (WAV and RAW only) */ SF_FORMAT_FLOAT = 0x0006, /* 32 bit float data */ SF_FORMAT_DOUBLE = 0x0007, /* 64 bit float data */ SF_FORMAT_ULAW = 0x0010, /* U-Law encoded. */ SF_FORMAT_ALAW = 0x0011, /* A-Law encoded. */ SF_FORMAT_IMA_ADPCM = 0x0012, /* IMA ADPCM. */ SF_FORMAT_MS_ADPCM = 0x0013, /* Microsoft ADPCM. */ SF_FORMAT_GSM610 = 0x0020, /* GSM 6.10 encoding. */ SF_FORMAT_VOX_ADPCM = 0x0021, /* OKI / Dialogix ADPCM */ SF_FORMAT_G721_32 = 0x0030, /* 32kbs G721 ADPCM encoding. */ SF_FORMAT_G723_24 = 0x0031, /* 24kbs G723 ADPCM encoding. */ SF_FORMAT_G723_40 = 0x0032, /* 40kbs G723 ADPCM encoding. */ SF_FORMAT_DWVW_12 = 0x0040, /* 12 bit Delta Width Variable Word encoding. */ SF_FORMAT_DWVW_16 = 0x0041, /* 16 bit Delta Width Variable Word encoding. */ SF_FORMAT_DWVW_24 = 0x0042, /* 24 bit Delta Width Variable Word encoding. */ SF_FORMAT_DWVW_N = 0x0043, /* N bit Delta Width Variable Word encoding. */ SF_FORMAT_DPCM_8 = 0x0050, /* 8 bit differential PCM (XI only) */ SF_FORMAT_DPCM_16 = 0x0051, /* 16 bit differential PCM (XI only) */ SF_FORMAT_VORBIS = 0x0060, /* Xiph Vorbis encoding. */ /* Endian-ness options. */ SF_ENDIAN_FILE = 0x00000000, /* Default file endian-ness. */ SF_ENDIAN_LITTLE = 0x10000000, /* Force little endian-ness. */ SF_ENDIAN_BIG = 0x20000000, /* Force big endian-ness. */ SF_ENDIAN_CPU = 0x30000000, /* Force CPU endian-ness. */ SF_FORMAT_SUBMASK = 0x0000FFFF, SF_FORMAT_TYPEMASK = 0x0FFF0000, SF_FORMAT_ENDMASK = 0x30000000 } ; /* ** The following are the valid command numbers for the sf_command() ** interface. The use of these commands is documented in the file ** command.html in the doc directory of the source code distribution. */ enum { SFC_GET_LIB_VERSION = 0x1000, SFC_GET_LOG_INFO = 0x1001, SFC_GET_CURRENT_SF_INFO = 0x1002, SFC_GET_NORM_DOUBLE = 0x1010, SFC_GET_NORM_FLOAT = 0x1011, SFC_SET_NORM_DOUBLE = 0x1012, SFC_SET_NORM_FLOAT = 0x1013, SFC_SET_SCALE_FLOAT_INT_READ = 0x1014, SFC_SET_SCALE_INT_FLOAT_WRITE = 0x1015, SFC_GET_SIMPLE_FORMAT_COUNT = 0x1020, SFC_GET_SIMPLE_FORMAT = 0x1021, SFC_GET_FORMAT_INFO = 0x1028, SFC_GET_FORMAT_MAJOR_COUNT = 0x1030, SFC_GET_FORMAT_MAJOR = 0x1031, SFC_GET_FORMAT_SUBTYPE_COUNT = 0x1032, SFC_GET_FORMAT_SUBTYPE = 0x1033, SFC_CALC_SIGNAL_MAX = 0x1040, SFC_CALC_NORM_SIGNAL_MAX = 0x1041, SFC_CALC_MAX_ALL_CHANNELS = 0x1042, SFC_CALC_NORM_MAX_ALL_CHANNELS = 0x1043, SFC_GET_SIGNAL_MAX = 0x1044, SFC_GET_MAX_ALL_CHANNELS = 0x1045, SFC_SET_ADD_PEAK_CHUNK = 0x1050, SFC_SET_ADD_HEADER_PAD_CHUNK = 0x1051, SFC_UPDATE_HEADER_NOW = 0x1060, SFC_SET_UPDATE_HEADER_AUTO = 0x1061, SFC_FILE_TRUNCATE = 0x1080, SFC_SET_RAW_START_OFFSET = 0x1090, SFC_SET_DITHER_ON_WRITE = 0x10A0, SFC_SET_DITHER_ON_READ = 0x10A1, SFC_GET_DITHER_INFO_COUNT = 0x10A2, SFC_GET_DITHER_INFO = 0x10A3, SFC_GET_EMBED_FILE_INFO = 0x10B0, SFC_SET_CLIPPING = 0x10C0, SFC_GET_CLIPPING = 0x10C1, SFC_GET_INSTRUMENT = 0x10D0, SFC_SET_INSTRUMENT = 0x10D1, SFC_GET_LOOP_INFO = 0x10E0, SFC_GET_BROADCAST_INFO = 0x10F0, SFC_SET_BROADCAST_INFO = 0x10F1, SFC_GET_CHANNEL_MAP_INFO = 0x1100, SFC_SET_CHANNEL_MAP_INFO = 0x1101, SFC_RAW_DATA_NEEDS_ENDSWAP = 0x1110, /* Support for Wavex Ambisonics Format */ SFC_WAVEX_SET_AMBISONIC = 0x1200, SFC_WAVEX_GET_AMBISONIC = 0x1201, SFC_SET_VBR_ENCODING_QUALITY = 0x1300, /* Following commands for testing only. */ SFC_TEST_IEEE_FLOAT_REPLACE = 0x6001, /* ** SFC_SET_ADD_* values are deprecated and will disappear at some ** time in the future. They are guaranteed to be here up to and ** including version 1.0.8 to avoid breakage of existng software. ** They currently do nothing and will continue to do nothing. */ SFC_SET_ADD_DITHER_ON_WRITE = 0x1070, SFC_SET_ADD_DITHER_ON_READ = 0x1071 } ; /* ** String types that can be set and read from files. Not all file types ** support this and even the file types which support one, may not support ** all string types. */ enum { SF_STR_TITLE = 0x01, SF_STR_COPYRIGHT = 0x02, SF_STR_SOFTWARE = 0x03, SF_STR_ARTIST = 0x04, SF_STR_COMMENT = 0x05, SF_STR_DATE = 0x06, SF_STR_ALBUM = 0x07, SF_STR_LICENSE = 0x08, SF_STR_TRACKNUMBER = 0x09, SF_STR_GENRE = 0x10 } ; /* ** Use the following as the start and end index when doing metadata ** transcoding. */ #define SF_STR_FIRST SF_STR_TITLE #define SF_STR_LAST SF_STR_GENRE enum { /* True and false */ SF_FALSE = 0, SF_TRUE = 1, /* Modes for opening files. */ SFM_READ = 0x10, SFM_WRITE = 0x20, SFM_RDWR = 0x30, SF_AMBISONIC_NONE = 0x40, SF_AMBISONIC_B_FORMAT = 0x41 } ; /* Public error values. These are guaranteed to remain unchanged for the duration ** of the library major version number. ** There are also a large number of private error numbers which are internal to ** the library which can change at any time. */ enum { SF_ERR_NO_ERROR = 0, SF_ERR_UNRECOGNISED_FORMAT = 1, SF_ERR_SYSTEM = 2, SF_ERR_MALFORMED_FILE = 3, SF_ERR_UNSUPPORTED_ENCODING = 4 } ; /* Channel map values (used with SFC_SET/GET_CHANNEL_MAP). */ enum { SF_CHANNEL_MAP_INVALID = 0, SF_CHANNEL_MAP_MONO = 1, SF_CHANNEL_MAP_LEFT, /* Apple calls this 'Left' */ SF_CHANNEL_MAP_RIGHT, /* Apple calls this 'Right' */ SF_CHANNEL_MAP_CENTER, /* Apple calls this 'Center' */ SF_CHANNEL_MAP_FRONT_LEFT, SF_CHANNEL_MAP_FRONT_RIGHT, SF_CHANNEL_MAP_FRONT_CENTER, SF_CHANNEL_MAP_REAR_CENTER, /* Apple calls this 'Center Surround', Msft calls this 'Back Center' */ SF_CHANNEL_MAP_REAR_LEFT, /* Apple calls this 'Left Surround', Msft calls this 'Back Left' */ SF_CHANNEL_MAP_REAR_RIGHT, /* Apple calls this 'Right Surround', Msft calls this 'Back Right' */ SF_CHANNEL_MAP_LFE, /* Apple calls this 'LFEScreen', Msft calls this 'Low Frequency' */ SF_CHANNEL_MAP_FRONT_LEFT_OF_CENTER, /* Apple calls this 'Left Center' */ SF_CHANNEL_MAP_FRONT_RIGHT_OF_CENTER, /* Apple calls this 'Right Center */ SF_CHANNEL_MAP_SIDE_LEFT, /* Apple calls this 'Left Surround Direct' */ SF_CHANNEL_MAP_SIDE_RIGHT, /* Apple calls this 'Right Surround Direct' */ SF_CHANNEL_MAP_TOP_CENTER, /* Apple calls this 'Top Center Surround' */ SF_CHANNEL_MAP_TOP_FRONT_LEFT, /* Apple calls this 'Vertical Height Left' */ SF_CHANNEL_MAP_TOP_FRONT_RIGHT, /* Apple calls this 'Vertical Height Right' */ SF_CHANNEL_MAP_TOP_FRONT_CENTER, /* Apple calls this 'Vertical Height Center' */ SF_CHANNEL_MAP_TOP_REAR_LEFT, /* Apple and MS call this 'Top Back Left' */ SF_CHANNEL_MAP_TOP_REAR_RIGHT, /* Apple and MS call this 'Top Back Right' */ SF_CHANNEL_MAP_TOP_REAR_CENTER, /* Apple and MS call this 'Top Back Center' */ SF_CHANNEL_MAP_AMBISONIC_B_W, SF_CHANNEL_MAP_AMBISONIC_B_X, SF_CHANNEL_MAP_AMBISONIC_B_Y, SF_CHANNEL_MAP_AMBISONIC_B_Z, SF_CHANNEL_MAP_MAX } ; /* A SNDFILE* pointer can be passed around much like stdio.h's FILE* pointer. */ typedef struct SNDFILE_tag SNDFILE ; /* The following typedef is system specific and is defined when libsndfile is ** compiled. sf_count_t will be a 64 bit value when the underlying OS allows ** 64 bit file offsets. ** On windows, we need to allow the same header file to be compiler by both GCC ** and the Microsoft compiler. */ #if (defined (_MSCVER) || defined (_MSC_VER)) typedef __int64 sf_count_t ; #define SF_COUNT_MAX 0x7fffffffffffffffi64 #else typedef int64_t sf_count_t ; #define SF_COUNT_MAX 0x7FFFFFFFFFFFFFFFLL #endif /* A pointer to a SF_INFO structure is passed to sf_open () and filled in. ** On write, the SF_INFO structure is filled in by the user and passed into ** sf_open (). */ struct SF_INFO { sf_count_t frames ; /* Used to be called samples. Changed to avoid confusion. */ int samplerate ; int channels ; int format ; int sections ; int seekable ; } ; typedef struct SF_INFO SF_INFO ; /* The SF_FORMAT_INFO struct is used to retrieve information about the sound ** file formats libsndfile supports using the sf_command () interface. ** ** Using this interface will allow applications to support new file formats ** and encoding types when libsndfile is upgraded, without requiring ** re-compilation of the application. ** ** Please consult the libsndfile documentation (particularly the information ** on the sf_command () interface) for examples of its use. */ typedef struct { int format ; const char *name ; const char *extension ; } SF_FORMAT_INFO ; /* ** Enums and typedefs for adding dither on read and write. ** See the html documentation for sf_command(), SFC_SET_DITHER_ON_WRITE ** and SFC_SET_DITHER_ON_READ. */ enum { SFD_DEFAULT_LEVEL = 0, SFD_CUSTOM_LEVEL = 0x40000000, SFD_NO_DITHER = 500, SFD_WHITE = 501, SFD_TRIANGULAR_PDF = 502 } ; typedef struct { int type ; double level ; const char *name ; } SF_DITHER_INFO ; /* Struct used to retrieve information about a file embedded within a ** larger file. See SFC_GET_EMBED_FILE_INFO. */ typedef struct { sf_count_t offset ; sf_count_t length ; } SF_EMBED_FILE_INFO ; /* ** Structs used to retrieve music sample information from a file. */ enum { /* ** The loop mode field in SF_INSTRUMENT will be one of the following. */ SF_LOOP_NONE = 800, SF_LOOP_FORWARD, SF_LOOP_BACKWARD, SF_LOOP_ALTERNATING } ; typedef struct { int gain ; char basenote, detune ; char velocity_lo, velocity_hi ; char key_lo, key_hi ; int loop_count ; struct { int mode ; unsigned int start ; unsigned int end ; unsigned int count ; } loops [16] ; /* make variable in a sensible way */ } SF_INSTRUMENT ; /* Struct used to retrieve loop information from a file.*/ typedef struct { short time_sig_num ; /* any positive integer > 0 */ short time_sig_den ; /* any positive power of 2 > 0 */ int loop_mode ; /* see SF_LOOP enum */ int num_beats ; /* this is NOT the amount of quarter notes !!!*/ /* a full bar of 4/4 is 4 beats */ /* a full bar of 7/8 is 7 beats */ float bpm ; /* suggestion, as it can be calculated using other fields:*/ /* file's lenght, file's sampleRate and our time_sig_den*/ /* -> bpms are always the amount of _quarter notes_ per minute */ int root_key ; /* MIDI note, or -1 for None */ int future [6] ; } SF_LOOP_INFO ; /* Struct used to retrieve broadcast (EBU) information from a file. ** Strongly (!) based on EBU "bext" chunk format used in Broadcast WAVE. */ #define SF_BROADCAST_INFO_VAR(coding_hist_size) \ struct \ { char description [256] ; \ char originator [32] ; \ char originator_reference [32] ; \ char origination_date [10] ; \ char origination_time [8] ; \ unsigned int time_reference_low ; \ unsigned int time_reference_high ; \ short version ; \ char umid [64] ; \ char reserved [190] ; \ unsigned int coding_history_size ; \ char coding_history [coding_hist_size] ; \ } /* SF_BROADCAST_INFO is the above struct with coding_history field of 256 bytes. */ typedef SF_BROADCAST_INFO_VAR (256) SF_BROADCAST_INFO ; /* Virtual I/O functionality. */ typedef sf_count_t (*sf_vio_get_filelen) (void *user_data) ; typedef sf_count_t (*sf_vio_seek) (sf_count_t offset, int whence, void *user_data) ; typedef sf_count_t (*sf_vio_read) (void *ptr, sf_count_t count, void *user_data) ; typedef sf_count_t (*sf_vio_write) (const void *ptr, sf_count_t count, void *user_data) ; typedef sf_count_t (*sf_vio_tell) (void *user_data) ; struct SF_VIRTUAL_IO { sf_vio_get_filelen get_filelen ; sf_vio_seek seek ; sf_vio_read read ; sf_vio_write write ; sf_vio_tell tell ; } ; typedef struct SF_VIRTUAL_IO SF_VIRTUAL_IO ; /* Open the specified file for read, write or both. On error, this will ** return a NULL pointer. To find the error number, pass a NULL SNDFILE ** to sf_strerror (). ** All calls to sf_open() should be matched with a call to sf_close(). */ SNDFILE* sf_open (const char *path, int mode, SF_INFO *sfinfo) ; /* Use the existing file descriptor to create a SNDFILE object. If close_desc ** is TRUE, the file descriptor will be closed when sf_close() is called. If ** it is FALSE, the descritor will not be closed. ** When passed a descriptor like this, the library will assume that the start ** of file header is at the current file offset. This allows sound files within ** larger container files to be read and/or written. ** On error, this will return a NULL pointer. To find the error number, pass a ** NULL SNDFILE to sf_strerror (). ** All calls to sf_open_fd() should be matched with a call to sf_close(). */ SNDFILE* sf_open_fd (int fd, int mode, SF_INFO *sfinfo, int close_desc) ; SNDFILE* sf_open_virtual (SF_VIRTUAL_IO *sfvirtual, int mode, SF_INFO *sfinfo, void *user_data) ; /* sf_error () returns a error number which can be translated to a text ** string using sf_error_number(). */ int sf_error (SNDFILE *sndfile) ; /* sf_strerror () returns to the caller a pointer to the current error message for ** the given SNDFILE. */ const char* sf_strerror (SNDFILE *sndfile) ; /* sf_error_number () allows the retrieval of the error string for each internal ** error number. ** */ const char* sf_error_number (int errnum) ; /* The following two error functions are deprecated but they will remain in the ** library for the forseeable future. The function sf_strerror() should be used ** in their place. */ int sf_perror (SNDFILE *sndfile) ; int sf_error_str (SNDFILE *sndfile, char* str, size_t len) ; /* Return TRUE if fields of the SF_INFO struct are a valid combination of values. */ int sf_command (SNDFILE *sndfile, int command, void *data, int datasize) ; /* Return TRUE if fields of the SF_INFO struct are a valid combination of values. */ int sf_format_check (const SF_INFO *info) ; /* Seek within the waveform data chunk of the SNDFILE. sf_seek () uses ** the same values for whence (SEEK_SET, SEEK_CUR and SEEK_END) as ** stdio.h function fseek (). ** An offset of zero with whence set to SEEK_SET will position the ** read / write pointer to the first data sample. ** On success sf_seek returns the current position in (multi-channel) ** samples from the start of the file. ** Please see the libsndfile documentation for moving the read pointer ** separately from the write pointer on files open in mode SFM_RDWR. ** On error all of these functions return -1. */ sf_count_t sf_seek (SNDFILE *sndfile, sf_count_t frames, int whence) ; /* Functions for retrieving and setting string data within sound files. ** Not all file types support this features; AIFF and WAV do. For both ** functions, the str_type parameter must be one of the SF_STR_* values ** defined above. ** On error, sf_set_string() returns non-zero while sf_get_string() ** returns NULL. */ int sf_set_string (SNDFILE *sndfile, int str_type, const char* str) ; const char* sf_get_string (SNDFILE *sndfile, int str_type) ; /* Return the library version string. */ const char * sf_version_string (void) ; /* Functions for reading/writing the waveform data of a sound file. */ sf_count_t sf_read_raw (SNDFILE *sndfile, void *ptr, sf_count_t bytes) ; sf_count_t sf_write_raw (SNDFILE *sndfile, const void *ptr, sf_count_t bytes) ; /* Functions for reading and writing the data chunk in terms of frames. ** The number of items actually read/written = frames * number of channels. ** sf_xxxx_raw read/writes the raw data bytes from/to the file ** sf_xxxx_short passes data in the native short format ** sf_xxxx_int passes data in the native int format ** sf_xxxx_float passes data in the native float format ** sf_xxxx_double passes data in the native double format ** All of these read/write function return number of frames read/written. */ sf_count_t sf_readf_short (SNDFILE *sndfile, short *ptr, sf_count_t frames) ; sf_count_t sf_writef_short (SNDFILE *sndfile, const short *ptr, sf_count_t frames) ; sf_count_t sf_readf_int (SNDFILE *sndfile, int *ptr, sf_count_t frames) ; sf_count_t sf_writef_int (SNDFILE *sndfile, const int *ptr, sf_count_t frames) ; sf_count_t sf_readf_float (SNDFILE *sndfile, float *ptr, sf_count_t frames) ; sf_count_t sf_writef_float (SNDFILE *sndfile, const float *ptr, sf_count_t frames) ; sf_count_t sf_readf_double (SNDFILE *sndfile, double *ptr, sf_count_t frames) ; sf_count_t sf_writef_double (SNDFILE *sndfile, const double *ptr, sf_count_t frames) ; /* Functions for reading and writing the data chunk in terms of items. ** Otherwise similar to above. ** All of these read/write function return number of items read/written. */ sf_count_t sf_read_short (SNDFILE *sndfile, short *ptr, sf_count_t items) ; sf_count_t sf_write_short (SNDFILE *sndfile, const short *ptr, sf_count_t items) ; sf_count_t sf_read_int (SNDFILE *sndfile, int *ptr, sf_count_t items) ; sf_count_t sf_write_int (SNDFILE *sndfile, const int *ptr, sf_count_t items) ; sf_count_t sf_read_float (SNDFILE *sndfile, float *ptr, sf_count_t items) ; sf_count_t sf_write_float (SNDFILE *sndfile, const float *ptr, sf_count_t items) ; sf_count_t sf_read_double (SNDFILE *sndfile, double *ptr, sf_count_t items) ; sf_count_t sf_write_double (SNDFILE *sndfile, const double *ptr, sf_count_t items) ; /* Close the SNDFILE and clean up all memory allocations associated with this ** file. ** Returns 0 on success, or an error number. */ int sf_close (SNDFILE *sndfile) ; /* If the file is opened SFM_WRITE or SFM_RDWR, call fsync() on the file ** to force the writing of data to disk. If the file is opened SFM_READ ** no action is taken. */ void sf_write_sync (SNDFILE *sndfile) ; /* The function sf_wchar_open() is Windows Only! ** Open a file passing in a Windows Unicode filename. Otherwise, this is ** the same as sf_open(). ** ** In order for this to work, you need to do the following: ** ** #include ** #define ENABLE_SNDFILE_WINDOWS_PROTOTYPES 1 ** #including */ #if (defined (ENABLE_SNDFILE_WINDOWS_PROTOTYPES) && ENABLE_SNDFILE_WINDOWS_PROTOTYPES) SNDFILE* sf_wchar_open (LPCWSTR wpath, int mode, SF_INFO *sfinfo) ; #endif #ifdef __cplusplus } /* extern "C" */ #endif /* __cplusplus */ #endif /* SNDFILE_H */ c2hs-0.28.1/tests/bugs/issue-75/issue75.h0000644000000000000000000000013212677513065015777 0ustar0000000000000000struct CHK_TST { int a; }; typedef struct CHK_TST CHK_TST; CHK_TST *chk_make_tst(void); c2hs-0.28.1/tests/bugs/issue-75/Issue75.chs0000644000000000000000000000042512677513065016272 0ustar0000000000000000module Main where {#context prefix="chk"#} #include "issue75.h" data TstStruct = TstStruct { a :: Int } {#pointer *TST as TstPtr -> TstStruct#} {#fun make_tst as ^ {} -> `TstPtr'#} main :: IO () main = do s <- makeTst aval <- {#get CHK_TST.a#} s putStrLn $ show aval c2hs-0.28.1/tests/bugs/issue-75/issue75.c0000644000000000000000000000016212677513065015775 0ustar0000000000000000#include "issue75.h" CHK_TST tmpstruct; CHK_TST *chk_make_tst(void) { tmpstruct.a = 1; return &tmpstruct; } c2hs-0.28.1/tests/bugs/issue-9/0000755000000000000000000000000012677513065014243 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-9/issue9.c0000644000000000000000000000000012677513065015616 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-9/Issue9.chs0000644000000000000000000000050512677513065016123 0ustar0000000000000000module Main where #include "issue9.h" main :: IO () main = do putStrLn $ "PTA:" ++ show ({# sizeof pointer_to_array #} :: Int) putStrLn $ "AOP:" ++ show ({# sizeof array_of_pointers #} :: Int) print (({# sizeof inner_t #}, {# sizeof outer_t #}) :: (Int, Int)) print ({# sizeof ok_outer_t #} :: Int) putStrLn "OK" c2hs-0.28.1/tests/bugs/issue-9/issue9.h0000644000000000000000000000040012677513065015627 0ustar0000000000000000struct pointer_to_array { int (*y)[4]; } PTA; struct array_of_pointers { int *y[4]; } AOP; typedef char inner_t[32]; typedef struct { inner_t first; inner_t second; } outer_t; typedef struct { char first[32]; char second[32]; } ok_outer_t; c2hs-0.28.1/tests/bugs/issue-48/0000755000000000000000000000000012677513065014326 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-48/issue48.c0000644000000000000000000000010112677513065015766 0ustar0000000000000000#include "issue48.h" int64_t foo(int64_t n) { return n + 1; } c2hs-0.28.1/tests/bugs/issue-48/issue48.h0000644000000000000000000000006012677513065015777 0ustar0000000000000000#include int64_t foo(int64_t n); c2hs-0.28.1/tests/bugs/issue-48/Issue48.chs0000644000000000000000000000041612677513065016272 0ustar0000000000000000module Main where import Foreign.C.Types #include "issue48.h" {#typedef int64_t CLong#} {#default out `Int' [int64_t] fromIntegral#} {#default in `Int' [int64_t] fromIntegral#} {#fun foo {`Int'} -> `Int'#} main :: IO () main = do foo 1 >>= print foo 4 >>= print c2hs-0.28.1/tests/bugs/issue-19/0000755000000000000000000000000012677513065014324 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-19/Issue19.chs0000644000000000000000000000055512677513065016272 0ustar0000000000000000module Main where import Control.Monad #include "issue19.h" {#context prefix="enums"#} {#enum enums1 as Enums1 {underscoreToCase}#} {#enum enums2 as Enums2 {underscoreToCase} add prefix="TEST"#} main :: IO () main = do unless (1 == fromEnum One) $ putStrLn "1 /= One!!!" unless (5 == fromEnum TestFive) $ putStrLn "5 /= TestFive!!!" putStrLn "Did it!" c2hs-0.28.1/tests/bugs/issue-19/issue19.h0000644000000000000000000000022012677513065015771 0ustar0000000000000000enum enums1 { ENUMS_ONE = 1, ENUMS_TWO = 2, ENUMS_THREE = 3 }; enum enums2 { ENUMS_FOUR = 4, ENUMS_FIVE = 5, ENUMS_SIX = 6 }; c2hs-0.28.1/tests/bugs/issue-19/issue19.c0000644000000000000000000000002512677513065015767 0ustar0000000000000000#include "issue19.h" c2hs-0.28.1/tests/bugs/issue-62/0000755000000000000000000000000012677513065014322 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-62/Issue62.chs0000644000000000000000000000126512677513065016265 0ustar0000000000000000module Main where import Foreign.C import Foreign.Marshal import Foreign.Ptr import Foreign.Storable #include "issue62.h" peekToInt :: Ptr CInt -> IO Int peekToInt p = peek p >>= return . fromIntegral {# fun f1 { `Int' -- ^ This is a multiline -- comment for -- para1 , `Int' , `Int' -- ^ comment for para3 } -> `Int' -- ^ multiline -- comment for -- result #} {# fun f2 { `Int' , alloca- `Int' peekToInt* -- ^ comment -- won't appear , alloca- `Int' peekToInt* -- ^ won't appear } -> `Int' -- ^ The only comment for result #} main :: IO () main = return () c2hs-0.28.1/tests/bugs/issue-62/issue62.c0000644000000000000000000000016112677513065015764 0ustar0000000000000000#include "issue62.h" int f1(int x, int y, int z) { return 0; } int f2(int x, int* y, int* z) { return 0; } c2hs-0.28.1/tests/bugs/issue-62/issue62.h0000644000000000000000000000022612677513065015773 0ustar0000000000000000/* @(#)issue62.h */ #ifndef _ISSUE62_H_ #define _ISSUE62_H_ int f1(int x, int y, int z); int f2(int x, int* y, int* z); #endif /* _ISSUE62_H_ */ c2hs-0.28.1/tests/bugs/issue-97/0000755000000000000000000000000012677513065014332 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-97/Issue97A.chs0000644000000000000000000000031712677513065016403 0ustar0000000000000000-- Foo.chs {-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-} module Issue97A ( Foo , FooPtr ) where import Foreign #include "issue97.h" data Foo {#pointer *foo_t as FooPtr -> Foo #} c2hs-0.28.1/tests/bugs/issue-97/issue97.c0000644000000000000000000000011312677513065016001 0ustar0000000000000000/* foo.c */ #include "issue97.h" int foo_x(foo_t *f) { return f->x; } c2hs-0.28.1/tests/bugs/issue-97/issue97.h0000644000000000000000000000016712677513065016017 0ustar0000000000000000/* foo.h */ #ifndef FOO_H #define FOO_H typedef struct { int x; int y; } foo_t; int foo_x(foo_t *f); #endif c2hs-0.28.1/tests/bugs/issue-97/Issue97.chs0000644000000000000000000000056112677513065016303 0ustar0000000000000000-- Main.chs {-# LANGUAGE ForeignFunctionInterface #-} module Main where {#import Issue97A#} import Foreign import Foreign.C.Types import System.IO.Unsafe (unsafePerformIO) #include "issue97.h" {#fun pure foo_x as fooX { `FooPtr' } -> `Int' #} main :: IO () main = allocaBytes {#sizeof foo_t #} $ \fooPtr -> do {#set foo_t.x #} fooPtr 42 print $ fooX fooPtr c2hs-0.28.1/tests/bugs/issue-32/0000755000000000000000000000000012677513065014317 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-32/issue32.c0000644000000000000000000000027612677513065015765 0ustar0000000000000000#include "issue32.h" static testStruct makeItFrom; testStruct *makeIt(void) { makeItFrom.a = 1234; makeItFrom.b = 1; makeItFrom.c = 523; makeItFrom.d = 24; return &makeItFrom; } c2hs-0.28.1/tests/bugs/issue-32/issue32.h0000644000000000000000000000024312677513065015764 0ustar0000000000000000typedef struct testStruct_ testStruct; struct testStruct_ { unsigned a: 27; unsigned b: 1; unsigned c: 13; unsigned d: 8; }; testStruct *makeIt(void); c2hs-0.28.1/tests/bugs/issue-32/Issue32.chs0000644000000000000000000000037112677513065016254 0ustar0000000000000000module Main where #include "issue32.h" {#pointer *testStruct as TestStructPtr #} main :: IO () main = do x <- {#call makeIt #} print =<< ({#get testStruct->a #} x) print =<< ({#get testStruct->b #} x) print =<< ({#get testStruct->c #} x) c2hs-0.28.1/tests/bugs/issue-31/0000755000000000000000000000000012677513065014316 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-31/Issue31.chs0000644000000000000000000000507212677513065016255 0ustar0000000000000000module Main where #include "issue31.h" -- CASE 1: -- -- fromIntegral . fromEnum and toEnum . fromIntegral from an enum hook {#enum test_enum as TestEnum {underscoreToCase} deriving (Eq, Show)#} {#fun enum_test {`TestEnum'} -> `TestEnum'#} enumTest :: IO () enumTest = do res1 <- enum_test E1 res2 <- enum_test E2 res3 <- enum_test E3 case (res1, res2, res3) of (E2, E3, E1) -> putStrLn "Enum OK" _ -> putStrLn "Enum FAILED" -- CASE 2: -- -- id and id from both naked and newtype pointer hooks data TestStruct1 = TestStruct1 { a :: Int } {#pointer *test_struct1 as TestNakedPtr -> TestStruct1#} {#pointer *test_struct2 as TestNtPtr newtype#} {#fun make_struct1 as nakedMakeStruct {} -> `TestNakedPtr'#} {#fun make_struct2 as newtypeMakeStruct {} -> `TestNtPtr'#} {#fun access_struct1 as nakedAccess {`TestNakedPtr'} -> `Int'#} {#fun access_struct2 as newtypeAccess {`TestNtPtr'} -> `Int'#} pointerTest :: IO () pointerTest = do nakedPtr <- nakedMakeStruct nakedVal1 <- nakedAccess nakedPtr nakedVal2 <- {#get test_struct1->a#} nakedPtr putStrLn $ "Pointer 1: " ++ show nakedVal1 ++ " " ++ show nakedVal2 newtypePtr <- newtypeMakeStruct newtypeVal <- newtypeAccess newtypePtr putStrLn $ "Pointer 2: " ++ show newtypeVal -- CASE 3: -- -- * withForeignPtr and newForeignPtr_ for foreign pointer hooks {#pointer *test_struct3 as TestForeignPtr foreign#} {#fun make_struct3 as foreignMakeStruct {} -> `TestForeignPtr'#} {#fun access_struct3 as foreignAccess {`TestForeignPtr'} -> `Int'#} foreignPointerTest :: IO () foreignPointerTest = do foreignPtr <- foreignMakeStruct foreignVal <- foreignAccess foreignPtr putStrLn $ "Foreign pointer: " ++ show foreignVal -- CASE 4: -- -- * withPointerType (the generated function) and -- PointerType . newForeignPtr_ for foreign newtype pointer -- hooks. The out marshaller is not great here, a !ForeignPtr with -- no finalizers is not terribly useful concealed inside the -- newtype. Perhaps foreign newtype should be left naked, or -- furnished with an 'in' default marshaller only. {#pointer *test_struct4 as TestForeignNtPtr foreign newtype#} {#fun make_struct4 as foreignNtMakeStruct {} -> `TestForeignNtPtr'#} {#fun access_struct4 as foreignNtAccess {`TestForeignNtPtr'} -> `Int'#} foreignNtPointerTest :: IO () foreignNtPointerTest = do foreignNtPtr <- foreignNtMakeStruct foreignNtVal <- foreignNtAccess foreignNtPtr putStrLn $ "Foreign newtype pointer: " ++ show foreignNtVal return () main :: IO () main = do enumTest pointerTest foreignPointerTest foreignNtPointerTest return () c2hs-0.28.1/tests/bugs/issue-31/issue31.h0000644000000000000000000000101712677513065015762 0ustar0000000000000000typedef enum { E_1, E_2, E_3 } test_enum; test_enum enum_test(test_enum n); typedef struct { int a; } test_struct1; test_struct1 *make_struct1(void); int access_struct1(test_struct1 *); typedef struct { int b; } test_struct2; test_struct2 *make_struct2(void); int access_struct2(test_struct2 *); typedef struct { int c; } test_struct3; test_struct3 *make_struct3(void); int access_struct3(test_struct3 *); typedef struct { int d; } test_struct4; test_struct4 *make_struct4(void); int access_struct4(test_struct4 *); c2hs-0.28.1/tests/bugs/issue-31/issue31.c0000644000000000000000000000143112677513065015755 0ustar0000000000000000#include "issue31.h" test_enum enum_test(test_enum n) { switch (n) { case E_1: return E_2; case E_2: return E_3; case E_3: return E_1; } } test_struct1 tmpstruct1; test_struct1 *make_struct1(void) { tmpstruct1.a = 1; return &tmpstruct1; } int access_struct1(test_struct1 *s) { return s->a; } test_struct2 tmpstruct2; test_struct2 *make_struct2(void) { tmpstruct2.b = 2; return &tmpstruct2; } int access_struct2(test_struct2 *s) { return s->b; } test_struct3 tmpstruct3; test_struct3 *make_struct3(void) { tmpstruct3.c = 3; return &tmpstruct3; } int access_struct3(test_struct3 *s) { return s->c; } test_struct4 tmpstruct4; test_struct4 *make_struct4(void) { tmpstruct4.d = 4; return &tmpstruct4; } int access_struct4(test_struct4 *s) { return s->d; } c2hs-0.28.1/tests/bugs/issue-79/0000755000000000000000000000000012677513065014332 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-79/issue79.h0000644000000000000000000000006112677513065016010 0ustar0000000000000000enum foo { A = 1, B = 2, C = 2, D = 3 }; c2hs-0.28.1/tests/bugs/issue-79/Issue79.chs0000644000000000000000000000035412677513065016303 0ustar0000000000000000module Main where import Control.Monad (forM_) #include "issue79.h" {#enum foo as Foo {underscoreToCase} deriving (Eq, Show)#} main :: IO () main = do forM_ [A, B, C, D] $ \v -> putStrLn $ show v ++ "=" ++ (show $ fromEnum v) c2hs-0.28.1/tests/bugs/issue-79/issue79.c0000644000000000000000000000000012677513065015774 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-73/0000755000000000000000000000000012677513065014324 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-73/Issue73.chs0000644000000000000000000000414512677513065016271 0ustar0000000000000000module Main where #include "issue73.h" -- * withForeignPtr and newForeignPtr_ for foreign pointer hooks {#pointer *test_struct3 as TestForeign1Ptr foreign#} {#fun make_struct3 as foreign1MakeStruct {} -> `TestForeign1Ptr'#} {#fun access_struct3 as foreign1Access {`TestForeign1Ptr'} -> `Int'#} foreign1 :: IO () foreign1 = do foreignPtr <- foreign1MakeStruct foreignVal <- foreign1Access foreignPtr putStrLn $ "Foreign pointer: " ++ show foreignVal {#pointer *test_struct3 as TestForeign2Ptr foreign finalizer free_struct3#} {#fun make_struct3 as foreign2MakeStruct {} -> `TestForeign2Ptr'#} {#fun access_struct3 as foreign2Access {`TestForeign2Ptr'} -> `Int'#} foreign2 :: IO () foreign2 = do foreignPtr <- foreign2MakeStruct foreignVal <- foreign2Access foreignPtr putStrLn $ "Foreign pointer: " ++ show foreignVal -- * withPointerType (the generated function) and -- PointerType . newForeignPtr_ for foreign newtype pointer -- hooks. The out marshaller is not great here, a !ForeignPtr with -- no finalizers is not terribly useful concealed inside the -- newtype. Perhaps foreign newtype should be left naked, or -- furnished with an 'in' default marshaller only. {#pointer *test_struct4 as TestForeignNt1Ptr foreign newtype#} {#fun make_struct4 as foreignNt1MakeStruct {} -> `TestForeignNt1Ptr'#} {#fun access_struct4 as foreignNt1Access {`TestForeignNt1Ptr'} -> `Int'#} foreignNt1 :: IO () foreignNt1 = do foreignNtPtr <- foreignNt1MakeStruct foreignNtVal <- foreignNt1Access foreignNtPtr putStrLn $ "Foreign newtype pointer: " ++ show foreignNtVal return () {#pointer *test_struct4 as TestForeignNt2Ptr foreign finalizer free_struct4 newtype#} {#fun make_struct4 as foreignNt2MakeStruct {} -> `TestForeignNt2Ptr'#} {#fun access_struct4 as foreignNt2Access {`TestForeignNt2Ptr'} -> `Int'#} foreignNt2 :: IO () foreignNt2 = do foreignNtPtr <- foreignNt2MakeStruct foreignNtVal <- foreignNt2Access foreignNtPtr putStrLn $ "Foreign newtype pointer: " ++ show foreignNtVal return () main :: IO () main = do foreign1 foreign2 foreignNt1 foreignNt2 return () c2hs-0.28.1/tests/bugs/issue-73/issue73.h0000644000000000000000000000044512677513065016002 0ustar0000000000000000typedef struct { int c; } test_struct3; test_struct3 *make_struct3(void); void free_struct3(test_struct3 *v); int access_struct3(test_struct3 *); typedef struct { int d; } test_struct4; test_struct4 *make_struct4(void); void free_struct4(test_struct4 *v); int access_struct4(test_struct4 *); c2hs-0.28.1/tests/bugs/issue-73/issue73.c0000644000000000000000000000123712677513065015775 0ustar0000000000000000#include #include #include "issue73.h" test_struct3 *make_struct3(void) { test_struct3 *tmp = (test_struct3 *)(malloc(sizeof(test_struct3))); tmp->c = 3; printf("Allocated struct3\n"); return tmp; } int access_struct3(test_struct3 *s) { return s->c; } void free_struct3(test_struct3 *s) { printf("Freeing struct3\n"); free(s); } test_struct4 *make_struct4(void) { test_struct4 *tmp = (test_struct4 *)(malloc(sizeof(test_struct4))); tmp->d = 4; printf("Allocated struct4\n"); return tmp; } int access_struct4(test_struct4 *s) { return s->d; } void free_struct4(test_struct4 *s) { printf("Freeing struct4\n"); free(s); } c2hs-0.28.1/tests/bugs/issue-69/0000755000000000000000000000000012677513065014331 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-69/issue69.c0000644000000000000000000000005212677513065016001 0ustar0000000000000000void foo1(int n) { } void foo2(int n) { } c2hs-0.28.1/tests/bugs/issue-69/Issue69.chs0000644000000000000000000000021712677513065016277 0ustar0000000000000000module Main where #include "issue69.h" {#fun foo1 {`Int'} -> `()'#} {# fun foo2 {`Int'} -> `()'#} main :: IO () main = do foo1 2 foo2 2 c2hs-0.28.1/tests/bugs/issue-69/issue69.h0000644000000000000000000000004012677513065016003 0ustar0000000000000000void foo1(int); void foo2(int); c2hs-0.28.1/tests/bugs/issue-45/0000755000000000000000000000000012677513065014323 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-45/Issue45.chs0000644000000000000000000000015012677513065016257 0ustar0000000000000000module Main where #include "issue45.h" main :: IO () main = foo 2 where {#fun foo {`Int'} -> `()'#} c2hs-0.28.1/tests/bugs/issue-45/issue45.c0000644000000000000000000000002412677513065015764 0ustar0000000000000000void foo(int n) { } c2hs-0.28.1/tests/bugs/issue-45/issue45.h0000644000000000000000000000001712677513065015773 0ustar0000000000000000void foo(int); c2hs-0.28.1/tests/bugs/issue-60/0000755000000000000000000000000012677513065014320 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-60/issue60.c0000644000000000000000000000000012677513065015750 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-60/stdlib.h0000644000000000000000000004410412677513065015755 0ustar0000000000000000/* * stdlib.h * This file has no copyright assigned and is placed in the Public Domain. * This file is a part of the mingw-runtime package. * No warranty is given; refer to the file DISCLAIMER within the package. * * Definitions for common types, variables, and functions. * */ #ifndef _STDLIB_H_ #define _STDLIB_H_ /* All the headers include this file. */ #include "_mingw.h" #define __need_size_t #define __need_wchar_t #define __need_NULL #ifndef RC_INVOKED #include #endif /* RC_INVOKED */ /* * RAND_MAX is the maximum value that may be returned by rand. * The minimum is zero. */ #define RAND_MAX 0x7FFF /* * These values may be used as exit status codes. */ #define EXIT_SUCCESS 0 #define EXIT_FAILURE 1 /* * Definitions for path name functions. * NOTE: All of these values have simply been chosen to be conservatively high. * Remember that with long file names we can no longer depend on * extensions being short. */ #ifndef __STRICT_ANSI__ #ifndef MAX_PATH #define MAX_PATH (260) #endif #define _MAX_PATH MAX_PATH #define _MAX_DRIVE (3) #define _MAX_DIR 256 #define _MAX_FNAME 256 #define _MAX_EXT 256 #endif /* Not __STRICT_ANSI__ */ #ifndef RC_INVOKED #ifdef __cplusplus extern "C" { #endif #if !defined (__STRICT_ANSI__) /* * This seems like a convenient place to declare these variables, which * give programs using WinMain (or main for that matter) access to main-ish * argc and argv. environ is a pointer to a table of environment variables. * NOTE: Strings in _argv and environ are ANSI strings. */ extern int _argc; extern char** _argv; /* imports from runtime dll of the above variables */ #ifdef __MSVCRT__ extern int* __cdecl __MINGW_NOTHROW __p___argc(void); extern char*** __cdecl __MINGW_NOTHROW __p___argv(void); extern wchar_t*** __cdecl __MINGW_NOTHROW __p___wargv(void); #define __argc (*__p___argc()) #define __argv (*__p___argv()) #define __wargv (*__p___wargv()) #else /* !MSVCRT */ #ifndef __DECLSPEC_SUPPORTED extern int* _imp____argc_dll; extern char*** _imp____argv_dll; #define __argc (*_imp____argc_dll) #define __argv (*_imp____argv_dll) #else /* __DECLSPEC_SUPPORTED */ __MINGW_IMPORT int __argc_dll; __MINGW_IMPORT char** __argv_dll; #define __argc __argc_dll #define __argv __argv_dll #endif /* __DECLSPEC_SUPPORTED */ #endif /* __MSVCRT */ #endif /* __STRICT_ANSI__ */ /* * Also defined in ctype.h. */ #ifndef MB_CUR_MAX #ifdef __DECLSPEC_SUPPORTED # ifdef __MSVCRT__ # define MB_CUR_MAX __mb_cur_max __MINGW_IMPORT int __mb_cur_max; # else /* not __MSVCRT */ # define MB_CUR_MAX __mb_cur_max_dll __MINGW_IMPORT int __mb_cur_max_dll; # endif /* not __MSVCRT */ #else /* ! __DECLSPEC_SUPPORTED */ # ifdef __MSVCRT__ extern int* _imp____mb_cur_max; # define MB_CUR_MAX (*_imp____mb_cur_max) # else /* not __MSVCRT */ extern int* _imp____mb_cur_max_dll; # define MB_CUR_MAX (*_imp____mb_cur_max_dll) # endif /* not __MSVCRT */ #endif /* __DECLSPEC_SUPPORTED */ #endif /* MB_CUR_MAX */ /* * MS likes to declare errno in stdlib.h as well. */ #ifdef _UWIN #undef errno extern int errno; #else _CRTIMP int* __cdecl __MINGW_NOTHROW _errno(void); #define errno (*_errno()) #endif _CRTIMP int* __cdecl __MINGW_NOTHROW __doserrno(void); #define _doserrno (*__doserrno()) #if !defined (__STRICT_ANSI__) /* * Use environ from the DLL, not as a global. */ #ifdef __MSVCRT__ extern _CRTIMP char *** __cdecl __MINGW_NOTHROW __p__environ(void); extern _CRTIMP wchar_t *** __cdecl __MINGW_NOTHROW __p__wenviron(void); # define _environ (*__p__environ()) # define _wenviron (*__p__wenviron()) #else /* ! __MSVCRT__ */ # ifndef __DECLSPEC_SUPPORTED extern char *** _imp___environ_dll; # define _environ (*_imp___environ_dll) # else /* __DECLSPEC_SUPPORTED */ __MINGW_IMPORT char ** _environ_dll; # define _environ _environ_dll # endif /* __DECLSPEC_SUPPORTED */ #endif /* ! __MSVCRT__ */ #define environ _environ #ifdef __MSVCRT__ /* One of the MSVCRTxx libraries */ #ifndef __DECLSPEC_SUPPORTED extern int* _imp___sys_nerr; # define sys_nerr (*_imp___sys_nerr) #else /* __DECLSPEC_SUPPORTED */ __MINGW_IMPORT int _sys_nerr; # ifndef _UWIN # define sys_nerr _sys_nerr # endif /* _UWIN */ #endif /* __DECLSPEC_SUPPORTED */ #else /* ! __MSVCRT__ */ /* CRTDLL run time library */ #ifndef __DECLSPEC_SUPPORTED extern int* _imp___sys_nerr_dll; # define sys_nerr (*_imp___sys_nerr_dll) #else /* __DECLSPEC_SUPPORTED */ __MINGW_IMPORT int _sys_nerr_dll; # define sys_nerr _sys_nerr_dll #endif /* __DECLSPEC_SUPPORTED */ #endif /* ! __MSVCRT__ */ #ifndef __DECLSPEC_SUPPORTED extern char*** _imp__sys_errlist; #define sys_errlist (*_imp___sys_errlist) #else /* __DECLSPEC_SUPPORTED */ __MINGW_IMPORT char* _sys_errlist[]; #ifndef _UWIN #define sys_errlist _sys_errlist #endif /* _UWIN */ #endif /* __DECLSPEC_SUPPORTED */ /* * OS version and such constants. */ #ifdef __MSVCRT__ /* msvcrtxx.dll */ extern _CRTIMP unsigned __cdecl __MINGW_NOTHROW int* __p__osver(void); extern _CRTIMP unsigned __cdecl __MINGW_NOTHROW int* __p__winver(void); extern _CRTIMP unsigned __cdecl __MINGW_NOTHROW int* __p__winmajor(void); extern _CRTIMP unsigned __cdecl __MINGW_NOTHROW int* __p__winminor(void); #ifndef __DECLSPEC_SUPPORTED # define _osver (*__p__osver()) # define _winver (*__p__winver()) # define _winmajor (*__p__winmajor()) # define _winminor (*__p__winminor()) #else __MINGW_IMPORT unsigned int _osver; __MINGW_IMPORT unsigned int _winver; __MINGW_IMPORT unsigned int _winmajor; __MINGW_IMPORT unsigned int _winminor; #endif /* __DECLSPEC_SUPPORTED */ #else /* Not msvcrtxx.dll, thus crtdll.dll */ #ifndef __DECLSPEC_SUPPORTED extern unsigned int* _imp___osver_dll; extern unsigned int* _imp___winver_dll; extern unsigned int* _imp___winmajor_dll; extern unsigned int* _imp___winminor_dll; #define _osver (*_imp___osver_dll) #define _winver (*_imp___winver_dll) #define _winmajor (*_imp___winmajor_dll) #define _winminor (*_imp___winminor_dll) #else /* __DECLSPEC_SUPPORTED */ __MINGW_IMPORT unsigned int _osver_dll; __MINGW_IMPORT unsigned int _winver_dll; __MINGW_IMPORT unsigned int _winmajor_dll; __MINGW_IMPORT unsigned int _winminor_dll; #define _osver _osver_dll #define _winver _winver_dll #define _winmajor _winmajor_dll #define _winminor _winminor_dll #endif /* __DECLSPEC_SUPPORTED */ #endif #if defined __MSVCRT__ /* although the _pgmptr is exported as DATA, * be safe and use the access function __p__pgmptr() to get it. */ _CRTIMP char** __cdecl __MINGW_NOTHROW __p__pgmptr(void); #define _pgmptr (*__p__pgmptr()) _CRTIMP wchar_t** __cdecl __MINGW_NOTHROW __p__wpgmptr(void); #define _wpgmptr (*__p__wpgmptr()) #else /* ! __MSVCRT__ */ # ifndef __DECLSPEC_SUPPORTED extern char** __imp__pgmptr_dll; # define _pgmptr (*_imp___pgmptr_dll) # else /* __DECLSPEC_SUPPORTED */ __MINGW_IMPORT char* _pgmptr_dll; # define _pgmptr _pgmptr_dll # endif /* __DECLSPEC_SUPPORTED */ /* no wide version in CRTDLL */ #endif /* __MSVCRT__ */ /* * This variable determines the default file mode. * TODO: Which flags work? */ #if !defined (__DECLSPEC_SUPPORTED) || defined (__IN_MINGW_RUNTIME) #ifdef __MSVCRT__ extern int* _imp___fmode; #define _fmode (*_imp___fmode) #else /* CRTDLL */ extern int* _imp___fmode_dll; #define _fmode (*_imp___fmode_dll) #endif #else /* __DECLSPEC_SUPPORTED */ #ifdef __MSVCRT__ __MINGW_IMPORT int _fmode; #else /* ! __MSVCRT__ */ __MINGW_IMPORT int _fmode_dll; #define _fmode _fmode_dll #endif /* ! __MSVCRT__ */ #endif /* __DECLSPEC_SUPPORTED */ #endif /* Not __STRICT_ANSI__ */ _CRTIMP double __cdecl __MINGW_NOTHROW atof (const char*); _CRTIMP int __cdecl __MINGW_NOTHROW atoi (const char*); _CRTIMP long __cdecl __MINGW_NOTHROW atol (const char*); #if !defined (__STRICT_ANSI__) _CRTIMP double __cdecl __MINGW_NOTHROW _wtof (const wchar_t *); _CRTIMP int __cdecl __MINGW_NOTHROW _wtoi (const wchar_t *); _CRTIMP long __cdecl __MINGW_NOTHROW _wtol (const wchar_t *); #endif #if !defined __NO_ISOCEXT /* in libmingwex.a */ double __cdecl __MINGW_NOTHROW __strtod (const char*, char**); extern double __cdecl __MINGW_NOTHROW strtod (const char* __restrict__ __nptr, char** __restrict__ __endptr); float __cdecl __MINGW_NOTHROW strtof (const char * __restrict__, char ** __restrict__); long double __cdecl __MINGW_NOTHROW strtold (const char * __restrict__, char ** __restrict__); #else _CRTIMP double __cdecl __MINGW_NOTHROW strtod (const char*, char**); #endif /* __NO_ISOCEXT */ _CRTIMP long __cdecl __MINGW_NOTHROW strtol (const char*, char**, int); _CRTIMP unsigned long __cdecl __MINGW_NOTHROW strtoul (const char*, char**, int); #ifndef _WSTDLIB_DEFINED /* also declared in wchar.h */ _CRTIMP long __cdecl __MINGW_NOTHROW wcstol (const wchar_t*, wchar_t**, int); _CRTIMP unsigned long __cdecl __MINGW_NOTHROW wcstoul (const wchar_t*, wchar_t**, int); _CRTIMP double __cdecl __MINGW_NOTHROW wcstod (const wchar_t*, wchar_t**); #if !defined __NO_ISOCEXT /* in libmingwex.a */ float __cdecl __MINGW_NOTHROW wcstof( const wchar_t * __restrict__, wchar_t ** __restrict__); long double __cdecl __MINGW_NOTHROW wcstold (const wchar_t * __restrict__, wchar_t ** __restrict__); #endif /* __NO_ISOCEXT */ #ifdef __MSVCRT__ _CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _wgetenv(const wchar_t*); _CRTIMP int __cdecl __MINGW_NOTHROW _wputenv(const wchar_t*); _CRTIMP void __cdecl __MINGW_NOTHROW _wsearchenv(const wchar_t*, const wchar_t*, wchar_t*); _CRTIMP int __cdecl __MINGW_NOTHROW _wsystem(const wchar_t*); _CRTIMP void __cdecl __MINGW_NOTHROW _wmakepath(wchar_t*, const wchar_t*, const wchar_t*, const wchar_t*, const wchar_t*); _CRTIMP void __cdecl __MINGW_NOTHROW _wsplitpath (const wchar_t*, wchar_t*, wchar_t*, wchar_t*, wchar_t*); _CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _wfullpath (wchar_t*, const wchar_t*, size_t); #endif #define _WSTDLIB_DEFINED #endif _CRTIMP size_t __cdecl __MINGW_NOTHROW wcstombs (char*, const wchar_t*, size_t); _CRTIMP int __cdecl __MINGW_NOTHROW wctomb (char*, wchar_t); _CRTIMP int __cdecl __MINGW_NOTHROW mblen (const char*, size_t); _CRTIMP size_t __cdecl __MINGW_NOTHROW mbstowcs (wchar_t*, const char*, size_t); _CRTIMP int __cdecl __MINGW_NOTHROW mbtowc (wchar_t*, const char*, size_t); _CRTIMP int __cdecl __MINGW_NOTHROW rand (void); _CRTIMP void __cdecl __MINGW_NOTHROW srand (unsigned int); _CRTIMP void* __cdecl __MINGW_NOTHROW calloc (size_t, size_t) __MINGW_ATTRIB_MALLOC; _CRTIMP void* __cdecl __MINGW_NOTHROW malloc (size_t) __MINGW_ATTRIB_MALLOC; _CRTIMP void* __cdecl __MINGW_NOTHROW realloc (void*, size_t); _CRTIMP void __cdecl __MINGW_NOTHROW free (void*); _CRTIMP void __cdecl __MINGW_NOTHROW abort (void) __MINGW_ATTRIB_NORETURN; _CRTIMP void __cdecl __MINGW_NOTHROW exit (int) __MINGW_ATTRIB_NORETURN; /* Note: This is in startup code, not imported directly from dll */ int __cdecl __MINGW_NOTHROW atexit (void (*)(void)); _CRTIMP int __cdecl __MINGW_NOTHROW system (const char*); _CRTIMP char* __cdecl __MINGW_NOTHROW getenv (const char*); /* bsearch and qsort are also in non-ANSI header search.h */ _CRTIMP void* __cdecl bsearch (const void*, const void*, size_t, size_t, int (*)(const void*, const void*)); _CRTIMP void __cdecl qsort(void*, size_t, size_t, int (*)(const void*, const void*)); _CRTIMP int __cdecl __MINGW_NOTHROW abs (int) __MINGW_ATTRIB_CONST; _CRTIMP long __cdecl __MINGW_NOTHROW labs (long) __MINGW_ATTRIB_CONST; /* * div_t and ldiv_t are structures used to return the results of div and * ldiv. * * NOTE: div and ldiv appear not to work correctly unless * -fno-pcc-struct-return is specified. This is included in the * mingw32 specs file. */ typedef struct { int quot, rem; } div_t; typedef struct { long quot, rem; } ldiv_t; _CRTIMP div_t __cdecl __MINGW_NOTHROW div (int, int) __MINGW_ATTRIB_CONST; _CRTIMP ldiv_t __cdecl __MINGW_NOTHROW ldiv (long, long) __MINGW_ATTRIB_CONST; #if !defined (__STRICT_ANSI__) /* * NOTE: Officially the three following functions are obsolete. The Win32 API * functions SetErrorMode, Beep and Sleep are their replacements. */ _CRTIMP void __cdecl __MINGW_NOTHROW _beep (unsigned int, unsigned int) __MINGW_ATTRIB_DEPRECATED; /* Not to be confused with _set_error_mode (int). */ _CRTIMP void __cdecl __MINGW_NOTHROW _seterrormode (int) __MINGW_ATTRIB_DEPRECATED; _CRTIMP void __cdecl __MINGW_NOTHROW _sleep (unsigned long) __MINGW_ATTRIB_DEPRECATED; _CRTIMP void __cdecl __MINGW_NOTHROW _exit (int) __MINGW_ATTRIB_NORETURN; /* _onexit is MS extension. Use atexit for portability. */ /* Note: This is in startup code, not imported directly from dll */ typedef int (* _onexit_t)(void); _onexit_t __cdecl __MINGW_NOTHROW _onexit( _onexit_t ); _CRTIMP int __cdecl __MINGW_NOTHROW _putenv (const char*); _CRTIMP void __cdecl __MINGW_NOTHROW _searchenv (const char*, const char*, char*); _CRTIMP char* __cdecl __MINGW_NOTHROW _ecvt (double, int, int*, int*); _CRTIMP char* __cdecl __MINGW_NOTHROW _fcvt (double, int, int*, int*); _CRTIMP char* __cdecl __MINGW_NOTHROW _gcvt (double, int, char*); _CRTIMP void __cdecl __MINGW_NOTHROW _makepath (char*, const char*, const char*, const char*, const char*); _CRTIMP void __cdecl __MINGW_NOTHROW _splitpath (const char*, char*, char*, char*, char*); _CRTIMP char* __cdecl __MINGW_NOTHROW _fullpath (char*, const char*, size_t); _CRTIMP char* __cdecl __MINGW_NOTHROW _itoa (int, char*, int); _CRTIMP char* __cdecl __MINGW_NOTHROW _ltoa (long, char*, int); _CRTIMP char* __cdecl __MINGW_NOTHROW _ultoa(unsigned long, char*, int); _CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _itow (int, wchar_t*, int); _CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _ltow (long, wchar_t*, int); _CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _ultow (unsigned long, wchar_t*, int); #ifdef __MSVCRT__ _CRTIMP __int64 __cdecl __MINGW_NOTHROW _atoi64(const char *); _CRTIMP char* __cdecl __MINGW_NOTHROW _i64toa(__int64, char *, int); _CRTIMP char* __cdecl __MINGW_NOTHROW _ui64toa(unsigned __int64, char *, int); _CRTIMP __int64 __cdecl __MINGW_NOTHROW _wtoi64(const wchar_t *); _CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _i64tow(__int64, wchar_t *, int); _CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _ui64tow(unsigned __int64, wchar_t *, int); _CRTIMP unsigned int __cdecl __MINGW_NOTHROW (_rotl)(unsigned int, int) __MINGW_ATTRIB_CONST; _CRTIMP unsigned int __cdecl __MINGW_NOTHROW (_rotr)(unsigned int, int) __MINGW_ATTRIB_CONST; _CRTIMP unsigned long __cdecl __MINGW_NOTHROW (_lrotl)(unsigned long, int) __MINGW_ATTRIB_CONST; _CRTIMP unsigned long __cdecl __MINGW_NOTHROW (_lrotr)(unsigned long, int) __MINGW_ATTRIB_CONST; _CRTIMP int __cdecl __MINGW_NOTHROW _set_error_mode (int); # define _OUT_TO_DEFAULT 0 # define _OUT_TO_STDERR 1 # define _OUT_TO_MSGBOX 2 # define _REPORT_ERRMODE 3 # if __MSVCRT_VERSION__ >= 0x800 # ifndef _UINTPTR_T_DEFINED # define _UINTPTR_T_DEFINED # ifdef _WIN64 typedef unsigned __int64 uintptr_t; # else typedef unsigned int uintptr_t; # endif # endif _CRTIMP unsigned int __cdecl __MINGW_NOTHROW _set_abort_behavior (unsigned int, unsigned int); /* These masks work with msvcr80.dll version 8.0.50215.44 (a beta release). */ # define _WRITE_ABORT_MSG 1 # define _CALL_REPORTFAULT 2 typedef void (* _invalid_parameter_handler) ( const wchar_t *, const wchar_t *, const wchar_t *, unsigned int, uintptr_t); _invalid_parameter_handler _set_invalid_parameter_handler (_invalid_parameter_handler); # endif /* __MSVCRT_VERSION__ >= 0x800 */ #endif /* __MSVCRT__ */ #ifndef _NO_OLDNAMES _CRTIMP int __cdecl __MINGW_NOTHROW putenv (const char*); _CRTIMP void __cdecl __MINGW_NOTHROW searchenv (const char*, const char*, char*); _CRTIMP char* __cdecl __MINGW_NOTHROW itoa (int, char*, int); _CRTIMP char* __cdecl __MINGW_NOTHROW ltoa (long, char*, int); #ifndef _UWIN _CRTIMP char* __cdecl __MINGW_NOTHROW ecvt (double, int, int*, int*); _CRTIMP char* __cdecl __MINGW_NOTHROW fcvt (double, int, int*, int*); _CRTIMP char* __cdecl __MINGW_NOTHROW gcvt (double, int, char*); #endif /* _UWIN */ #endif /* Not _NO_OLDNAMES */ #endif /* Not __STRICT_ANSI__ */ /* C99 names */ #if !defined __NO_ISOCEXT /* externs in static libmingwex.a */ /* C99 name for _exit */ void __cdecl __MINGW_NOTHROW _Exit(int) __MINGW_ATTRIB_NORETURN; #if !defined __NO_INLINE__ && !defined __STRICT_ANSI__ __CRT_INLINE void __cdecl __MINGW_NOTHROW _Exit(int __status) { _exit (__status); } #endif typedef struct { long long quot, rem; } lldiv_t; lldiv_t __cdecl __MINGW_NOTHROW lldiv (long long, long long) __MINGW_ATTRIB_CONST; long long __cdecl __MINGW_NOTHROW llabs(long long); #ifndef __NO_INLINE__ __CRT_INLINE long long __cdecl __MINGW_NOTHROW llabs(long long _j) {return (_j >= 0 ? _j : -_j);} #endif long long __cdecl __MINGW_NOTHROW strtoll (const char* __restrict__, char** __restrict, int); unsigned long long __cdecl __MINGW_NOTHROW strtoull (const char* __restrict__, char** __restrict__, int); #if defined (__MSVCRT__) /* these are stubs for MS _i64 versions */ long long __cdecl __MINGW_NOTHROW atoll (const char *); #if !defined (__STRICT_ANSI__) long long __cdecl __MINGW_NOTHROW wtoll (const wchar_t *); char* __cdecl __MINGW_NOTHROW lltoa (long long, char *, int); char* __cdecl __MINGW_NOTHROW ulltoa (unsigned long long , char *, int); wchar_t* __cdecl __MINGW_NOTHROW lltow (long long, wchar_t *, int); wchar_t* __cdecl __MINGW_NOTHROW ulltow (unsigned long long, wchar_t *, int); /* inline using non-ansi functions */ #ifndef __NO_INLINE__ __CRT_INLINE long long __cdecl __MINGW_NOTHROW atoll (const char * _c) { return _atoi64 (_c); } __CRT_INLINE char* __cdecl __MINGW_NOTHROW lltoa (long long _n, char * _c, int _i) { return _i64toa (_n, _c, _i); } __CRT_INLINE char* __cdecl __MINGW_NOTHROW ulltoa (unsigned long long _n, char * _c, int _i) { return _ui64toa (_n, _c, _i); } __CRT_INLINE long long __cdecl __MINGW_NOTHROW wtoll (const wchar_t * _w) { return _wtoi64 (_w); } __CRT_INLINE wchar_t* __cdecl __MINGW_NOTHROW lltow (long long _n, wchar_t * _w, int _i) { return _i64tow (_n, _w, _i); } __CRT_INLINE wchar_t* __cdecl __MINGW_NOTHROW ulltow (unsigned long long _n, wchar_t * _w, int _i) { return _ui64tow (_n, _w, _i); } #endif /* (__NO_INLINE__) */ #endif /* (__STRICT_ANSI__) */ #endif /* __MSVCRT__ */ #endif /* !__NO_ISOCEXT */ #ifdef __cplusplus } #endif #endif /* Not RC_INVOKED */ #endif /* Not _STDLIB_H_ */ c2hs-0.28.1/tests/bugs/issue-60/_mingw.h0000644000000000000000000001736612677513065015766 0ustar0000000000000000#ifndef __MINGW_H /* * _mingw.h * * Mingw specific macros included by ALL include files. * * This file is part of the Mingw32 package. * * Contributors: * Created by Mumit Khan * * THIS SOFTWARE IS NOT COPYRIGHTED * * This source code is offered for use in the public domain. You may * use, modify or distribute it freely. * * This code is distributed in the hope that it will be useful but * WITHOUT ANY WARRANTY. ALL WARRANTIES, EXPRESS OR IMPLIED ARE HEREBY * DISCLAIMED. This includes but is not limited to warranties of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * */ #define __MINGW_H #define __MINGW32_VERSION 3.20 #define __MINGW32_MAJOR_VERSION 3 #define __MINGW32_MINOR_VERSION 20 #define __MINGW32_PATCHLEVEL 0 #if __GNUC__ >= 3 #ifndef __PCC__ #pragma GCC system_header #endif #endif /* These are defined by the user (or the compiler) to specify how identifiers are imported from a DLL. __DECLSPEC_SUPPORTED Defined if dllimport attribute is supported. __MINGW_IMPORT The attribute definition to specify imported variables/functions. _CRTIMP As above. For MS compatibility. __MINGW32_VERSION Runtime version. __MINGW32_MAJOR_VERSION Runtime major version. __MINGW32_MINOR_VERSION Runtime minor version. __MINGW32_BUILD_DATE Runtime build date. Macros to enable MinGW features which deviate from standard MSVC compatible behaviour; these may be specified directly in user code, activated implicitly, (e.g. by specifying _POSIX_C_SOURCE or such), or by inclusion in __MINGW_FEATURES__: __USE_MINGW_ANSI_STDIO Select a more ANSI C99 compatible implementation of printf() and friends. Other macros: __int64 define to be long long. Using a typedef doesn't work for "unsigned __int64" All headers should include this first, and then use __DECLSPEC_SUPPORTED to choose between the old ``__imp__name'' style or __MINGW_IMPORT style declarations. */ /* Manifest definitions identifying the flag bits, controlling activation * of MinGW features, as specified by the user in __MINGW_FEATURES__. */ #define __MINGW_ANSI_STDIO__ 0x0000000000000001ULL /* * The following three are not yet formally supported; they are * included here, to document anticipated future usage. */ #define __MINGW_LC_EXTENSIONS__ 0x0000000000000050ULL #define __MINGW_LC_MESSAGES__ 0x0000000000000010ULL #define __MINGW_LC_ENVVARS__ 0x0000000000000040ULL /* Try to avoid problems with outdated checks for GCC __attribute__ support. */ #undef __attribute__ #if defined (__PCC__) # undef __DECLSPEC_SUPPORTED # ifndef __MINGW_IMPORT # define __MINGW_IMPORT extern # endif # ifndef _CRTIMP # define _CRTIMP # endif # ifndef __cdecl # define __cdecl _Pragma("cdecl") # endif # ifndef __stdcall # define __stdcall _Pragma("stdcall") # endif # ifndef __int64 # define __int64 long long # endif # ifndef __int32 # define __int32 long # endif # ifndef __int16 # define __int16 short # endif # ifndef __int8 # define __int8 char # endif # ifndef __small # define __small char # endif # ifndef __hyper # define __hyper long long # endif # ifndef __volatile__ # define __volatile__ volatile # endif # ifndef __restrict__ # define __restrict__ restrict # endif # define NONAMELESSUNION #elif defined(__GNUC__) # ifdef __declspec # ifndef __MINGW_IMPORT /* Note the extern. This is needed to work around GCC's limitations in handling dllimport attribute. */ # define __MINGW_IMPORT extern __attribute__ ((__dllimport__)) # endif # ifndef _CRTIMP # ifdef __USE_CRTIMP # define _CRTIMP __attribute__ ((dllimport)) # else # define _CRTIMP # endif # endif # define __DECLSPEC_SUPPORTED # else /* __declspec */ # undef __DECLSPEC_SUPPORTED # undef __MINGW_IMPORT # ifndef _CRTIMP # define _CRTIMP # endif # endif /* __declspec */ /* * The next two defines can cause problems if user code adds the * __cdecl attribute like so: * void __attribute__ ((__cdecl)) foo(void); */ # ifndef __cdecl # define __cdecl __attribute__ ((__cdecl__)) # endif # ifndef __stdcall # define __stdcall __attribute__ ((__stdcall__)) # endif # ifndef __int64 # define __int64 long long # endif # ifndef __int32 # define __int32 long # endif # ifndef __int16 # define __int16 short # endif # ifndef __int8 # define __int8 char # endif # ifndef __small # define __small char # endif # ifndef __hyper # define __hyper long long # endif #else /* ! __GNUC__ && ! __PCC__ */ # ifndef __MINGW_IMPORT # define __MINGW_IMPORT __declspec(dllimport) # endif # ifndef _CRTIMP # define _CRTIMP __declspec(dllimport) # endif # define __DECLSPEC_SUPPORTED # define __attribute__(x) /* nothing */ #endif #if defined (__GNUC__) && defined (__GNUC_MINOR__) #define __MINGW_GNUC_PREREQ(major, minor) \ (__GNUC__ > (major) \ || (__GNUC__ == (major) && __GNUC_MINOR__ >= (minor))) #else #define __MINGW_GNUC_PREREQ(major, minor) 0 #endif #ifdef __cplusplus # define __CRT_INLINE inline #else # if __GNUC_STDC_INLINE__ # define __CRT_INLINE extern inline __attribute__((__gnu_inline__)) # else # define __CRT_INLINE extern __inline__ # endif #endif # ifdef __GNUC__ # define _CRTALIAS __CRT_INLINE __attribute__ ((__always_inline__)) # else # define _CRTALIAS __CRT_INLINE # endif #ifdef __cplusplus # define __UNUSED_PARAM(x) #else # ifdef __GNUC__ # define __UNUSED_PARAM(x) x __attribute__ ((__unused__)) # else # define __UNUSED_PARAM(x) x # endif #endif #ifdef __GNUC__ #define __MINGW_ATTRIB_NORETURN __attribute__ ((__noreturn__)) #define __MINGW_ATTRIB_CONST __attribute__ ((__const__)) #else #define __MINGW_ATTRIB_NORETURN #define __MINGW_ATTRIB_CONST #endif #if __MINGW_GNUC_PREREQ (3, 0) #define __MINGW_ATTRIB_MALLOC __attribute__ ((__malloc__)) #define __MINGW_ATTRIB_PURE __attribute__ ((__pure__)) #else #define __MINGW_ATTRIB_MALLOC #define __MINGW_ATTRIB_PURE #endif /* Attribute `nonnull' was valid as of gcc 3.3. We don't use GCC's variadiac macro facility, because variadic macros cause syntax errors with --traditional-cpp. */ #if __MINGW_GNUC_PREREQ (3, 3) #define __MINGW_ATTRIB_NONNULL(arg) __attribute__ ((__nonnull__ (arg))) #else #define __MINGW_ATTRIB_NONNULL(arg) #endif /* GNUC >= 3.3 */ #if __MINGW_GNUC_PREREQ (3, 1) #define __MINGW_ATTRIB_DEPRECATED __attribute__ ((__deprecated__)) #else #define __MINGW_ATTRIB_DEPRECATED #endif /* GNUC >= 3.1 */ #if __MINGW_GNUC_PREREQ (3, 3) #define __MINGW_NOTHROW __attribute__ ((__nothrow__)) #else #define __MINGW_NOTHROW #endif /* GNUC >= 3.3 */ /* TODO: Mark (almost) all CRT functions as __MINGW_NOTHROW. This will allow GCC to optimize away some EH unwind code, at least in DW2 case. */ #ifndef __MSVCRT_VERSION__ /* High byte is the major version, low byte is the minor. */ # define __MSVCRT_VERSION__ 0x0600 #endif /* Activation of MinGW specific extended features: */ #ifndef __USE_MINGW_ANSI_STDIO /* * If user didn't specify it explicitly... */ # if defined __STRICT_ANSI__ || defined _ISOC99_SOURCE \ || defined _POSIX_SOURCE || defined _POSIX_C_SOURCE \ || defined _XOPEN_SOURCE || defined _XOPEN_SOURCE_EXTENDED \ || defined _GNU_SOURCE || defined _BSD_SOURCE \ || defined _SVID_SOURCE /* * but where any of these source code qualifiers are specified, * then assume ANSI I/O standards are preferred over Microsoft's... */ # define __USE_MINGW_ANSI_STDIO 1 # else /* * otherwise use whatever __MINGW_FEATURES__ specifies... */ # define __USE_MINGW_ANSI_STDIO (__MINGW_FEATURES__ & __MINGW_ANSI_STDIO__) # endif #endif #endif /* __MINGW_H */ c2hs-0.28.1/tests/bugs/issue-60/Issue60.chs0000644000000000000000000000011312677513065016250 0ustar0000000000000000module Main where #include "stdlib.h" main :: IO () main = putStrLn "OK" c2hs-0.28.1/tests/bugs/issue-136/0000755000000000000000000000000012677513065014404 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-136/Issue136.chs0000644000000000000000000000164412677513065016432 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-} {- | This will break things if you're not careful about comment parsing... -- Hmmm... -} -- And so will this -} module Main where import Control.Applicative ( (<$>) , (<*>) , (*>)) import Foreign.Marshal.Utils import Foreign.Storable #include "issue136.h" data Foo data Bar = Bar Int Int instance Storable Bar where sizeOf _ = {#sizeof bar_t #} alignment _ = {#alignof bar_t #} peek p = Bar <$> (fromIntegral <$> {#get bar_t.y #} p) <*> (fromIntegral <$> {#get bar_t.z #} p) poke p (Bar y z) = ({#set bar_t.y #} p $ fromIntegral y) *> ({#set bar_t.z #} p $ fromIntegral z) {#pointer *foo_t as FooPtr -> Foo #} {#pointer *bar_t as BarPtr -> Bar #} {#fun unsafe mutate_foo as mutateFoo { `FooPtr' , with* `Bar' } -> `()' #} main :: IO () main = putStrLn "OK" c2hs-0.28.1/tests/bugs/issue-136/issue136.h0000644000000000000000000000021712677513065016137 0ustar0000000000000000typedef struct { int y; int z; } bar_t; typedef struct { int x; bar_t bar; } foo_t; void mutate_foo(foo_t *foo, bar_t *bar); c2hs-0.28.1/tests/bugs/issue-136/issue136.c0000644000000000000000000000013012677513065016124 0ustar0000000000000000#include "issue136.h" void mutate_foo(foo_t *foo, bar_t *bar) { foo->bar = *bar; } c2hs-0.28.1/tests/bugs/issue-36/0000755000000000000000000000000012677513065014323 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-36/issue36.h0000644000000000000000000000011412677513065015771 0ustar0000000000000000typedef struct { int a; } hit_int; typedef struct { double a; } hit_double; c2hs-0.28.1/tests/bugs/issue-36/Issue36.chs0000644000000000000000000000047512677513065016271 0ustar0000000000000000module Main where #include "issue36.h" data Hit1 a = Hit1 a data Hit2 a b = Hit2 a b {#pointer *hit_int as HitEg1 -> Hit1 Int#} {#pointer *hit_double as HitEg2 -> Hit1 Double#} {#pointer *hit_int as HitEg3 -> `Hit2 Int ()'#} {#pointer *hit_double as HitEg4 -> `Hit2 Double [Int]'#} main :: IO () main = return () c2hs-0.28.1/tests/bugs/issue-29/0000755000000000000000000000000012677513065014325 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-29/issue29.h0000644000000000000000000000020312677513065015774 0ustar0000000000000000#ifndef _STDLIB_H_ #define _STDLIB_H_ int atexit(void (*)(void)); #ifdef __BLOCKS__ int atexit_b(void (^)(void)); #endif #endif c2hs-0.28.1/tests/bugs/issue-29/Issue29.chs0000644000000000000000000000011012677513065016257 0ustar0000000000000000module Main where #include "issue29.h" main :: IO () main = return () c2hs-0.28.1/tests/bugs/issue-65/0000755000000000000000000000000012677513065014325 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-65/issue65.h0000644000000000000000000000007612677513065016004 0ustar0000000000000000#define CONST1 123 #define CONST2 3.14 #define CONST3 "hello" c2hs-0.28.1/tests/bugs/issue-65/issue65.c0000644000000000000000000000000012677513065015762 0ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-65/Issue65.chs0000644000000000000000000000035412677513065016271 0ustar0000000000000000module Main where #include "issue65.h" const1 :: Int const1 = {#const CONST1#} const2 :: Double const2 = {#const CONST2#} const3 :: String const3 = {#const CONST3#} main :: IO () main = print const1 >> print const2 >> print const3 c2hs-0.28.1/tests/bugs/issue-70/0000755000000000000000000000000012677513065014321 5ustar0000000000000000c2hs-0.28.1/tests/bugs/issue-70/issue70.h0000644000000000000000000000006412677513065015771 0ustar0000000000000000enum Foo { BAR, BAZ, QUX = 5, XYZZY_THUD }; c2hs-0.28.1/tests/bugs/issue-70/Issue70.chs0000644000000000000000000000132312677513065016256 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} module Foo where #include "issue70.h" class Flux a where data FluxCode a gigawattsNeeded :: a -> Double gigawattsNeeded _ = 1.21 data Capacitor = Capacitor Int instance Flux Capacitor where -- associated data type decl data FluxCode Capacitor = Bar | Baz | Qux | Xyzzy -- Note: must be able to define longer names here, I've used single quotes. -- underscoreToCase still works, it aliases the C identifiers for the instance. -- XYZZY_THUD is manually aliased. -- nocode suppresses emitting a data declaration. {# enum Foo as 'FluxCode Capacitor' nocode { underscoreToCase, XYZZY_THUD as Xyzzy } #} c2hs-0.28.1/tests/bugs/issue-70/issue70.c0000644000000000000000000000000012677513065015752 0ustar0000000000000000c2hs-0.28.1/tests/system/0000755000000000000000000000000012677513065013331 5ustar0000000000000000c2hs-0.28.1/tests/system/Makefile0000644000000000000000000000604612677513065014777 0ustar0000000000000000# Note that file.o and File.o are the same file on case-insensitive systems # Therefore we shouldn't use one for C and one for HS HC=ghc HCFLAGS= -fffi C2HS = ../../dist/build/c2hs/c2hs # C2HSFLAGS = -d trace -d genbind -d ctrav -d chs PRGMS = simple calls enums pointer structs marsh cpp default: tests # builds C2HS.o: ../../C2HS.hs cp -p ../../C2HS.hs . $(HC) -c C2HS.hs simple: C2HS.o Simple.chs simple.h simple.c $(C2HS) $(C2HSFLAGS) simple.h Simple.chs $(HC) -c -o Simple_hs.o Simple.hs $(HCFLAGS) $(CC) -c simple.c $(HC) -o simple simple.o Simple_hs.o C2HS.o calls: C2HS.o Calls.chs calls.h $(C2HS) $(C2HSFLAGS) calls.h Calls.chs $(HC) -c -o Calls.o Calls.hs -#include\"calls.h\" $(HCFLAGS) || \ echo "!!! Building calls failed ! known bug #?" enums: C2HS.o Enums.chs enums.h $(C2HS) $(C2HSFLAGS) enums.h Enums.chs $(CC) -o enums_c.o -c enums.c $(HC) -o enums enums_c.o Enums.hs -#include\"enums.h\" $(HCFLAGS) C2HS.o pointer: C2HS.o Pointer.chs pointer.h pointer.c $(C2HS) $(C2HSFLAGS) pointer.h Pointer.chs $(CC) -o pointer_c.o -c pointer.c $(HC) -o pointer pointer_c.o Pointer.hs -#include\"pointer.h\"\ $(HCFLAGS) C2HS.o sizeof: C2HS.o Sizeof.chs sizeof.h sizeof.c $(C2HS) $(C2HSFLAGS) sizeof.h Sizeof.chs $(HC) -c -o Sizeof.o Sizeof.hs -#include\"sizeof.h\" $(HCFLAGS) $(CC) -o sizeof_c.o -c sizeof.c $(HC) -o sizeof sizeof_c.o Sizeof.o $(HCFLAGS) C2HS.o structs: C2HS.o Structs.chs structs.h structs.c $(C2HS) $(C2HSFLAGS) structs.h Structs.chs $(HC) -c -o Structs.o Structs.hs -#include\"structs.h\" $(HCFLAGS) $(CC) -o structs_c.o -c structs.c $(HC) -o structs structs_c.o Structs.o $(HCFLAGS) C2HS.o marsh: C2HS.o Marsh.chs marsh.h $(C2HS) $(C2HSFLAGS) marsh.h Marsh.chs $(HC) -o marsh Marsh.hs -#include\"marsh.h\" $(HCFLAGS) C2HS.o cpp: C2HS.o Cpp.chs cpp.h $(C2HS) $(C2HSFLAGS) Cpp.chs $(HC) -c -o Cpp.o Cpp.hs -#include\"Cpp.h\" $(HCFLAGS) C2HS.o # runs .PHONY: tests simple.run calls.build enums.run pointer.run structs.run\ marsh.run cpp.build tests: simple.run enums.run pointer.run structs.run marsh.run\ cpp.build buggy buggy: calls.build sizeof.run simple.run: simple @echo "---=== Output of \`simple'": @./simple @echo "---=== End of Output" calls.build: calls @echo "---=== Binding for \`calls'": @cat Calls.hs @echo "---=== End of Binding" enums.run: enums @echo "---=== Output for \`enums'": @./enums @echo "---=== End of Output" pointer.run: pointer @echo "---=== Output for \`pointer'": @./pointer @echo "---=== End of Output" sizeof.run: sizeof @echo "---=== Output for \`sizeof'": @./sizeof || \ echo "!!! sizeof FAILED: Maybe related to bug #10" @echo "---=== End of Output" structs.run: structs @echo "---=== Output for \`structs'": @./structs > structs.out @cat structs.out @diff structs.out structs.expect @echo "---=== End of Output (diff ok)" marsh.run: marsh @echo "---=== Output for \`marsh'": @./marsh @echo "---=== End of Output" cpp.build: cpp @echo "---=== Binding for \`cpp'": @cat Cpp.hs @echo "---=== End of Binding" # misc clean: -rm -f *.o *.hi *.hs *.out $(PRGMS) c2hs-0.28.1/tests/system/enums/0000755000000000000000000000000012677513065014460 5ustar0000000000000000c2hs-0.28.1/tests/system/enums/Enums.chs0000644000000000000000000000212712677513065016250 0ustar0000000000000000-- -*-haskell-*- import Control.Monad import Foreign import Foreign.C import System.IO.Unsafe (unsafePerformIO) cToEnum :: (Integral i, Enum e) => i -> e cToEnum = toEnum . fromIntegral cFromEnum :: (Enum e, Integral i) => e -> i cFromEnum = fromIntegral . fromEnum {#context prefix="enums"#} {#enum colour as Colour {upcaseFirstLetter}#} {#enum weird as Weird {underscoreToCase}#} {#enum side as Side {underscoreToCase}#} {#enum other_side as OtherSide {}#} {#enum enum_net_type as NetType {underscoreToCase}#} {#enum enums_enums as Enums {underscoreToCase, ENUMS_TWO as Two}#} colourOfSide :: Side -> Colour colourOfSide = cToEnum . {#call fun colourOfSide as colourOfSidePrim#} . cFromEnum #c enum ThisThat { This = THIS, That = THAT }; enum ThisThatCast { CThis = C_THIS, CThat = C_THAT }; #endc {#enum ThisThat {}#} {#enum ThisThatCast {}#} main :: IO () main = do const (return ()) discard unless (1 == fromEnum One) $ putStrLn "1 /= One!!!" putStrLn "Did it!" where -- is not executed, only type checked discard = {#get NET.nettype#} undefined :: IO CInt c2hs-0.28.1/tests/system/enums/enums.c0000644000000000000000000000021412677513065015750 0ustar0000000000000000#include #include "enums.h" enum colour colourOfSide (side aside) { /* not executed, but needed for linking */ abort (); } c2hs-0.28.1/tests/system/enums/enums.h0000644000000000000000000000136012677513065015760 0ustar0000000000000000#ifndef _ENUMS_H #define _ENUMS_H #define STOP -1 enum colour { red, green, blue }; enum weird { NUL, EINS = red + 1, /* refers to other enum */ FIVE = 5, SIX, MINUS_ONE = STOP }; typedef enum { TOP, BOTTOM, RIGHT, LEFT } side; typedef side other_side; enum colour colourOfSide (side aside); enum enum_net_type { NET_TYPE_TCPIP, NET_TYPE_SOCKET, NET_TYPE_NAMEDPIPE }; typedef struct st_net { enum enum_net_type nettype; int rest; } NET; enum enums_enums { ENUMS_ONE = 1, ENUMS_TWO = 2, ENUMS_THREE = 3 }; /* A #define enum */ #define THIS 1 #define THAT 2 typedef unsigned long DWORD; /* A #define enum with casts */ #define C_THIS ((DWORD)0x1L) #define C_THAT ((DWORD)0x2L) #endif /* !_ENUMS_H */ c2hs-0.28.1/tests/system/sizeof/0000755000000000000000000000000012677513065014630 5ustar0000000000000000c2hs-0.28.1/tests/system/sizeof/sizeof.c0000644000000000000000000000071512677513065016276 0ustar0000000000000000#include "sizeof.h" size_t size_of_s1() { return sizeof(struct s1); } size_t size_of_s2() { return sizeof(struct s2); } size_t size_of_s3() { return sizeof(struct s3); } size_t size_of_s4() { return sizeof(struct s4); } size_t align_of_s1() { return __alignof__(struct s1); } size_t align_of_s2() { return __alignof__(struct s2); } size_t align_of_s3() { return __alignof__(struct s3); } size_t align_of_s4() { return __alignof__(struct s4); } c2hs-0.28.1/tests/system/sizeof/Sizeof.chs0000644000000000000000000000363712677513065016577 0ustar0000000000000000module Main where import Control.Monad (liftM, when) import Foreign.C main = do size alignment size = do let sz1 = {# sizeof S1 #} sz1expect <- liftM fromIntegral {# call size_of_s1 #} let sz2 = {# sizeof S2 #} sz2expect <- liftM fromIntegral {# call size_of_s2 #} -- small bitfield in struct gets wrong size, should be sizeof int, c2hs gets 1 -- http://hackage.haskell.org/trac/c2hs/ticket/10 let sz3 = {# sizeof S3 #} sz3expect <- liftM fromIntegral {# call size_of_s3 #} let sz4 = {# sizeof S4 #} sz4expect <- liftM fromIntegral {# call size_of_s4 #} putStrLn $ show sz1 ++ " & " ++ show sz2 ++ " & " ++ show sz3 ++ " & " ++ show sz4 when (sz1 /= sz1expect) $ fail "Fatal: sizeof s1 != size_of_s1()" when (sz2 /= sz2expect) $ fail "Fatal: sizeof s2 != size_of_s2()" when (sz3 /= sz3expect) $ fail $ "Fatal: sizeof s3 != size_of_s3(): " ++ show sz3 ++ " but expected " ++ show sz3expect when (sz4 /= sz4expect) $ fail $ "Fatal: sizeof s4 != size_of_s4(): " ++ show sz4 ++ " but expected " ++ show sz4expect alignment = do let al1 = {# alignof S1 #} al1expect <- liftM fromIntegral {# call align_of_s1 #} let al2 = {# alignof S2 #} al2expect <- liftM fromIntegral {# call align_of_s2 #} let al3 = {# alignof S3 #} al3expect <- liftM fromIntegral {# call align_of_s3 #} let al4 = {# alignof S4 #} al4expect <- liftM fromIntegral {# call align_of_s4 #} putStrLn $ show al1 ++ " & " ++ show al2 ++ " & " ++ show al3 ++ " & " ++ show al4 when (al1 /= al1expect) $ fail "Fatal: alignment s1 != align_of_s1()" when (al2 /= al2expect) $ fail "Fatal: alignment s2 != align_of_s2()" when (al3 /= al3expect) $ fail $ "Fatal: alignment s3 != align_of_s3(): " ++ show al3 ++ " but expected " ++ show al3expect when (al4 /= al4expect) $ fail $ "Fatal: alignment s4 != align_of_s4(): " ++ show al4 ++ " but expected " ++ show al4expect c2hs-0.28.1/tests/system/sizeof/sizeof.h0000644000000000000000000000172112677513065016301 0ustar0000000000000000#include #define BFSZ(ty,bits) bits size_t size_of_s1(); size_t size_of_s2(); size_t size_of_s3(); size_t size_of_s4(); size_t align_of_s1(); size_t align_of_s2(); size_t align_of_s3(); size_t align_of_s4(); typedef struct s1 { int x; char y; void* z; } S1; typedef struct s2 { int* x[5]; int (*y)[7]; int (*f1)(void); int (*f2)[11]; } S2; typedef struct s3 { int a:7; } S3; typedef struct s4 { struct { int a : BFSZ(int,13); int b : BFSZ(int,13); int b_1: BFSZ(int,13); int b_2: BFSZ(int,13); int b_3: BFSZ(int,13); } f0; /* NOT SUPPORTED: c2hs does not allow char/short etc. as bitfield types struct { signed char c:BFSZ(signed char,4); unsigned char d; short e:BFSZ(short,7); short f:BFSZ(short,7); short f_1:BFSZ(short,7); long long g; long long h:BFSZ(long long, 15); */ } S4; c2hs-0.28.1/tests/system/structs/0000755000000000000000000000000012677513065015040 5ustar0000000000000000c2hs-0.28.1/tests/system/structs/Structs.chs0000644000000000000000000000432412677513065017211 0ustar0000000000000000-- To build, do -*-haskell-*- -- % gcc -c structs.c -- % ../c2hs structs.h Structs.chs -- % ghc -fglasgow-exts '-#include' -o structs\ -- -i../lib -L../lib Structs.hs structs.o -lc2hs import Control.Monad (liftM, when) import Foreign import Foreign.C import System.IO.Unsafe (unsafePerformIO) cIntConv :: (Integral a, Integral b) => a -> b cIntConv = fromIntegral newtype Point = Point {#type point#} unPoint :: Point -> {#type point#} unPoint (Point p) = p makePoint :: Int -> Int -> Point makePoint x y = Point ({#call fun make_point#} (cIntConv x) (cIntConv y)) pointSize :: Int pointSize = {#sizeof point#} bar = {#sizeof SDL_Event#} -- regression test main :: IO () main = do val <- liftM cIntConv $ {#get _point.y#} $! unPoint pnt val' <- liftM cIntConv $ {#get point->y#} $! unPoint pnt when (val /= val') $ error "val /= val': Panic!" weird <- {#call make_weird#} val2 <- liftM cIntConv $ {#get weird->x#} weird val3 <- liftM cIntConv $ {#get weird->nested.z#} weird val4 <- liftM cIntConv $ {#get weird->nested.pnt->y#} weird const nop $ {#set cpoint->col#} nullPtr 5 -- only for seeing what is generated spacePtr <- {#call getSpacePtr#} space <- liftM castCCharToChar $ {#get *mychar#} spacePtr; -- bitfields bitStructPtr <- {#call get_bit_struct#} {#set bit_struct.bit#} bitStructPtr 0 bit <- {#get struct bit_struct.bit#} bitStructPtr when (bit /= 0) $ error "bit /= 0: Panic!" smallInt <- {#get bit_struct.very_small_int#} bitStructPtr when (smallInt /= -1) $ error "smallInt /= -1: Panic!" -- putStr (show val ++ " & " ++ -- expect: 42 show val2 ++ " & " ++ -- expect: weird->x = -1 show val3 ++ " & " ++ -- expect: weird->nested.z = 2 show val4 ++ " & " ++ -- expect: weird->nested.pnt -> y = 200 show space ++ "\n") -- expect: ' ' where pnt = makePoint 35 42 nop = return () c2hs-0.28.1/tests/system/structs/structs.c0000644000000000000000000000127112677513065016714 0ustar0000000000000000#include #include "structs.h" point make_point (int x, int y) { point pnt; pnt = (point) malloc (sizeof (*pnt)); pnt->x = x; pnt->y = y; return pnt; } weird make_weird (void) { weird w; w = (weird) malloc (sizeof (*w)); w->b = ' '; w->x = -1; w->nested.y = 4; w->nested.z = 2; w->nested.pnt = make_point (100, 200); return w; } mychar *getSpacePtr (void) { static char c = ' '; return &c; } struct bit_struct my_bit_struct; struct bit_struct *get_bit_struct() { my_bit_struct.c1 = '\0'; my_bit_struct.bit = 1; my_bit_struct.very_small_int = -1; my_bit_struct.c2 = '\0'; return &my_bit_struct; } c2hs-0.28.1/tests/system/structs/structs.h0000644000000000000000000000222312677513065016717 0ustar0000000000000000#ifndef __STRUCTS_H__ #define __STRUCTS_H__ typedef char bool, mychar; typedef struct _point *point; int _point(void); struct _point { int x, y; }; int _point(void); typedef struct { struct _point pnt; int col; } *cpoint; typedef struct { bool b; int x; struct { int y, z; point pnt; } nested; } *weird; typedef struct ambiguousName { int x; } ambiguousName; /* same name for struct tag and type */ typedef struct ambiguousName someOtherName; point make_point (int x, int y); weird make_weird (void); mychar *getSpacePtr (void); /* bitfield functionality */ struct bit_struct { char c1; unsigned int bit : 1; signed int very_small_int : 3; char c2; }; struct bit_struct *get_bit_struct(); #ifdef __GNUC__ /* this is to check c2hs's resistance to GNU extensions */ struct _MyStructAlign {long int x;}; struct _MyStruct { int bar; } __attribute__ ((aligned (__alignof (struct _MyStructAlign)))) ; #endif /* __GNUC__ */ /* to test nested struct/unions (regression test) */ typedef struct { int type; int typ1; } FT; typedef union { int type; FT typ1; } SDL_Event; #endif /* __STRUCTS_H__ */ c2hs-0.28.1/tests/system/cpp/0000755000000000000000000000000012677513065014113 5ustar0000000000000000c2hs-0.28.1/tests/system/cpp/Cpp.chs0000644000000000000000000000064512677513065015341 0ustar0000000000000000-- -*-haskell-*- module Cpp where import Foreign import Foreign.C import System.IO.Unsafe (unsafePerformIO) -- CPP directive -- - #define VERSION 2 -- conditional binding -- - #if (VERSION == 1) -- this does not match the C definition -- foo :: CInt -> CInt foo = {#call pure fooC#} #else -- this does -- foo :: CInt -> CInt -> CInt foo = {#call pure fooC#} #endif -- C code -- - #c int fooC (int, int); #endc c2hs-0.28.1/tests/system/pointer/0000755000000000000000000000000012677513065015011 5ustar0000000000000000c2hs-0.28.1/tests/system/pointer/Pointer.chs0000644000000000000000000000304412677513065017131 0ustar0000000000000000-- -*-haskell-*- import Control.Monad import Foreign import Foreign.C cIntConv :: (Integral a, Integral b) => a -> b cIntConv = fromIntegral {#pointer string as MyCString foreign newtype#} cconcat :: MyCString -> MyCString -> IO MyCString cconcat s1 s2 = do ptr <- withMyCString s1 $ \s1' -> withMyCString s2 $ \s2' -> {#call concat as _concat#} s1' s2' liftM MyCString $ newForeignPtr finalizerFree ptr data Point = Point { x :: Int, y :: Int } {#pointer *Point as CPoint foreign -> Point#} -- this is just to exercise some more paths in GenBind.hs {#pointer *_Point as C_Point foreign -> Point#} {#pointer PointPtr#} makeCPoint :: Int -> Int -> IO CPoint makeCPoint x y = do ptr <- {#call unsafe make_point#} (cIntConv x) (cIntConv y) newForeignPtr finalizerFree ptr transCPoint :: CPoint -> Int -> Int -> IO CPoint transCPoint pnt x y = do ptr <- withForeignPtr pnt $ \pnt' -> {#call unsafe trans_point#} pnt' (cIntConv x) (cIntConv y) newForeignPtr finalizerFree ptr -- test function pointers {#pointer FunPtrFun#} -- test pointer to pointer type PtrString = {#type stringPtr#} checkType :: PtrString -> Ptr (Ptr CChar) checkType = id -- test classes {#pointer *Point as APoint newtype#} {#class APointClass APoint#} {#pointer *ColourPoint as AColourPoint newtype#} {#class APointClass => AColourPointClass AColourPoint#} -- test suppression of code generation {#pointer *Point as APoint2 newtype nocode#} main = putStrLn "This test doesn't compute much; it's all about the generated \ \types." c2hs-0.28.1/tests/system/pointer/pointer.c0000644000000000000000000000074712677513065016645 0ustar0000000000000000#include #include #include "pointer.h" string concat (string str1, string str2) { printf ("concat doesn't do anything"); return str1; } Point *make_point (int x, int y) { Point *pnt; pnt = (Point *) malloc (sizeof (Point)); pnt->x = x; pnt->x = y; return pnt; } Point *trans_point (Point *pnt, int x, int y) { Point *newPnt; newPnt = (Point *) malloc (sizeof (Point)); newPnt->x = pnt->x + x; newPnt->y = pnt->y + y; return newPnt; } c2hs-0.28.1/tests/system/pointer/pointer.h0000644000000000000000000000075112677513065016645 0ustar0000000000000000#ifndef _POINTER_H #define _POINTER_H typedef char *string; string concat (string str1, string str2); struct _Point { int x, y; }; struct _ColourPoint { int x, y; unsigned int colour; }; typedef struct _Point Point; typedef struct _ColourPoint ColourPoint; typedef struct _Point *PointPtr; Point *make_point (int x, int y); Point *trans_point (Point *pnt, int x, int y); typedef void (*FunPtrFun) (void *data); typedef char **stringPtr; #endif /* !_POINTER_H */ c2hs-0.28.1/tests/system/marsh/0000755000000000000000000000000012677513065014443 5ustar0000000000000000c2hs-0.28.1/tests/system/marsh/Marsh.chs0000644000000000000000000000077512677513065016225 0ustar0000000000000000-- To build, do -*-haskell-*- -- {-% gcc -c marsh.c-} -- % ../c2hs marsh.h Marsh.chs -- % ghc -fglasgow-exts '-#include' -o marsh\ -- -i../lib -L../lib Marsh.hs {-marsh.o-} -lc2hs import Foreign import Foreign.C main :: IO () main = do mem <- newCString "Hello World!\n" str <- peekCString mem free mem putStr str let l = [5, 3, 7] :: [CInt] len = length l mem <- newArray l l <- peekArray len mem free mem putStr $ show l ++ "\n" c2hs-0.28.1/tests/system/marsh/marsh.h0000644000000000000000000000011212677513065015720 0ustar0000000000000000#ifndef __MARSH_H__ #define __MARSH_H__ int x; #endif /* __MARSH_H__ */ c2hs-0.28.1/tests/system/calls/0000755000000000000000000000000012677513065014427 5ustar0000000000000000c2hs-0.28.1/tests/system/calls/calls.h0000644000000000000000000000054412677513065015701 0ustar0000000000000000#ifndef _CALLS_H #define _CALLS_H int foo (); float bar (int); void baz (int x, float y); char *MyString (void); typedef char *tString; void printString (tString str); void printString2 (tString); int foobar (tString chars, int nchars, int *items, float x); /* type of function `MyString' */ typedef char *(*MyStringType) (int); #endif /* !_CALLS_H */ c2hs-0.28.1/tests/system/calls/Calls.chs0000644000000000000000000000235712677513065016173 0ustar0000000000000000-- -*-haskell-*- module Main where import Control.Monad import Foreign hiding (unsafePerformIO) import Foreign.C import System.IO.Unsafe (unsafePerformIO) withCStringLenIntConv :: Num n => String -> ((CString, n) -> IO a) -> IO a withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, fromIntegral n) peekIntConv :: (Storable a, Integral a, Integral b) => Ptr a -> IO b peekIntConv = liftM fromIntegral . peek {#context lib="calls"#} type TString = {#type tString#} type MyStringT = {#type MyStringType#} -- extract a function type main :: IO () main = do let barfoo = {#call fun bar#} {#call fun foo#} {#call unsafe baz#} {#call fun foo#} barfoo -- BUG ! {#call printString#} {# call pure MyString as myString #} -- test typedef'ed args without argument variable in prototype {#call printString2#} {# call pure MyString as myString #} {#fun foo as fooFun {} -> `Int'#} {#fun pure bar as barFun {`Int'} -> `Float'#} {#fun baz as bazFun {`Int', `Float'} -> `()'#} {#fun pure MyString as myStringFun {} -> `String'#} {#fun printString as printStringFun {`String'} -> `()'#} {#fun foobar { `String'& , alloca- `Int' peekIntConv*, `Float' } -> `Int'#} c2hs-0.28.1/tests/system/simple/0000755000000000000000000000000012677513065014622 5ustar0000000000000000c2hs-0.28.1/tests/system/simple/simple.h0000644000000000000000000000001512677513065016260 0ustar0000000000000000void foo (); c2hs-0.28.1/tests/system/simple/Simple.chs0000644000000000000000000000006612677513065016554 0ustar0000000000000000module Main where main :: IO () main = {#call foo#} c2hs-0.28.1/tests/system/simple/simple.c0000644000000000000000000000011112677513065016250 0ustar0000000000000000#include void foo () { printf ("I am the mighty foo!\n"); } c2hs-0.28.1/doc/0000755000000000000000000000000012677513065011410 5ustar0000000000000000c2hs-0.28.1/doc/c2hs.xml0000644000000000000000000016030512677513065012776 0ustar0000000000000000 c2hs'> ]>
The Binding Generator &C2hs; Manuel Chakravarty chak@cse.unsw.edu.au November 2007 &C2hs; is an interface generator that simplifies the development of Haskell bindings to C libraries. The tool processes existing C header files that determine data layout and function signatures on the C side in conjunction with Haskell modules that specify Haskell-side type signatures and marshaling details. Hooks embedded in the Haskell code signal access to C structures and functions -- they are expanded by the interfacing tool in dependence on information from the corresponding C header file. Another noteworthy property is the lightweight nature of the approach. More background information is available in a research paper discussing &C2hs;, which is at . However, this paper does not cover the more recent advanced features such as function hooks and conditional compilation. Installation It follows a brief discussion of the installation from source. There is, however, a file INSTALL in the source distribution, which is more frequently updated and should be consulted in any case. Where is the Source? The master site of &C2hs; is at . It has all the latest information and sources. Furthermore, it explains how to get access to the &C2hs; Darcs repository and has references to pre-compiled binaries. What Else Do I Need? You need a Haskell system supported by &C2hs;. Currently, this is only the Glasgow Haskell Compiler (GHC), which you can obtain from . Furthermore, you need the Haskell package system Cabal. See the INSTALL file for details on supported versions. To build the documentation, you will also need the SGML Tools, which you find at your nearest sunsite or Linux mirror or at . On an up-to-date Linux system, the tools are probably already installed. I Got Everything, and Now? The short answer is $ tar -xzf package.tar.gz # unpack the sources $ cd package # change to the toplevel directory $ runghc Setup.hs configure # configure the build system $ runghc Setup.hs build # build everything [ Become root if necessary ] $ runghc Setup.hs install # install c2hs In the INSTALL file, there are more details. Optionally, you can build the documentation by issuing make doc and install it with make install-doc. Usage of &C2hs; Let's have a brief look at how to call the tool and how to use the generated interfaces. Usage of &c2hs; &C2hs; is implemented by the executable &c2hs;. The simplest form of usage is c2hs Lib.chs where Lib.chs is the Haskell binding module defining the Haskell interface to a C library together with the required marshalling code. If &c2hs; is invoked in this manner, the binding module must contain a cpp #include directive to determine the C-side interface of the library. Alternatively, a C header file can be specified on the command line, as in c2hs lib.h Lib.chs However, the latter option is only preserved for backwards compatibility and not recommended. If no errors occur, &c2hs; generates three files: a pure Haskell module Lib.hs, which implements the Haskell API of the library a C header file Lib.h which some Haskell systems need to compile the generated Haskell code. a &c2hs; interface file Lib.chi that is used by other binding modules that import Lib.hs using an import hook (see the section on import hooks for details). The executable &c2hs; has a couple more options: Usage: c2hs [ option... ] [header-file] binding-file -C CPPOPTS --cppopts=CPPOPTS pass CPPOPTS to the C preprocessor -c CPP --cpp=CPP use executable CPP to invoke C preprocessor -d TYPE --dump=TYPE dump internal information (for debugging) -h, -? --help brief help (the present message) -i INCLUDE --include=INCLUDE include paths for .chi files -k --keep keep pre-processed C header -l --copy-library copy `C2HS' library module in -o FILE --output=FILE output result to FILE (should end in .hs) -p PLATFORM --platform=PLATFORM platform to use for cross compilation -t PATH --output-dir=PATH place generated files in PATH -v --version show version information --numeric-version show version number The header file must be a C header file matching the given binding file. The dump TYPE can be trace -- trace compiler phases genbind -- trace binding generation ctrav -- trace C declaration traversal chs -- dump the binding file (adds `.dump' to the name) PLATFORM can be x86_64-linux, i686-linux, m68k-palmos The most useful of these is probably --cppopts= (or -C). If the C header file needs any special options (like -D or -I) to go through the C pre-processor, here is the place to pass them. A call may look like this: c2hs --cppopts='-I/some/obscure/dir' --cppopts=-DEXTRA' Lib.chs If you have more than one option that you want to pass to the pre-processor it is best to use multiple --cppopts= flags. That way there is no need to worry about quoting. Often, lib.h will not be in the current directory, but in one of the header file directories. &c2hs; leaves locating the header file to the standard C preprocessor, which usually looks in two places for the header: first, in the standard include directory of the used system, this is usually /usr/include and /usr/local/include; and second, it will look in every directory that is mentioned in a -IDIR option passed to the pre-processor via --cppopts. If the compiled binding module contains import hooks, &C2hs; needs to find the .chi (&C2hs; interface files) produced while compiling the corresponding binding modules. By default, they will be searched for in the current working directory. If they are located elsewhere, the --include=INCLUDE option has to be used to indicate the location, where INCLUDE is a colon-separated list of directories. Multiple such options are admissible. Paths specified later are searched first. Compilation of a Generated Haskell API &C2hs; comes with a marshalling library, called C2HS, which needs to be explicitly imported into Haskell binding modules. The library contains functions that users might use explicitly, but also functions that &C2hs; will generate for some classes of bindings. The library takes the form of a single Haskell module, which &c2hs; places in the same directory as the generated binding whenever it is given the --copy-library (or -l) option. Implementation of Haskell Binding Modules A discussion of binding modules, the principles behind the tool, and a discussion of related work can be found in a research paper located at . All features described in the paper, except enum define hooks are implemented in the tool, but since the publication of the paper, the tool has been extended further. The library interface essentially consists of the new Haskell FFI Marshalling Library. More details about this library are provided in the next section. The remainder of this section describes the hooks that are available in binding modules. Import Hooks {#import [qualified] modid#} Is translated into the same syntactic form in Haskell, which implies that it may be followed by an explicit import list. Moreover, it implies that the module modid is also generated by &C2hs; and instructs the tool to read the file modid.chi. If an explicit output file name is given (--output option), this name determines the basename for the .chi file of the currently translated module. Currently, only pointer hooks generate information that is stored in a .chi file and needs to be incorporated into any client module that makes use of these pointer types. It is, however, regarded as good style to use import hooks for any module generated by &C2hs;. Restriction &C2hs; does not use qualified names. This can be a problem, for example, if two pointer hooks are defined to have the same unqualified Haskell name in two different modules, which are then imported by a third module. To partially work around this problem, it is guaranteed that the declaration of the textually later import hook dominates. Context Hooks {#context [lib = lib] [prefix = prefix]#} Context hooks define a set of global configuration options. Currently, there are two parameters which are both strings lib is a dynamic library that contains symbols needed by the present binding. prefix is an identifier prefix that may be omitted in the lexemes of identifiers referring to C definitions in any binding hook. The is useful as C libraries often use a prefix, such as gtk_, as a form of poor man's name spaces. Any occurrence of underline characters between a prefix and the main part of an identifier must also be dropped. Case is not relevant in a prefix. In case of a conflict of the abbreviation with an explicitly defined identifier, the explicit definition takes preference. Both parameters are optional. An example of a context hook is the following: {#context prefix = "gtk"#} If a binding module contains a binding hook, it must be the first hook in the module. Type Hooks {#type ident#} A type hooks maps a C type to a Haskell type. As an example, consider type GInt = {#type gint#} The type must be a defined type, primitive types, such as int, are not admissible. Sizeof Hooks {#sizeof ident#} A sizeof hooks maps a C type to its size in bytes. As an example, consider gIntSize :: Int gIntSize = {#sizeof gint#} The type must be a defined type, primitive types, such as int, are not admissible. The size of primitive types can always be obtained using Storable.sizeOf. Enumeration Hooks {#enum cid [as hsid] {alias1 , ... , aliasn} [with prefix = pref] [deriving (clid1 , ... , clidn)]#} Rewrite the C enumeration called cid into a Haskell data type declaration, which is made an instance of Enum such that the ordinals match those of the enumeration values in C. This takes explicit enumeration values in the C definitions into account. If hsid is given, this is the name of the Haskell data type. The identifiers clid1 to clidn are added to the deriving clause of the Haskell type. By default, the names of the C enumeration are used for the constructors in Haskell. If alias1 is underscoreToCase, the original C names are capitalised and the use of underscores is rewritten to caps. If it is upcaseFirstLetter or downcaseFirstLetter, the first letter of the original C name changes case correspondingly. It is also possible to combine underscoreToCase with one of upcaseFirstLetter or downcaseFirstLetter. Moreover, alias1 to aliasn may be aliases of the form cid as hsid, which map individual C names to Haskell names. Instead of the global prefix introduced by a context hook, a local prefix pref can optionally be specified. As an example, consider {#enum WindowType {underscoreToCase} deriving (Eq)#} <literal>enum define</literal> hooks Many C libraries do not use enum types, but macro definitions to implement constants. c2hs provides enum define hooks generate a haskell datatype from a collection of macro definitions. {#enum define hsid {alias1 , ... , aliasn} [deriving (clid1 , ... , clidn)]#} Create a haskell datatype hsid, with nullary constructors as given by the aliases alias1 through aliasn. Each alias has to be of the form macrodef as hsid, where hsid is the name of the nullary haskell constructor, and macrodef the C macro which the haskell constructor should map to. The deriving part is handled as in ordinary enum hooks. Here's an example #define X 0 #define Y 1 {#enum define Axis {X as Axis0, Y as Axis1} deriving (Eq,Ord) #} Call Hooks {#call [pure] [unsafe] cid [as (hsid | ^)]#} A call hook rewrites to a call to the C function cid and also ensures that the appropriate foreign import declaration is generated. The tags pure and unsafe specify that the external function is purely functional and cannot re-enter the Haskell runtime, respectively. If hsid is present, it is used as the identifier for the foreign declaration, which otherwise defaults to the cid. When instead of hsid, the symbol ^ is given, the cid after conversion from C's underscore notation to a capitalised identifier is used. As an example, consider sin :: Float -> Float sin = {#call pure sin as "_sin"#} Function Hooks {#fun [pure] [unsafe] cid [as (hsid | ^)] [ctxt =>] { parm1 , ... , parmn } -> parm Function hooks are call hooks including parameter marshalling. Thus, the components of a function hook up to and including the as alias are the same as for call hooks. However, an as alias has a different meaning; it specifies the name of the generated Haskell function. The remaining components use literals enclosed in backwards and foward single quotes (` and ') to denote Haskell code fragments (or more precisely, parts of the Haskell type signature for the bound function). The first one is the phrase ctxt preceding =>, which denotes the type context. This is followed by zero or more type and marshalling specifications parm1 to parmn for the function arguments and one parm for the function result. Each such specification parm has the form [inmarsh [* | -]] hsty[&] [outmarsh [*] [-]] where hsty is a Haskell code fragment denoting a Haskell type. The optional information to the left and right of this type determines the marshalling of the corresponding Haskell value to and from C; they are called the in and out marshaller, respectively. Each marshalling specification parm corresponds to one or two arguments of the C function, in the order in which they are given. A marshalling specification in which the symbol & follows the Haskell type corresponds to two C function arguments; otherwise, it corresponds only to one argument. The parm following the left arrow -> determines the marshalling of the result of the C function and may not contain the symbol &. The *- output marshal specification is for monadic actions that must be executed but whose results are discarded. This is very useful for e.g. checking an error value and throwing an exception if needed. Both inmarsh and outmarsh are identifiers of Haskell marshalling functions. By default they are assumed to be pure functions; if they have to be executed in the IO monad, the function name needs to be followed by a star symbol *. Alternatively, the identifier may be followed by a minux sign -, in which case the Haskell type does not appear as an argument (in marshaller) or result (out marshaller) of the generated Haskell function. In other words, the argument types of the Haskell function is determined by the set of all marshalling specifications where the in marshaller is not followed by a minus sign. Conversely, the result tuple of the Haskell function is determined by the set of all marshalling specifications where the out marshaller is not followed by a minus sign. The order of function arguments and components in the result tuple is the same as the order in which the marshalling specifications are given, with the exception that the value of the result marshaller is always the first component in the result tuple if it is included at all. For a set of commonly occuring Haskell and C type combinations, default marshallers are provided by &C2hs; if no explicit marshaller is given. The out marshaller for function arguments is by default void-. The defaults for the in marshallers for function arguments are as follows: Bool and integral C type (including chars): cFromBool Integral Haskell and integral C type: cIntConv Floating Haskell and floating C type: cFloatConv String and char*: withCString* String and char* with explicit length: withCStringLen* T and T*: with* T and T* where T is an integral type: withIntConv* T and T* where T is a floating type: withFloatConv* Bool and T* where T is an integral type: withFromBool* The defaults for the out marshaller of the result are the converse of the above; i.e., instead of the with functions, the corresponding peek functions are used. Moreover, when the Haskell type is (), the default marshaller is void-. As an example, consider {#fun notebook_query_tab_label_packing as ^ `(NotebookClass nb, WidgetClass cld)' => {notebook `nb' , widget `cld' , alloca- `Bool' peekBool*, alloca- `Bool' peekBool*, alloca- `PackType' peekEnum*} -> `()'#} which results in the Haskell type signature notebookQueryTabLabelPacking :: (NotebookClass nb, WidgetClass cld) => nb -> cld -> IO (Bool, Bool, PackType) which binds the following C function: void gtk_notebook_query_tab_label_packing (GtkNotebook *notebook, GtkWidget *child, gboolean *expand, gboolean *fill, GtkPackType *pack_type); Get Hooks {#get apath#} A get hook supports accessing a member value of a C structure. The hook itself yields a function that, when given the address of a structure of the right type, performs the structure access. The member that is to be extracted is specified by the access path apath. Access paths are formed as follows (following a subset of the C expression syntax): The root of any access path is a simple identifier, which denotes either a type name or struct tag. An access path of the form *apath denotes dereferencing of the pointer yielded by accessing the access path apath. An access path of the form apath.cid specifies that the value of the struct member called cid should be accessed. Finally, an access path of the form apath->cid, as in C, specifies a combination of dereferencing and member selection. For example, we may have visualGetType :: Visual -> IO VisualType visualGetType (Visual vis) = liftM cToEnum $ {#get Visual->type#} vis Set Hooks {#set apath#} Set hooks are formed in the same way as get hooks, but yield a function that assigns a value to a member of a C structure. These functions expect a pointer to the structure as the first and the value to be assigned as the second argument. For example, we may have {#set sockaddr_in.sin_family#} addr_in (cFromEnum AF_NET) Pointer Hooks {#pointer [*] cid [as hsid] [foreign | stable] [newtype | -> hsid2] [nocode]#} A pointer hook facilitates the mapping of C to Haskell pointer types. In particular, it enables the use of ForeignPtr and StablePtr types and defines type name translations for pointers to non-basic types. In general, such a hook establishes an association between the C type cid or *cid and the Haskell type hsid, where the latter defaults to cid if not explicitly given. The identifier cid will usually be a type name, but in the case of *cid may also be a struct, union, or enum tag. If both a type name and a tag of the same name are available, the type name takes precedence. Optionally, the Haskell representation of the pointer can be by a ForeignPtr or StablePtr instead of a plain Ptr. If the newtype tag is given, the Haskell type hsid is defined as a newtype rather than a transparent type synonym. In case of a newtype, the type argument to the Haskell pointer type will be hsid, which gives a cyclic definition, but the type argument is here really only used as a unique type tag. Without newtype, the default type argument is (), but another type can be specified after the symbol ->. For example, we may have {#pointer *GtkObject as Object newtype#} This will generate a new type Object as follows: newtype Object = Object (Ptr Object) which enables exporting Object as an abstract type and facilitates type checking at call sites of imported functions using the encapsulated pointer. The latter is achieved by &C2hs; as follows. The tool remembers the association of the C type *GtkObject with the Haskell type Object, and so, it generates for the C function void gtk_unref_object (GtkObject *obj); the import declaration foreign import gtk_unref_object :: Object -> IO () This function can obviously only be applied to pointers of the right type, and thus, protects against the common mistake of confusing the order of pointer arguments in function calls. However, as the Haskell FFI does not permit to directly pass ForeignPtrs to function calls or return them, the tool will use the type Ptr HsName in this case, where HsName is the Haskell name of the type. So, if we modify the above declaration to be {#pointer *GtkObject as Object foreign newtype#} the type Ptr Object will be used instead of a plain Object in import declarations; i.e., the previous import declaration will become foreign import gtk_unref_object :: Ptr Object -> IO () To simplify the required marshalling code for such pointers, the tool automatically generates a function withObject :: Object -> (Ptr Object -> IO a) -> IO a As an example that does not represent the pointer as an abstract type, consider the C type declaration: typedef struct {int x, y;} *point; We can represent it in Haskell as data Point = Point {x :: Int, y :: Int} {#pointer point as PointPtr -> Point#} which will translate to data Point = Point {x :: Int, y :: Int} type PointPtr = Ptr Point and establish a type association between point and PointPtr. If the keyword nocode is added to the end of a pointer hook, &C2hs; will not emit a type declaration. This is useful when a &C2hs; module wants to make use of an existing type declaration in a binding not generated by &C2hs; (i.e., where there are no .chi files). Restriction The name cid cannot be a basic C type (such as int), it must be a defined name. Class Hooks {#class [hsid1 =>] hsid2 hsid3#} Class hooks facilitate the definition of a single inheritance class hierachy for external pointers including up and down cast functionality. This is meant to be used in cases where the objects referred to by the external pointers are order in such a hierachy in the external API - such structures are encountered in C libraries that provide an object-oriented interface. Each class hook rewrites to a class declaration and one or more instance declarations. All classes in a hierarchy, except the root, will have a superclass identified by hsid1. The new class is given by hsid2 and the corresponding external pointer is identified by hsid3. Both the superclass and the pointer type must already have been defined by binding hooks that precede the class hook. The pointers in a hierachy must either all be foreign pointers or all be normal pointers. Stable pointers are not allowed. Both pointer defined as newtypes and those defined by type synonyms may be used in class declarations and they may be mixed. In the case of synonyms, Haskell's usual restrictions regarding overlapping instance declarations apply. The newly defined class has two members whose names are derived from the type name hsid3. The name of first member is derived from hsid3 by converting the first character to lower case. This function casts from any superclass to the current class. The name of the second member is derived by prefixing hsid3 with the from. It casts from the current class to any superclass. A class hook generates an instance for the pointer in the newly defined class as well as in all its superclasses. As an example, consider {#pointer *GtkObject newtype#} {#class GtkObjectClass GtkObject#} {#pointer *GtkWidget newtype#} {#class GtkObjectClass => GtkWidgetClass GtkWidget#} The second class hook generates an instance for GtkWidget for both the GtkWidgetClass as well as for the GtkObjectClass. CPP Directives and Inline C Code A Haskell binding module may include arbitrary C pre-processor directives using the standard C syntax. The directives are used in two ways: Firstly, they are included in the C header file generated by &C2hs; in exactly the same order in which they appear in the binding module. Secondly, all conditional directives are honoured by &C2hs; in that all Haskell binding code in alternatives that are discarded by the C pre-processor are also discarded by &C2hs;. This latter feature is, for example, useful to maintain different bindings for multiple versions of the same C API in a single Haskell binding module. In addition to C pre-processor directives, vanilla C code can be maintained in a Haskell binding module by bracketing this C code with the pseudo directives #c and #endc. Such inline C code is emitted into the C header generated by &C2hs; at exactly the same position relative to CPP directives as it occurs in the binding module. Pre-processor directives may encompass the #include directive, which can be used instead of specifying a C header file as an argument to c2hs. In particular, this enables the simultaneous use of multiple header files without the need to provide a custom header file that binds them together. If a header file lib.h is specified as an argument to c2hs, the tool will emit the directive #include"lib.h" into the generated C header before any other CPP directive or inline C code. As an artificial example of these features consider the following code: #define VERSION 2 #if (VERSION == 1) foo :: CInt -> CInt foo = {#call pure fooC#} #else foo :: CInt -> CInt -> CInt foo = {#call pure fooC#} #endif #c int fooC (int, int); #endc One of two versions of the Haskell function foo (having different arities) is selected in dependence on the value of the CPP macro VERSION, which in this example is defined in the same file. In realistic code, VERSION would be defined in the header file supplied with the C library that is made accessible from Haskell by a binding module. The above code fragment also includes one line of inline C code that declares a C prototype for fooC. Current limitation of the implementation Inline C code can currently not contain any code blocks; i.e., only declarations as typically found in header files may be included. Grammar Rules The following grammar rules define the syntax of binding hooks: hook -> `{#' inner `#}' inner -> `import' ['qualified'] ident | `context' ctxt | `type' ident | `sizeof' ident | `enum' idalias trans [`with' prefix] [deriving] | `call' [`pure'] [`unsafe'] idalias | `fun' [`pure'] [`unsafe'] idalias parms | `get' apath | `set' apath | `pointer' ['*'] idalias ptrkind | `class' [ident `=>'] ident ident ctxt -> [`lib' `=' string] [prefix] idalias -> ident [(`as' ident | `^')] prefix -> `prefix' `=' string deriving -> `deriving' `(' ident_1 `,' ... `,' ident_n `)' parms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm parm -> [ident_1 [`*' | `-']] verbhs [`&'] [ident_2 [`*'] [`-']] apath -> ident | `*' apath | apath `.' ident | apath `->' ident trans -> `{' alias_1 `,' ... `,' alias_n `}' alias -> `underscoreToCase' | `upcaseFirstLetter' | `downcaseFirstLetter' | ident `as' ident ptrkind -> [`foreign' | `stable'] ['newtype' | '->' ident] Identifier ident follow the lexis of Haskell. They may be enclosed in single quotes to disambiguate them from C->Haskell keywords. Bug Reports and Suggestions There is a tracker for bugs and feature requests: . Alternatively if you prefer email please send your bug reports and suggestions to the C->Haskell List c2hs@haskell.org. A good bug report contains information on the used operating system and Haskell compiler as well as the version of &C2hs; that you have been using. You can obtain the version information by running c2hs --version. If possible a concise example illustrating your problem would be appreciated. Copyright &C2hs; is Copyright (C) [1999..2005] Manuel M. T. Chakravarty &C2hs; License This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Documentation License This manual is Copyright (c) [2000..2005] by Manuel M. T. Chakravarty. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.1 or any later version published by the Free Software Foundation; with no Invariant Sections, with no Front-Cover Texts, and with the no Back-Cover Texts. A copy of the license is included in the section entitled "GNU Free Documentation License". Possible Licenses of Generated Code All code included into generated bindings is under a BSD-style license that does not place any restrictions on the license of the inteface produced with &C2hs; (ie, closed proprietary licenses are possible, too). In other words, I do not care what you use &C2hs; for or to whom you are giving &C2hs; or any interfaces generated with &C2hs;, only if you modify or improve &C2hs; itself, you have to contribute your changes back to the community. Nevertheless, I will of course be particularly delighted if you choose to make your work freely available. GNU Free Documentation License The GNU Free Documentation License is available at . Release Notes Important changes (especially those affecting the semantics of the tool) are documented in the following. Version 0.15.1 "Rainy Days" New C parser that can parse all of C99 and GNU C Make c2hs integrate better with Cabal (1.2 and later) Adapted to GHC 6.8. Now requires Cabal 1.2. Lots and lots of old code removal Several bug fixes and improvements from Udo Stenzel: allowing variadic functions in structures allowing call and fun hooks for FunPtrs in C structs embedded arrays size calculated correctly Version 0.14.5 "Travelling Lightly" Added nocode directive to pointer hooks Can use structs properly in pointer hooks now (contributed by Jelmer Vernooij) upcaseFirstLetter and downcaseFirstLetter Cross-compiling with --platform flag Gcc's asm construct is supported (contributed by Duncan Coutts) Hierarchical modules syntax in import hooks supported No separately installed marshaling library anymore; as a result binary &C2hs; packages and installations are now independent of the targeted Haskell system New lexer and parser generated with Alex and Happy (contributed by Duncan Coutts) Cabal build system Version 0.13.6 "Pressing Forward" Works with GHC 6.4 and Cabal packages Strings may contain 8-bit characters (e.g., umlauts). Identifier may optionally be put in single quotes. (This is useful if they would otherwise collide with a &C2hs; keyword.) Some smaller bug fixes C chars are treated as integral types for marshalling purposes. If there is no explicit output file specified, the generated header file is put in the same directory as the binding file; otherwise, it goes in the directory where the output file is put. Moreover, the --output-dir option enables the specification of directory where all generated files are to be put. Foreign import declarations include the name of the header file generated by &C2hs; (ie, it needs neither be passed to the Haskell compiler at the command line nor in an OPTIONS pragma). We allow structs and unions with no declarations. Headers including function bodies are now parsed correctly. Duncan Coutts identified a space leak in the parser whose removal improved performance significantly. Version 0.12.1 "Springtime" Removed support for deprecated C2HS interface and for old versions of the FFI libraries Improved line pragma generation Works with GHC 6.3 Builds on Mac OS X thanks to a patch by Sean Seefried Version 0.11.5 "Powder Snow" Bug fixes Constant expression can now contain enumerators header label removed from context hooks This version of c2hs may overwrite C header files in the current directory. More precisely, if a binding module with the name Foo.chs is processed, a header file with the name Foo.h is generated and will overwrite any file of the same name in the current directory or the directory specified via the -o option. Added support for CPP directives, including special treatment of conditions, and for inline C code; specification of a header file as an argument to c2hs is now option. GHC line pragmas are emitted into generated Haskell code Swap the order of reading the binding module and the C header (i.e., we now read the binding module first) Version 0.10.17 "Altocumulus Stratiformis Perlucidus Undulatus" Worked around a bug in GHC 5.04.1 Solaris-related fix Marshalling support for bit masks represented as enumeration types Added fun hooks as aliases can use ^ convert the orignal identifier with underscore2case In call hooks, the attributes `fun' was replaced by `pure' (`fun' is will still be recognised for a while to ensure backwards compatibility, but it's use is deprecated) GHC's package system is now supported If two import hooks add a type mapping for a pointer hook with the same name, the textual later one dominates. Bug fixes Support for bitfields (they are correctly handled when computing struct offsets and they can be accessed using set and get hooks) Some more support for GNU C extensions ("alignof" and better support "__attribute__") Added class hooks Version 0.9.9 "Blue Ginger" Bug fixes Library names in foreign imports have been removed until the convention of the new FFI is implemented (they are currently silently omitted) Added sizeof hooks; sizeof of type names is now also supported in constant expressions Local prefix for enum hooks; courtesy of Armin Sander Added import hooks The documentation includes a description of binding hooks Added pointer hooks, which were derived from code for a similar feature by Axel Simon; this includes proper treatment of parametrised pointers Integrated deriving option for enum hooks, which was contributed by Axel Simon Adapted to GHC 5.0 Version 0.8.2 "Gentle Moon" Adaptation layer for legacy StablePtr interface Forgot to export FunPtr and associated functions from C2HS Forgot to export some names in C2HSDeprecated Added support for gcc's __builtin_va_list Version 0.8.1 "Gentle Moon" Library adapted to New FFI; the old interface can still be used by importing C2HSDeprecated FFI Library specification added to the documentation Version 0.7.10 "Afterthought" CygWin support; based on suggestions by Anibal Maffioletti Rodrigues de DEUS anibaldedeus@email.com IntConv instances for Int8, Word8, and Char Version 0.7.9 "Afterthought" Debugged the stripping of prefixes from enumerators; prefixes are now generally stripped, independent of whether they can be stripped from all enumerators of a given enumeration type Comma now correctly required after underscoreToCase. This breaks source compatibility with previous versions. Version 0.7.8 Provisional support for GHC 4.08 Corrected constant folding Version 0.7.7 Ignores any occurrence of #pragma. Version 0.7.6 Bug fixes and support for long long. Version 0.7.5 This is mainly a bug fix release. In particular, the space behaviour of &C2hs; has been significantly improved. IMPORTANT NOTE: From this release on, library names in lib tags in context hooks should not contain a suffix (i.e., omit .so etc).
c2hs-0.28.1/doc/c2hs.css0000644000000000000000000000147212677513065012765 0ustar0000000000000000div { font-family: sans-serif; color: black; background: white } h1, h2, h3, h4, h5, h6, p.title { color: #005A9C } h1 { font: 170% sans-serif } h2 { font: 140% sans-serif } h3 { font: 120% sans-serif } h4 { font: bold 100% sans-serif } h5 { font: italic 100% sans-serif } h6 { font: small-caps 100% sans-serif } pre { font-family: monospace; border-width: 1px; border-style: solid; padding: 0.3em } pre.screen { color: #006400 } pre.programlisting { color: maroon } div.example { margin: 1ex 0em; border: solid #412e25 1px; padding: 0ex 0.4em } div.example, div.example-contents { background-color: #fffcf5 } a:link { color: #0000C8 } a:hover { background: #FFFFA8 } a:active { color: #D00000 } a:visited { color: #680098 } c2hs-0.28.1/doc/Makefile0000644000000000000000000000316212677513065013052 0ustar0000000000000000# C->Haskell Compiler: documentation makefile # # Author : Manuel M T Chakravarty # Created: 30 October 1999 # # Version $Revision: 1.9 $ from $Date: 2002/07/06 09:59:40 $ # # Copyright (c) [1999..2002] Manuel M T Chakravarty # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This file is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # = DOCU ===================================================================== # # * Nothing is installed at the moment. That has to be done manually. # must be first # default: html XMLLINT=xmllint XMLLINT_OPTIONS=--nonet --noout --valid XSLTPROC=xsltproc XSLTPROC_HTML_OUTDIR=users_guide/ XSLTPROC_HTML_CSS=c2hs.css XSLTPROC_HTML_PARAMS=\ --param use.id.as.filename 1 \ --stringparam base.dir $(XSLTPROC_HTML_OUTDIR) \ --stringparam html.stylesheet $(XSLTPROC_HTML_CSS) XSLTPROC_HTML_STYLESHEET=http://docbook.sourceforge.net/release/xsl/current/html/chunk.xsl XSLTPROC_OPTIONS=--nonet $(XSLTPROC_HTML_PARAMS) $(XSLTPROC_HTML_STYLESHEET) # build targets # .PHONY: html pdf html: c2hs.xml $(XMLLINT) $(XMLLINT_OPTIONS) $< $(XSLTPROC) $(XSLTPROC_OPTIONS) $< cp $(XSLTPROC_HTML_CSS) $(XSLTPROC_HTML_OUTDIR) pdf: c2hs.xml sgml2pdf $< # auxiliary targets # .PHONY: clean clean: -rm -rf users_guide/ c2hs.pdf c2hs-0.28.1/doc/man1/0000755000000000000000000000000012677513065012244 5ustar0000000000000000c2hs-0.28.1/doc/man1/c2hs.10000644000000000000000000001034512677513065013170 0ustar0000000000000000.\" Hey Emacs! This file is -*- nroff -*- source. .\" .\" Version $Revision: 1.2 $ from $Date: 2002/09/15 07:00:41 $ .\" .TH C2HS 1 "November 2007" "Version 0.15.1" C\->Haskell .SH NAME c2hs \- C->Haskell Interface Generator .SH SYNOPSIS .B c2hs .RB [ OPTIONS ]... .I header-file .I binding-file .SH DESCRIPTION This manual page briefly describes the .B c2hs command. For more details, refer to the main documentation, which is available in various other formats, including SGML and HTML; see below. .PP .SH OPTIONS The programs follow the usual GNU command line syntax, with long options starting with two dashes (`-'). A summary of options are included below. For a complete description, see the other documentation. .B c2hs accepts the following options: .TP .B \-h, \-?, \-\-help brief help .TP .B \-v, \-\-version show version information .TP .B \-\-numeric\-version show version number .TP .BI \-c \ CPP\fR, \ \-\-cpp= CPP use executable \fICPP\fR to invoke C preprocessor .TP .BR \-C \ CPPOPTS\fR, \ \-\-cppopts= CPPOPTS pass CPPOPTS to the C preprocessor .TP .BI \-o \ FILE\fR, \ \-\-output= FILE output result to \fIFILE\fR (should end in \fI.hs\fR) .TP .BI \-t \ PATH\fR, \ \-\-output\-dir= PATH place generated files in PATH .TP .B \-p \ PLATFORM, \-\-platform=PLATFORM platform to use for cross compilation .TP .B \-k, \-\-keep keep pre-processed C header .TP .B \-l, \-\-copy\-library copy `C2HS' library module to the current directory .TP .BR \-d \ TYPE\fR, \ \-\-dump= TYPE dump internal information (for debugging), where TYPE is one of: .RS .IP "\(bu \fBtrace\fR" 10 trace compiler phases .IP "\(bu \fBgenbind\fR" 10 trace binding generation .IP "\(bu \fBctrav\fR" 10 trace C declaration traversal .IP "\(bu \fBchs\fR" 10 dump the binding file (adds \fI.dump\fR to the name) .RE .PP .I header-file is the header file belonging to the marshalled library. It must end with suffix .IR .h . .I binding-file is the corresponding Haskell binding file, which must end with suffix .IR .chs . .I PLATFORM The platform name can be one of: .IR x86_64-linux . .IR i686-linux . .IR m68k-palmos . This allows for cross-compilation, assuming the rest of your toolchain supports that. The default is the current host platform. The most useful of these options is probably .B \-\-cppopts (or .BR \-C ). If the C header file needs any special options (like \-D or \-I) to go through the C pre-processor, here is the place to pass them. .SH EXAMPLES The easiest way to use the C->Haskell Interface Generator is via .I Cabal. Cabal knows about .I .chs files and will run .B c2hs automatically, passing the appropriate flags. When used directly, .Bc2hs is usually called as: .B c2hs .I lib.h Lib.chs where .I lib.h is the header file and .I Lib.chs the Haskell binding module, which define the C- and Haskell-side interface, respectively. If no errors occur, the result is a pure Haskell module .IR Lib.hs , which implements the Haskell API of the library. A more advanced call may look like this: .BR "c2hs" \ \-\-cppopts=\-I\fI/some/obscure/dir\fR \-\-cppopts=\-DEXTRA .I lib.h Lib.chs Often, .I lib.h will not be in the current directory, but in one of the header file directories. Apart from the current directory, C->Haskell looks in two places for the header: first, in the standard include directory of the used system, this is usually .IR /usr/include " and " /usr/local/include ; and second, it will look in every directory that is mentioned in a .RI \-I DIR option passed to the pre-processor via .BR \-\-cppopts . .SH CAVEATS If you have more than one option that you want to give to the pre-processor, use multiple .BR \-\-cppopts= \ flags. .SH "SEE ALSO" User guide .I /usr/share/doc/c2hs-0.15.1/html/c2hs.html Home page .I http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ .SH "BUGS" Please report bugs and feature requests in the c2hs trac .I http://hackage.haskell.org/trac/c2hs/ or to the C->Haskell mailing list .I c2hs@haskell.org .SH COPYRIGHT C->Haskell Version 0.15.1 Copyright (c) [1999..2007] Manuel M. T. Chakravarty .SH AUTHOR This manual page was mainly assembled from the original documentation. It was written by Michael Weber for the Debian GNU/Linux system (but may be used by others). c2hs-0.28.1/src/0000755000000000000000000000000012677513064011431 5ustar0000000000000000c2hs-0.28.1/src/Main.hs0000644000000000000000000005212112677513064012652 0ustar0000000000000000-- C->Haskell Compiler: main module -- -- Copyright (c) [1999..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- Description --------------------------------------------------------------- -- -- Language: Haskell 98 -- -- This is the main module of the compiler. It sets the version, processes -- the command line arguments, and controls the compilation process. -- -- Usage: -- ------ -- -- c2hs [ option... ] [header-file] binding-file -- -- The compiler is supposed to emit a Haskell program that expands all hooks -- in the given binding file. -- -- File name suffix: -- ----------------- -- -- Note: These also depend on suffixes defined in the compiler proper. -- -- .h C header file -- .i pre-processeed C header file -- .hs Haskell file -- .chs Haskell file with C->Haskell hooks (binding file) -- .chi C->Haskell interface file -- -- Options: -- -------- -- -- -C CPPOPTS -- --cppopts=CPPOPTS -- Pass the additional options CPPOPTS to the C preprocessor. -- -- Repeated occurences accumulate. -- -- -c CPP -- --cpp=CPP -- Use the executable CPP to invoke CPP. -- -- In the case of repeated occurences, the last takes effect. -- -- -d TYPE -- --dump=TYPE -- Dump intermediate representation: -- -- + if TYPE is `trace', trace the compiler phases (to stderr) -- + if TYPE is `genbind', trace binding generation (to stderr) -- + if TYPE is `ctrav', trace C declaration traversal (to stderr) -- + if TYPE is `chs', dump the binding file (insert `.dump' into the -- file name to avoid overwriting the original file) -- -- -h, -? -- --help -- Dump brief usage information to stderr. -- -- -i DIRS -- --include=DIRS -- Search the colon (Linux) or semicolon (Windows) separated -- list of directories DIRS when searching for .chi files. -- -- -k -- --keep -- Keep the intermediate file that contains the pre-processed C header -- (it carries the suffix `.i'). -- -- -l -- --copy-library -- Copies the library module `C2HS' into the same directory where the -- generated code from the binding file is placed. -- -- -o FILE -- --output=FILE -- Place output in file FILE. -- -- If `-o' is not specified, the default is to put the output for -- `source.chs' in `source.hs' in the same directory that contains the -- binding file. If specified, the emitted C header file is put into -- the same directory as the output file. The same holds for -- C->Haskell interface file. All generated files also share the -- basename. -- -- -p PLATFORM -- --platform=PLATFORM -- Generate output for the given PLATFORM. By default we generate -- output for the platform that c2hs executes on. -- -- -t PATH -- --output-dir=PATH -- Place generated files in the directory PATH. -- -- If this option as well as the `-o' option is given, the basename of -- the file specified with `-o' is put in the directory specified with -- `-t'. -- -- -v, -- --version -- Print (on standard output) the version and copyright -- information of the compiler (before doing anything else). -- --- TODO ---------------------------------------------------------------------- -- module Main (main) where -- standard libraries import Data.List (intersperse, partition) import Control.Monad (when, unless) import Data.Version (showVersion) import qualified Data.Version as DV import System.Console.GetOpt (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) import qualified System.FilePath as FilePath (takeDirectory, takeExtension, dropExtension) import System.FilePath ((<.>), (), splitSearchPath) import System.IO (stderr, openFile, IOMode(..)) import System.IO.Error (ioeGetErrorString, ioeGetFileName) import System.Process (runProcess, waitForProcess) -- c2hs modules import C2HS.State (CST, runC2HS, fatal, fatalsHandledBy, SwitchBoard(..), Traces(..), setTraces, traceSet, setSwitch, getSwitch, putTraceStr) import qualified System.CIO as CIO import C2HS.C (csuffix, hsuffix, isuffix, loadAttrC) import C2HS.CHS (loadCHS, dumpCHS, hssuffix, chssuffix, dumpCHI, hasNonGNU) import C2HS.Gen.Header (genHeader) import C2HS.Gen.Wrapper (genWrappers) import C2HS.Gen.Bind (expandHooks) import C2HS.Version (versnum, version, copyright, disclaimer) import C2HS.Config (cppopts, libfname, PlatformSpec(..), defaultPlatformSpec, platformSpecDB) import qualified C2HS.Config as CConf import Paths_c2hs (getDataDir) -- | wrapper running the compiler -- main :: IO () main = runC2HS compile -- option handling -- =============== -- | header is output in case of help, before the descriptions of the options; -- errTrailer is output after an error message -- header :: String header = version ++ "\n" ++ copyright ++ "\n" ++ disclaimer ++ "\n\nUsage: c2hs [ option... ] [header-file] binding-file\n" trailer, errTrailer :: String trailer = "\n\ \The header file must be a C header file matching the given \ \binding file.\n\ \The dump TYPE can be\n\ \ trace -- trace compiler phases\n\ \ genbind -- trace binding generation\n\ \ ctrav -- trace C declaration traversal\n\ \ chs -- dump the binding file (adds `.dump' to the name)\n" errTrailer = "Try the option `--help' on its own for more information.\n" -- | supported option types -- data Flag = CPPOpts String -- ^ additional options for C preprocessor | CPP String -- ^ program name of C preprocessor | Dump DumpType -- ^ dump internal information | Help -- ^ print brief usage information | Keep -- ^ keep the .i file | Library -- ^ copy library module @C2HS@ | Include String -- ^ list of directories to search .chi files | Output String -- ^ file where the generated file should go | Platform String -- ^ target platform to generate code for | OutDir String -- ^ directory where generates files should go | Version -- ^ print version information on stdout | NumericVersion -- ^ print numeric version on stdout | Error String -- ^ error occured during processing of options deriving Eq data DumpType = Trace -- ^ compiler trace | GenBind -- ^ trace "C2HS.Gen.Bind" | CTrav -- ^ trace "C2HS.C.CTrav" | CHS -- ^ dump binding file deriving Eq -- | option description suitable for "Distribution.GetOpt" -- options :: [OptDescr Flag] options = [ Option ['C'] ["cppopts"] (ReqArg CPPOpts "CPPOPTS") "pass CPPOPTS to the C preprocessor", Option ['c'] ["cpp"] (ReqArg CPP "CPP") "use executable CPP to invoke C preprocessor", Option ['d'] ["dump"] (ReqArg dumpArg "TYPE") "dump internal information (for debugging)", Option ['h', '?'] ["help"] (NoArg Help) "brief help (the present message)", Option ['i'] ["include"] (ReqArg Include "INCLUDE") "include paths for .chi files", Option ['k'] ["keep"] (NoArg Keep) "keep pre-processed C header", Option ['l'] ["copy-library"] (NoArg Library) "copy `C2HS' library module in", Option ['o'] ["output"] (ReqArg Output "FILE") "output result to FILE (should end in .hs)", Option ['p'] ["platform"] (ReqArg Platform "PLATFORM") "platform to use for cross compilation", Option ['t'] ["output-dir"] (ReqArg OutDir "PATH") "place generated files in PATH", Option ['v'] ["version"] (NoArg Version) "show version information", Option [] ["numeric-version"] (NoArg NumericVersion) "show version number"] -- | convert argument of 'Dump' option -- dumpArg :: String -> Flag dumpArg "trace" = Dump Trace dumpArg "genbind" = Dump GenBind dumpArg "ctrav" = Dump CTrav dumpArg "chs" = Dump CHS dumpArg _ = Error "Illegal dump type." -- | main process (set up base configuration, analyse command line, and execute -- compilation process) -- -- * Exceptions are caught and reported -- compile :: CST s () compile = do setup cmdLine <- CIO.getArgs case getOpt Permute options cmdLine of (opts, [] , []) | noCompOpts opts -> doExecute opts Nothing (opts, args, []) -> case parseArgs args of justargs@(Just _) -> doExecute opts justargs Nothing -> raiseErrs [wrongNoOfArgsErr] (_ , _ , errs) -> raiseErrs errs where -- These options can be used without specifying a binding module. Then, -- the corresponding action is executed without any compilation to take -- place. (There can be --data and --output-dir (-t) options in addition -- to the action.) -- aloneOptions = [Help, Version, NumericVersion, Library] -- noCompOpts opts = let nonDataOpts = filter nonDataOrDir opts in (not . null) nonDataOpts && all (`elem` aloneOptions) nonDataOpts where nonDataOrDir (OutDir _) = False nonDataOrDir _ = True -- parseArgs :: [FilePath] -> Maybe (FilePath, [FilePath]) parseArgs = parseArgs' [] Nothing where parseArgs' hs (Just chs) [] = Just (chs, reverse hs) parseArgs' hs Nothing (file:files) | FilePath.takeExtension file == '.':chssuffix = parseArgs' hs (Just file) files parseArgs' hs chs (file:files) | FilePath.takeExtension file == '.':hsuffix = parseArgs' (file:hs) chs files parseArgs' _ _ _ = Nothing -- doExecute opts args = do execute opts args `fatalsHandledBy` failureHandler CIO.exitWith CIO.ExitSuccess -- wrongNoOfArgsErr = "There must be exactly one binding file (suffix .chs),\n\ \and optionally one or more header files (suffix .h).\n" -- -- exception handler -- failureHandler err = do let msg = ioeGetErrorString err fnMsg = case ioeGetFileName err of Nothing -> "" Just s -> " (file: `" ++ s ++ "')" name <- CIO.getProgName CIO.hPutStrLn stderr $ concat [name, ": ", msg, fnMsg] CIO.exitWith $ CIO.ExitFailure 1 -- | set up base configuration -- setup :: CST s () setup = do setCPP CConf.cpp addCPPOpts cppopts -- | output error message -- raiseErrs :: [String] -> CST s a raiseErrs errs = do CIO.hPutStr stderr (concat errs) CIO.hPutStr stderr errTrailer CIO.exitWith $ CIO.ExitFailure 1 -- Process tasks -- ------------- -- | execute the compilation task -- -- * if 'Help' is present, emit the help message and ignore the rest -- * if 'Version' is present, do it first (and only once) -- * actual compilation is only invoked if we have one or two extra arguments -- (otherwise, it is just skipped) -- execute :: [Flag] -> Maybe (FilePath, [FilePath]) -> CST s () execute opts args | Help `elem` opts = help | otherwise = do let (vs,opts') = partition (\opt -> opt == Version || opt == NumericVersion) opts mapM_ processOpt (atMostOne vs ++ opts') case args of Just (bndFile, headerFiles) -> do let bndFileWithoutSuffix = FilePath.dropExtension bndFile computeOutputName bndFileWithoutSuffix process headerFiles bndFileWithoutSuffix Nothing -> computeOutputName "." -- we need the output name for library copying copyLibrary where atMostOne = (foldl (\_ x -> [x]) []) -- | emit help message -- help :: CST s () help = do CIO.putStr (usageInfo header options) CIO.putStr trailer CIO.putStr $ "PLATFORM can be " ++ hosts ++ "\n" CIO.putStr $ " (default is " ++ identPS defaultPlatformSpec ++ ")\n" where hosts = (concat . intersperse ", " . map identPS) platformSpecDB -- | process an option -- -- * 'Help' cannot occur -- processOpt :: Flag -> CST s () processOpt (CPPOpts cppopt ) = addCPPOpts [cppopt] processOpt (CPP cpp ) = setCPP cpp processOpt (Dump dt ) = setDump dt processOpt (Keep ) = setKeep processOpt (Library ) = setLibrary processOpt (Include dirs ) = setInclude dirs processOpt (Output fname ) = setOutput fname processOpt (Platform fname ) = setPlatform fname processOpt (OutDir fname ) = setOutDir fname processOpt Version = do CIO.putStrLn version platform <- getSwitch platformSB CIO.putStr " build platform is " CIO.print platform processOpt NumericVersion = CIO.putStrLn (showVersion versnum) processOpt (Error msg ) = abort msg -- | emit error message and raise an error -- abort :: String -> CST s () abort msg = do CIO.hPutStrLn stderr msg CIO.hPutStr stderr errTrailer fatal "Error in command line options" -- | Compute the base name for all generated files (Haskell, C header, and .chi -- file) -- -- * The result is available from the 'outputSB' switch -- computeOutputName :: FilePath -> CST s () computeOutputName bndFileNoSuffix = setSwitch $ \sb@SwitchBoard{ outputSB = output } -> sb { outputSB = if null output then bndFileNoSuffix else output } -- | Copy the C2HS library if requested -- copyLibrary :: CST s () copyLibrary = do outdir <- getSwitch outDirSB library <- getSwitch librarySB datadir <- CIO.liftIO getDataDir let libFullName = datadir libfname libDestName = outdir libfname when library $ CIO.readFile libFullName >>= CIO.writeFile libDestName -- set switches -- ------------ -- | set the options for the C proprocessor -- addCPPOpts :: [String] -> CST s () addCPPOpts opts = setSwitch $ \sb -> sb {cppOptsSB = cppOptsSB sb ++ opts} -- | set the program name of the C proprocessor -- setCPP :: FilePath -> CST s () setCPP fname = setSwitch $ \sb -> sb {cppSB = fname} -- set the given dump option -- setDump :: DumpType -> CST s () setDump Trace = setTraces $ \ts -> ts {tracePhasesSW = True} setDump GenBind = setTraces $ \ts -> ts {traceGenBindSW = True} setDump CTrav = setTraces $ \ts -> ts {traceCTravSW = True} setDump CHS = setTraces $ \ts -> ts {dumpCHSSW = True} -- | set flag to keep the pre-processed header file -- setKeep :: CST s () setKeep = setSwitch $ \sb -> sb {keepSB = True} -- | set flag to copy library module in -- setLibrary :: CST s () setLibrary = setSwitch $ \sb -> sb {librarySB = True} -- | set the search directories for .chi files -- -- * Several -i flags are accumulated. Later paths have higher priority. -- -- * The current directory is always searched last because it is the -- standard value in the compiler state. -- setInclude :: String -> CST s () setInclude str = setSwitch $ \sb -> sb {chiPathSB = splitSearchPath str ++ (chiPathSB sb)} -- | set the output file name -- setOutput :: FilePath -> CST s () setOutput fname = do when (FilePath.takeExtension fname /= '.':hssuffix) $ raiseErrs ["Output file should end in .hs!\n"] setSwitch $ \sb -> sb {outputSB = FilePath.dropExtension fname} -- | set platform -- setPlatform :: String -> CST s () setPlatform platform = case lookup platform platformAL of Nothing -> raiseErrs ["Unknown platform `" ++ platform ++ "'\n"] Just p -> setSwitch $ \sb -> sb {platformSB = p} where platformAL = [(identPS p, p) | p <- platformSpecDB] -- | set the output directory -- setOutDir :: FilePath -> CST s () setOutDir fname = setSwitch $ \sb -> sb {outDirSB = fname} -- | set the name of the generated header file -- setHeader :: FilePath -> CST s () setHeader fname = setSwitch $ \sb -> sb {headerSB = fname} -- compilation process -- ------------------- -- | read the binding module, construct a header, run it through CPP, read it, -- and finally generate the Haskell target -- -- * the header file name (first argument) may be empty; otherwise, it already -- contains the right suffix -- -- * the binding file name has been stripped of the .chs suffix -- process :: [FilePath] -> FilePath -> CST s () process headerFiles bndFile = do -- load the Haskell binding module -- (chsMod , warnmsgs) <- loadCHS bndFile CIO.putStr warnmsgs -- -- get output directory and create it if it's missing -- outFName <- getSwitch outputSB outDir <- getSwitch outDirSB let outFPath = outDir outFName CIO.createDirectoryIfMissing True $ FilePath.takeDirectory outFPath -- -- dump the binding file when demanded -- flag <- traceSet dumpCHSSW when flag $ do let chsName = outFPath <.> "dump" CIO.putStrLn $ "...dumping CHS to `" ++ chsName ++ "'..." dumpCHS chsName chsMod False -- -- extract CPP and inline-C embedded in the .chs file (all CPP and -- inline-C fragments are removed from the .chs tree and conditionals are -- replaced by structured conditionals) -- (header', strippedCHSMod, headerwarnmsgs) <- genHeader chsMod CIO.putStr headerwarnmsgs -- -- create new header file, make it #include `headerFile', and emit -- CPP and inline-C of .chs file into the new header -- let newHeader = outFName <.> chssuffix <.> hsuffix newHeaderFile = outDir newHeader preprocFile = outFPath <.> isuffix CIO.writeFile newHeaderFile $ concat $ [ "#define C2HS_MIN_VERSION(mj,mn,rv) " ++ "((mj)<=C2HS_VERSION_MAJOR && " ++ "(mn)<=C2HS_VERSION_MINOR && " ++ "(rv)<=C2HS_VERSION_REV)\n" ] ++ [ "#include \"" ++ headerFile ++ "\"\n" | headerFile <- headerFiles ] ++ header' setHeader newHeader -- -- run C preprocessor over the header -- cpp <- getSwitch cppSB cppOpts <- getSwitch cppOptsSB let nonGNUOpts = if hasNonGNU chsMod then [ "-U__GNUC__" , "-U__GNUC_MINOR__" , "-U__GNUC_PATCHLEVEL__" ] else [] [versMajor, versMinor, versRev] = map show $ DV.versionBranch versnum versionOpt = [ "-DC2HS_VERSION_MAJOR=" ++ versMajor , "-DC2HS_VERSION_MINOR=" ++ versMinor , "-DC2HS_VERSION_REV=" ++ versRev ] args = cppOpts ++ nonGNUOpts ++ ["-U__BLOCKS__"] ++ versionOpt ++ [newHeaderFile] tracePreproc (unwords (cpp:args)) exitCode <- CIO.liftIO $ do preprocHnd <- openFile preprocFile WriteMode cppproc <- runProcess cpp args Nothing Nothing Nothing (Just preprocHnd) Nothing waitForProcess cppproc case exitCode of CIO.ExitFailure _ -> fatal "Error during preprocessing custom header file" _ -> return () -- -- load and analyse the C header file -- (cheader, preprocMsgs) <- loadAttrC preprocFile CIO.putStr preprocMsgs -- -- remove the pre-processed header and if we no longer need it, remove the -- custom header file too. -- keep <- getSwitch keepSB unless keep $ do CIO.removeFile preprocFile case headerFiles of [_headerFile] | null header -> CIO.removeFile newHeaderFile _ -> return () -- keep it since we'll need it to compile the .hs file -- -- expand binding hooks into plain Haskell -- (hsMod, chi, wrappers, hooksMsgs) <- expandHooks cheader strippedCHSMod CIO.putStr hooksMsgs -- -- output the result -- dumpCHS outFPath hsMod True dumpCHI outFPath chi -- different suffix will be appended -- -- create new wrapper file if necessary -- when (not $ null wrappers) $ do wrapper' <- genWrappers wrappers let newWrapperFile = outDir outFName <.> chssuffix <.> csuffix CIO.writeFile newWrapperFile $ concat $ [ "#include \"" ++ newHeader ++ "\"\n" ] ++ wrapper' where tracePreproc cmd = putTraceStr tracePhasesSW $ "Invoking cpp as `" ++ cmd ++ "'...\n" c2hs-0.28.1/src/Data/0000755000000000000000000000000012677513064012302 5ustar0000000000000000c2hs-0.28.1/src/Data/Errors.hs0000644000000000000000000000545412677513064014122 0ustar0000000000000000-- Compiler Toolkit: basic error management -- -- Author : Manuel M. T. Chakravarty -- Created: 20 February 95 -- -- Copyright (c) [1995..2000] Manuel M. T. Chakravarty -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Library General Public -- License as published by the Free Software Foundation; either -- version 2 of the License, or (at your option) any later version. -- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Library General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This modules exports some auxilliary routines for error handling. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * the single lines of error messages shouldn't be to long as file name -- and position are prepended at each line -- --- TODO ---------------------------------------------------------------------- -- module Data.Errors ( -- handling of internal error -- interr, todo, -- -- errors in the compiled program (wrapper to Language.C Error type) -- ErrorLevel(..), Error, makeError, errorLevel, showError, errorAtPos ) where import Language.C.Data.Error hiding (Error) import Language.C.Data.Position type Error = CError -- internal errors -- --------------- -- | raise a fatal internal error; message may have multiple lines -- interr :: String -> a interr msg = error ("INTERNAL COMPILER ERROR:\n" ++ indentMultilineString 2 msg ++ "\n") -- | raise a error due to a implementation restriction; message may have multiple -- lines -- todo :: String -> a todo msg = error ("Feature not yet implemented:\n" ++ indentMultilineString 2 msg ++ "\n") -- | produce an 'Error', given its level, position, and a list of lines of -- the error message that must not be empty -- makeError :: ErrorLevel -> Position -> [String] -> Error makeError lvl pos msgs = CError $ ErrorInfo lvl pos msgs errorAtPos :: Position -> [String] -> a errorAtPos pos = error --FIXME: should be using show here, but Show instance -- for CError from language-c is wierd . showErrorInfo "" . errorInfo . makeError LevelError pos -- | indent the given multiline text by the given number of spaces -- indentMultilineString :: Int -> String -> String indentMultilineString n = unlines . (map (spaces++)) . lines where spaces = take n (repeat ' ') c2hs-0.28.1/src/Data/Attributes.hs0000644000000000000000000003506612677513064014776 0ustar0000000000000000-- Compiler Toolkit: general purpose attribute management -- -- Author : Manuel M. T. Chakravarty -- Created: 14 February 95 -- -- Copyright (c) [1995..1999] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides an abstract notion of attributes (in the sense of -- compiler construction). The collection of attributes that is attached to a -- single node of the structure tree is referenced via an attributes -- identifier. This is basically a reference into so-called attribute tables, -- which manage attributes of one type and may use different representations. -- There is also a position attribute managed via the attribute identifier -- without needing a further table (it is already fixed on construction of -- the structure tree). -- -- The `Attributed' class is based on a suggestion from Roman Lechtchinsky. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * Attribute identifiers are generated during parsing and whenever new -- structure tree elements, possibly due to transformations, are generated. -- -- * New attributes can be added by simply providing a new attribute table -- indexed by the attribute identifiers. Thus, adding or discarding an -- attribute does not involve any change in the structure tree. -- -- * Consecutive sequences of names are used as attribute identifiers to -- facilitate the use of arrays for attributes that are fixed; speeds up -- read access. (See also TODO.) -- -- * Each attribute table can simultaneously provide melted (updatable) and -- frozen (non-updatable) attributes. It also allows to dynamically grow the -- table, i.e., cover a wider range of attribute identifiers. -- -- * There is a variant merely providing a position, which is used for -- internal identifiers and such. -- -- * `StdAttr' provides standard undefined and don't care variants for -- attribute values. -- --- TODO ---------------------------------------------------------------------- -- -- * When there are sparse attribute tables that we want to freeze (and they -- will occur sooner or later), then introduce a third variant of tables -- realized via hash table---depending on the type of attribute table, we -- may even allow them to be soft. -- -- NOTE: Currently, if assertions are switched on, on freezing a table, its -- density is calculate and, if it is below 33%, an internal error is -- raised (only if there are more than 1000 entries in the table). -- -- * check whether it would increase the performance significantly if we use -- a mixed finite map/array representation for soft tables (all attributes -- defined before the last `soften' could be held in the array, changing -- an attribute just means to update it in the FM; i.e., the FM entries take -- precedence over the array entries) -- module Data.Attributes (-- attribute management -- NodeInfo, newAttrsOnlyPos, newAttrs, Attributed(attrsOf), eqOfAttrsOf, posOfAttrsOf, -- -- attributes and attribute tables -- Attr(undef, isUndef, dontCare, isDontCare), AttrTable, newAttrTable, getAttr, setAttr, updAttr, copyAttr, freezeAttrTable, softenAttrTable, StdAttr(..), getStdAttr, getStdAttrDft, isDontCareStdAttr, isUndefStdAttr, setStdAttr, updStdAttr, getGenAttr, setGenAttr, updGenAttr) where import Data.Array import Control.Exception (assert) import qualified Data.IntMap as NameMap (fromList, insert, findWithDefault, empty, assocs) import Data.IntMap (IntMap) import Language.C.Data.Node import Language.C.Data.Position import Language.C.Data.Name (Name(Name, nameId)) import Data.Errors (interr) type NameMap = IntMap -- attribute management data structures and operations -- --------------------------------------------------- -- a class for convenient access to the attributes of an attributed object -- -- class Attributed a where attrsOf :: a -> NodeInfo -- equality induced by attribution -- eqOfAttrsOf :: Attributed a => a -> a -> Bool eqOfAttrsOf obj1 obj2 = (attrsOf obj1) == (attrsOf obj2) -- position induced by attribution -- posOfAttrsOf :: Attributed a => a -> Position posOfAttrsOf = posOf . attrsOf -- attribute identifier creation -- ----------------------------- -- Given only a source position, create a new attribute identifier -- newAttrsOnlyPos :: Position -> NodeInfo newAttrsOnlyPos = mkNodeInfoOnlyPos -- Given a source position and a unique name, create a new attribute -- identifier -- newAttrs :: Position -> Name -> NodeInfo newAttrs = mkNodeInfo -- attribute tables and operations on them -- --------------------------------------- -- | the type class 'Attr' determines which types may be used as attributes -- -- -- * such types have to provide values representing an undefined and a don't -- care state, together with two functions to test for these values -- -- * an attribute in an attribute table is initially set to 'undef' (before -- some value is assigned to it) -- -- * an attribute with value 'dontCare' participated in an already detected -- error, it's value may not be used for further computations in order to -- avoid error avalanches -- class Attr a where undef :: a isUndef :: a -> Bool dontCare :: a isDontCare :: a -> Bool undef = interr "Attributes: Undefined `undef' method in `Attr' class!" isUndef = interr "Attributes: Undefined `isUndef' method in `Attr' \ \class!" dontCare = interr "Attributes: Undefined `dontCare' method in `Attr' \ \class!" isDontCare = interr "Attributes: Undefined `isDontCare' method in `Attr' \ \class!" -- | attribute tables map attribute identifiers to attribute values -- -- * the attributes within a table can be soft or frozen, the former may by be -- updated, but the latter can not be changed -- -- * the attributes in a frozen table are stored in an array for fast -- lookup; consequently, the attribute identifiers must be *dense* -- -- * the table description string is used to emit better error messages (for -- internal errors) -- data Attr a => AttrTable a = -- for all attribute identifiers not contained in the -- finite map the value is 'undef' -- SoftTable (NameMap a) -- updated attr.s String -- desc of the table -- the array contains 'undef' attributes for the undefined -- attributes; for all attribute identifiers outside the -- bounds, the value is also 'undef'; -- | FrozenTable (Array Name a) -- attribute values String -- desc of the table instance (Attr a, Show a) => Show (AttrTable a) where show (SoftTable mp descr) = -- freeze is disabled "AttrTable "++ descr ++ " { " ++ (unwords . map show) (NameMap.assocs mp) ++ " }" show tbl@(FrozenTable _ _) = show (softenAttrTable tbl) nameMapToList :: NameMap a -> [(Name, a)] nameMapToList = map (\(k,v) -> (Name k, v)) . NameMap.assocs nameMapFromList :: [(Name, a)] -> NameMap a nameMapFromList = NameMap.fromList . map (\(k,v) -> (nameId k, v)) -- | create an attribute table, where all attributes are 'undef' -- -- the description string is used to identify the table in error messages -- (internal errors); a table is initially soft -- newAttrTable :: Attr a => String -> AttrTable a newAttrTable desc = SoftTable NameMap.empty desc -- | get the value of an attribute from the given attribute table -- getAttr :: Attr a => AttrTable a -> NodeInfo -> a getAttr at node = case nameOfNode node of Nothing -> onlyPosErr "getAttr" at (posOfNode node) Just aid -> case at of (SoftTable fm _) -> NameMap.findWithDefault undef (nameId aid) fm (FrozenTable arr _) -> let (lbd, ubd) = bounds arr in if (aid < lbd || aid > ubd) then undef else arr!aid -- | set the value of an, up to now, undefined attribute from the given -- attribute table -- setAttr :: Attr a => AttrTable a -> NodeInfo -> a -> AttrTable a setAttr at node av = case nameOfNode node of Nothing -> onlyPosErr "setAttr" at (posOfNode node) Just aid -> case at of (SoftTable fm desc) -> assert (isUndef (NameMap.findWithDefault undef (nameId aid) fm)) $ SoftTable (NameMap.insert (nameId aid) av fm) desc (FrozenTable _arr _) -> interr frozenErr where frozenErr = "Attributes.setAttr: Tried to write frozen attribute in\n" ++ errLoc at (posOfNode node) -- | update the value of an attribute from the given attribute table -- updAttr :: Attr a => AttrTable a -> NodeInfo -> a -> AttrTable a updAttr at node av = case nameOfNode node of Nothing -> onlyPosErr "updAttr" at (posOfNode node) Just aid -> case at of (SoftTable fm desc) -> SoftTable (NameMap.insert (nameId aid) av fm) desc (FrozenTable _arr _) -> interr $ "Attributes.updAttr: Tried to\ \ update frozen attribute in\n" ++ errLoc at (posOfNode node) -- | copy the value of an attribute to another one -- -- * undefined attributes are not copied, to avoid filling the table -- copyAttr :: Attr a => AttrTable a -> NodeInfo -> NodeInfo -> AttrTable a copyAttr at ats ats' | isUndef av = assert (isUndef (getAttr at ats')) at | otherwise = updAttr at ats' av where av = getAttr at ats -- | auxiliary functions for error messages -- onlyPosErr :: Attr a => String -> AttrTable a -> Position -> b onlyPosErr fctName at pos = interr $ "Attributes." ++ fctName ++ ": No attribute identifier in\n" ++ errLoc at pos -- errLoc :: Attr a => AttrTable a -> Position -> String errLoc at pos = " table `" ++ tableDesc at ++ "' for construct at\n\ \ position " ++ show pos ++ "!" where tableDesc (SoftTable _ desc) = desc tableDesc (FrozenTable _ desc) = desc -- | freeze a soft table; afterwards no more changes are possible until the -- table is softened again -- freezeAttrTable :: Attr a => AttrTable a -> AttrTable a freezeAttrTable (SoftTable fm desc) = let contents = nameMapToList fm keys = map fst contents lbd = minimum keys ubd = maximum keys in assert (length keys < 1000 || (length . range) (lbd, ubd) > 3 * length keys) (FrozenTable (array (lbd, ubd) contents) desc) freezeAttrTable (FrozenTable _ desc) = interr ("Attributes.freezeAttrTable: Attempt to freeze the already frozen\n\ \ table `" ++ desc ++ "'!") -- | soften a frozen table; afterwards changes are possible until the -- table is frozen again -- softenAttrTable :: Attr a => AttrTable a -> AttrTable a softenAttrTable (SoftTable _fm desc) = interr ("Attributes.softenAttrTable: Attempt to soften the already \ \softened\n table `" ++ desc ++ "'!") softenAttrTable (FrozenTable arr desc) = SoftTable (nameMapFromList . assocs $ arr) desc -- standard attributes -- ------------------- -- | standard attribute variants -- data StdAttr a = UndefStdAttr | DontCareStdAttr | JustStdAttr a instance Attr (StdAttr a) where undef = UndefStdAttr isUndef UndefStdAttr = True isUndef _ = False dontCare = DontCareStdAttr isDontCare DontCareStdAttr = True isDontCare _ = False -- | get an attribute value from a standard attribute table -- -- * if the attribute can be "don't care", this should be checked before -- calling this function (using 'isDontCareStdAttr') -- getStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> a getStdAttr atab at = getStdAttrDft atab at err where err = interr $ "Attributes.getStdAttr: Don't care in\n" ++ errLoc atab (posOf at) -- | get an attribute value from a standard attribute table, where a default is -- substituted if the table is don't care -- getStdAttrDft :: AttrTable (StdAttr a) -> NodeInfo -> a -> a getStdAttrDft atab at dft = case getAttr atab at of DontCareStdAttr -> dft JustStdAttr av -> av UndefStdAttr -> interr $ "Attributes.getStdAttrDft: Undefined in\n" ++ errLoc atab (posOf at) -- | check if the attribue value is marked as "don't care" -- isDontCareStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> Bool isDontCareStdAttr atab at = isDontCare (getAttr atab at) -- | check if the attribue value is still undefined -- -- * we also regard "don't care" attributes as undefined -- isUndefStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> Bool isUndefStdAttr atab at = isUndef (getAttr atab at) -- | set an attribute value in a standard attribute table -- setStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> a -> AttrTable (StdAttr a) setStdAttr atab at av = setAttr atab at (JustStdAttr av) -- | update an attribute value in a standard attribute table -- updStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> a -> AttrTable (StdAttr a) updStdAttr atab at av = updAttr atab at (JustStdAttr av) -- generic attribute table access -- ------------------------------ getGenAttr :: (Attr a, Attributed obj) => AttrTable a -> obj -> a getGenAttr atab at = getAttr atab (attrsOf at) setGenAttr :: (Attr a, Attributed obj) => AttrTable a -> obj -> a -> AttrTable a setGenAttr atab at av = setAttr atab (attrsOf at) av updGenAttr :: (Attr a, Attributed obj) => AttrTable a -> obj -> a -> AttrTable a updGenAttr atab at av = updAttr atab (attrsOf at) av c2hs-0.28.1/src/Data/NameSpaces.hs0000644000000000000000000001355012677513064014661 0ustar0000000000000000-- Compiler Toolkit: name space management -- -- Author : Manuel M. T. Chakravarty -- Created: 12 November 95 -- -- Copyright (c) [1995..1999] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module manages name spaces. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * A name space associates identifiers with their definition. -- -- * Each name space is organized in a hierarchical way using the notion of -- ranges. A name space, at any moment, always has a global range and may -- have several local ranges. Definitions in inner ranges hide definitions -- of the same identifiert in outer ranges. -- --- TODO ---------------------------------------------------------------------- -- -- * evaluate the performance gain that a hashtable would bring -- module Data.NameSpaces (NameSpace, nameSpace, defGlobal, enterNewRange, leaveRange, defLocal, find, nameSpaceToList) where import qualified Data.Map as Map (empty, insert, lookup, toList) import Data.Map (Map) import Language.C.Data.Ident import Data.Errors (interr) -- | name space -- -- * the definitions in the global ranges are stored in a finite map, because -- they tend to be a lot and are normally not updated after the global range -- is constructed -- -- * the definitions of the local ranges are stored in a single list, usually -- they are not very many and the definitions entered last are the most -- frequently accessed ones; the list structure naturally hides older -- definitions, i.e., definitions from outer ranges; adding new definitions -- is done in time proportinal to the current size of the range; removing a -- range is done in constant time (and the definitions of a range can be -- returned as a result of leaving the range); lookup is proportional to the -- number of definitions in the local ranges and the logarithm of the number -- of definitions in the global range---i.e., efficiency relies on a -- relatively low number of local definitions together with frequent lookup -- of the most recently defined local identifiers -- data NameSpace a = NameSpace (Map Ident a) -- defs in global range [[(Ident, a)]] -- stack of local ranges instance (Show a) => Show (NameSpace a) where show = show . nameSpaceToList -- | create a name space -- nameSpace :: NameSpace a nameSpace = NameSpace Map.empty [] -- | add global definition -- -- * returns the modfied name space -- -- * if the identfier is already declared, the resulting name space contains -- the new binding and the second component of the result contains the -- definition declared previosuly (which is henceforth not contained in the -- name space anymore) -- defGlobal :: NameSpace a -> Ident -> a -> (NameSpace a, Maybe a) defGlobal (NameSpace gs lss) ide def = (NameSpace (Map.insert ide def gs) lss, Map.lookup ide gs) -- | add new range -- enterNewRange :: NameSpace a -> NameSpace a enterNewRange (NameSpace gs lss) = NameSpace gs ([]:lss) -- | pop topmost range and return its definitions -- leaveRange :: NameSpace a -> (NameSpace a, [(Ident, a)]) leaveRange (NameSpace _gs []) = interr "NameSpaces.leaveRange: \ \No local range!" leaveRange (NameSpace gs (ls:lss)) = (NameSpace gs lss, ls) -- | add local definition -- -- * returns the modfied name space -- -- * if there is no local range, the definition is entered globally -- -- * if the identfier is already declared, the resulting name space contains -- the new binding and the second component of the result contains the -- definition declared previosuly (which is henceforth not contained in the -- name space anymore) -- defLocal :: NameSpace a -> Ident -> a -> (NameSpace a, Maybe a) defLocal ns@(NameSpace _ [] ) ide def = defGlobal ns ide def defLocal (NameSpace gs (ls:lss)) ide def = (NameSpace gs (((ide, def):ls):lss), lookup' ls) where lookup' [] = Nothing lookup' ((ide', def'):ls') | ide == ide' = Just def' | otherwise = lookup' ls' -- | search for a definition -- -- * the definition from the innermost range is returned, if any -- find :: NameSpace a -> Ident -> Maybe a find (NameSpace gs lss) ide = case (lookup' lss) of Nothing -> Map.lookup ide gs Just def -> Just def where lookup' [] = Nothing lookup' (ls:lss') = case (lookup'' ls) of Nothing -> lookup' lss' Just def -> Just def lookup'' [] = Nothing lookup'' ((ide', def):ls) | ide' == ide = Just def | otherwise = lookup'' ls -- | dump a name space into a list -- -- * local ranges are concatenated -- nameSpaceToList :: NameSpace a -> [(Ident, a)] nameSpaceToList (NameSpace gs lss) = Map.toList gs ++ concat lss c2hs-0.28.1/src/System/0000755000000000000000000000000012677513064012715 5ustar0000000000000000c2hs-0.28.1/src/System/CIO.hs0000644000000000000000000001215412677513064013666 0ustar0000000000000000{-# LANGUAGE CPP #-} -- Compiler Toolkit: Compiler I/O -- -- Author : Manuel M T Chakravarty -- Created: 2 November 95 -- -- Copyright (c) [1995...2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module lifts the Haskell I/O facilities into `STB' and provides some -- useful extensions. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * the usage of the `...CIO' functions is exactly as that of the -- corresponding `...' functions from the Haskell 98 prelude and library -- -- * error handling can be found in the module `StateTrans' and `State' -- -- * Also reexports constants, such as `stderr', and data types of `IO' to -- avoid explicit imports of `IO' in the rest of the compiler. -- --- TODO ---------------------------------------------------------------------- -- module System.CIO ( -- -- file handling -- openFile, hClose, -- -- text I/O -- putChar, putStr, putStrLn, hPutStr, hPutStrLn, writeFile, readFile, print, getChar, hFlush, hPutChar, hSetBuffering, hGetBuffering, newline, -- -- `Directory' -- createDirectoryIfMissing, doesFileExist, removeFile, -- -- `System' -- IO.ExitCode(..), exitWith, getArgs, getProgName, system, -- -- lifting -- liftIO ) where import Prelude (Bool, Char, String, FilePath, (.), ($), Show, return) import qualified System.IO as IO import qualified System.Directory as IO (createDirectoryIfMissing, doesFileExist, removeFile) import qualified System.Environment as IO (getArgs, getProgName) import qualified System.Process as IO (system) import qualified System.Exit as IO (ExitCode(..), exitWith) import Control.StateBase (PreCST, liftIO) -- file handling -- ------------- openFile :: FilePath -> IO.IOMode -> PreCST e s IO.Handle openFile p m = liftIO $ do hnd <- IO.openFile p m #if MIN_VERSION_base(4,2,0) --FIXME: really we should be using utf8 for .chs and .hs files -- however the current .chs lexer cannot cope with chars -- that are over 255, it goes into an infinte loop. -- As an workaround, use latin1 encoding for the moment: IO.hSetEncoding hnd IO.latin1 #endif return hnd hClose :: IO.Handle -> PreCST e s () hClose h = liftIO (IO.hClose h) -- text I/O -- -------- putChar :: Char -> PreCST e s () putChar c = liftIO (IO.putChar c) putStr :: String -> PreCST e s () putStr s = liftIO (IO.putStr s) putStrLn :: String -> PreCST e s () putStrLn s = liftIO (IO.putStrLn s) hPutStr :: IO.Handle -> String -> PreCST e s () hPutStr h s = liftIO (IO.hPutStr h s) hPutStrLn :: IO.Handle -> String -> PreCST e s () hPutStrLn h s = liftIO (IO.hPutStrLn h s) writeFile :: FilePath -> String -> PreCST e s () writeFile fname contents = do --FIXME: see encoding comment with openFile above -- this isn't exception-safe hnd <- openFile fname IO.WriteMode hPutStr hnd contents hClose hnd readFile :: FilePath -> PreCST e s String readFile fname = do --FIXME: see encoding comment with openFile above hnd <- openFile fname IO.ReadMode liftIO (IO.hGetContents hnd) print :: Show a => a -> PreCST e s () print a = liftIO (IO.print a) getChar :: PreCST e s Char getChar = liftIO IO.getChar hFlush :: IO.Handle -> PreCST e s () hFlush h = liftIO (IO.hFlush h) hPutChar :: IO.Handle -> Char -> PreCST e s () hPutChar h ch = liftIO (IO.hPutChar h ch) hSetBuffering :: IO.Handle -> IO.BufferMode -> PreCST e s () hSetBuffering h m = liftIO (IO.hSetBuffering h m) hGetBuffering :: IO.Handle -> PreCST e s IO.BufferMode hGetBuffering h = liftIO (IO.hGetBuffering h) -- derived functions -- newline :: PreCST e s () newline = putChar '\n' -- `Directory' -- ----------- createDirectoryIfMissing :: Bool -> FilePath -> PreCST e s () createDirectoryIfMissing p = liftIO . IO.createDirectoryIfMissing p doesFileExist :: FilePath -> PreCST e s Bool doesFileExist = liftIO . IO.doesFileExist removeFile :: FilePath -> PreCST e s () removeFile = liftIO . IO.removeFile -- `System' -- -------- exitWith :: IO.ExitCode -> PreCST e s a exitWith = liftIO . IO.exitWith getArgs :: PreCST e s [String] getArgs = liftIO IO.getArgs getProgName :: PreCST e s String getProgName = liftIO IO.getProgName system :: String -> PreCST e s IO.ExitCode system = liftIO . IO.system c2hs-0.28.1/src/Text/0000755000000000000000000000000012677513064012355 5ustar0000000000000000c2hs-0.28.1/src/Text/Lexers.hs0000644000000000000000000004535712677513064014171 0ustar0000000000000000-- Compiler Toolkit: Self-optimizing lexers -- -- Author : Manuel M. T. Chakravarty -- Created: 2 March 99 -- -- Copyright (c) 1999 Manuel M. T. Chakravarty -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Library General Public -- License as published by the Free Software Foundation; either -- version 2 of the License, or (at your option) any later version. -- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Library General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- Self-optimizing lexer combinators. -- -- For detailed information, see ``Lazy Lexing is Fast'', Manuel -- M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of -- Fourth Fuji International Symposium on Functional and Logic Programming, -- Springer-Verlag, LNCS 1722, 1999. (See my Web page for details.) -- -- Thanks to Simon L. Peyton Jones and Roman -- Lechtchinsky for their helpful suggestions that -- improved the design of this library. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- The idea is to combine the benefits of off-line generators with -- combinators like in `Parsers.hs' (which builds on Swierstra/Duponcheel's -- technique for self-optimizing parser combinators). In essence, a state -- transition graph representing a lexer table is computed on the fly, to -- make lexing deterministic and based on cheap table lookups. -- -- Regular expression map to Haskell expressions as follows. If `x' and `y' -- are regular expressions, -- -- -> epsilon -- xy -> x +> y -- x*y -> x `star` y -- x+y -> x `plus` y -- x?y -> x `quest` y -- -- Given such a Haskelized regular expression `hre', we can use -- -- (1) hre `lexaction` \lexeme -> Nothing -- (2) hre `lexaction` \lexeme -> Just token -- (3) hre `lexmeta` \lexeme pos s -> (res, pos', s', Nothing) -- (4) hre `lexmeta` \lexeme pos s -> (res, pos', s', Just l) -- -- where `epsilon' is required at the end of `hre' if it otherwise ends on -- `star', `plus', or `quest', and then, we have -- -- (1) discards `lexeme' accepted by `hre', -- (2) turns the `lexeme' accepted by `hre' into a token, -- (3) while discarding the lexeme accepted by `hre', transforms the -- position and/or user state, and -- (4) while discarding the lexeme accepted by `hre', transforms the -- position and/or user state and returns a lexer to be used for the -- next lexeme. -- -- The component `res' in case of a meta action, can be `Nothing', `Just -- (Left err)', or `Just (Right token)' to return nothing, an error, or a -- token from a meta action, respectively. -- -- * By adding `ctrlLexer', `Positions' are properly handled in the presence -- of layout control characters. -- -- * This module makes essential use of graphical data structures (for -- representing the state transition graph) and laziness (for maintaining -- the last action in `execLexer'. -- -- NOTES: -- -- * In this implementation, the combinators `quest`, `star`, and `plus` are -- *right* associative - this was different in the ``Lazy Lexing is Fast'' -- paper. This change was made on a suggestion by Martin Norbäck -- . -- --- TODO ---------------------------------------------------------------------- -- -- * error correction is missing -- -- * in (>||<) in the last case, `(addBoundsNum bn bn')' is too simple, as -- the number of outgoing edges is not the sum of the numbers of the -- individual states when there are conflicting edges, ie, ones labeled -- with the same character; however, the number is only used to decide a -- heuristic, so it is questionable whether it is worth spending the -- additional effort of computing the accurate number -- -- * Unicode posses a problem as the character domain becomes too big for -- using arrays to represent transition tables and even sparse structures -- will posse a significant overhead when character ranges are naively -- represented. So, it might be time for finite maps again. -- -- Regarding the character ranges, there seem to be at least two -- possibilities. Doaitse explicitly uses ranges and avoids expanding -- them. The problem with this approach is that we may only have -- predicates such as `isAlphaNum' to determine whether a givne character -- belongs to some character class. From this representation it is -- difficult to efficiently compute a range. The second approach, as -- proposed by Tom Pledger (on the Haskell list) -- would be to actually use predicates directly and make the whole business -- efficient by caching predicate queries. In other words, for any given -- character after we have determined (in a given state) once what the -- following state on accepting that character is, we need not consult the -- predicates again if we memorise the successor state the first time -- around. -- -- * Ken Shan writes ``Section 4.3 of your paper -- computes the definition -- -- re1 `star` re2 = \l' -> let self = re1 self >||< re2 l' in self -- -- If we let re2 = epsilon, we get -- -- many :: Regexp s t -> Regexp s t -- many re = \l' -> let self = re1 self >||< l' in self -- -- since epsilon = id.'' This should actually be as good as the current -- definiton and it might be worthwhile to offer it as a variant. -- module Text.Lexers (Regexp, Lexer, Action, epsilon, char, (+>), lexaction, lexactionErr, lexmeta, (>|<), (>||<), ctrlChars, ctrlLexer, star, plus, quest, alt, string, LexerState, execLexer) where import Data.Maybe (fromMaybe) import Data.Array (Array, (!), assocs, accumArray) import Language.C.Data.Position import qualified Data.DList as DL import Data.Errors (interr, ErrorLevel(..), Error, makeError) infixr 4 `quest`, `star`, `plus` infixl 3 +>, `lexaction`, `lexmeta` infixl 2 >|<, >||< -- constants -- --------- -- | we use the dense representation if a table has at least the given number of -- (non-error) elements -- denseMin :: Int denseMin = 20 -- data structures -- --------------- -- | represents the number of (non-error) elements and the bounds of a table -- type BoundsNum = (Int, Char, Char) -- | combine two bounds -- addBoundsNum :: BoundsNum -> BoundsNum -> BoundsNum addBoundsNum (n, lc, hc) (n', lc', hc') = (n + n', min lc lc', max hc hc') -- | check whether a character is in the bounds -- inBounds :: Char -> BoundsNum -> Bool inBounds c (_, lc, hc) = c >= lc && c <= hc -- | Lexical actions take a lexeme with its position and may return a token; in -- a variant, an error can be returned -- -- * if there is no token returned, the current lexeme is discarded lexing -- continues looking for a token -- type Action t = String -> Position -> Maybe t type ActionErr t = String -> Position -> Either Error t -- | Meta actions transform the lexeme, position, and a user-defined state; they -- may return a lexer, which is then used for accepting the next token (this -- is important to implement non-regular behaviour like nested comments) -- type Meta s t = String -> Position -> s -> (Maybe (Either Error t), -- err/tok? Position, -- new pos s, -- state Maybe (Lexer s t)) -- lexer? -- | tree structure used to represent the lexer table -- -- * each node in the tree corresponds to a state of the lexer; the associated -- actions are those that apply when the corresponding state is reached -- data Lexer s t = Lexer (LexAction s t) (Cont s t) -- | represent the continuation of a lexer -- data Cont s t = -- on top of the tree, where entries are dense, we use arrays -- Dense BoundsNum (Array Char (Lexer s t)) -- -- further down, where the valid entries are sparse, we -- use association lists, to save memory (the first argument -- is the length of the list) -- | Sparse BoundsNum [(Char, Lexer s t)] -- -- end of a automaton -- | Done -- deriving Show -- | lexical action -- data LexAction s t = Action (Meta s t) | NoAction -- deriving Show -- | a regular expression -- type Regexp s t = Lexer s t -> Lexer s t -- basic combinators -- ----------------- -- | Empty lexeme -- epsilon :: Regexp s t epsilon = id -- | One character regexp -- char :: Char -> Regexp s t char c = \l -> Lexer NoAction (Sparse (1, c, c) [(c, l)]) -- | Concatenation of regexps -- (+>) :: Regexp s t -> Regexp s t -> Regexp s t (+>) = (.) -- | Close a regular expression with an action that converts the lexeme into a -- token -- -- * Note: After the application of the action, the position is advanced -- according to the length of the lexeme. This implies that normal -- actions should not be used in the case where a lexeme might contain -- control characters that imply non-standard changes of the position, -- such as newlines or tabs. -- lexaction :: Regexp s t -> Action t -> Lexer s t lexaction re a = re `lexmeta` a' where a' lexeme pos s = let pos' = incPos pos (length lexeme) in pos' `seq` case a lexeme pos of Nothing -> (Nothing, pos', s, Nothing) Just t -> (Just (Right t), pos', s, Nothing) -- | Variant for actions that may returns an error -- lexactionErr :: Regexp s t -> ActionErr t -> Lexer s t lexactionErr re a = re `lexmeta` a' where a' lexeme pos s = let pos' = incPos pos (length lexeme) in pos' `seq` (Just (a lexeme pos), pos', s, Nothing) -- | Close a regular expression with a meta action -- -- * Note: Meta actions have to advance the position in dependence of the -- lexeme by themselves. -- lexmeta :: Regexp s t -> Meta s t -> Lexer s t lexmeta re a = re (Lexer (Action a) Done) -- | disjunctive combination of two regexps -- (>|<) :: Regexp s t -> Regexp s t -> Regexp s t re >|< re' = \l -> re l >||< re' l -- | disjunctive combination of two lexers -- (>||<) :: Lexer s t -> Lexer s t -> Lexer s t (Lexer a c) >||< (Lexer a' c') = Lexer (joinActions a a') (joinConts c c') -- | combine two disjunctive continuations -- joinConts :: Cont s t -> Cont s t -> Cont s t joinConts Done c' = c' joinConts c Done = c joinConts c c' = let (bn , cls ) = listify c (bn', cls') = listify c' in -- note: `addsBoundsNum' can, at this point, only -- approx. the number of *non-overlapping* cases; -- however, the bounds are correct -- aggregate (addBoundsNum bn bn') (cls ++ cls') where listify (Dense n arr) = (n, assocs arr) listify (Sparse n cls) = (n, cls) listify _ = interr "Lexers.listify: Impossible argument!" -- | combine two actions -- joinActions :: LexAction s t -> LexAction s t -> LexAction s t joinActions NoAction a' = a' joinActions a NoAction = a joinActions _ _ = interr "Lexers.>||<: Overlapping actions!" -- | Note: `n' is only an upper bound of the number of non-overlapping cases -- aggregate :: BoundsNum -> ([(Char, Lexer s t)]) -> Cont s t aggregate bn@(n, lc, hc) cls | n >= denseMin = Dense bn (accumArray (>||<) noLexer (lc, hc) cls) | otherwise = Sparse bn (accum (>||<) cls) where noLexer = Lexer NoAction Done -- | combine the elements in the association list that have the same key -- accum :: Eq a => (b -> b -> b) -> [(a, b)] -> [(a, b)] accum _ [] = [] accum f ((k, e):kes) = let (ke, kes') = gather k e kes in ke : accum f kes' where gather k' e' [] = ((k', e'), []) gather k' e' (ke'@(k'2, e'2):kes') | k' == k'2 = gather k' (f e' e'2) kes' | otherwise = let (ke'2, kes'2) = gather k' e' kes' in (ke'2, ke':kes'2) -- handling of control characters -- ------------------------------ -- | control characters recognized by `ctrlLexer' -- ctrlChars :: [Char] ctrlChars = ['\n', '\r', '\f', '\t'] -- | control lexer -- -- * implements proper `Position' management in the presence of the standard -- layout control characters -- ctrlLexer :: Lexer s t ctrlLexer = char '\n' `lexmeta` newline >||< char '\r' `lexmeta` newline >||< char '\v' `lexmeta` newline >||< char '\f' `lexmeta` formfeed >||< char '\t' `lexmeta` tab where newline _ pos s = (Nothing, retPos pos , s, Nothing) formfeed _ pos s = (Nothing, incPos pos 1, s, Nothing) tab _ pos s = (Nothing, incPos pos 8, s, Nothing) -- non-basic combinators -- --------------------- -- | x `star` y corresponds to the regular expression x*y -- star :: Regexp s t -> Regexp s t -> Regexp s t -- -- The definition used below can be obtained by equational reasoning from this -- one (which is much easier to understand): -- -- star re1 re2 = let self = (re1 +> self >|< epsilon) in self +> re2 -- -- However, in the above, `self' is of type `Regexp s t' (ie, a functional), -- whereas below it is of type `Lexer s t'. Thus, below we have a graphical -- body (finite representation of an infinite structure), which doesn't grow -- with the size of the accepted lexeme - in contrast to the definition using -- the functional recursion. -- star re1 re2 = \l -> let self = re1 self >||< re2 l in self -- | x `plus` y corresponds to the regular expression x+y -- plus :: Regexp s t -> Regexp s t -> Regexp s t plus re1 re2 = re1 +> (re1 `star` re2) -- | x `quest` y corresponds to the regular expression x?y -- quest :: Regexp s t -> Regexp s t -> Regexp s t quest re1 re2 = (re1 +> re2) >|< re2 -- | accepts a non-empty set of alternative characters -- alt :: [Char] -> Regexp s t -- -- Equiv. to `(foldr1 (>|<) . map char) cs', but much faster -- alt [] = interr "Lexers.alt: Empty character set!" alt cs = \l -> let bnds = (length cs, minimum cs, maximum cs) in Lexer NoAction (aggregate bnds [(c, l) | c <- cs]) -- | accept a character sequence -- string :: String -> Regexp s t string [] = interr "Lexers.string: Empty character set!" string cs = (foldr1 (+>) . map char) cs -- execution of a lexer -- -------------------- -- | threaded top-down during lexing (current input, current position, meta -- state) -- type LexerState s = (String, Position, s) -- | apply a lexer, yielding a token sequence and a list of errors -- -- * Currently, all errors are fatal; thus, the result is undefined in case of -- an error (this changes when error correction is added). -- -- * The final lexer state is returned. -- -- * The order of the error messages is undefined. -- execLexer :: Lexer s t -> LexerState s -> ([t], LexerState s, [Error]) -- -- * the following is moderately tuned -- execLexer _ state@([], _, _) = ([], state, []) execLexer l state = case lexOne l state of (Nothing , _ , state') -> execLexer l state' (Just res, l', state') -> let (ts, final, allErrs) = execLexer l' state' in case res of (Left err) -> (ts , final, err:allErrs) (Right t ) -> (t:ts, final, allErrs) where -- accept a single lexeme -- -- lexOne :: Lexer s t -> LexerState s t -- -> (Either Error (Maybe t), Lexer s t, LexerState s t) lexOne l0 state' = oneLexeme l0 state' DL.empty lexErr where -- the result triple of `lexOne' that signals a lexical error; -- the result state is advanced by one character for error correction -- lexErr = let (cs, pos, s) = state' err = makeError LevelError pos ["Lexical error!", "The character " ++ show (head cs) ++ " does not fit here; skipping it."] in (Just (Left err), l, (tail cs, incPos pos 1, s)) -- we take an open list of characters down, where we accumulate the -- lexeme; this function returns maybe a token, the next lexer to use -- (can be altered by a meta action), the new lexer state, and a list -- of errors -- -- we implement the "principle of the longest match" by taking a -- potential result quadruple down (in the last argument); the -- potential result quadruple is updated whenever we pass by an action -- (different from `NoAction'); initially it is an error result -- -- oneLexeme :: Lexer s t -- -> LexerState -- -> DList Char -- -> (Maybe (Either Error t), Maybe (Lexer s t), -- LexerState s t) -- -> (Maybe (Either Error t), Maybe (Lexer s t), -- LexerState s t) oneLexeme (Lexer a cont') state''@(cs, pos, s) csDL last' = let last'' = action a csDL state'' last' in case cs of [] -> last'' (c:cs') -> oneChar cont' c (cs', pos, s) csDL last'' oneChar Done _ _ _ last' = last' oneChar (Dense bn arr) c state'' csDL last' | c `inBounds` bn = cont (arr!c) c state'' csDL last' | otherwise = last' oneChar (Sparse bn cls) c state'' csDL last' | c `inBounds` bn = case lookup c cls of Nothing -> last' Just l' -> cont l' c state'' csDL last' | otherwise = last' -- continue within the current lexeme -- cont l' c state'' csDL last' = oneLexeme l' state'' (csDL `DL.snoc` c) last' -- execute the action if present and finalise the current lexeme -- action (Action f) csDL (cs, pos, s) _last = case f (DL.toList csDL) pos s of (Nothing, pos', s', l') | not . null $ cs -> lexOne (fromMaybe l0 l') (cs, pos', s') (res , pos', s', l') -> (res, (fromMaybe l0 l'), (cs, pos', s')) action NoAction _csDL _state last' = last' -- no change c2hs-0.28.1/src/Control/0000755000000000000000000000000012677513064013051 5ustar0000000000000000c2hs-0.28.1/src/Control/StateTrans.hs0000644000000000000000000002723212677513064015503 0ustar0000000000000000-- The HiPar Toolkit: state transformer routines -- -- Author : Manuel M. T. Chakravarty -- Created: 3 March 95 -- -- Copyright (C) [1995..1999] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides basic support for the use of state transformers. -- The state transformer is build around the `IO' monad to allow the -- manipulation of external state. It encapsulated two separate states with -- the intention to use the first one for the omnipresent compiler state -- consisting of the accumulated error messages etc. and to use the second as -- a generic component that can be used in different ways by the different -- phases of the compiler. -- -- The module also supports the use of exceptions and fatal errors. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * We explicitly do not use any names for the monad types and functions -- that are used by either Haskell's `IO' monad or GHC's `ST' monad. Since -- Haskell 1.4, `STB' is an instance of the `Monad' constructor class. -- -- * To integrate the Haskell prelude `IO' monad into our `STB' monad we use -- the technique from ``Composing monads'' by Mark P. Jones and Luc -- Duponcheel (Report YALEU/DCS/RR-1004) from 1993, Section 8. -- -- * The use of GHC's inplace-update goodies within monads of kind `STB' is -- possible, bacause `IO' is based on `ST' in the GHC. -- -- * In the following, we call the two kinds of state managed by the `STB' the -- base state (the omnipresent state of the compiler) and generic state. -- -- * `STB' is a newtype, which requires careful wrapping and unwrapping of its -- values in the following definitions. -- --- TODO ---------------------------------------------------------------------- -- -- * with constructor classes, the state transformer business can be made -- more elegant (they weren't around when this module was initially written) -- -- * it would be possible to maintain the already applied changes to the base -- and generic state even in the case of a fatal error, when in `listIO' -- every IO operation is encapsulated into a handler that transforms IO -- errors into exceptions -- module Control.StateTrans (-- the monad and the generic operations -- STB, -- -- monad specific operations -- readBase, writeBase, transBase, readGeneric, writeGeneric, transGeneric, liftIO, runSTB, interleave, -- -- exception handling and fatal errors -- throwExc, fatal, catchExc, fatalsHandledBy) where import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap) import Control.Exception (catch) import Prelude hiding (catch) -- BEWARE! You enter monad country. Read any of Wadler's or -- Launchbury/Peyton-Jones' texts before entering. Otherwise, -- your mental health my be in danger. You have been warned! -- state transformer base and its monad operations -- ----------------------------------------------- -- | the generic form of a state transformer using the external state represented -- by 'IO'; 'STB' is a abbreviation for state transformer base -- -- the first state component @bs@ is provided for the omnipresent compiler -- state and the, second, @gs@ for the generic component -- -- the third component of the result distinguishes between erroneous and -- successful computations where -- -- @Left (tag, msg)@ -- stands for an exception identified by @tag@ with -- error message @msg@, and -- @Right a@ -- is a successfully delivered result -- newtype STB bs gs a = STB (bs -> gs -> IO (bs, gs, Either (String, String) a)) instance Functor (STB bs gs) where fmap = liftM instance Applicative (STB bs gs) where pure = return (<*>) = ap instance Monad (STB bs gs) where return = yield (>>=) = (+>=) -- | the monad's unit -- yield :: a -> STB bs gs a yield a = STB $ \bs gs -> return (bs, gs, Right a) -- | the monad's bind -- -- * exceptions are propagated -- (+>=) :: STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b m +>= k = let STB m' = m in STB $ \bs gs -> m' bs gs >>= \(bs', gs', res) -> case res of Left exc -> return (bs', gs', Left exc) -- prop exc Right a -> let STB k' = k a in k' bs' gs' -- cont -- generic state manipulation -- -------------------------- -- base state: -- -- | given a reader function for the base state, wrap it into an STB monad -- readBase :: (bs -> a) -> STB bs gs a readBase f = STB $ \bs gs -> return (bs, gs, Right (f bs)) -- | given a new base state, inject it into an STB monad -- writeBase :: bs -> STB bs gs () writeBase bs' = STB $ \_ gs -> return (bs', gs, Right ()) -- | given a transformer function for the base state, wrap it into an STB monad -- transBase :: (bs -> (bs, a)) -> STB bs gs a transBase f = STB $ \bs gs -> let (bs', a) = f bs in return (bs', gs, Right a) -- generic state: -- -- | given a reader function for the generic state, wrap it into an STB monad -- readGeneric :: (gs -> a) -> STB bs gs a readGeneric f = STB $ \bs gs -> return (bs, gs, Right (f gs)) -- | given a new generic state, inject it into an STB monad -- writeGeneric :: gs -> STB bs gs () writeGeneric gs' = STB $ \bs _ -> return (bs, gs', Right ()) -- | given a transformer function for the generic state, wrap it into an STB -- monad -- transGeneric :: (gs -> (gs, a)) -> STB bs gs a transGeneric f = STB $ \bs gs -> let (gs', a) = f gs in return (bs, gs', Right a) -- interaction with the encapsulated 'IO' monad -- -------------------------------------------- -- | lifts an 'IO' state transformer into 'STB' -- liftIO :: IO a -> STB bs gs a liftIO m = STB $ \bs gs -> m >>= \r -> return (bs, gs, Right r) -- | given an initial state, executes the 'STB' state transformer yielding an -- 'IO' state transformer that must be placed into the context of the external -- IO -- -- * uncaught exceptions become fatal errors -- runSTB :: STB bs gs a -> bs -> gs -> IO a runSTB m bs gs = let STB m' = m in m' bs gs >>= \(_, _, res) -> case res of Left (tag, msg) -> let err = userError ("Exception `" ++ tag ++ "': " ++ msg) in ioError err Right a -> return a -- | interleave the (complete) execution of an 'STB' with another generic state -- component into an 'STB' -- interleave :: STB bs gs' a -> gs' -> STB bs gs a interleave m gs' = STB $ let STB m' = m in \bs gs -> (m' bs gs' >>= \(bs', _, a) -> return (bs', gs, a)) -- error and exception handling -- ---------------------------- -- * we exploit the 'UserError' component of 'IOError' for fatal errors -- -- * we distinguish exceptions and user-defined fatal errors -- -- - exceptions are meant to be caught in order to recover the currently -- executed operation; they turn into fatal errors if they are not caught; -- execeptions are tagged, which allows to deal with multiple kinds of -- execeptions at the same time and to handle them differently -- - user-defined fatal errors abort the currently executed operation, but -- they may be caught at the top-level in order to terminate gracefully or -- to invoke another operation; there is no special support for different -- handling of different kinds of fatal-errors -- -- * the costs for fatal error handling are already incurred by the 'IO' monad; -- the costs for exceptions mainly is the case distinction in the definition -- of '+>=' -- -- | throw an exception with the given tag and message -- throwExc :: String -> String -> STB bs gs a throwExc tag msg = STB $ \bs gs -> return (bs, gs, Left (tag, msg)) -- | raise a fatal user-defined error -- -- * such an error my be caught and handled using 'fatalsHandeledBy' -- fatal :: String -> STB bs gs a fatal s = liftIO (ioError (userError s)) -- | the given state transformer is executed and exceptions with the given tag -- are caught using the provided handler, which expects to get the exception -- message -- -- * the base and generic state observed by the exception handler is *modified* -- by the failed state transformer upto the point where the exception was -- thrown (this semantics is the only reasonable when it should be possible -- to use updating for maintaining the state) -- catchExc :: STB bs gs a -> (String, String -> STB bs gs a) -> STB bs gs a catchExc m (tag, handler) = STB $ \bs gs -> let STB m' = m in m' bs gs >>= \state@(bs', gs', res) -> case res of Left (tag', msg) -> if (tag == tag') -- exception with... then let STB handler' = handler msg in handler' bs' gs' -- correct tag, catch else return state -- wrong tag, rethrow Right _ -> return state -- no exception -- | given a state transformer that may raise fatal errors and an error handler -- for fatal errors, execute the state transformer and apply the error handler -- when a fatal error occurs -- -- * fatal errors are IO monad errors and errors raised by 'fatal' as well as -- uncaught exceptions -- -- * the base and generic state observed by the error handler is *in contrast -- to 'catch'* the state *before* the state transformer is applied -- fatalsHandledBy :: STB bs gs a -> (IOError -> STB bs gs a) -> STB bs gs a fatalsHandledBy m handler = STB $ \bs gs -> (let STB m' = m in m' bs gs >>= \state@(_gs', _bs', res) -> case res of Left (tag, msg) -> let err = userError ("Exception `" ++ tag ++ "': " ++ msg) in ioError err Right _a -> return state ) `catch` (\err -> let STB handler' = handler err in handler' bs gs) c2hs-0.28.1/src/Control/StateBase.hs0000644000000000000000000001111512677513064015257 0ustar0000000000000000-- Compiler Toolkit: compiler state management basics -- -- Author : Manuel M. T. Chakravarty -- Created: 7 November 97 -- -- Copyright (C) [1997..1999] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides basic types and services used to realize the state -- management of the compiler. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * The monad `PreCST' is an instance of `STB' where the base state is fixed. -- However, the base state itself is parametrized by an extra state -- component that can be instantiated by the compiler that uses the toolkit -- (to store information like compiler switches) -- this is the reason for -- adding the prefix `Pre'. -- -- * The module exports the details of the `BaseState' etc as they have to be -- know by `State'. The latter ensures the necessary abstraction for -- modules that do not belong to the state management. -- -- * Due to this module, the state management modules can share internal -- information about the data types hidden to the rest of the system. -- -- * The following state components are maintained: -- -- + errorsBS (type `ErrorState') -- keeps track of raised errors -- + namesBS (type `NameSupply') -- provides unique names -- + extraBS (generic type) -- extra compiler-dependent state -- information, e.g., for compiler -- switches -- --- TODO ---------------------------------------------------------------------- -- module Control.StateBase (PreCST(..), ErrorState(..), BaseState(..), unpackCST, readCST, writeCST, transCST, liftIO) where import Control.StateTrans (STB, readGeneric, writeGeneric, transGeneric) import qualified Control.StateTrans as StateTrans (liftIO) import Data.Errors (ErrorLevel(..), Error) import Language.C.Data.Name import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap) -- state used in the whole compiler -- -------------------------------- -- | form of the error state -- -- * when no error was raised yet, the error level is the lowest possible one -- data ErrorState = ErrorState ErrorLevel -- worst error level that was raised Int -- number of errors (excl warnings) [Error] -- already raised errors -- | base state -- data BaseState e = BaseState { errorsBS :: ErrorState, supplyBS :: [Name], -- unique names extraBS :: e -- extra state } -- | the compiler state transformer -- newtype PreCST e s a = CST (STB (BaseState e) s a) instance Functor (PreCST e s) where fmap = liftM instance Applicative (PreCST e s) where pure = return (<*>) = ap instance Monad (PreCST e s) where return = yield (>>=) = (+>=) -- | unwrapper coercion function -- unpackCST :: PreCST e s a -> STB (BaseState e) s a unpackCST m = let CST m' = m in m' -- monad operations -- ---------------- -- | the monad's unit -- yield :: a -> PreCST e s a yield a = CST $ return a -- | the monad's bind -- (+>=) :: PreCST e s a -> (a -> PreCST e s b) -> PreCST e s b m +>= k = CST $ unpackCST m >>= (\a -> unpackCST (k a)) -- generic state manipulation -- -------------------------- -- | given a reader function for the state, wrap it into an CST monad -- readCST :: (s -> a) -> PreCST e s a readCST f = CST $ readGeneric f -- | given a new state, inject it into an CST monad -- writeCST :: s -> PreCST e s () writeCST s' = CST $ writeGeneric s' -- | given a transformer function for the state, wrap it into an CST monad -- transCST :: (s -> (s, a)) -> PreCST e s a transCST f = CST $ transGeneric f -- interaction with the encapsulated 'IO' monad -- -------------------------------------------- -- | lifts an 'IO' state transformer into 'CST' -- liftIO :: IO a -> PreCST e s a liftIO m = CST $ (StateTrans.liftIO m) c2hs-0.28.1/src/Control/State.hs0000644000000000000000000002447312677513064014477 0ustar0000000000000000-- Compiler Toolkit: compiler state management -- -- Author : Manuel M. T. Chakravarty -- Created: 2 November 95 -- -- Copyright (c) [1995..1999] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module forms the interface to the state base of the compiler. It is -- used by all modules that are not directly involved in implementing the -- state base. It provides a state transformer that is capable of doing I/O -- and provides facilities such as error handling and compiler switch -- management. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * The monad `PreCST' is reexported abstractly. -- -- * Errors are dumped to `stdout' to facilitate communication with other -- processes (see `Interact'). -- --- TODO ---------------------------------------------------------------------- -- module Control.State (-- the PreCST monad -- PreCST, -- reexport ABSTRACT throwExc, fatal, catchExc, fatalsHandledBy, -- reexport lifted readCST, writeCST, transCST, run, runCST, -- -- more compiler I/O -- liftIO, -- -- error management -- raise, raiseWarning, raiseError, raiseFatal, showErrors, errorsPresent, -- -- state management helpers getNameSupply, setNameSupply, -- -- extra state management -- readExtra, updExtra) where import Control.Monad (when) import Control.StateTrans (readBase, transBase, runSTB) import qualified Control.StateTrans as StateTrans (interleave, throwExc, fatal, catchExc, fatalsHandledBy) import Control.StateBase (PreCST(..), ErrorState(..), BaseState(..), unpackCST, readCST, writeCST, transCST, liftIO) import qualified System.CIO as CIO import Data.Errors (Error, makeError) import Language.C.Data.Name import Language.C.Data.Position import Language.C.Data.Error hiding (Error) -- state used in the whole compiler -- -------------------------------- -- | initialization -- -- * it gets the version information and the initial extra state as arguments -- initialBaseState :: e -> BaseState e initialBaseState es = BaseState { supplyBS = newNameSupply, errorsBS = initialErrorState, extraBS = es } -- executing state transformers -- ---------------------------- -- | initiate a complete run of the ToolKit represented by a PreCST with a void -- generic component (type '()') -- -- * fatals errors are explicitly caught and reported (instead of letting them -- through to the runtime system) -- run :: e -> PreCST e () a -> IO a run es cst = runSTB m (initialBaseState es) () where m = unpackCST ( cst `fatalsHandledBy` \err -> CIO.putStr ("Uncaught fatal error: " ++ show err) >> CIO.exitWith (CIO.ExitFailure 1) ) -- | run a PreCST in the context of another PreCST -- -- the generic state of the enclosing PreCST is preserved while the -- computation of the PreCST passed as an argument is interleaved in the -- execution of the enclosing one -- runCST :: PreCST e s a -> s -> PreCST e s' a runCST m s = CST $ StateTrans.interleave (unpackCST m) s -- exception handling -- ------------------ -- | throw an exception with the given tag and message -- throwExc :: String -> String -> PreCST e s a throwExc s1 s2 = CST $ StateTrans.throwExc s1 s2 -- | raise a fatal user-defined error -- -- * such an error my be caught and handled using 'fatalsHandeledBy' -- fatal :: String -> PreCST e s a fatal = CST . StateTrans.fatal -- | the given state transformer is executed and exceptions with the given tag -- are caught using the provided handler, which expects to get the exception -- message -- -- * the state observed by the exception handler is *modified* by the failed -- state transformer upto the point where the exception was thrown (this -- semantics is the only reasonable when it should be possible to use -- updating for maintaining the state) -- catchExc :: PreCST e s a -> (String, String -> PreCST e s a) -> PreCST e s a catchExc m (s, h) = CST $ StateTrans.catchExc (unpackCST m) (s, unpackCST . h) -- | given a state transformer that may raise fatal errors and an error handler -- for fatal errors, execute the state transformer and apply the error handler -- when a fatal error occurs -- -- * fatal errors are IO monad errors and errors raised by 'fatal' as well as -- uncaught exceptions -- -- * the base and generic state observed by the error handler is *in contrast -- to 'catch'* the state *before* the state transformer is applied -- fatalsHandledBy :: PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a fatalsHandledBy m h = CST $ StateTrans.fatalsHandledBy m' h' where m' = unpackCST m h' = unpackCST . h -- manipulating the error state -- ---------------------------- -- | the lowest level of errors is 'LevelWarn', but it is meaningless as long as -- the the list of errors is empty -- initialErrorState :: ErrorState initialErrorState = ErrorState LevelWarn 0 [] -- | raise an error -- -- * a fatal error is reported immediately; see 'raiseFatal' -- raise :: Error -> PreCST e s () raise err = case errorLevel err of LevelWarn -> raise0 err LevelError -> raise0 err LevelFatal -> raiseFatal0 "Generic fatal error." err -- | raise a warning (see 'raiseErr') -- raiseWarning :: Position -> [String] -> PreCST e s () raiseWarning pos msg = raise0 (makeError LevelWarn pos msg) -- | raise an error (see 'raiseErr') -- raiseError :: Position -> [String] -> PreCST e s () raiseError pos msg = raise0 (makeError LevelError pos msg) -- | raise a fatal compilation error -- -- * the error is together with the up-to-now accumulated errors are reported -- as part of the error message of the fatal error exception -- -- * the current thread of control is discarded and control is passed to the -- innermost handler for fatal errors -- -- * the first argument must contain a short description of the error, while -- the second and third argument are like the two arguments to 'raise' -- raiseFatal :: String -> Position -> [String] -> PreCST e s a raiseFatal short pos long = raiseFatal0 short (makeError LevelFatal pos long) -- | raise a fatal error; internal version that gets an abstract error -- raiseFatal0 :: String -> Error -> PreCST e s a raiseFatal0 short err = do raise0 err errmsgs <- showErrors fatal (short ++ "\n\n" ++ errmsgs) -- | raise an error; internal version, doesn't check whether the error is fatal -- -- * the error is entered into the compiler state and a fatal error is -- triggered if the 'errorLimit' is reached -- raise0 :: Error -> PreCST e s () raise0 err = do noOfErrs <- CST $ transBase doRaise when (noOfErrs >= errorLimit) $ do errmsgs <- showErrors fatal ("Error limit of " ++ show errorLimit ++ " errors has been reached.\n" ++ errmsgs) where errorLimit = 20 doRaise :: BaseState e -> (BaseState e, Int) doRaise bs = let lvl = errorLevel err ErrorState wlvl no errs = errorsBS bs wlvl' = max wlvl lvl no' = no + if lvl > LevelWarn then 1 else 0 errs' = err : errs in (bs {errorsBS = (ErrorState wlvl' no' errs')}, no') -- | yield a string containing the collected error messages -- -- * the error state is reset in this process -- showErrors :: PreCST e s String showErrors = CST $ do ErrorState _ _ errs <- transBase extractErrs return $ concatMap (showErrorInfo "" . errorInfo) errs --FIXME: should be using show here ^^, but Show instance -- for CError from language-c is weird where extractErrs :: BaseState e -> (BaseState e, ErrorState) extractErrs bs = (bs {errorsBS = initialErrorState}, errorsBS bs) -- | inquire if there was already an error of at least level 'LevelError' raised -- errorsPresent :: PreCST e s Bool errorsPresent = CST $ do ErrorState wlvl _ _ <- readBase errorsBS return $ wlvl >= LevelError -- helpers for manipulating state -- ---------------------------- -- | get a name supply getNameSupply :: PreCST e s [Name] getNameSupply = CST $ readBase supplyBS -- | update the name supply setNameSupply :: [Name] -> PreCST e s () setNameSupply ns = CST $ transBase $ \st -> (st { supplyBS = ns }, ()) -- manipulating the extra state -- ---------------------------- -- | apply a reader function to the extra state and yield the reader's result -- readExtra :: (e -> a) -> PreCST e s a readExtra rf = CST $ readBase (\bs -> (rf . extraBS) bs ) -- | apply an update function to the extra state -- updExtra :: (e -> e) -> PreCST e s () updExtra uf = CST $ transBase (\bs -> let es = extraBS bs in (bs {extraBS = uf es}, ()) ) c2hs-0.28.1/src/C2HS/0000755000000000000000000000000012677513065012131 5ustar0000000000000000c2hs-0.28.1/src/C2HS/Config.hs0000644000000000000000000001267712677513064013706 0ustar0000000000000000-- -*-haskell-*- -- ** @configure_input@ ** -- =========================================================================== -- C -> Haskell Compiler: configuration -- -- Author : Manuel M T Chakravarty -- Created: 27 September 99 -- -- Copyright (c) [1999..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- Configuration options; largely set by `configure'. -- --- TODO ---------------------------------------------------------------------- -- module C2HS.Config ( -- -- programs and paths -- cpp, cppopts, libfname, hpaths, -- -- parameters of the targeted C compiler -- PlatformSpec(..), defaultPlatformSpec, platformSpecDB ) where import Foreign (toBool) import Foreign.C (CInt(..)) import System.Info (arch, os) -- program settings -- ---------------- -- | C preprocessor executable -- cpp :: FilePath cpp = case os of "darwin" -> "gcc" _ -> "cpp" -- | C preprocessor options -- -- * `-x c' forces CPP to regard the input as C code; this option seems to be -- understood at least on Linux, FreeBSD, and Solaris and seems to make a -- difference over the default language setting on FreeBSD -- -- * @-P@ would suppress @#line@ directives -- cppopts :: [String] cppopts = case (os,cpp) of -- why is gcc different between all these platforms? ("openbsd","cpp") -> ["-xc"] (_,"cpp") -> ["-x", "c"] (_,"gcc") -> ["-E", "-x", "c"] _ -> [] -- | C2HS Library file name -- libfname :: FilePath libfname = "C2HS.hs" -- | Standard system search paths for header files -- hpaths :: [FilePath] hpaths = [".", "/usr/include", "/usr/local/include"] -- parameters of the targeted C compiler -- ------------------------------------- -- | Parameters that characterise implementation-dependent features of the -- targeted C compiler -- data PlatformSpec = PlatformSpec { identPS :: String, -- platform identifier bitfieldDirectionPS :: Int, -- to fill bitfields bitfieldPaddingPS :: Bool, -- padding or split? bitfieldIntSignedPS :: Bool, -- `int' signed bitf.? bitfieldAlignmentPS :: Int -- alignment constraint } instance Show PlatformSpec where show (PlatformSpec ident dir pad intSig align) = show ident ++ " <" ++ show dir ++ ", " ++ show pad ++ ", " ++ show intSig ++ ", " ++ show align ++ ">" -- | Platform specification for the C compiler used to compile c2hs (which is -- the default target). -- defaultPlatformSpec :: PlatformSpec defaultPlatformSpec = PlatformSpec { identPS = arch ++ "-" ++ os, bitfieldDirectionPS = bitfieldDirection, bitfieldPaddingPS = bitfieldPadding, bitfieldIntSignedPS = bitfieldIntSigned, bitfieldAlignmentPS = bitfieldAlignment } -- | The set of platform specification that may be choosen for cross compiling -- bindings. -- platformSpecDB :: [PlatformSpec] platformSpecDB = [ PlatformSpec { identPS = "x86_64-linux", bitfieldDirectionPS = 1, bitfieldPaddingPS = True, bitfieldIntSignedPS = True, bitfieldAlignmentPS = 1 }, PlatformSpec { identPS = "i686-linux", bitfieldDirectionPS = 1, bitfieldPaddingPS = True, bitfieldIntSignedPS = True, bitfieldAlignmentPS = 1 }, PlatformSpec { identPS = "m68k-palmos", bitfieldDirectionPS = -1, bitfieldPaddingPS = True, bitfieldIntSignedPS = True, bitfieldAlignmentPS = 1 } ] -- | indicates in which direction the C compiler fills bitfields -- -- * the value is 1 or -1, depending on whether the direction is growing -- towards the MSB -- bitfieldDirection :: Int bitfieldDirection = fromIntegral bitfield_direction foreign import ccall "config.h" bitfield_direction :: CInt -- | indicates whether a bitfield that does not fit into a partially filled -- storage unit in its entirety introduce padding or split over two storage -- units -- -- * 'True' means that such a bitfield introduces padding (instead of being -- split) -- bitfieldPadding :: Bool bitfieldPadding = toBool bitfield_padding foreign import ccall "config.h" bitfield_padding :: CInt -- | indicates whether a bitfield of type `int' is signed in the targeted C -- compiler -- bitfieldIntSigned :: Bool bitfieldIntSigned = toBool bitfield_int_signed foreign import ccall "config.h" bitfield_int_signed :: CInt -- | the alignment constraint for a bitfield -- -- * this makes the assumption that the alignment of a bitfield is independent -- of the bitfield's size -- bitfieldAlignment :: Int bitfieldAlignment = fromIntegral bitfield_alignment foreign import ccall "config.h" bitfield_alignment :: CInt c2hs-0.28.1/src/C2HS/C.hs0000644000000000000000000001525412677513064012655 0ustar0000000000000000-- C->Haskell Compiler: interface to C processing routines -- -- Author : Manuel M. T. Chakravarty -- Created: 12 August 99 -- -- Copyright (c) 1999 Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This modules provides access to the C processing routines for the rest of -- the compiler. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- --- TODO ---------------------------------------------------------------------- -- -- module C2HS.C (-- interface to KL for all non-KL modules -- -- stuff from `Common' (reexported) -- Pos(posOf), -- -- structure tree -- module Language.C.Syntax, -- -- attributed structure tree with operations (reexported from -- `CAttrs') -- AttrC, CObj(..), CTag(..), CDef(..), lookupDefObjC, lookupDefTagC, getDefOfIdentC, -- -- support for C structure tree traversals -- module C2HS.C.Trav, -- loadAttrC, -- locally defined -- -- misc. reexported stuff -- Ident, NodeInfo, Attr(..), -- -- misc. own stuff -- csuffix, hsuffix, isuffix) where import Language.C.Data import Language.C.Syntax import Language.C.Parser import Data.Attributes (Attr(..)) import qualified Data.ByteString.Char8 as BS import C2HS.State (CST, fatal, errorsPresent, showErrors, raiseError, getNameSupply, setNameSupply, Traces(..), putTraceStr) import System.CIO as CIO (liftIO) import C2HS.C.Attrs (AttrC, CObj(..), CTag(..), CDef(..), lookupDefObjC, lookupDefTagC, getDefOfIdentC) import C2HS.C.Names (nameAnalysis) import C2HS.C.Trav -- | suffix for files containing C -- csuffix, hsuffix, isuffix :: String csuffix = "c" hsuffix = "h" isuffix = "i" -- | parse a header file, raise an error if parsing failed parseHeader :: InputStream -> Position -> CST s CTranslUnit parseHeader is pos = do ns <- getNameSupply case execParser translUnitP is pos builtinTypeNames ns of Left (ParseError (msgs,pos')) -> raiseError pos' msgs >> return (CTranslUnit [] undefNode) Right (ct,ns') -> setNameSupply ns' >> return ct -- | @bsReplace old new haystack@ replaces occurences of @old@ with -- @new@ in the @haystack@. bsReplace :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BS.ByteString bsReplace old new = go id where go acc hay | BS.null hay = BS.concat (acc []) | otherwise = case BS.breakSubstring old hay of (h,t) | BS.null t -> BS.concat (acc [h]) | otherwise -> go (acc . (h:) . (new:)) (BS.drop n t) n = BS.length old -- | given a file name (with suffix), parse that file as a C header and do the -- static analysis (collect defined names) -- -- * currently, lexical and syntactical errors are reported immediately and -- abort the program; others are reported as part of the fatal error message; -- warnings are returned together with the read unit -- loadAttrC :: String -> CST s (AttrC, String) loadAttrC fname = do -- read file -- traceInfoRead fname -- very hacky dodge of Apple's block syntax in -- type definitions. This simply replaces a block -- type with a function pointer type. The issue -- is that language-c does not support this -- syntax, but frameworks such as OpenCL now use -- it in their headers. let fixBlockTypeDef x | BS.isPrefixOf (BS.pack "typedef ") x = bsReplace (BS.pack "(^") (BS.pack "(*") x | otherwise = x fixLines = BS.unlines . map fixBlockTypeDef . BS.lines contents <- fmap fixLines (liftIO $ readInputStream fname) -- parse -- traceInfoParse header <- parseHeader contents (initPos fname) -- name analysis -- traceInfoNA headerWithAttrs <- nameAnalysis header -- check for errors and finalize -- errs <- errorsPresent if errs then do traceInfoErr errmsgs <- showErrors fatal ("C header contains \ \errors:\n\n" ++ errmsgs) -- fatal error else do traceInfoOK warnmsgs <- showErrors return (headerWithAttrs, warnmsgs) where traceInfoRead fname' = putTraceStr tracePhasesSW ("Attempting to read file `" ++ fname' ++ "'...\n") traceInfoParse = putTraceStr tracePhasesSW ("...parsing `" ++ fname ++ "'...\n") traceInfoNA = putTraceStr tracePhasesSW ("...name analysis of `" ++ fname ++ "'...\n") traceInfoErr = putTraceStr tracePhasesSW ("...error(s) detected in `" ++ fname ++ "'.\n") traceInfoOK = putTraceStr tracePhasesSW ("...successfully loaded `" ++ fname ++ "'.\n") c2hs-0.28.1/src/C2HS/config.c0000644000000000000000000000613512677513064013546 0ustar0000000000000000/* C -> Haskell Compiler: configuration query routines * * Author : Manuel M T Chakravarty * Created: 12 November 1 * * Copyright (c) [2001..2002] Manuel M T Chakravarty * * This file is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This file is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * DESCRIPTION --------------------------------------------------------------- * * Runtime configuration query functions * * TODO ---------------------------------------------------------------------- */ #include "config.h" /* compute the direction in which bitfields are growing * ==================================================== */ union bitfield_direction_union { unsigned int allbits; struct { unsigned int first_bit : 1; unsigned int second_bit : 1; } twobits; }; int bitfield_direction () { union bitfield_direction_union v; /* if setting the second bit in a bitfield makes the storeage unit contain * the value `2', the direction of bitfields must be increasing towards the * MSB */ v.allbits = 0; v.twobits.second_bit = 1; return (2 == v.allbits ? 1 : -1); } /* use padding for overspilling bitfields? * ======================================= */ union bitfield_padding_union { struct { unsigned int allbits1; unsigned int allbits2; } allbits; struct { unsigned int first_bit : 1; int full_unit : sizeof (int) * 8; } somebits; }; int bitfield_padding () { union bitfield_padding_union v; /* test whether more than one bit of `full_unit' spills over into `allbits2' */ v.allbits.allbits1 = 0; v.allbits.allbits2 = 0; v.somebits.full_unit = -1; return v.allbits.allbits2 == -1; } /* is an `int' bitfield signed? * ============================ */ union bitfield_int_signed_union { struct { unsigned int first_bit : 1; unsigned int second_bit : 1; } two_single_bits; struct { int two_bits : 2; } two_bits; }; int bitfield_int_signed () { union bitfield_int_signed_union v; /* check whether a two bit field with both bits set, gives us a negative * number; then, `int' bitfields must be signed */ v.two_single_bits.first_bit = 1; v.two_single_bits.second_bit = 1; return v.two_bits.two_bits == -1; } /* alignment constraint for bitfields * ================================== */ struct bitfield_alignment_struct { char start; unsigned int bit : 1; char end; }; int bitfield_alignment () { struct bitfield_alignment_struct v; return ((int) (&v.end - &v.start)) - 1; } c2hs-0.28.1/src/C2HS/CHS.hs0000644000000000000000000021054412677513064013107 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving #-} -- C->Haskell Compiler: CHS file abstraction -- -- Author : Manuel M T Chakravarty -- Created: 16 August 99 -- -- Copyright (c) [1999..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- Main file for reading CHS files. -- -- Import hooks & .chi files -- ------------------------- -- -- Reading of `.chi' files is interleaved with parsing. More precisely, -- whenever the parser comes across an import hook, it immediately reads the -- `.chi' file and inserts its contents into the abstract representation of -- the hook. The parser checks the version of the `.chi' file, but does not -- otherwise attempt to interpret its contents. This is only done during -- generation of the binding module. The first line of a .chi file has the -- form -- -- C->Haskell Interface Version -- -- where is the three component version number `Version.version'. -- C->Haskell will only accept files whose version number match its own in -- the first two components (ie, major and minor version). In other words, -- it must be guaranteed that the format of .chi files is not altered between -- versions that differ only in their patchlevel. All remaining lines of the -- file are version dependent and contain a dump of state information that -- the binding file generator needs to rescue across modules. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- The following binding hooks are recognised: -- -- hook -> `{#' inner `#}' -- inner -> `import' ['qualified'] ident -- | `context' ctxt -- | `type' ident -- | `sizeof' ident -- | `alignof' ident -- | `enum' idalias trans [`nocode'] [`with' prefix] [`add' prefix] [deriving] -- | `enum` `define` idalias [deriving] -- | `call' [`pure'] [`unsafe'] idalias -- | `fun' [`pure'] [`unsafe'] idalias parms -- | `get' [`struct'] apath -- | `set' [`struct'] apath -- | `offsetof` apath -- | `pointer' ['*'] idalias ptrkind ['nocode'] -- | `class' [ident `=>'] ident ident -- | `const' ident -- | `default' ident ident [dft ...] -- ctxt -> [`lib' `=' string] [prefix] -- idalias -> ident -- | looseident [`as' (ident | `^' | `'' ident1 ident2 ... `'')] -- prefix -> `prefix' `=' string [`add' `prefix' `=' string] -- deriving -> `deriving' `(' ident_1 `,' ... `,' ident_n `)' -- parms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm -- parm -> `+' -- | [ident_or_quot_1 [`*' | `-']] verbhs [`&'] [ident_or_quot_2 [`*'] [`-']] -- ident_or_quot -> ident | quoths -- apath -> ident -- | `*' apath -- | apath `.' ident -- | apath `->' ident -- trans -> `{' alias_1 `,' ... `,' alias_n `}' [omit] -- omit -> `omit' `(' ident_1 `,' ... `,' ident_n `)' -- alias -> `underscoreToCase' | `upcaseFirstLetter' -- | `downcaseFirstLetter' -- | ident `as' ident -- ptrkind -> [`foreign' [`finalizer' idalias] | `stable'] ['newtype' | '->' ident] -- dft -> dfttype `=` ident [`*'] -- dfttype -> `in' | `out' | `ptr_in' | `ptr_out' -- -- If `underscoreToCase', `upcaseFirstLetter', or `downcaseFirstLetter' -- occurs in a translation table, it must be the first entry, or if two of -- them occur the first two entries. -- -- Remark: Optional Haskell names are normalised during structure tree -- construction, ie, associations that associated a name with itself -- are removed. (They don't carry semantic content, and make some -- tests more complicated.) -- --- TODO ---------------------------------------------------------------------- -- module C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSChangeCase(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..), CHSTypedefInfo, CHSDefaultMarsh, Direction(..), CHSPlusParmType(..), loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI, chisuffix, showCHSParm, apathToIdent, apathRootIdent, hasNonGNU, isParmWrapped) where -- standard libraries import Data.Char (isSpace, toUpper, toLower) import Data.List (intersperse) import Control.Monad (when) import System.FilePath ((<.>), ()) -- Language.C import Language.C.Data.Ident import Language.C.Data.Position import Data.Errors (interr) -- C->Haskell import C2HS.State (CST, getSwitch, chiPathSB, catchExc, throwExc, raiseError, fatal, errorsPresent, showErrors, Traces(..), putTraceStr) import qualified System.CIO as CIO import C2HS.C.Info (CPrimType(..)) import C2HS.Version (version) -- friends import C2HS.CHS.Lexer (CHSToken(..), lexCHS, keywordToIdent) -- CHS abstract syntax -- ------------------- -- | representation of a CHS module -- data CHSModule = CHSModule [CHSFrag] deriving instance Show CHSModule deriving instance Show CHSFrag deriving instance Show CHSHook deriving instance Show CHSAccess deriving instance Show CHSPlusParmType deriving instance Show CHSParm deriving instance Show CHSTrans deriving instance Show CHSArg deriving instance Show CHSChangeCase -- | a CHS code fragament -- -- * 'CHSVerb' fragments are present throughout the compilation and finally -- they are the only type of fragment (describing the generated Haskell -- code) -- -- * 'CHSHook' are binding hooks, which are being replaced by Haskell code by -- 'GenBind.expandHooks' -- -- * 'CHSCPP' and 'CHSC' are fragements of C code that are being removed when -- generating the custom C header in 'GenHeader.genHeader' -- -- * 'CHSCond' are strutured conditionals that are being generated by -- 'GenHeader.genHeader' from conditional CPP directives ('CHSCPP') -- data CHSFrag = CHSVerb String -- Haskell code Position | CHSHook CHSHook -- binding hook Position | CHSCPP String -- pre-processor directive Position Bool | CHSLine Position -- line pragma | CHSC String -- C code Position | CHSCond [(Ident, -- C variable repr. condition [CHSFrag])] -- then/elif branches (Maybe [CHSFrag]) -- else branch hasNonGNU :: CHSModule -> Bool hasNonGNU (CHSModule frags) = any isNonGNU frags where isNonGNU (CHSHook (CHSNonGNU _) _) = True isNonGNU _ = False instance Pos CHSFrag where posOf (CHSVerb _ pos ) = pos posOf (CHSHook _ pos ) = pos posOf (CHSCPP _ pos _) = pos posOf (CHSLine pos ) = pos posOf (CHSC _ pos ) = pos posOf (CHSCond alts _ ) = case alts of (_, frag:_):_ -> posOf frag _ -> nopos -- | a CHS binding hook -- data CHSHook = CHSImport Bool -- qualified? Ident -- module name String -- content of .chi file Position | CHSContext (Maybe String) -- library name (Maybe String) -- prefix (Maybe String) -- replacement prefix Position | CHSNonGNU Position | CHSType Ident -- C type Position | CHSSizeof Ident -- C type Position | CHSAlignof Ident -- C type Position | CHSEnum Ident -- C enumeration type (Maybe Ident) -- Haskell name CHSTrans -- translation table Bool -- emit code or not? (Maybe String) -- local prefix (Maybe String) -- local replacement prefix [Ident] -- instance requests from user Position | CHSEnumDefine Ident -- Haskell name CHSTrans -- translation table [Ident] -- instance requests from user Position | CHSCall Bool -- is a pure function? Bool -- is unsafe? CHSAPath -- C function (Maybe Ident) -- Haskell name Position | CHSFun Bool -- is a pure function? Bool -- is unsafe? Bool -- is variadic? [String] -- variadic C parameter types CHSAPath -- C function (Maybe Ident) -- Haskell name (Maybe String) -- type context [CHSParm] -- argument marshalling CHSParm -- result marshalling Position | CHSField CHSAccess -- access type CHSAPath -- access path Position | CHSOffsetof CHSAPath -- access path Position | CHSPointer Bool -- explicit '*' in hook Ident -- C pointer name (Maybe Ident) -- Haskell name CHSPtrType -- Ptr, ForeignPtr or StablePtr Bool -- create new type? [Ident] -- Haskell type pointed to Bool -- emit type decl? Position | CHSClass (Maybe Ident) -- superclass Ident -- class name Ident -- name of pointer type Position | CHSConst Ident -- C identifier Position | CHSTypedef Ident -- C type name Ident -- Haskell type name Position | CHSDefault Direction -- in or out marshaller? String -- Haskell type name String -- C type string Bool -- is it a C pointer? (Either Ident String, CHSArg) -- marshaller Position data Direction = In | Out deriving (Eq, Ord, Show) instance Pos CHSHook where posOf (CHSImport _ _ _ pos) = pos posOf (CHSContext _ _ _ pos) = pos posOf (CHSType _ pos) = pos posOf (CHSSizeof _ pos) = pos posOf (CHSAlignof _ pos) = pos posOf (CHSEnum _ _ _ _ _ _ _ pos) = pos posOf (CHSEnumDefine _ _ _ pos) = pos posOf (CHSCall _ _ _ _ pos) = pos posOf (CHSFun _ _ _ _ _ _ _ _ _ pos) = pos posOf (CHSField _ _ pos) = pos posOf (CHSOffsetof _ pos) = pos posOf (CHSPointer _ _ _ _ _ _ _ pos) = pos posOf (CHSClass _ _ _ pos) = pos posOf (CHSConst _ pos) = pos posOf (CHSTypedef _ _ pos) = pos posOf (CHSDefault _ _ _ _ _ pos) = pos -- | two hooks are equal if they have the same Haskell name and reference the -- same C object -- instance Eq CHSHook where (CHSImport qual1 ide1 _ _) == (CHSImport qual2 ide2 _ _) = qual1 == qual2 && ide1 == ide2 (CHSContext olib1 opref1 orpref1 _) == (CHSContext olib2 opref2 orpref2 _) = olib1 == olib2 && opref1 == opref2 && orpref1 == orpref2 (CHSType ide1 _) == (CHSType ide2 _) = ide1 == ide2 (CHSSizeof ide1 _) == (CHSSizeof ide2 _) = ide1 == ide2 (CHSAlignof ide1 _) == (CHSAlignof ide2 _) = ide1 == ide2 (CHSEnum ide1 oalias1 _ _ _ _ _ _) == (CHSEnum ide2 oalias2 _ _ _ _ _ _) = oalias1 == oalias2 && ide1 == ide2 (CHSEnumDefine ide1 _ _ _) == (CHSEnumDefine ide2 _ _ _) = ide1 == ide2 (CHSCall _ _ ide1 oalias1 _) == (CHSCall _ _ ide2 oalias2 _) = oalias1 == oalias2 && ide1 == ide2 (CHSFun _ _ _ _ ide1 oalias1 _ _ _ _) == (CHSFun _ _ _ _ ide2 oalias2 _ _ _ _) = oalias1 == oalias2 && ide1 == ide2 (CHSField acc1 path1 _) == (CHSField acc2 path2 _) = acc1 == acc2 && path1 == path2 (CHSOffsetof path1 _) == (CHSOffsetof path2 _) = path1 == path2 (CHSPointer _ ide1 oalias1 _ _ _ _ _) == (CHSPointer _ ide2 oalias2 _ _ _ _ _) = ide1 == ide2 && oalias1 == oalias2 (CHSClass _ ide1 _ _) == (CHSClass _ ide2 _ _) = ide1 == ide2 (CHSConst ide1 _) == (CHSConst ide2 _) = ide1 == ide2 (CHSTypedef ide1 _ _) == (CHSTypedef ide2 _ _) = ide1 == ide2 (CHSDefault _ ide1 _ _ _ _) == (CHSDefault _ ide2 _ _ _ _) = ide1 == ide2 _ == _ = False -- | translation table -- data CHSTrans = CHSTrans Bool -- underscore to case? CHSChangeCase -- upcase or downcase? [(Ident, Ident)] -- alias list [Ident] -- omit list data CHSChangeCase = CHSSameCase | CHSUpCase | CHSDownCase deriving Eq -- | marshaller consists of a function name or verbatim Haskell code -- and flag indicating whether it has to be executed in the IO monad -- type CHSMarsh = Maybe (Either Ident String, CHSArg) -- | Type default information type CHSTypedefInfo = (Ident, CPrimType) -- | Type default information type CHSDefaultMarsh = (Either Ident String, CHSArg) -- | Special "+" parameter types. data CHSPlusParmType = CHSPlusBare | CHSPlusS | CHSPlusNum Int -- | marshalling descriptor for function hooks -- data CHSParm = CHSPlusParm CHSPlusParmType -- special "+" parameter | CHSParm CHSMarsh -- "in" marshaller String -- Haskell type Bool -- C repr: two values? CHSMarsh -- "out" marshaller Bool -- wrapped? Position String -- Comment for this para -- | Check whether parameter requires wrapping for bare structures. -- isParmWrapped :: CHSParm -> Bool isParmWrapped (CHSParm _ _ _ _ w _ _) = w isParmWrapped _ = False -- | kinds of arguments in function hooks -- data CHSArg = CHSValArg -- plain value argument | CHSIOArg -- reference argument | CHSVoidArg -- no argument | CHSIOVoidArg -- drops argument, but in monad deriving (Eq) -- | structure member access types -- data CHSAccess = CHSSet -- set structure field | CHSGet -- get structure field deriving (Eq) -- | structure access path -- data CHSAPath = CHSRoot Bool Ident -- root of access path with flag indicating presence -- of "struct" keyword | CHSDeref CHSAPath Position -- dereferencing | CHSRef CHSAPath Ident -- member referencing deriving (Eq,Show) instance Pos CHSAPath where posOf (CHSRoot _ ide) = posOf ide posOf (CHSDeref _ pos) = pos posOf (CHSRef _ ide) = posOf ide -- | pointer options -- data CHSPtrType = CHSPtr -- standard Ptr from Haskell | CHSForeignPtr (Maybe (Ident, Maybe Ident)) -- a foreign pointer possibly with a finalizer | CHSStablePtr -- a pointer into Haskell land deriving (Eq) instance Show CHSPtrType where show CHSPtr = "Ptr" show (CHSForeignPtr _) = "ForeignPtr" show CHSStablePtr = "StablePtr" instance Read CHSPtrType where readsPrec _ ( 'P':'t':'r':rest) = [(CHSPtr, rest)] readsPrec _ ('F':'o':'r':'e':'i':'g':'n':'P':'t':'r':rest) = [(CHSForeignPtr Nothing, rest)] readsPrec _ ('S':'t':'a':'b':'l':'e' :'P':'t':'r':rest) = [(CHSStablePtr, rest)] readsPrec p (c:cs) | isSpace c = readsPrec p cs readsPrec _ _ = [] -- load and dump a CHS file -- ------------------------ hssuffix, chssuffix :: String hssuffix = "hs" chssuffix = "chs" -- | load a CHS module -- -- * the file suffix is automagically appended -- -- * in case of a syntactical or lexical error, a fatal error is raised; -- warnings are returned together with the module -- loadCHS :: FilePath -> CST s (CHSModule, String) loadCHS fname = do let fullname = fname <.> chssuffix -- read file -- traceInfoRead fullname contents <- CIO.readFile fullname -- parse -- traceInfoParse mod' <- parseCHSModule (initPos fullname) contents -- check for errors and finalize -- errs <- errorsPresent if errs then do traceInfoErr errmsgs <- showErrors fatal ("CHS module contains \ \errors:\n\n" ++ errmsgs) -- fatal error else do traceInfoOK warnmsgs <- showErrors return (mod', warnmsgs) where traceInfoRead fname' = putTraceStr tracePhasesSW ("Attempting to read file `" ++ fname' ++ "'...\n") traceInfoParse = putTraceStr tracePhasesSW ("...parsing `" ++ fname ++ "'...\n") traceInfoErr = putTraceStr tracePhasesSW ("...error(s) detected in `" ++ fname ++ "'.\n") traceInfoOK = putTraceStr tracePhasesSW ("...successfully loaded `" ++ fname ++ "'.\n") -- | given a file name (no suffix) and a CHS module, the module is printed -- into that file -- -- * the module can be flagged as being pure Haskell -- -- * the correct suffix will automagically be appended -- dumpCHS :: String -> CHSModule -> Bool -> CST s () dumpCHS fname mod' pureHaskell = do let (suffix, kind) = if pureHaskell then (hssuffix , "(Haskell)") else (chssuffix, "(C->HS binding)") CIO.writeFile (fname <.> suffix) (contents version kind) where contents version' kind = "-- GENERATED by " ++ version' ++ " " ++ kind ++ "\n\ \-- Edit the ORIGNAL .chs file instead!\n\n" ++ showCHSModule mod' pureHaskell -- | to keep track of the current state of the line emission automaton -- data LineState = Emit -- emit LINE pragma if next frag is Haskell | Wait -- emit LINE pragma after the next '\n' | NoLine -- no pragma needed deriving (Eq) -- | convert a CHS module into a string -- -- * if the second argument is 'True', all fragments must contain Haskell code -- showCHSModule :: CHSModule -> Bool -> String showCHSModule (CHSModule fragments) pureHaskell = showFrags pureHaskell Emit fragments [] where -- the second argument indicates whether the next fragment (if it is -- Haskell code) should be preceded by a LINE pragma; in particular -- generated fragments and those following them need to be prefixed with a -- LINE pragma -- showFrags :: Bool -> LineState -> [CHSFrag] -> ShowS showFrags _ _ [] = id showFrags pureHs state (CHSVerb s pos : frags) = let (fname,line) = (posFile pos, posRow pos) generated = isBuiltinPos pos emitNow = state == Emit || (state == Wait && not (null s) && head s == '\n') nextState = if generated then Wait else NoLine in (if emitNow then showString ("\n{-# LINE " ++ show (line `max` 0) ++ " " ++ show fname ++ " #-}\n") else id) . showString s . showFrags pureHs nextState frags showFrags False _ (CHSHook hook _ : frags) = showString "{#" . showCHSHook hook . showString "#}" . showFrags False Wait frags showFrags False _ (CHSCPP s _ nl : frags) = (if nl then showChar '\n' else id) . showChar '#' . showString s . showFrags False Emit frags showFrags pureHs _ (CHSLine _s : frags) = showFrags pureHs Emit frags showFrags False _ (CHSC s _ : frags) = showString "\n#c" . showString s . showString "\n#endc" . showFrags False Emit frags showFrags False _ (CHSCond _ _ : _ ) = interr "showCHSFrag: Cannot print `CHSCond'!" showFrags True _ _ = interr "showCHSFrag: Illegal hook, cpp directive, or inline C code!" showCHSHook :: CHSHook -> ShowS showCHSHook (CHSImport isQual ide _ _) = showString "import " . (if isQual then showString "qualified " else id) . showCHSIdent ide showCHSHook (CHSContext olib oprefix oreplprefix _) = showString "context " . (case olib of Nothing -> showString "" Just lib -> showString "lib = " . showString lib . showString " ") . showPrefix oprefix False . showReplacementPrefix oreplprefix showCHSHook (CHSType ide _) = showString "type " . showCHSIdent ide showCHSHook (CHSSizeof ide _) = showString "sizeof " . showCHSIdent ide showCHSHook (CHSAlignof ide _) = showString "alignof " . showCHSIdent ide showCHSHook (CHSEnum ide oalias trans emit oprefix oreplprefix derive _) = showString "enum " . showIdAlias ide oalias . showCHSTrans trans . (case emit of True -> showString "" False -> showString " nocode") . showPrefix oprefix True . showReplacementPrefix oreplprefix . if null derive then id else showString $ " deriving (" ++ concat (intersperse ", " (map identToString derive)) ++ ") " showCHSHook (CHSEnumDefine ide trans derive _) = showString "enum define " . showCHSIdent ide . showCHSTrans trans . if null derive then id else showString $ " deriving (" ++ concat (intersperse ", " (map identToString derive)) ++ ") " showCHSHook (CHSCall isPure isUns ide oalias _) = showString "call " . (if isPure then showString "pure " else id) . (if isUns then showString "unsafe " else id) . showApAlias ide oalias showCHSHook (CHSFun isPure isUns isVar varTypes ide oalias octxt parms parm _) = showString "fun " . (if isPure then showString "pure " else id) . (if isUns then showString "unsafe " else id) . (if isVar then showString "variadic " else id) . showFunAlias ide varTypes oalias . (case octxt of Nothing -> showChar ' ' Just ctxtStr -> showString ctxtStr . showString " => ") . showString "{" . foldr (.) id (intersperse (showString ", ") (map showCHSParm parms)) . showString "} -> " . showCHSParm parm showCHSHook (CHSField acc path _) = (case acc of CHSGet -> showString "get " CHSSet -> showString "set ") . showCHSAPath path showCHSHook (CHSOffsetof path _) = showString "offsetof " . showCHSAPath path showCHSHook (CHSPointer star ide oalias ptrType isNewtype oRefType emit _) = showString "pointer " . (if star then showString "*" else showString "") . showIdAlias ide oalias . (case ptrType of CHSForeignPtr Nothing -> showString " foreign" CHSForeignPtr (Just (fide, foalias)) -> showString " foreign finalizer " . showIdAlias fide foalias CHSStablePtr -> showString " stable" _ -> showString "") . (case (isNewtype, oRefType) of (True , _ ) -> showString " newtype" (False, [] ) -> showString "" (False, ides) -> showString " -> " . foldr (.) id (intersperse (showString " ") (map showCHSIdent ides))) . (case emit of True -> showString "" False -> showString " nocode") showCHSHook (CHSClass oclassIde classIde typeIde _) = showString "class " . (case oclassIde of Nothing -> showString "" Just classIde' -> showCHSIdent classIde' . showString " => ") . showCHSIdent classIde . showString " " . showCHSIdent typeIde showCHSHook (CHSConst constIde _) = showString "const " . showCHSIdent constIde showCHSHook (CHSTypedef cIde hsIde _) = showString "typedef " . showCHSIdent cIde . showCHSIdent hsIde showCHSHook (CHSDefault dir hsTy cTy cPtr marsh _) = showString "default " . showString (if dir == In then "in" else "out") . showChar '`' . showString hsTy . showChar '\'' . showChar '[' . showString cTy . showString (if cPtr then " *" else "") . showChar ']' . showMarsh marsh where showMarsh (Left ide, arg) = showCHSIdent ide . showArg arg showMarsh (Right s, arg) = showString s . showArg arg showArg CHSIOArg = showString "*" showArg _ = showString "" showPrefix :: Maybe String -> Bool -> ShowS showPrefix Nothing _ = showString "" showPrefix (Just prefix) withWith = maybeWith . showString "prefix = " . showString prefix . showString " " where maybeWith = if withWith then showString "with " else id showReplacementPrefix :: Maybe String -> ShowS showReplacementPrefix Nothing = showString "" showReplacementPrefix (Just prefix) = showString "add prefix = " . showString prefix . showString " " showIdAlias :: Ident -> Maybe Ident -> ShowS showIdAlias ide oalias = showCHSIdent ide . (case oalias of Nothing -> id Just ide' -> showString " as " . showCHSIdent ide') showApAlias :: CHSAPath -> Maybe Ident -> ShowS showApAlias apath oalias = showCHSAPath apath . (case oalias of Nothing -> id Just ide -> showString " as " . showCHSIdent ide) showFunAlias :: CHSAPath -> [String] -> Maybe Ident -> ShowS showFunAlias apath vas oalias = showCHSAPath apath . (if null vas then showString "" else showString "[" . foldr (.) id (intersperse (showString ", ") (map showString vas)) . showString "]") . (case oalias of Nothing -> id Just ide -> showString " as " . showCHSIdent ide) showCHSParm :: CHSParm -> ShowS showCHSParm (CHSPlusParm CHSPlusBare) = showChar '+' showCHSParm (CHSPlusParm CHSPlusS) = showString "+S" showCHSParm (CHSPlusParm (CHSPlusNum sz)) = showChar '+' . showString (show sz) showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh wrapped _ comment) = showOMarsh oimMarsh . showChar ' ' . (if wrapped then showChar '%' else id) . showHsVerb hsTyStr . (if twoCVals then showChar '&' else id) . showChar ' ' . showOMarsh oomMarsh . showChar ' ' . showComment comment where showOMarsh Nothing = id showOMarsh (Just (body, argKind)) = showMarshBody body . (case argKind of CHSValArg -> id CHSIOArg -> showString "*" CHSVoidArg -> showString "-" CHSIOVoidArg -> showString "*-") -- showMarshBody (Left ide) = showCHSIdent ide showMarshBody (Right str) = showChar '|' . showString str . showChar '|' -- showHsVerb str = showChar '`' . showString str . showChar '\'' showComment str = if null str then showString "" else showString "--" . showString str . showChar '\n' showCHSTrans :: CHSTrans -> ShowS showCHSTrans (CHSTrans _2Case chgCase assocs omit) = showString " {" . (if _2Case then showString ("underscoreToCase" ++ maybeComma) else id) . showCHSChangeCase chgCase . foldr (.) id (intersperse (showString ", ") (map showAssoc assocs)) . showString "}" . (if not (null omit) then showString " omit (" . foldr (.) id (intersperse (showString ", ") (map showCHSIdent omit)) . showString ")" else id) where maybeComma = if null assocs then "" else ", " -- showAssoc (ide1, ide2) = showCHSIdent ide1 . showString " as " . showCHSIdent ide2 showCHSChangeCase :: CHSChangeCase -> ShowS showCHSChangeCase CHSSameCase = id showCHSChangeCase CHSUpCase = showString "upcaseFirstLetter" showCHSChangeCase CHSDownCase = showString "downcaseFirstLetter" showCHSAPath :: CHSAPath -> ShowS showCHSAPath (CHSRoot True ide) = showString "struct " . showCHSIdent ide showCHSAPath (CHSRoot False ide) = showCHSIdent ide showCHSAPath (CHSDeref path _) = showString "* " . showCHSAPath path showCHSAPath (CHSRef (CHSDeref path _) ide) = showCHSAPath path . showString "->" . showCHSIdent ide showCHSAPath (CHSRef path ide) = showCHSAPath path . showString "." . showCHSIdent ide showCHSIdent :: Ident -> ShowS showCHSIdent ide = showString $ let s = identToString ide in case ' ' `elem` s of False -> s True -> "'" ++ s ++ "'" -- load and dump a CHI file -- ------------------------ chisuffix :: String chisuffix = "chi" versionPrefix :: String versionPrefix = "C->Haskell Interface Version " -- | load a CHI file -- -- * the file suffix is automagically appended -- -- * any error raises a syntax exception (see below) -- -- * the version of the .chi file is checked against the version of the current -- executable; they must match in the major and minor version -- loadCHI :: FilePath -> CST s String loadCHI fname = do -- search for .chi files -- paths <- getSwitch chiPathSB let fullnames = [path fname <.> chisuffix | path <- paths] fullname <- findFirst fullnames (fatal $ fname <.> chisuffix ++ " not found in:\n"++ unlines paths) -- read file -- traceInfoRead fullname contents <- CIO.readFile fullname -- parse -- traceInfoVersion let ls = lines contents when (null ls) $ errorCHICorrupt fname let versline:chi = ls prefixLen = length versionPrefix when (length versline < prefixLen || take prefixLen versline /= versionPrefix) $ errorCHICorrupt fname let versline' = drop prefixLen versline (major, minor) <- case majorMinor versline' of Nothing -> errorCHICorrupt fname Just majMin -> return majMin let Just (myMajor, myMinor) = majorMinor version when (major /= myMajor || minor /= myMinor) $ errorCHIVersion fname (major ++ "." ++ minor) (myMajor ++ "." ++ myMinor) -- finalize -- traceInfoOK return $ concat chi where traceInfoRead fname' = putTraceStr tracePhasesSW ("Attempting to read file `" ++ fname' ++ "'...\n") traceInfoVersion = putTraceStr tracePhasesSW ("...checking version `" ++ fname ++ "'...\n") traceInfoOK = putTraceStr tracePhasesSW ("...successfully loaded `" ++ fname ++ "'.\n") findFirst [] err = err findFirst (p:aths) err = do e <- CIO.doesFileExist p if e then return p else findFirst aths err -- | given a file name (no suffix) and a CHI file, the information is printed -- into that file -- -- * the correct suffix will automagically be appended -- dumpCHI :: String -> String -> CST s () dumpCHI fname contents = do CIO.writeFile (fname <.> chisuffix) $ versionPrefix ++ version ++ "\n" ++ contents -- | extract major and minor number from a version string -- majorMinor :: String -> Maybe (String, String) majorMinor vers = let (major, rest) = break (== '.') vers (minor, _ ) = break (== '.') . tail $ rest in if null rest then Nothing else Just (major, minor) -- parsing a CHS token stream -- -------------------------- syntaxExc :: String syntaxExc = "syntax" -- | alternative action in case of a syntax exception -- ifError :: CST s a -> CST s a -> CST s a ifError action handler = action `catchExc` (syntaxExc, const handler) -- | raise syntax error exception -- raiseSyntaxError :: CST s a raiseSyntaxError = throwExc syntaxExc "syntax error" -- | parse a complete module -- -- * errors are entered into the compiler state -- parseCHSModule :: Position -> String -> CST s CHSModule parseCHSModule pos cs = do toks <- lexCHS cs pos frags <- parseFrags toks return $ CHSModule frags -- | parsing of code fragments -- -- * in case of an error, all tokens that are neither Haskell nor control -- tokens are skipped; afterwards parsing continues -- -- * when encountering inline-C code we scan forward over all inline-C and -- control tokens to avoid turning the control tokens within a sequence of -- inline-C into Haskell fragments -- parseFrags :: [CHSToken] -> CST s [CHSFrag] parseFrags tokens = do parseFrags0 tokens `ifError` contFrags tokens where parseFrags0 :: [CHSToken] -> CST s [CHSFrag] parseFrags0 [] = return [] parseFrags0 (CHSTokHaskell pos s:toks) = do frags <- parseFrags toks return $ CHSVerb s pos : frags parseFrags0 (CHSTokCtrl pos c:toks) = do frags <- parseFrags toks return $ CHSVerb [c] pos : frags parseFrags0 (CHSTokCPP pos s nl:toks) = do frags <- parseFrags toks return $ CHSCPP s pos nl : frags parseFrags0 (CHSTokLine pos :toks) = do frags <- parseFrags toks return $ CHSLine pos : frags parseFrags0 (CHSTokC pos s:toks) = parseC pos s toks parseFrags0 (CHSTokHook hkpos: CHSTokImport pos :toks) = parseImport hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokContext pos :toks) = parseContext hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokNonGNU pos :toks) = parseNonGNU hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokType pos :toks) = parseType hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokSizeof pos :toks) = parseSizeof hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokAlignof pos :toks) = parseAlignof hkpos pos (removeCommentInHook toks) -- TODO: issue 70, add haddock support for enum hook parseFrags0 (CHSTokHook hkpos: CHSTokEnum pos :toks) = parseEnum hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokCall pos :toks) = parseCall hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokFun pos :toks) = parseFun hkpos pos toks parseFrags0 (CHSTokHook hkpos: CHSTokGet pos :toks) = parseField hkpos pos CHSGet (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokSet pos :toks) = parseField hkpos pos CHSSet (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokOffsetof pos :toks) = parseOffsetof hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokClass pos :toks) = parseClass hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokConst pos :toks) = parseConst hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokTypedef pos :toks) = parseTypedef hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokDefault pos :toks) = parseDefault hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: CHSTokPointer pos :toks) = parsePointer hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook _ :toks) = syntaxError toks parseFrags0 toks = syntaxError toks -- -- skip to next Haskell or control token -- contFrags [] = return [] contFrags toks@(CHSTokHaskell _ _:_ ) = parseFrags toks contFrags toks@(CHSTokCtrl _ _:_ ) = parseFrags toks contFrags (_ :toks) = contFrags toks -- -- Only keep comment in fun hook -- isComment (CHSTokComment _ _) = True isComment _ = False isEndHook (CHSTokEndHook _) = True isEndHook _ = False removeCommentInHook xs = let (lhs,rhs) = span (not . isEndHook) xs in filter (not . isComment) lhs ++ rhs parseC :: Position -> String -> [CHSToken] -> CST s [CHSFrag] parseC pos s toks = do frags <- collectCtrlAndC toks return $ CHSC s pos : frags where collectCtrlAndC (CHSTokCtrl pos' c :toks') = do frags <- collectCtrlAndC toks' return $ CHSC [c] pos' : frags collectCtrlAndC (CHSTokC pos' s':toks') = do frags <- collectCtrlAndC toks' return $ CHSC s' pos' : frags collectCtrlAndC toks' = parseFrags toks' parseImport :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseImport hkpos pos toks = do (qual, modid, toks') <- case toks of CHSTokIdent _ ide :toks' -> let (ide', toks'') = rebuildModuleId ide toks' in return (False, ide', toks'') CHSTokQualif _: CHSTokIdent _ ide:toks' -> let (ide', toks'') = rebuildModuleId ide toks' in return (True , ide', toks'') _ -> syntaxError toks chi <- loadCHI . moduleNameToFileName . identToString $ modid toks'2 <- parseEndHook toks' frags <- parseFrags toks'2 return $ CHSHook (CHSImport qual modid chi pos) hkpos : frags -- | Qualified module names do not get lexed as a single token so we need to -- reconstruct it from a sequence of identifer and dot tokens. -- rebuildModuleId :: Ident -> [CHSToken] -> (Ident, [CHSToken]) rebuildModuleId ide (CHSTokDot _ : CHSTokIdent _ ide' : toks) = let catIdent ide'3 ide'4 = internalIdentAt (posOf ide'3) --FIXME: unpleasant hack (identToString ide'3 ++ '.' : identToString ide'4) in rebuildModuleId (catIdent ide ide') toks rebuildModuleId ide toks = (ide, toks) moduleNameToFileName :: String -> FilePath moduleNameToFileName = map dotToSlash where dotToSlash '.' = '/' dotToSlash c = c parseContext :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseContext hkpos pos toks = do (olib , toks2) <- parseOptLib toks (opref , toks3) <- parseOptPrefix False toks2 (oreppref, toks4) <- parseOptReplPrefix toks3 toks5 <- parseEndHook toks4 frags <- parseFrags toks5 let frag = CHSContext olib opref oreppref pos return $ CHSHook frag hkpos : frags parseNonGNU :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseNonGNU hkpos pos toks = do toks2 <- parseEndHook toks frags <- parseFrags toks2 let frag = CHSNonGNU pos return $ CHSHook frag hkpos : frags parseType :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseType hkpos pos (CHSTokIdent _ ide:toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSType ide pos) hkpos : frags parseType _ _ toks = syntaxError toks parseSizeof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseSizeof hkpos pos (CHSTokIdent _ ide:toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSSizeof ide pos) hkpos : frags parseSizeof _ _ toks = syntaxError toks parseAlignof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseAlignof hkpos pos (CHSTokIdent _ ide:toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSAlignof ide pos) hkpos : frags parseAlignof _ _ toks = syntaxError toks parseEnum :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] -- {#enum define hsid {alias_1,...,alias_n} [deriving (clid_1,...,clid_n)] #} parseEnum hkpos pos (CHSTokIdent _ def: CHSTokIdent _ hsid: toks) | identToString def == "define" = do (trans , toks') <- parseTrans toks (derive, toks'') <- parseDerive toks' toks''' <- parseEndHook toks'' frags <- parseFrags toks''' return $ CHSHook (CHSEnumDefine hsid trans derive pos) hkpos : frags -- {#enum cid [as hsid] {alias_1,...,alias_n} [with prefix = pref] [deriving (clid_1,...,clid_n)] #} parseEnum hkpos pos (CHSTokIdent _ ide:toks) = do (oalias, toks2) <- parseOptAs ide True toks (emit, toks3) <- parseOptNoCode toks2 (trans, toks4) <- parseTrans toks3 (oprefix, toks5) <- parseOptPrefix True toks4 (oreplprefix, toks6) <- parseOptReplPrefix toks5 (derive, toks7) <- parseDerive toks6 toks8 <- parseEndHook toks7 frags <- parseFrags toks8 return $ CHSHook (CHSEnum ide (norm oalias) trans emit oprefix oreplprefix derive pos) hkpos : frags where norm Nothing = Nothing norm (Just ide') | ide == ide' = Nothing | otherwise = Just ide' parseEnum _ _ toks = syntaxError toks parseOptNoCode :: [CHSToken] -> CST s (Bool, [CHSToken]) parseOptNoCode (CHSTokNocode _ :toks) = return (False, toks) parseOptNoCode toks = return (True, toks) parseCall :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseCall hkpos pos toks = do (isPure , toks' ) <- parseIsPure toks (isUnsafe, toks'' ) <- parseIsUnsafe toks' (apath , toks''' ) <- parsePath toks'' (oalias , toks'''') <- parseOptAs (apathToIdent apath) False toks''' toks''''' <- parseEndHook toks'''' frags <- parseFrags toks''''' return $ CHSHook (CHSCall isPure isUnsafe apath oalias pos) hkpos : frags parseFun :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseFun hkpos pos inputToks = do (isPure , toks' ) <- parseIsPure toks (isUnsafe, toks'2) <- parseIsUnsafe toks' (isVar, toks'3) <- parseIsVariadic toks'2 (apath , toks'4) <- parsePath toks'3 (varTypes, toks'5) <- parseVarTypes toks'4 (oalias , toks'6) <- parseOptAs (apathToIdent apath) False toks'5 (octxt , toks'7) <- parseOptContext toks'6 (parms , toks'8) <- parseParms toks'7 (parm , toks'9) <- parseParm toks'8 when (isParmWrapped parm) $ errorOutWrap $ head toks'8 toks'10 <- parseEndHook toks'9 frags <- parseFrags toks'10 return $ CHSHook (CHSFun isPure isUnsafe isVar varTypes apath oalias octxt parms parm pos) hkpos : frags where toks = removeIllPositionedComment inputToks parseOptContext (CHSTokHSVerb _ ctxt:CHSTokDArrow _:toks') = return (Just ctxt, toks') parseOptContext toks' = return (Nothing , toks') -- parseVarTypes (CHSTokLBrack _:CHSTokCArg _ t:toks') = do (ts, toks'2) <- parseVarTypes' toks' return (t:ts, toks'2) parseVarTypes toks' = return ([], toks') parseVarTypes' (CHSTokRBrack _:toks') = return ([], toks') parseVarTypes' (CHSTokComma _:CHSTokCArg _ t:toks') = do (ts, toks'2) <- parseVarTypes' toks' return (t:ts, toks'2) -- parseParms (CHSTokLBrace _:CHSTokRBrace _:CHSTokArrow _:toks') = return ([], toks') parseParms (CHSTokLBrace _ :toks') = parseParms' (CHSTokComma nopos:toks') parseParms toks' = syntaxError toks' -- parseParms' (CHSTokRBrace _:CHSTokArrow _:toks') = return ([], toks') parseParms' (CHSTokComma _:CHSTokComment _ _:toks') = do (parm , toks'2 ) <- parseParm toks' (parms, toks'3) <- parseParms' toks'2 return (parm:parms, toks'3) parseParms' (CHSTokComma _ :toks') = do (parm , toks'2 ) <- parseParm toks' (parms, toks'3) <- parseParms' toks'2 return (parm:parms, toks'3) parseParms' (CHSTokRBrace _ :toks') = syntaxError toks' -- gives better error messages parseParms' toks' = syntaxError toks' -- isComment (CHSTokComment _ _) = True isComment _ = False isLBrace (CHSTokLBrace _) = True isLBrace _ = False isRBrace (CHSTokRBrace _) = True isRBrace _ = False isHSVerb (CHSTokHSVerb _ _) = True isHSVerb _ = False -- remove comment(s) between -- 1. {# and { -- 2. } and `ResultType' removeIllPositionedComment xs = let (lhs,rhs) = span (not . isLBrace) xs (lhs',rhs') = span (not . isRBrace) rhs (lhs'2,rhs'2) = span (not . isHSVerb) rhs' in filter (not . isComment) lhs ++ lhs' ++ (filter (not . isComment) lhs'2) ++ rhs'2 parseIsPure :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsPure (CHSTokPure _:toks) = return (True , toks) parseIsPure (CHSTokFun _:toks) = return (True , toks) -- backwards compat. parseIsPure toks = return (False, toks) -- FIXME: eventually, remove `fun'; it's currently deprecated parseIsUnsafe :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsUnsafe (CHSTokUnsafe _:toks) = return (True , toks) parseIsUnsafe toks = return (False, toks) parseIsVariadic :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsVariadic (CHSTokVariadic _:toks) = return (True , toks) parseIsVariadic toks = return (False, toks) apathToIdent :: CHSAPath -> Ident apathToIdent (CHSRoot _ ide) = let lowerFirst (c:cs) = toLower c : cs in internalIdentAt (posOf ide) (lowerFirst $ identToString ide) apathToIdent (CHSDeref apath _) = let ide = apathToIdent apath in internalIdentAt (posOf ide) (identToString ide ++ "_") apathToIdent (CHSRef apath ide') = let ide = apathToIdent apath upperFirst (c:cs) = toLower c : cs sel = upperFirst $ identToString ide' in internalIdentAt (posOf ide) (identToString ide ++ sel) apathRootIdent :: CHSAPath -> Ident apathRootIdent (CHSRoot _ ide) = ide apathRootIdent (CHSDeref apath _) = apathRootIdent apath apathRootIdent (CHSRef apath _) = apathRootIdent apath parseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken]) parseParm (CHSTokPlus _:toks') = return (CHSPlusParm CHSPlusBare, toks') parseParm (CHSTokPlusS _:toks') = return (CHSPlusParm CHSPlusS, toks') parseParm (CHSTokPlusNum _ sz:toks') = return (CHSPlusParm (CHSPlusNum sz), toks') parseParm toks = do (oimMarsh, toks' ) <- parseOptMarsh toks let (wrapped, toks'') = case toks' of (CHSTokPercent _:tokstmp) -> (True, tokstmp) _ -> (False, toks') (hsTyStr, twoCVals, pos, toks'2) <- case toks'' of (CHSTokHSVerb pos hsTyStr:CHSTokAmp _:toks'2) -> return (hsTyStr, True , pos, toks'2) (CHSTokHSVerb pos hsTyStr :toks'2) -> return (hsTyStr, False, pos, toks'2) _toks -> syntaxError toks'' (oomMarsh, toks'3) <- parseOptMarsh toks'2 (comments, toks'4) <- parseOptComments toks'3 return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh wrapped pos (concat (intersperse " " comments)), toks'4) where parseOptMarsh :: [CHSToken] -> CST s (CHSMarsh, [CHSToken]) parseOptMarsh (CHSTokIdent _ ide:toks') = do (marshType, toks'2) <- parseOptMarshType toks' return (Just (Left ide, marshType), toks'2) parseOptMarsh (CHSTokHSQuot _ str:toks') = do (marshType, toks'2) <- parseOptMarshType toks' return (Just (Right str, marshType), toks'2) parseOptMarsh (CHSTokWith _ ide:toks') = do (marshType, toks'2) <- parseOptMarshType toks' return (Just (Left ide, marshType), toks'2) parseOptMarsh toks' = return (Nothing, toks') parseOptMarshType (CHSTokStar _ :CHSTokMinus _:toks') = return (CHSIOVoidArg , toks') parseOptMarshType (CHSTokStar _ :toks') = return (CHSIOArg , toks') parseOptMarshType (CHSTokMinus _:toks') = return (CHSVoidArg, toks') parseOptMarshType toks' = return (CHSValArg, toks') parseOptComments :: [CHSToken] -> CST s ([String], [CHSToken]) parseOptComments = go [] where go acc (CHSTokComment _ s:toks) = go (s:acc) toks go acc _toks = return (reverse acc,_toks) parseField :: Position -> Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag] parseField hkpos pos access toks = do (path, toks') <- parsePath toks toks'' <- parseEndHook toks' frags <- parseFrags toks'' return $ CHSHook (CHSField access path pos) hkpos : frags parseOffsetof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseOffsetof hkpos pos toks = do (path, toks') <- parsePath toks toks'' <- parseEndHook toks' frags <- parseFrags toks'' return $ CHSHook (CHSOffsetof path pos) hkpos : frags parsePointer :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parsePointer hkpos pos toks = do (isStar, ide, toks') <- case toks of CHSTokStar _:CHSTokIdent _ ide:toks' -> return (True , ide, toks') CHSTokIdent _ ide :toks' -> return (False, ide, toks') _ -> syntaxError toks (oalias , toks'2) <- parseOptAs ide True toks' (ptrType, toks'3) <- parsePtrType toks'2 let (isNewtype, oRefType, toks'4) = case toks'3 of CHSTokNewtype _ :toks'' -> (True , [] , toks'' ) CHSTokArrow _:CHSTokIdent _ ide':toks'' -> let (ides, toks''') = span isIde toks'' isIde (CHSTokIdent _ _) = True isIde _ = False takeId (CHSTokIdent _ i) = i in (False, ide':map takeId ides, toks''') CHSTokArrow _:CHSTokHSVerb _ hs:toks'' -> (False, map internalIdent $ words hs, toks'') _ -> (False, [] , toks'3) let (emit, toks'5) = case toks'4 of CHSTokNocode _ :toks'' -> (False, toks'' ) _ -> (True , toks'4 ) toks'6 <- parseEndHook toks'5 frags <- parseFrags toks'6 return $ CHSHook (CHSPointer isStar ide (norm ide oalias) ptrType isNewtype oRefType emit pos) hkpos : frags where parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken]) parsePtrType (CHSTokForeign _:toks') = do (final, toks'') <- parseFinalizer toks' return (CHSForeignPtr final, toks'') parsePtrType (CHSTokStable _ :toks') = return (CHSStablePtr, toks') parsePtrType toks' = return (CHSPtr, toks') parseFinalizer (CHSTokFinal _ : CHSTokIdent _ ide : toks') = do (oalias, toks'') <- parseOptAs ide False toks' return (Just (ide, oalias), toks'') parseFinalizer toks' = return (Nothing, toks') norm _ Nothing = Nothing norm ide (Just ide') | ide == ide' = Nothing | otherwise = Just ide' parseClass :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseClass hkpos pos (CHSTokIdent _ sclassIde: CHSTokDArrow _ : CHSTokIdent _ classIde : CHSTokIdent _ typeIde : toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSClass (Just sclassIde) classIde typeIde pos) hkpos : frags parseClass hkpos pos (CHSTokIdent _ classIde : CHSTokIdent _ typeIde : toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSClass Nothing classIde typeIde pos) hkpos : frags parseClass _ _ toks = syntaxError toks parseConst :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseConst hkpos pos (CHSTokIdent _ constIde : toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSConst constIde pos) hkpos : frags parseConst _ _ toks = syntaxError toks parseTypedef :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseTypedef hkpos pos (CHSTokIdent _ cIde : CHSTokIdent _ hsIde : CHSTokEndHook _ : toks) = do frags <- parseFrags toks return $ CHSHook (CHSTypedef cIde hsIde pos) hkpos : frags parseTypedef _ _ toks = syntaxError toks parseDefault :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseDefault hkpos pos toks@(dirtok : CHSTokHSVerb _ hsTy : CHSTokLBrack _ : CHSTokCArg _ cTyIn : CHSTokRBrack _ : toks1) = do dir <- case dirtok of CHSTokIn _ -> return In CHSTokOut _ -> return Out _ -> syntaxError toks (marsh, toks2) <- parseMarshaller toks1 let trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace cTy' = trim cTyIn (cTy, cPtr) = if last cTy' == '*' then (trim $ init cTy', True) else (cTy', False) toks3 <- parseEndHook toks2 frags <- parseFrags toks3 return $ CHSHook (CHSDefault dir hsTy cTy cPtr marsh pos) hkpos : frags where parseMarshaller :: [CHSToken] -> CST s ((Either Ident String, CHSArg), [CHSToken]) parseMarshaller (CHSTokIdent _ mide : toks') = do (hasStar, toks'') <- parseOptStar toks' let argtype = if hasStar then CHSIOArg else CHSValArg return ((Left mide, argtype), toks'') parseMarshaller toks' = syntaxError toks' parseDefault _ _ toks = syntaxError toks parseOptStar :: [CHSToken] -> CST s (Bool, [CHSToken]) parseOptStar (CHSTokStar _ : toks) = return (True, toks) parseOptStar toks = return (False, toks) parseOptLib :: [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptLib (CHSTokLib _ : CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks) parseOptLib (CHSTokLib _:toks ) = syntaxError toks parseOptLib toks = return (Nothing, toks) parseOptPrefix :: Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptPrefix False (CHSTokPrefix _ : CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks) parseOptPrefix True (CHSTokWith _ _ : CHSTokPrefix _ : CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks) parseOptPrefix _ (CHSTokWith _ _:toks) = syntaxError toks parseOptPrefix _ (CHSTokPrefix _:toks) = syntaxError toks parseOptPrefix _ toks = return (Nothing, toks) parseOptReplPrefix :: [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptReplPrefix (CHSTokAdd _ : CHSTokPrefix _ : CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks) parseOptReplPrefix (CHSTokAdd _:toks) = syntaxError toks parseOptReplPrefix (CHSTokPrefix _:toks) = syntaxError toks parseOptReplPrefix toks = return (Nothing, toks) -- first argument is the identifier that is to be used when `^' is given and -- the second indicates whether the first character has to be upper case -- parseOptAs :: Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken]) parseOptAs _ _ (CHSTokAs _:CHSTokIdent _ ide:toks) = return (Just ide, toks) parseOptAs _ _ (CHSTokAs _:CHSTokHSQuot pos ide:toks) = return (Just $ internalIdentAt pos ide, toks) parseOptAs ide upper (CHSTokAs _:CHSTokHat pos :toks) = return (Just $ underscoreToCase ide upper pos, toks) parseOptAs _ _ (CHSTokAs _ :toks) = syntaxError toks parseOptAs _ _ toks = return (Nothing, toks) -- | convert C style identifier to Haskell style identifier -- underscoreToCase :: Ident -> Bool -> Position -> Ident underscoreToCase ide upper pos = let lexeme = identToString ide ps = filter (not . null) . parts $ lexeme in internalIdentAt pos . adjustHead . concat . map adjustCase $ ps where parts s = let (l, s') = break (== '_') s in l : case s' of [] -> [] (_:s'') -> parts s'' -- adjustCase "" = "" adjustCase (c:cs) = toUpper c : cs -- adjustHead "" = "" adjustHead (c:cs) = if upper then toUpper c : cs else toLower c:cs -- | this is disambiguated and left factored -- parsePath :: [CHSToken] -> CST s (CHSAPath, [CHSToken]) parsePath (CHSTokLParen _pos: toks) = do (inner_path, toks_rest) <- parsePath toks toks_rest' <- case toks_rest of (CHSTokRParen _pos' : ts) -> return ts _ -> syntaxError toks_rest (pathWithHole, toks') <- parsePath' toks_rest' return (pathWithHole inner_path, toks') parsePath (CHSTokStar pos:toks) = do (path, toks') <- parsePath toks return (CHSDeref path pos, toks') parsePath (CHSTokStruct _pos:tok:toks) = case keywordToIdent tok of (CHSTokIdent _ ide) -> do (pathWithHole, toks') <- parsePath' toks return (pathWithHole (CHSRoot True ide), toks') _ -> syntaxError (tok:toks) parsePath (tok:toks) = case keywordToIdent tok of (CHSTokIdent _ ide) -> do (pathWithHole, toks') <- parsePath' toks return (pathWithHole (CHSRoot False ide), toks') _ -> syntaxError (tok:toks) parsePath toks = syntaxError toks -- | @s->m@ is represented by @(*s).m@ in the tree -- parsePath' :: [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken]) parsePath' tokens@(CHSTokDot _:desig:toks) = do ide <- case keywordToIdent desig of CHSTokIdent _ i -> return i; _ -> syntaxError tokens (pathWithHole, toks') <- parsePath' toks return (pathWithHole . (\hole -> CHSRef hole ide), toks') parsePath' tokens@(CHSTokArrow pos:desig:toks) = do ide <- case keywordToIdent desig of CHSTokIdent _ i -> return i; _ -> syntaxError tokens (pathWithHole, toks') <- parsePath' toks return (pathWithHole . (\hole -> CHSRef (CHSDeref hole pos) ide), toks') parsePath' toks = return (id,toks) parseTrans :: [CHSToken] -> CST s (CHSTrans, [CHSToken]) parseTrans (CHSTokLBrace _:toks) = do (_2Case, chgCase, toks' ) <- parse_2CaseAndChange toks case toks' of (CHSTokRBrace _:toks'2) -> do (omits, toks'3) <- parseOmits toks'2 return (CHSTrans _2Case chgCase [] omits, toks'3) _ -> do -- if there was no `underscoreToCase', we add a comma token to meet -- the invariant of `parseTranss' -- (transs, toks'2) <- if (_2Case || chgCase /= CHSSameCase) then parseTranss toks' else parseTranss (CHSTokComma nopos:toks') (omits, toks'3) <- parseOmits toks'2 return (CHSTrans _2Case chgCase transs omits, toks'3) where parse_2CaseAndChange (CHSTok_2Case _:CHSTokComma _:CHSTokUpper _:toks') = return (True, CHSUpCase, toks') parse_2CaseAndChange (CHSTok_2Case _:CHSTokComma _:CHSTokDown _ :toks') = return (True, CHSDownCase, toks') parse_2CaseAndChange (CHSTok_2Case _ :toks') = return (True, CHSSameCase, toks') parse_2CaseAndChange (CHSTokUpper _:CHSTokComma _:CHSTok_2Case _:toks') = return (True, CHSUpCase, toks') parse_2CaseAndChange (CHSTokUpper _ :toks') = return (False, CHSUpCase, toks') parse_2CaseAndChange (CHSTokDown _:CHSTokComma _:CHSTok_2Case _:toks') = return (True, CHSDownCase, toks') parse_2CaseAndChange (CHSTokDown _ :toks') = return (False, CHSDownCase, toks') parse_2CaseAndChange toks' = return (False, CHSSameCase, toks') -- parseTranss (CHSTokRBrace _:toks') = return ([], toks') parseTranss (CHSTokComma _:toks') = do (assoc, toks'2 ) <- parseAssoc toks' (trans, toks'3) <- parseTranss toks'2 return (assoc:trans, toks'3) parseTranss toks' = syntaxError toks' -- parseOmits (CHSTokOmit _:CHSTokLParen _:CHSTokIdent _ omit:toks') = do (omits, toks'2) <- parseOmits1 toks' return (omit:omits, toks'2) parseOmits toks' = return ([], toks') -- parseOmits1 (CHSTokRParen _:toks') = return ([], toks') parseOmits1 (CHSTokComma _:CHSTokIdent _ omit:toks') = do (omits, toks'2) <- parseOmits1 toks' return (omit:omits, toks'2) parseOmits1 toks' = syntaxError toks' -- parseAssoc (CHSTokIdent _ ide1:CHSTokAs _:CHSTokIdent _ ide2:toks') = return ((ide1, ide2), toks') parseAssoc (CHSTokCIdentTail _ ide1:CHSTokAs _:CHSTokIdent _ ide2:toks') = return ((ide1, ide2), toks') parseAssoc (CHSTokIdent _ _ :CHSTokAs _:toks' ) = syntaxError toks' parseAssoc (CHSTokIdent _ _ :toks' ) = syntaxError toks' parseAssoc toks' = syntaxError toks' parseTrans toks = syntaxError toks parseDerive :: [CHSToken] -> CST s ([Ident], [CHSToken]) parseDerive (CHSTokDerive _ :CHSTokLParen _:CHSTokRParen _:toks) = return ([], toks) parseDerive (CHSTokDerive _ :CHSTokLParen _:toks) = parseCommaIdent (CHSTokComma nopos:toks) where parseCommaIdent :: [CHSToken] -> CST s ([Ident], [CHSToken]) parseCommaIdent (CHSTokComma _:CHSTokIdent _ ide:toks') = do (ids, tok') <- parseCommaIdent toks' return (ide:ids, tok') parseCommaIdent (CHSTokRParen _ :toks') = return ([], toks') parseDerive toks = return ([],toks) parseEndHook :: [CHSToken] -> CST s ([CHSToken]) parseEndHook (CHSTokEndHook _:toks) = return toks parseEndHook toks = syntaxError toks syntaxError :: [CHSToken] -> CST s a syntaxError [] = errorEOF syntaxError (tok:_) = errorIllegal tok errorIllegal :: CHSToken -> CST s a errorIllegal tok = do raiseError (posOf tok) ["Syntax error!", "The phrase `" ++ show tok ++ "' is not allowed \ \here."] raiseSyntaxError errorEOF :: CST s a errorEOF = do raiseError nopos ["Premature end of file!", "The .chs file ends in the middle of a binding hook."] raiseSyntaxError errorOutWrap :: CHSToken -> CST s a errorOutWrap tok = do raiseError (posOf tok) ["Syntax error!", "Structure wrapping is not allowed for return parameters."] raiseSyntaxError errorCHICorrupt :: String -> CST s a errorCHICorrupt ide = do raiseError nopos ["Corrupt .chi file!", "The file `" ++ ide ++ ".chi' is corrupt."] raiseSyntaxError errorCHIVersion :: String -> String -> String -> CST s a errorCHIVersion ide chiVersion myVersion = do raiseError nopos ["Wrong version of .chi file!", "The file `" ++ ide ++ ".chi' is version " ++ chiVersion ++ ", but mine is " ++ myVersion ++ "."] raiseSyntaxError c2hs-0.28.1/src/C2HS/State.hs0000644000000000000000000000613312677513064013547 0ustar0000000000000000-- C -> Haskell Compiler: C2HS's state -- -- Author : Manuel M. T. Chakravarty -- Created: 6 March 1999 -- -- Copyright (c) 1999 Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module instantiates the Compiler Toolkit's extra state with C2HS's -- uncommon state information that should be stored in the Toolkit's base -- state. -- -- This modules re-exports everything provided by `State', and thus, should be -- used as the single reference to state related functionality within C2HS. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- State components: -- -- - compiler switches -- --- TODO ---------------------------------------------------------------------- -- module C2HS.State (-- re-exports all of `State' -- module Control.State, -- -- instantiation of `PreCST' with C2HS's extra state -- CST, runC2HS, -- -- switches -- SwitchBoard(..), Traces(..), setTraces, traceSet, putTraceStr, setSwitch, getSwitch) where import Control.Monad (when) import System.IO (stderr) import Control.State import qualified System.CIO as CIO import C2HS.Switches (SwitchBoard(..), Traces(..), initialSwitchBoard) -- instantiation of the extra state -- -------------------------------- -- | the extra state consists of the `SwitchBoard' -- type CST s a = PreCST SwitchBoard s a -- | execution of c2hs starts with the initial `SwitchBoard' -- runC2HS :: CST () a -> IO a runC2HS = run initialSwitchBoard -- switch management -- ----------------- -- | set traces according to the given transformation function -- setTraces :: (Traces -> Traces) -> CST s () setTraces t = updExtra (\es -> es {tracesSB = t (tracesSB es)}) -- | inquire the status a trace using the given inquiry function -- traceSet :: (Traces -> Bool) -> CST s Bool traceSet t = readExtra (t . tracesSB) -- | output the given string to `stderr' when the trace determined by the inquiry -- function is activated -- putTraceStr :: (Traces -> Bool) -> String -> CST s () putTraceStr t msg = do set <- traceSet t when set $ CIO.hPutStr stderr msg -- | set a switch value -- setSwitch :: (SwitchBoard -> SwitchBoard) -> CST s () setSwitch = updExtra -- | get a switch values -- getSwitch :: (SwitchBoard -> a) -> CST s a getSwitch = readExtra c2hs-0.28.1/src/C2HS/Switches.hs0000644000000000000000000001043612677513064014261 0ustar0000000000000000-- C -> Haskell Compiler: management of switches -- -- Author : Manuel M T Chakravarty -- Created: 6 March 99 -- -- Copyright (c) [1999..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module manages C2HS's compiler switches. It exports the data types -- used to store the switches and operations on them. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Overview over the switches: -- -- * The cpp options specify the options passed to the C preprocessor. -- -- * The cpp filename gives the name of the executable of the C preprocessor. -- -- * The `keep' flag says whether the intermediate file produced by the C -- pre-processor should be retained or not. -- -- * `platformSB' specifies the implementation-dependent parameters of the -- targeted C compiler (as far as they are relevant to c2hs); this includes -- especially the conventions for the memory layout of bitfields -- -- * Traces specify which trace information should be output by the compiler. -- Currently the following trace information is supported: -- -- - information about phase activation and phase completion -- -- * After processing the compiler options, `outputSB' contains the base name -- for the generated Haskell, C header, and .chi files. However, during -- processing compiler options, `outputSB' contains arguments to the -- `--output' option and `outDirSB' contains arguments to the -- `--output-dir' option. -- --- TODO ---------------------------------------------------------------------- -- module C2HS.Switches ( SwitchBoard(..), Traces(..), initialSwitchBoard ) where import C2HS.Config (PlatformSpec, defaultPlatformSpec) -- the switch board contains all toolkit switches -- ---------------------------------------------- -- | all switches of the toolkit -- data SwitchBoard = SwitchBoard { cppOptsSB :: [String], -- cpp options cppSB :: FilePath, -- cpp executable noGnuSB :: Bool, -- suppress GNU preproc. symbols noBlocksSB :: Bool, -- suppress MacOS __BLOCKS__ symbol keepSB :: Bool, -- keep intermediate file librarySB :: Bool, -- copy library in tracesSB :: Traces, -- trace flags outputSB :: FilePath, -- basename of generated files outDirSB :: FilePath, -- dir where generated files go platformSB:: PlatformSpec, -- target platform spec. headerSB :: FilePath, -- generated header file chiPathSB :: [FilePath] -- .chi file directories } -- | switch states on startup -- initialSwitchBoard :: SwitchBoard initialSwitchBoard = SwitchBoard { cppOptsSB = [], cppSB = "cpp", noGnuSB = False, noBlocksSB = False, keepSB = False, librarySB = False, tracesSB = initialTraces, outputSB = "", outDirSB = "", platformSB = defaultPlatformSpec, headerSB = "", chiPathSB = ["."] } -- traces -- ------ -- | different kinds of traces possible -- data Traces = Traces { tracePhasesSW :: Bool, traceGenBindSW :: Bool, traceCTravSW :: Bool, dumpCHSSW :: Bool } -- | trace setting on startup -- -- * all traces are initially off -- initialTraces :: Traces initialTraces = Traces { tracePhasesSW = False, traceGenBindSW = False, traceCTravSW = False, dumpCHSSW = False } c2hs-0.28.1/src/C2HS/Version.hs0000644000000000000000000000153012677513064014110 0ustar0000000000000000module C2HS.Version (versnum, version, copyright, disclaimer) -- -*-haskell-*- where import qualified Paths_c2hs (version) import Data.Version (Version, showVersion) name, versnick, date, version, copyright, disclaimer :: String versnum :: Version name = "C->Haskell Compiler" versnum = Paths_c2hs.version versnick = "Switcheroo" date = "1 April 2016" version = name ++ ", version " ++ showVersion versnum ++ " " ++ versnick ++ ", " ++ date copyright = "Copyright (c) 1999-2007 Manuel M T Chakravarty\n" ++ " 2005-2008 Duncan Coutts\n" ++ " 2008 Benedikt Huber" disclaimer = "This software is distributed under the \ \terms of the GNU Public Licence.\n\ \NO WARRANTY WHATSOEVER IS PROVIDED. \ \See the details in the documentation." c2hs-0.28.1/src/C2HS/config.h0000644000000000000000000000247212677513065013554 0ustar0000000000000000/* C -> Haskell Compiler: configuration query header * * Author : Manuel M T Chakravarty * Created: 12 November 1 * * Copyright (c) 2001 Manuel M T Chakravarty * * This file is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This file is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * DESCRIPTION --------------------------------------------------------------- * * Interface to the runtime configuration query functions. * * TODO ---------------------------------------------------------------------- */ #ifndef C2HS_CONFIG #define C2HS_CONFIG /* routines querying C compiler properties */ int bitfield_direction (); /* direction in which bitfields are growing */ int bitfield_padding (); /* use padding for overspilling bitfields? */ int bitfield_int_signed (); /* is an `int' bitfield signed? */ int bitfield_alignment (); /* alignment constraint for bitfields */ #endif /* C2HS_CONFIG*/ c2hs-0.28.1/src/C2HS/CHS/0000755000000000000000000000000012677513064012545 5ustar0000000000000000c2hs-0.28.1/src/C2HS/CHS/Lexer.hs0000644000000000000000000012333512677513064014167 0ustar0000000000000000-- C->Haskell Compiler: Lexer for CHS Files -- -- Author : Manuel M T Chakravarty -- Created: 13 August 99 -- -- Copyright (c) [1999..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- Lexer for CHS files; the tokens are only partially recognised. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * CHS files are assumed to be Haskell 98 files that include C2HS binding -- hooks. -- -- * Haskell code is not tokenised, but binding hooks (delimited by `{#'and -- `#}') are analysed. Therefore the lexer operates in two states -- (realised as two lexer coupled by meta actions) depending on whether -- Haskell code or a binding hook is currently read. The lexer reading -- Haskell code is called `base lexer'; the other one, `binding-hook -- lexer'. In addition, there is a inline-c lexer, which, as the -- binding-hook lexer, can be triggered from the base lexer. -- -- * Base lexer: -- -- haskell -> (inline \\ special)* -- | special \\ `"' -- | comment -- | nested -- | hstring -- | '{#' -- | cpp -- special -> `(' | `{' | `-' | `"' -- ctrl -> `\n' | `\f' | `\r' | `\t' | `\v' -- -- inline -> any \\ ctrl -- any -> '\0'..'\255' -- -- Within the base lexer control codes appear as separate tokens in the -- token list. -- -- NOTE: It is important that `{' is an extra lexeme and not added as an -- optional component at the end of the first alternative for -- `haskell'. Otherwise, the principle of the longest match will -- divide `foo {#' into the tokens `foo {' and `#' instead of `foo ' -- and `{#'. -- -- One line comments are handled by -- -- comment -> `--' (any \\ `\n')* `\n' -- -- and nested comments by -- -- nested -> `{-' any* `-}' -- -- where `any*' may contain _balanced_ occurrences of `{-' and `-}'. -- -- hstring -> `"' inhstr* `"' -- inhstr -> ` '..`\127' \\ `"' -- | `\"' -- -- Pre-precessor directives as well as the switch to inline-C code are -- formed as follows: -- -- cpp -> `\n#' (inline | `\t')* `\n' -- | `\n#c' (' ' | '\t')* `\n' -- -- We allow whitespace between the `#' and the actual directive, but in `#c' -- and `#endc' the directive must immediately follow the `#'. This might -- be regarded as a not entirely orthogonal design, but simplifies matters -- especially for `#endc'. -- -- * On encountering the lexeme `{#', a meta action in the base lexer -- transfers control to the following binding-hook lexer: -- -- ident -> letter (letter | digit | `\'')* -- cidenttail -> digit (letter | digit)* -- reservedid -> `add' | `as' | `call' | `class' | `context' | `deriving' -- | `enum' | `foreign' | `fun' | `get' | `lib' -- | `downcaseFirstLetter' | `finalizer' -- | `newtype' | `nocode' | `pointer' | `prefix' | `pure' -- | `set' | `sizeof' | `stable' | `struct' | `type' -- | `underscoreToCase' | `upcaseFirstLetter' | `unsafe' | -- | `with' | `const' | `omit' -- reservedsym -> `{#' | `#}' | `{' | `}' | `,' | `.' | `->' | `=' -- | `=>' | '-' | `*' | `&' | `^' | `+' | `%' -- string -> `"' instr* `"' -- verbhs -> `\`' inhsverb* `\'' -- quoths -> `\'' inhsverb* `\'' -- instr -> ` '..`\127' \\ `"' -- inhsverb -> ` '..`\127' \\ `\'' -- comment -> `--' (any \\ `\n')* `\n' -- -- Control characters, white space, and comments are discarded in the -- binding-hook lexer. Nested comments are not allowed in a binding hook. -- Identifiers can be enclosed in single quotes to avoid collision with -- C->Haskell keywords, and in this case quoted part could also be followed by -- what is assumed to be a valid Haskell code, which would be transferred in the -- output file verbatim. -- -- * In the binding-hook lexer, the lexeme `#}' transfers control back to the -- base lexer. An occurence of the lexeme `{#' inside the binding-hook -- lexer triggers an error. The symbol `{#' is not explcitly represented -- in the resulting token stream. However, the occurrence of a token -- representing one of the reserved identifiers `call', `context', `enum', -- and `field' marks the start of a binding hook. Strictly speaking, `#}' -- need also not occur in the token stream, as the next `haskell' token -- marks a hook's end. It is, however, useful for producing accurate error -- messages (in case an hook is closed to early) to have a token -- representing `#}'. -- -- * The rule `ident' describes Haskell identifiers, but without -- distinguishing between variable and constructor identifers (ie, those -- starting with a lowercase and those starting with an uppercase letter). -- However, we use it also to scan C identifiers; although, strictly -- speaking, it is too general for them. In the case of C identifiers, -- this should not have any impact on the range of descriptions accepted by -- the tool, as illegal identifier will never occur in a C header file that -- is accepted by the C lexer. In the case of Haskell identifiers, a -- confusion between variable and constructor identifiers will be noted by -- the Haskell compiler translating the code generated by c2hs. Moreover, -- identifiers that are inside quoted parts (see above) may not contain apostrophes. -- -- * Any line starting with the character `#' is regarded to be a C -- preprocessor directive. With the exception of `#c' and `#endc', which -- delimit a set of lines containing inline C code. Hence, in the base -- lexer, the lexeme `#c' triggers a meta action transferring control to the -- following inline-C lexer: -- -- c -> inline* \\ `\n#endc' -- -- We do neither treat C strings nor C comments specially. Hence, if the -- string "\n#endc" occurs in a comment, we will mistakenly regard it as -- the end of the inline C code. Note that the problem cannot happen with -- strings, as C does not permit strings that extend over multiple lines. -- At the moment, it just seems not to be worth the effort required to -- treat this situation more accurately. -- -- The inline-C lexer also doesn't handle pre-processor directives -- specially. Hence, structural pre-processor directives (namely, -- conditionals) may occur within inline-C code only properly nested. -- -- Shortcomings -- ~~~~~~~~~~~~ -- Some lexemes that include single and double quote characters are not lexed -- correctly. See the implementation comment at `haskell' for details. -- -- --- TODO ---------------------------------------------------------------------- -- -- * In `haskell', the case of a single `"' (without a matching second one) -- is caught by an eplicit error raising rule. This shouldn't be -- necessary, but for some strange reason, the lexer otherwise hangs when a -- single `"' appears in the input. -- -- * Comments in the "gap" of a string are not yet supported. -- module C2HS.CHS.Lexer (CHSToken(..), lexCHS, keywordToIdent) where import Data.List ((\\)) import Data.Char (isDigit, isSpace) import Language.C.Data.Ident import Language.C.Data.Name import Language.C.Data.Position import Data.Errors (ErrorLevel(..), makeError) import Text.Lexers (Regexp, Lexer, Action, epsilon, char, (+>), lexaction, lexactionErr, lexmeta, (>|<), (>||<), ctrlLexer, star, plus, alt, string, execLexer) import Control.State (getNameSupply, setNameSupply) import C2HS.State (CST, raise, raiseError) -- token definition -- ---------------- -- | possible tokens -- data CHSToken = CHSTokArrow Position -- `->' | CHSTokDArrow Position -- `=>' | CHSTokDot Position -- `.' | CHSTokComma Position -- `,' | CHSTokEqual Position -- `=' | CHSTokMinus Position -- `-' | CHSTokStar Position -- `*' | CHSTokAmp Position -- `&' | CHSTokHat Position -- `^' | CHSTokPercent Position -- `%' | CHSTokPlus Position -- `+' | CHSTokPlusS Position -- `+S' | CHSTokPlusNum Position Int -- `+' | CHSTokLBrace Position -- `{' | CHSTokRBrace Position -- `}' | CHSTokLParen Position -- `(' | CHSTokRParen Position -- `)' | CHSTokLBrack Position -- `[' | CHSTokRBrack Position -- `]' | CHSTokHook Position -- `{#' | CHSTokEndHook Position -- `#}' | CHSTokAdd Position -- `add' | CHSTokAs Position -- `as' | CHSTokCall Position -- `call' | CHSTokClass Position -- `class' | CHSTokConst Position -- `const' | CHSTokContext Position -- `context' | CHSTokNonGNU Position -- `nonGNU' | CHSTokTypedef Position -- `typedef' | CHSTokDefault Position -- `default' | CHSTokDerive Position -- `deriving' | CHSTokDown Position -- `downcaseFirstLetter' | CHSTokEnum Position -- `enum' | CHSTokFinal Position -- `finalizer' | CHSTokForeign Position -- `foreign' | CHSTokFun Position -- `fun' | CHSTokGet Position -- `get' | CHSTokImport Position -- `import' | CHSTokLib Position -- `lib' | CHSTokNewtype Position -- `newtype' | CHSTokNocode Position -- `nocode' | CHSTokOffsetof Position -- `offsetof' | CHSTokOmit Position -- `omit' | CHSTokPointer Position -- `pointer' | CHSTokPrefix Position -- `prefix' | CHSTokPure Position -- `pure' | CHSTokQualif Position -- `qualified' | CHSTokSet Position -- `set' | CHSTokSizeof Position -- `sizeof' | CHSTokAlignof Position -- `alignof' | CHSTokStable Position -- `stable' | CHSTokStruct Position -- `struct' | CHSTokType Position -- `type' | CHSTok_2Case Position -- `underscoreToCase' | CHSTokUnsafe Position -- `unsafe' | CHSTokUpper Position -- `upcaseFirstLetter' | CHSTokVariadic Position -- `variadic' | CHSTokWith Position Ident -- `with' | CHSTokIn Position -- `in' | CHSTokOut Position -- `out' | CHSTokString Position String -- string | CHSTokHSVerb Position String -- verbatim Haskell (`...') | CHSTokHSQuot Position String -- quoted Haskell ('...') | CHSTokIdent Position Ident -- identifier | CHSTokHaskell Position String -- verbatim Haskell code | CHSTokCPP Position String Bool -- pre-processor directive | CHSTokLine Position -- line pragma | CHSTokC Position String -- verbatim C code | CHSTokCtrl Position Char -- control code | CHSTokComment Position String -- comment | CHSTokCIdentTail Position Ident -- C identifier without prefix | CHSTokCArg Position String -- C type argument instance Pos CHSToken where posOf (CHSTokArrow pos ) = pos posOf (CHSTokDArrow pos ) = pos posOf (CHSTokDot pos ) = pos posOf (CHSTokComma pos ) = pos posOf (CHSTokEqual pos ) = pos posOf (CHSTokMinus pos ) = pos posOf (CHSTokStar pos ) = pos posOf (CHSTokAmp pos ) = pos posOf (CHSTokHat pos ) = pos posOf (CHSTokLBrace pos ) = pos posOf (CHSTokRBrace pos ) = pos posOf (CHSTokLParen pos ) = pos posOf (CHSTokRParen pos ) = pos posOf (CHSTokLBrack pos ) = pos posOf (CHSTokRBrack pos ) = pos posOf (CHSTokHook pos ) = pos posOf (CHSTokEndHook pos ) = pos posOf (CHSTokAdd pos ) = pos posOf (CHSTokAs pos ) = pos posOf (CHSTokCall pos ) = pos posOf (CHSTokClass pos ) = pos posOf (CHSTokConst pos ) = pos posOf (CHSTokContext pos ) = pos posOf (CHSTokNonGNU pos ) = pos posOf (CHSTokDerive pos ) = pos posOf (CHSTokTypedef pos ) = pos posOf (CHSTokDefault pos ) = pos posOf (CHSTokDown pos ) = pos posOf (CHSTokEnum pos ) = pos posOf (CHSTokFinal pos ) = pos posOf (CHSTokForeign pos ) = pos posOf (CHSTokFun pos ) = pos posOf (CHSTokGet pos ) = pos posOf (CHSTokImport pos ) = pos posOf (CHSTokLib pos ) = pos posOf (CHSTokNewtype pos ) = pos posOf (CHSTokNocode pos ) = pos posOf (CHSTokOffsetof pos ) = pos posOf (CHSTokOmit pos ) = pos posOf (CHSTokPointer pos ) = pos posOf (CHSTokPrefix pos ) = pos posOf (CHSTokPure pos ) = pos posOf (CHSTokQualif pos ) = pos posOf (CHSTokSet pos ) = pos posOf (CHSTokSizeof pos ) = pos posOf (CHSTokAlignof pos ) = pos posOf (CHSTokStable pos ) = pos posOf (CHSTokStruct pos ) = pos posOf (CHSTokType pos ) = pos posOf (CHSTok_2Case pos ) = pos posOf (CHSTokUnsafe pos ) = pos posOf (CHSTokUpper pos ) = pos posOf (CHSTokVariadic pos ) = pos posOf (CHSTokWith pos _) = pos posOf (CHSTokIn pos ) = pos posOf (CHSTokOut pos ) = pos posOf (CHSTokString pos _) = pos posOf (CHSTokHSVerb pos _) = pos posOf (CHSTokHSQuot pos _) = pos posOf (CHSTokIdent pos _) = pos posOf (CHSTokHaskell pos _) = pos posOf (CHSTokCPP pos _ _) = pos posOf (CHSTokLine pos ) = pos posOf (CHSTokC pos _) = pos posOf (CHSTokCtrl pos _) = pos posOf (CHSTokComment pos _) = pos posOf (CHSTokCIdentTail pos _) = pos posOf (CHSTokCArg pos _) = pos posOf (CHSTokPercent pos) = pos instance Eq CHSToken where (CHSTokArrow _ ) == (CHSTokArrow _ ) = True (CHSTokDArrow _ ) == (CHSTokDArrow _ ) = True (CHSTokDot _ ) == (CHSTokDot _ ) = True (CHSTokComma _ ) == (CHSTokComma _ ) = True (CHSTokEqual _ ) == (CHSTokEqual _ ) = True (CHSTokMinus _ ) == (CHSTokMinus _ ) = True (CHSTokStar _ ) == (CHSTokStar _ ) = True (CHSTokAmp _ ) == (CHSTokAmp _ ) = True (CHSTokHat _ ) == (CHSTokHat _ ) = True (CHSTokLBrace _ ) == (CHSTokLBrace _ ) = True (CHSTokRBrace _ ) == (CHSTokRBrace _ ) = True (CHSTokLParen _ ) == (CHSTokLParen _ ) = True (CHSTokRParen _ ) == (CHSTokRParen _ ) = True (CHSTokLBrack _ ) == (CHSTokLBrack _ ) = True (CHSTokRBrack _ ) == (CHSTokRBrack _ ) = True (CHSTokHook _ ) == (CHSTokHook _ ) = True (CHSTokEndHook _ ) == (CHSTokEndHook _ ) = True (CHSTokAdd _ ) == (CHSTokAdd _ ) = True (CHSTokAs _ ) == (CHSTokAs _ ) = True (CHSTokCall _ ) == (CHSTokCall _ ) = True (CHSTokClass _ ) == (CHSTokClass _ ) = True (CHSTokConst _ ) == (CHSTokConst _ ) = True (CHSTokContext _ ) == (CHSTokContext _ ) = True (CHSTokNonGNU _ ) == (CHSTokNonGNU _ ) = True (CHSTokTypedef _ ) == (CHSTokTypedef _ ) = True (CHSTokDefault _ ) == (CHSTokDefault _ ) = True (CHSTokDerive _ ) == (CHSTokDerive _ ) = True (CHSTokDown _ ) == (CHSTokDown _ ) = True (CHSTokEnum _ ) == (CHSTokEnum _ ) = True (CHSTokFinal _ ) == (CHSTokFinal _ ) = True (CHSTokForeign _ ) == (CHSTokForeign _ ) = True (CHSTokFun _ ) == (CHSTokFun _ ) = True (CHSTokGet _ ) == (CHSTokGet _ ) = True (CHSTokImport _ ) == (CHSTokImport _ ) = True (CHSTokLib _ ) == (CHSTokLib _ ) = True (CHSTokNewtype _ ) == (CHSTokNewtype _ ) = True (CHSTokNocode _ ) == (CHSTokNocode _ ) = True (CHSTokOffsetof _ ) == (CHSTokOffsetof _ ) = True (CHSTokOmit _ ) == (CHSTokOmit _ ) = True (CHSTokPointer _ ) == (CHSTokPointer _ ) = True (CHSTokPrefix _ ) == (CHSTokPrefix _ ) = True (CHSTokPure _ ) == (CHSTokPure _ ) = True (CHSTokQualif _ ) == (CHSTokQualif _ ) = True (CHSTokSet _ ) == (CHSTokSet _ ) = True (CHSTokSizeof _ ) == (CHSTokSizeof _ ) = True (CHSTokAlignof _ ) == (CHSTokAlignof _ ) = True (CHSTokStable _ ) == (CHSTokStable _ ) = True (CHSTokStruct _ ) == (CHSTokStruct _ ) = True (CHSTokType _ ) == (CHSTokType _ ) = True (CHSTok_2Case _ ) == (CHSTok_2Case _ ) = True (CHSTokUnsafe _ ) == (CHSTokUnsafe _ ) = True (CHSTokUpper _ ) == (CHSTokUpper _ ) = True (CHSTokVariadic _ ) == (CHSTokVariadic _ ) = True (CHSTokWith _ _) == (CHSTokWith _ _) = True (CHSTokIn _ ) == (CHSTokIn _ ) = True (CHSTokOut _ ) == (CHSTokOut _ ) = True (CHSTokString _ _) == (CHSTokString _ _) = True (CHSTokHSVerb _ _) == (CHSTokHSVerb _ _) = True (CHSTokHSQuot _ _) == (CHSTokHSQuot _ _) = True (CHSTokIdent _ _) == (CHSTokIdent _ _) = True (CHSTokHaskell _ _) == (CHSTokHaskell _ _) = True (CHSTokCPP _ _ _) == (CHSTokCPP _ _ _) = True (CHSTokLine _ ) == (CHSTokLine _ ) = True (CHSTokC _ _) == (CHSTokC _ _) = True (CHSTokCtrl _ _) == (CHSTokCtrl _ _) = True (CHSTokComment _ _) == (CHSTokComment _ _) = True (CHSTokCIdentTail _ _) == (CHSTokCIdentTail _ _) = True (CHSTokCArg _ _) == (CHSTokCArg _ _) = True _ == _ = False instance Show CHSToken where showsPrec _ (CHSTokArrow _ ) = showString "->" showsPrec _ (CHSTokDArrow _ ) = showString "=>" showsPrec _ (CHSTokDot _ ) = showString "." showsPrec _ (CHSTokComma _ ) = showString "," showsPrec _ (CHSTokEqual _ ) = showString "=" showsPrec _ (CHSTokMinus _ ) = showString "-" showsPrec _ (CHSTokStar _ ) = showString "*" showsPrec _ (CHSTokAmp _ ) = showString "&" showsPrec _ (CHSTokHat _ ) = showString "^" showsPrec _ (CHSTokPercent _ ) = showString "%" showsPrec _ (CHSTokPlus _ ) = showString "+" showsPrec _ (CHSTokPlusS _ ) = showString "+S" showsPrec _ (CHSTokPlusNum _ sz) = showString ("+" ++ show sz) showsPrec _ (CHSTokLBrace _ ) = showString "{" showsPrec _ (CHSTokRBrace _ ) = showString "}" showsPrec _ (CHSTokLParen _ ) = showString "(" showsPrec _ (CHSTokRParen _ ) = showString ")" showsPrec _ (CHSTokLBrack _ ) = showString "[" showsPrec _ (CHSTokRBrack _ ) = showString "]" showsPrec _ (CHSTokHook _ ) = showString "{#" showsPrec _ (CHSTokEndHook _ ) = showString "#}" showsPrec _ (CHSTokAdd _ ) = showString "add" showsPrec _ (CHSTokAs _ ) = showString "as" showsPrec _ (CHSTokCall _ ) = showString "call" showsPrec _ (CHSTokClass _ ) = showString "class" showsPrec _ (CHSTokConst _ ) = showString "const" showsPrec _ (CHSTokContext _ ) = showString "context" showsPrec _ (CHSTokNonGNU _ ) = showString "nonGNU" showsPrec _ (CHSTokTypedef _ ) = showString "typedef" showsPrec _ (CHSTokDefault _ ) = showString "default" showsPrec _ (CHSTokDerive _ ) = showString "deriving" showsPrec _ (CHSTokDown _ ) = showString "downcaseFirstLetter" showsPrec _ (CHSTokEnum _ ) = showString "enum" showsPrec _ (CHSTokFinal _ ) = showString "finalizer" showsPrec _ (CHSTokForeign _ ) = showString "foreign" showsPrec _ (CHSTokFun _ ) = showString "fun" showsPrec _ (CHSTokGet _ ) = showString "get" showsPrec _ (CHSTokImport _ ) = showString "import" showsPrec _ (CHSTokLib _ ) = showString "lib" showsPrec _ (CHSTokNewtype _ ) = showString "newtype" showsPrec _ (CHSTokNocode _ ) = showString "nocode" showsPrec _ (CHSTokOffsetof _ ) = showString "offsetof" showsPrec _ (CHSTokOmit _ ) = showString "omit" showsPrec _ (CHSTokPointer _ ) = showString "pointer" showsPrec _ (CHSTokPrefix _ ) = showString "prefix" showsPrec _ (CHSTokPure _ ) = showString "pure" showsPrec _ (CHSTokQualif _ ) = showString "qualified" showsPrec _ (CHSTokSet _ ) = showString "set" showsPrec _ (CHSTokSizeof _ ) = showString "sizeof" showsPrec _ (CHSTokAlignof _ ) = showString "alignof" showsPrec _ (CHSTokStable _ ) = showString "stable" showsPrec _ (CHSTokStruct _ ) = showString "struct" showsPrec _ (CHSTokType _ ) = showString "type" showsPrec _ (CHSTok_2Case _ ) = showString "underscoreToCase" showsPrec _ (CHSTokUnsafe _ ) = showString "unsafe" showsPrec _ (CHSTokUpper _ ) = showString "upcaseFirstLetter" showsPrec _ (CHSTokVariadic _ ) = showString "variadic" showsPrec _ (CHSTokWith _ _) = showString "with" showsPrec _ (CHSTokIn _ ) = showString "in" showsPrec _ (CHSTokOut _ ) = showString "out" showsPrec _ (CHSTokString _ s) = showString ("\"" ++ s ++ "\"") showsPrec _ (CHSTokHSVerb _ s) = showString ("`" ++ s ++ "'") showsPrec _ (CHSTokHSQuot _ s) = showString ("'" ++ s ++ "'") showsPrec _ (CHSTokIdent _ i) = (showString . identToString) i showsPrec _ (CHSTokHaskell _ s) = showString s showsPrec _ (CHSTokCPP _ s nl) = showString (if nl then "\n" else "" ++ s) showsPrec _ (CHSTokLine _ ) = id --TODO show line num? showsPrec _ (CHSTokC _ s) = showString s showsPrec _ (CHSTokCtrl _ c) = showChar c showsPrec _ (CHSTokComment _ s) = showString (if null s then "" else " --" ++ s ++ "\n") showsPrec _ (CHSTokCIdentTail _ i) = (showString . identToString) i showsPrec _ (CHSTokCArg _ s) = showString s -- lexer state -- ----------- -- | state threaded through the lexer -- data CHSLexerState = CHSLS { nestLvl :: Int, -- nesting depth of nested comments inHook :: Bool, -- within a binding hook? namesup :: [Name] -- supply of unique names } -- | initial state -- initialState :: [Name] -> CST s CHSLexerState initialState nameSupply = do return CHSLS { nestLvl = 0, inHook = False, namesup = nameSupply } -- | raise an error if the given state is not a final state -- assertFinalState :: Position -> CHSLexerState -> CST s () assertFinalState pos CHSLS {nestLvl = nestLvl', inHook = inHook'} | nestLvl' > 0 = raiseError pos ["Unexpected end of file!", "Unclosed nested comment."] | inHook' = raiseError pos ["Unexpected end of file!", "Unclosed binding hook."] | otherwise = return () -- | lexer and action type used throughout this specification -- type CHSLexer = Lexer CHSLexerState CHSToken type CHSAction = Action CHSToken type CHSRegexp = Regexp CHSLexerState CHSToken -- | for actions that need a new unique name -- infixl 3 `lexactionName` lexactionName :: CHSRegexp -> (String -> Position -> Name -> CHSToken) -> CHSLexer re `lexactionName` action = re `lexmeta` action' where action' str pos state = let name:ns = namesup state in (Just $ Right (action str pos name), incPos pos (length str), state {namesup = ns}, Nothing) -- lexical specification -- --------------------- -- | the lexical definition of the tokens (the base lexer) -- chslexer :: CHSLexer chslexer = haskell -- Haskell code >||< nested -- nested comments >||< ctrl -- control code (that has to be preserved) >||< hook -- start of a binding hook >||< cpp -- a pre-processor directive (or `#c') >||< startmarker -- marks beginning of input -- | stream of Haskell code (terminated by a control character or binding hook) -- haskell :: CHSLexer -- -- NB: We need to make sure that '"' is not regarded as the beginning of a -- string; however, we cannot really lex character literals properly -- without lexing identifiers (as the latter may containing single quotes -- as part of their lexeme). Thus, we special case '"'. This is still a -- kludge, as a program fragment, such as -- -- foo'"'strange string" -- -- will not be handled correctly. -- haskell = ( anyButSpecial`star` epsilon >|< specialButQuotes >|< char '"' +> inhstr`star` char '"' >|< string "'\"'" -- special case of " >|< string "--" +> anyButNL`star` epsilon -- comment ) `lexaction` copyVerbatim >||< char '"' -- this is a bad kludge `lexactionErr` \_ pos -> (Left $ makeError LevelError pos ["Lexical error!", "Unclosed string."]) where anyButSpecial = alt (inlineSet \\ specialSet) specialButQuotes = alt (specialSet \\ ['"']) anyButNL = alt (anySet \\ ['\n']) inhstr = instr >|< char '\\' >|< string "\\\"" >|< gap gap = char '\\' +> alt (' ':ctrlSet)`plus` char '\\' -- | action copying the input verbatim to `CHSTokHaskell' tokens -- copyVerbatim :: CHSAction copyVerbatim cs pos = Just $ CHSTokHaskell pos cs -- | nested comments -- nested :: CHSLexer nested = string "{-" {- for Haskell emacs mode :-( -} `lexmeta` enterComment >||< string "-}" `lexmeta` leaveComment where enterComment cs pos s = (copyVerbatim' cs pos, -- collect the lexeme incPos pos 2, -- advance current position s {nestLvl = nestLvl s + 1}, -- increase nesting level Just $ inNestedComment) -- continue in comment lexer -- leaveComment cs pos s = case nestLvl s of 0 -> (commentCloseErr pos, -- 0: -} outside comment => err incPos pos 2, -- advance current position s, Nothing) 1 -> (copyVerbatim' cs pos, -- collect the lexeme incPos pos 2, -- advance current position s {nestLvl = nestLvl s - 1}, -- decrease nesting level Just chslexer) -- 1: continue with root lexer _ -> (copyVerbatim' cs pos, -- collect the lexeme incPos pos 2, -- advance current position s {nestLvl = nestLvl s - 1}, -- decrease nesting level Nothing) -- _: cont with comment lexer -- copyVerbatim' cs pos = Just $ Right (CHSTokHaskell pos cs) -- commentCloseErr pos = Just $ Left (makeError LevelError pos ["Lexical error!", "`-}' not preceded by a matching `{-'."]) {- for Haskell emacs mode :-( -} -- | lexer processing the inner of a comment -- inNestedComment :: CHSLexer inNestedComment = commentInterior -- inside a comment >||< nested -- nested comments >||< ctrl -- control code (preserved) -- | standard characters in a nested comment -- commentInterior :: CHSLexer commentInterior = ( anyButSpecial`star` epsilon >|< special ) `lexaction` copyVerbatim where anyButSpecial = alt (inlineSet \\ commentSpecialSet) special = alt commentSpecialSet -- | control code in the base lexer (is turned into a token) -- -- * this covers exactly the same set of characters as contained in `ctrlSet' -- and `Lexers.ctrlLexer' and advances positions also like the `ctrlLexer' -- ctrl :: CHSLexer ctrl = char '\n' `lexmeta` newline >||< char '\r' `lexmeta` newline >||< char '\v' `lexmeta` newline >||< char '\f' `lexmeta` formfeed >||< char '\t' `lexmeta` tab where newline [c] pos = ctrlResult pos c (retPos pos) formfeed [c] pos = ctrlResult pos c (incPos pos 1) tab [c] pos = ctrlResult pos c (incPos pos 8) ctrlResult pos c pos' s = (Just $ Right (CHSTokCtrl pos c), pos', s, Nothing) -- | start of a binding hook (ie, enter the binding hook lexer) -- hook :: CHSLexer hook = string "{#" `lexmeta` \_ pos s -> (Just $ Right (CHSTokHook pos), incPos pos 2, s, Just bhLexer) -- | start marker: used to identify pre-processor directive at -- beginning of input -- this lexer just drops the start marker if it -- hasn't been used to handle a pre-processor directive -- startmarker :: CHSLexer startmarker = char '\000' `lexmeta` \_ pos s -> (Nothing, incPos pos 1, s, Just chslexer) -- | pre-processor directives and `#c' -- -- * we lex `#c' as a directive and special case it in the action -- -- * we lex C line number pragmas and special case it in the action -- cpp :: CHSLexer cpp = directive where directive = --(string "\n#" >|< string "\0#") +> alt "\n\0" +> alt " \t" `star` string "#" +> alt ('\t':inlineSet)`star` epsilon `lexmeta` \t@(ld:spdir) pos s -> -- strip off the "\n" or "\0" let dir = drop 1 $ dropWhile (`elem` " \t") spdir in case dir of ['c'] -> -- #c (Nothing, incPos pos (length t), s, Just cLexer) -- a #c may be followed by whitespace 'c':sp:_ | sp `elem` " \t" -> -- #c (Nothing, incPos pos (length t), s, Just cLexer) ' ':line@(n:_) | isDigit n -> -- C line pragma let pos' = adjustPosByCLinePragma line pos in (Just $ Right (CHSTokLine pos'), pos', s, Nothing) _ -> -- CPP directive (Just $ Right (CHSTokCPP pos dir (ld == '\n')), if ld == '\n' then retPos pos else incPos pos (length t), s, Nothing) adjustPosByCLinePragma :: String -> Position -> Position adjustPosByCLinePragma str pos = adjustPos fname' row' pos where fname = posFile pos str' = dropWhite str (rowStr, str'') = span isDigit str' row' = read rowStr str''' = dropWhite str'' fnameStr = takeWhile (/= '"') . drop 1 $ str''' fname' | null str''' || head str''' /= '"' = fname -- try and get more sharing of file name strings | fnameStr == fname = fname | otherwise = fnameStr -- dropWhite = dropWhile (\c -> c == ' ' || c == '\t') -- | the binding hook lexer -- bhLexer :: CHSLexer bhLexer = identOrKW >||< symbol >||< strlit >||< hsverb >||< hsquot >||< whitespace >||< arglist >||< endOfHook >||< string "--" +> anyButNL`star` epsilon -- comment `lexaction` \cs pos -> Just (CHSTokComment pos (drop 2 cs)) where anyButNL = alt (anySet \\ ['\n']) endOfHook = string "#}" `lexmeta` \_ pos s -> (Just $ Right (CHSTokEndHook pos), incPos pos 2, s, Just chslexer) arglist = string "[" `lexmeta` \_ pos s -> (Just $ Right (CHSTokLBrack pos), incPos pos 1, s, Just alLexer) -- | lexer for C function types for variadic functions -- alLexer :: CHSLexer alLexer = sym "," CHSTokComma >||< endOfArgList >||< cArg where sym cs con = string cs `lexaction` \_ pos -> Just (con pos) endOfArgList = string "]" `lexmeta` \_ pos s -> (Just $ Right (CHSTokRBrack pos), incPos pos 1, s, Just bhLexer) cArg = ((alt (anySet \\ ",]")) `star` epsilon) `lexaction` \cs pos -> Just (CHSTokCArg pos $ trim cs) trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace -- | the inline-C lexer -- cLexer :: CHSLexer cLexer = inlineC -- inline C code >||< ctrl -- control code (preserved) >||< string "\n#endc" -- end of inline C code... `lexmeta` -- ...preserve '\n' as control token \_ pos s -> (Just $ Right (CHSTokCtrl pos '\n'), retPos pos, s, Just chslexer) where inlineC = alt inlineSet `lexaction` copyVerbatimC -- copyVerbatimC :: CHSAction copyVerbatimC cs pos = Just $ CHSTokC pos cs -- | whitespace -- -- * horizontal and vertical tabs, newlines, and form feeds are filter out by -- `Lexers.ctrlLexer' -- whitespace :: CHSLexer whitespace = (char ' ' `lexaction` \_ _ -> Nothing) >||< ctrlLexer -- | identifiers and keywords -- identOrKW :: CHSLexer -- -- the strictness annotations seem to help a bit -- identOrKW = -- identifier or keyword (letter +> (letter >|< digit >|< char '\'')`star` epsilon `lexactionName` \cs pos name -> (idkwtok $!pos) cs name) >||< (digit +> (letter >|< digit)`star` epsilon `lexactionName` \cs pos name -> CHSTokCIdentTail pos (mkIdent pos cs name)) where idkwtok pos "add" _ = CHSTokAdd pos idkwtok pos "as" _ = CHSTokAs pos idkwtok pos "call" _ = CHSTokCall pos idkwtok pos "class" _ = CHSTokClass pos idkwtok pos "const" _ = CHSTokConst pos idkwtok pos "context" _ = CHSTokContext pos idkwtok pos "nonGNU" _ = CHSTokNonGNU pos idkwtok pos "typedef" _ = CHSTokTypedef pos idkwtok pos "default" _ = CHSTokDefault pos idkwtok pos "deriving" _ = CHSTokDerive pos idkwtok pos "downcaseFirstLetter" _ = CHSTokDown pos idkwtok pos "enum" _ = CHSTokEnum pos idkwtok pos "finalizer" _ = CHSTokFinal pos idkwtok pos "foreign" _ = CHSTokForeign pos idkwtok pos "fun" _ = CHSTokFun pos idkwtok pos "get" _ = CHSTokGet pos idkwtok pos "import" _ = CHSTokImport pos idkwtok pos "lib" _ = CHSTokLib pos idkwtok pos "newtype" _ = CHSTokNewtype pos idkwtok pos "nocode" _ = CHSTokNocode pos idkwtok pos "offsetof" _ = CHSTokOffsetof pos idkwtok pos "omit" _ = CHSTokOmit pos idkwtok pos "pointer" _ = CHSTokPointer pos idkwtok pos "prefix" _ = CHSTokPrefix pos idkwtok pos "pure" _ = CHSTokPure pos idkwtok pos "qualified" _ = CHSTokQualif pos idkwtok pos "set" _ = CHSTokSet pos idkwtok pos "sizeof" _ = CHSTokSizeof pos idkwtok pos "alignof" _ = CHSTokAlignof pos idkwtok pos "stable" _ = CHSTokStable pos idkwtok pos "struct" _ = CHSTokStruct pos idkwtok pos "type" _ = CHSTokType pos idkwtok pos "underscoreToCase" _ = CHSTok_2Case pos idkwtok pos "unsafe" _ = CHSTokUnsafe pos idkwtok pos "upcaseFirstLetter"_ = CHSTokUpper pos idkwtok pos "variadic" _ = CHSTokVariadic pos idkwtok pos "with" name = mkwith pos name idkwtok pos "in" _ = CHSTokIn pos idkwtok pos "out" _ = CHSTokOut pos idkwtok pos cs name = mkid pos cs name -- mkid pos cs name = CHSTokIdent pos (mkIdent pos cs name) mkwith pos name = CHSTokWith pos (mkIdent pos "with" name) keywordToIdent :: CHSToken -> CHSToken keywordToIdent tok = case tok of CHSTokAdd pos -> mkid pos "add" CHSTokAs pos -> mkid pos "as" CHSTokCall pos -> mkid pos "call" CHSTokClass pos -> mkid pos "class" CHSTokConst pos -> mkid pos "const" CHSTokContext pos -> mkid pos "context" CHSTokNonGNU pos -> mkid pos "nonGNU" CHSTokTypedef pos -> mkid pos "typedef" CHSTokDefault pos -> mkid pos "default" CHSTokDerive pos -> mkid pos "deriving" CHSTokDown pos -> mkid pos "downcaseFirstLetter" CHSTokEnum pos -> mkid pos "enum" CHSTokFinal pos -> mkid pos "finalizer" CHSTokForeign pos -> mkid pos "foreign" CHSTokFun pos -> mkid pos "fun" CHSTokGet pos -> mkid pos "get" CHSTokImport pos -> mkid pos "import" CHSTokLib pos -> mkid pos "lib" CHSTokNewtype pos -> mkid pos "newtype" CHSTokNocode pos -> mkid pos "nocode" CHSTokOffsetof pos -> mkid pos "offsetof" CHSTokOmit pos -> mkid pos "omit" CHSTokPointer pos -> mkid pos "pointer" CHSTokPrefix pos -> mkid pos "prefix" CHSTokPure pos -> mkid pos "pure" CHSTokQualif pos -> mkid pos "qualified" CHSTokSet pos -> mkid pos "set" CHSTokSizeof pos -> mkid pos "sizeof" CHSTokAlignof pos -> mkid pos "alignof" CHSTokStable pos -> mkid pos "stable" CHSTokStruct pos -> mkid pos "struct" CHSTokType pos -> mkid pos "type" CHSTok_2Case pos -> mkid pos "underscoreToCase" CHSTokUnsafe pos -> mkid pos "unsafe" CHSTokUpper pos -> mkid pos "upcaseFirstLetter" CHSTokVariadic pos -> mkid pos "variadic" CHSTokWith pos ide -> CHSTokIdent pos ide CHSTokIn pos -> mkid pos "in" CHSTokOut pos -> mkid pos "out" _ -> tok where mkid pos str = CHSTokIdent pos (internalIdent str) -- | reserved symbols -- symbol :: CHSLexer symbol = sym "->" CHSTokArrow >||< sym "=>" CHSTokDArrow >||< sym "." CHSTokDot >||< sym "," CHSTokComma >||< sym "=" CHSTokEqual >||< sym "-" CHSTokMinus >||< sym "*" CHSTokStar >||< sym "&" CHSTokAmp >||< sym "^" CHSTokHat >||< sym "%" CHSTokPercent >||< sym "+" CHSTokPlus >||< sym "+S" CHSTokPlusS >||< sym_with_num "+" CHSTokPlusNum >||< sym "{" CHSTokLBrace >||< sym "}" CHSTokRBrace >||< sym "(" CHSTokLParen >||< sym ")" CHSTokRParen where sym cs con = string cs `lexaction` \_ pos -> Just (con pos) sym_with_num cs con = string cs +> digit +> digit`star` epsilon `lexaction` \(_:ds) pos -> Just (con pos (read ds)) -- | string -- strlit :: CHSLexer strlit = char '"' +> (instr >|< char '\\')`star` char '"' `lexaction` \cs pos -> Just (CHSTokString pos (init . tail $ cs)) -- | verbatim code -- hsverb :: CHSLexer hsverb = char '`' +> inhsverb`star` char '\'' `lexaction` \cs pos -> Just (CHSTokHSVerb pos (init . tail $ cs)) -- | quoted code -- hsquot :: CHSLexer hsquot = char '\'' +> inhsverb`star` char '\'' `lexaction` \cs pos -> Just (CHSTokHSQuot pos (init . tail $ cs)) -- | regular expressions -- letter, digit, instr, inhsverb :: Regexp s t letter = alt ['a'..'z'] >|< alt ['A'..'Z'] >|< char '_' digit = alt ['0'..'9'] instr = alt ([' '..'\255'] \\ "\"\\") inhsverb = alt ([' '..'\127'] \\ "'") -- | character sets -- anySet, inlineSet, specialSet, commentSpecialSet, ctrlSet :: [Char] anySet = ['\1'..'\255'] inlineSet = anySet \\ ctrlSet specialSet = ['{', '-', '"', '\''] commentSpecialSet = ['{', '-'] ctrlSet = ['\n', '\f', '\r', '\t', '\v'] -- main lexing routine -- ------------------- -- | generate a token sequence out of a string denoting a CHS file -- -- * the given position is attributed to the first character in the string -- -- * errors are entered into the compiler state -- -- * on a successfull parse, the name supply is updated lexCHS :: String -> Position -> CST s [CHSToken] lexCHS cs pos = do nameSupply <- getNameSupply state <- initialState nameSupply let (ts, lstate, errs) = execLexer chslexer ('\0':cs, pos, state) (_, pos', state') = lstate mapM_ raise errs assertFinalState pos' state' setNameSupply $ namesup state' return ts c2hs-0.28.1/src/C2HS/Gen/0000755000000000000000000000000012677513064012641 5ustar0000000000000000c2hs-0.28.1/src/C2HS/Gen/Wrapper.hs0000644000000000000000000001466012677513064014624 0ustar0000000000000000-- C->Haskell Compiler: custom wrapper generator -- -- Author : Manuel M T Chakravarty -- Created: 5 February 2003 -- -- Copyright (c) 2004 Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module implements the generation of a custom C file to wrap -- functions requiring marshalling of bare C structs to pointers. -- module C2HS.Gen.Wrapper ( genWrappers ) where import Control.Monad -- Language.C / Compiler Toolkit import Language.C.Syntax import Language.C.Pretty import Text.PrettyPrint.HughesPJ (render) import Language.C.Data.Node (undefNode) import Language.C.Data.Position import Language.C.Data.Ident (Ident(..), internalIdent) import Data.DList (DList) import qualified Data.DList as DL -- C->Haskell import C2HS.State (CST, raiseError, throwExc, catchExc, errorsPresent, showErrors, fatal) import C2HS.C.Trav (isPtrDeclr) -- friends import C2HS.Gen.Monad (Wrapper(..)) -- | Generate a custom C wrapper from a CHS binding module for -- functions that require marshalling of bare C structs. -- genWrappers :: [Wrapper] -> CST s [String] genWrappers ws = do wraps <- mapM genWrapper (reverse ws) `ifWrapExc` return [] errs <- errorsPresent if errs then do errmsgs <- showErrors fatal ("Errors during generation of C wrappers:\n\n" ++ errmsgs) else do return $ DL.toList . DL.concat $ wraps -- | Process a single fragment. -- genWrapper :: Wrapper -> CST s (DList String) genWrapper (Wrapper wfn ofn (CDecl specs [(Just decl, _, _)] _) args (boolres, boolargs) pos) = do let renamed = rename (internalIdent wfn) decl wrapdecl <- fixArgs ofn pos args boolargs renamed let fspecs = if boolres then map replaceBoolSpec specs else specs expr <- callBody ofn pos args decl let body = CCompound [] [CBlockStmt (CReturn (Just expr) undefNode)] undefNode wrapfn = CFunDef fspecs wrapdecl [] body undefNode return $ DL.fromList [render (pretty wrapfn) ++ "\n"] genWrapper (Wrapper _ ofn _ _ _ pos) = internalWrapperErr pos ["genWrapper:" ++ ofn] rename :: Ident -> CDeclr -> CDeclr rename ide (CDeclr _ dds str attrs n) = CDeclr (Just ide) dds str attrs n fixArgs :: String -> Position -> [Bool] -> [Bool] -> CDeclr -> CST s CDeclr fixArgs ofn pos args bools (CDeclr ide fd str attrs n) = do fd' <- case fd of [] -> return [] f:fs -> do f' <- fixFunArgs ofn pos args bools f return $ f' : fs return $ CDeclr ide fd' str attrs n fixFunArgs :: String -> Position -> [Bool] -> [Bool] -> CDerivedDeclr -> CST s CDerivedDeclr fixFunArgs ofn pos args bools (CFunDeclr (Right (adecls, flg)) attrs n) = do adecls' <- zipWithM (fixDecl ofn pos) (zip3 args bools [1..]) adecls return $ CFunDeclr (Right (adecls', flg)) attrs n fixFunArgs ofn pos args bools cdecl = internalWrapperErr pos ["fixFunArgs:" ++ ofn, "args=" ++ show args, "bools=" ++ show bools, "cdecl=" ++ show cdecl] replaceBool :: CDecl -> CDecl replaceBool (CDecl spec ds n) = CDecl (map replaceBoolSpec spec) ds n replaceBoolSpec :: CDeclSpec -> CDeclSpec replaceBoolSpec (CTypeSpec (CBoolType tn)) = CTypeSpec (CIntType tn) replaceBoolSpec t = t fixDecl :: String -> Position -> (Bool, Bool, Int) -> CDecl -> CST s CDecl fixDecl _ _ (False, True, idx) d = return $ replaceBool $ fixEmpty d idx fixDecl _ _ (False, False, idx) d = return $ fixEmpty d idx fixDecl _ pos (True, _, idx) din = do let (CDecl specs [(Just decl, Nothing, Nothing)] n) = fixEmpty din idx decl' <- addPtr pos decl return $ CDecl specs [(Just decl', Nothing, Nothing)] n fixEmpty :: CDecl -> Int -> CDecl fixEmpty d@(CDecl _ [(Just _, Nothing, Nothing)] _) _ = d fixEmpty (CDecl ss [] n) idx = let d = CDeclr (Just $ internalIdent $ "c2hs__dummy_arg_" ++ show idx) [] Nothing [] n in CDecl ss [(Just d, Nothing, Nothing)] n addPtr :: Position -> CDeclr -> CST s CDeclr addPtr _ (CDeclr ide [] cs attrs n) = return $ CDeclr ide [CPtrDeclr [] n] cs attrs n addPtr pos cdecl = if isPtrDeclr cdecl then wrapperOnPointerErr pos else invalidWrapperErr pos callBody :: String -> Position -> [Bool] -> CDeclr -> CST s CExpr callBody fn pos args (CDeclr _ (fd:_) _ _ n) = do as <- zipWithM (makeArg pos) (zip args [1..]) (funArgs fd) return $ CCall (CVar (internalIdent fn) n) as n makeArg :: Position -> (Bool, Int) -> CDecl -> CST s CExpr makeArg _ (arg, _) (CDecl _ [(Just (CDeclr (Just i) _ _ _ _), _, _)] n) = return $ case arg of False -> CVar i n True -> CUnary CIndOp (CVar i n) n makeArg _ (arg, idx) (CDecl _ [] n) = let i = internalIdent $ "c2hs__dummy_arg_" ++ show idx in return $ case arg of False -> CVar i n True -> CUnary CIndOp (CVar i n) n makeArg pos (arg, idx) cdecl = internalWrapperErr pos ["makeArg:arg=" ++ show arg, "cdecl=" ++ show cdecl, "idx=" ++ show idx] funArgs :: CDerivedDeclr -> [CDecl] funArgs (CFunDeclr (Right (adecls, _)) _ _) = adecls throwWrapExc :: CST s a throwWrapExc = throwExc "wrapExc" "Error during wrapper generation" ifWrapExc :: CST s a -> CST s a -> CST s a ifWrapExc m handler = m `catchExc` ("wrapExc", const handler) raiseErrorWrapper :: Position -> [String] -> CST s a raiseErrorWrapper pos errs = raiseError pos errs >> throwWrapExc internalWrapperErr :: Position -> [String] -> CST s a internalWrapperErr pos msg = raiseErrorWrapper pos $ ["Internal wrapper error!", "Something went wrong generating a bare structure wrapper."] ++ msg wrapperOnPointerErr :: Position -> CST s a wrapperOnPointerErr pos = raiseErrorWrapper pos $ ["Bare structure wrapper error!", "Are you trying to put a wrapper on a pointer type?"] invalidWrapperErr :: Position -> CST s a invalidWrapperErr pos = raiseErrorWrapper pos $ ["Bare structure wrapper error!", "Invalid bare structure wrapper"] c2hs-0.28.1/src/C2HS/Gen/Bind.hs0000644000000000000000000037676312677513064014077 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- C->Haskell Compiler: binding generator -- -- Copyright (c) [1999..2003] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- Description --------------------------------------------------------------- -- -- Language: Haskell 98 -- -- Module implementing the expansion of the binding hooks. -- -- * If there is an error in one binding hook, it is skipped and the next one -- is processed (to collect as many errors as possible). However, if at -- least one error occured, the expansion of binding hooks ends in a fatal -- exception. -- -- * `CST' exceptions are used to back off a binding hook as soon as an error -- is encountered while it is processed. -- -- Mapping of C types to Haskell FFI types: -- ---------------------------------------- -- -- The following defines the mapping for basic types. If the type specifer -- is missing, it is taken to be `int'. In the following, elements enclosed -- in square brackets are optional. -- -- void -> () -- char -> CChar -- unsigned char -> CUChar -- signed char -> CShort -- signed -> CInt -- [signed] int -> CInt -- [signed] short [int] -> CSInt -- [signed] long [int] -> CLong -- [signed] long long [int] -> CLLong -- unsigned [int] -> CUInt -- unsigned short [int] -> CUShort -- unsigned long [int] -> CULong -- unsigned long long [int] -> CULLong -- float -> CFloat -- double -> CDouble -- long double -> CLDouble -- bool -> CBool -- enum ... -> CInt -- struct ... -> ** error ** -- union ... -> ** error ** -- -- Plain structures or unions (ie, if not the base type of a pointer type) -- are not supported at the moment (the underlying FFI does not support them -- directly). Named types (ie, in C type names defined using `typedef') are -- traced back to their original definitions. Pointer types are mapped -- to `Ptr a' or `FunPtr a' depending on whether they point to a functional. -- Values obtained from bit fields are represented by `CInt' or `CUInt' -- depending on whether they are signed. -- -- We obtain the size and alignment constraints for all primitive types of C -- from `CInfo', which obtains it from the Haskell 98 FFI. In the alignment -- computations involving bit fields, we assume that the alignment -- constraints for bitfields (wrt to non-bitfield members) is always the same -- as for `int' irrespective of the size of the bitfield. This seems to be -- implicitly guaranteed by K&R A8.3, but it is not entirely clear. -- -- Identifier lookup: -- ------------------ -- -- We allow to identify enumerations and structures by the names of `typedef' -- types aliased to them. -- -- * enumerations: It is first checked whether there is a tag with the given -- identifier; if such a tag does not exist, the definition of a typedef -- with the same name is taken if it exists. -- * structs/unions: like enumerations -- -- We generally use `shadow' lookups. When an identifier cannot be found, -- we check whether - according to the prefix set by the context hook - -- another identifier casts a shadow that matches. If so, that identifier is -- taken instead of the original one. -- --- ToDo ---------------------------------------------------------------------- -- -- * A function prototype that uses a defined type on its left hand side may -- declare a function, while that is not obvious from the declaration -- itself (without also considering the `typedef'). Calls to such -- functions are currently rejected, which is a BUG. -- -- * context hook must preceded all but the import hooks -- -- * The use of `++' in the recursive definition of the routines generating -- `Enum' instances is not particularly efficient. -- -- * Some operands are missing in `applyBin' - unfortunately, Haskell does -- not have standard bit operations. Some constructs are also missing -- from `evalConstCExpr'. Haskell 98 FFI standardises `Bits'; use that. -- module C2HS.Gen.Bind (expandHooks) where import Prelude hiding (exp, lookup) import qualified Prelude -- standard libraries import Data.Char (toLower, isSpace) import Data.Function (on) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import System.IO.Unsafe (unsafePerformIO) import System.IO (withFile, hPutStrLn, IOMode(..)) import System.Exit (ExitCode(..)) import System.Directory (removeFile) import System.Process (readProcessWithExitCode, system) import Data.List (deleteBy, groupBy, sortBy, intersperse, find, nubBy, intercalate, isPrefixOf, isInfixOf, foldl') import Data.Map (lookup) import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Data.Bits ((.|.), (.&.)) import Control.Arrow (second) import Control.Monad (when, unless, liftM, mapAndUnzipM, zipWithM, forM) import Data.Ord (comparing) import qualified Foreign.Storable as Storable (Storable(alignment), Storable(sizeOf)) import Foreign (Ptr, FunPtr) import Foreign.C -- Language.C / compiler toolkit import Language.C.Data.Position import Language.C.Data.Ident import Language.C.Pretty import Text.PrettyPrint.HughesPJ (render) import Data.Errors import C2HS.Config (PlatformSpec(..)) import C2HS.State (getSwitch) import C2HS.Switches (platformSB) -- C->Haskell import C2HS.State (CST, errorsPresent, showErrors, fatal, SwitchBoard(..), Traces(..), putTraceStr) import C2HS.C -- friends import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), CHSTypedefInfo, Direction(..), CHSPlusParmType(..), CHSPtrType(..), showCHSParm, apathToIdent, apathRootIdent) import C2HS.C.Info (CPrimType(..)) import C2HS.Gen.Monad (TransFun, transTabToTransFun, HsObject(..), GB, GBState(..), Wrapper(..), initialGBState, setContext, getPrefix, getReplacementPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, sizeIs, querySize, queryClass, queryPointer, mergeMaps, dumpMaps, queryEnum, isEnum, queryTypedef, isC2HSTypedef, queryDefaultMarsh, isDefaultMarsh, addWrapper, getWrappers, addHsDependency, getHsDependencies) -- Module import alias. imp :: String imp = "C2HSImp" impm :: String -> String impm s = imp ++ "." ++ s -- default marshallers -- ------------------- -- FIXME: -- - we might have a dynamically extended table in the monad if needed (we -- could marshall enums this way and also save the 'id' marshallers for -- pointers defined via (newtype) pointer hooks) -- - the checks for the Haskell types are quite kludgy stringIn :: String stringIn = "\\s f -> " ++ impm "withCStringLen" ++ " s " ++ "(\\(p, n) -> f (p, fromIntegral n))" -- | determine the default "in" marshaller for the given Haskell and C types -- lookupDftMarshIn :: String -> [ExtType] -> GB CHSMarsh lookupDftMarshIn "Bool" [PrimET pt] | isIntegralCPrimType pt = do addHsDependency "Foreign.Marshal.Utils" return $ Just (Left cFromBoolIde, CHSValArg) lookupDftMarshIn hsTy [PrimET pt] | isIntegralHsType hsTy &&isIntegralCPrimType pt = return $ Just (Left cIntConvIde, CHSValArg) lookupDftMarshIn hsTy [PrimET pt] | isFloatHsType hsTy &&isFloatCPrimType pt = return $ Just (Left cFloatConvIde, CHSValArg) lookupDftMarshIn "Char" [PrimET CCharPT] = do addHsDependency "Foreign.C.String" return $ Just (Left castCharToCCharIde, CHSValArg) lookupDftMarshIn "Char" [PrimET CUCharPT] = do addHsDependency "Foreign.C.String" return $ Just (Left castCharToCUCharIde, CHSValArg) lookupDftMarshIn "Char" [PrimET CSCharPT] = do addHsDependency "Foreign.C.String" return $ Just (Left castCharToCSCharIde, CHSValArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT)] = do addHsDependency "Foreign.C.String" return $ Just (Left withCStringIde, CHSIOArg) lookupDftMarshIn "CString" [PtrET (PrimET CCharPT)] = return $ Just (Right "flip ($)", CHSIOArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt] | isIntegralCPrimType pt = do addHsDependency "Foreign.C.String" return $ Just (Right stringIn , CHSIOArg) lookupDftMarshIn hsTy [PtrET (PrimET pt)] | isIntegralHsType hsTy && isIntegralCPrimType pt = do addHsDependency "Foreign.Marshal.Utils" return $ Just (Right $ impm "with" ++ " . fromIntegral", CHSIOArg) lookupDftMarshIn hsTy [PtrET (PrimET pt)] | isFloatHsType hsTy && isFloatCPrimType pt = do addHsDependency "Foreign.Marshal.Utils" return $ Just (Right $ impm "with" ++ " . realToFrac", CHSIOArg) lookupDftMarshIn "Bool" [PtrET (PrimET pt)] | isIntegralCPrimType pt = do addHsDependency "Foreign.Marshal.Utils" return $ Just (Right $ impm "with" ++ " . fromBool", CHSIOArg) lookupDftMarshIn hsTy [PtrET UnitET] | "Ptr " `isPrefixOf` hsTy = return $ Just (Left idIde, CHSValArg) lookupDftMarshIn hsTy [PrimET (CAliasedPT tds hsAlias _)] = do mm <- queryDefaultMarsh $ (In, tds, False) case mm of Nothing -> if hsTy == hsAlias then return $ Just (Left idIde, CHSValArg) else return Nothing Just m -> return $ Just m lookupDftMarshIn hsTy [PtrET (PrimET (CAliasedPT tds hsAlias _pt))] = do mm <- queryDefaultMarsh $ (In, tds, True) case mm of Nothing -> if hsTy == hsAlias then return $ Just (Left idIde, CHSValArg) else return Nothing Just m -> return $ Just m -- Default case deals with: lookupDftMarshIn hsty _ = do om <- readCT objmap isenum <- queryEnum hsty case (isenum, (internalIdent hsty) `lookup` om) of -- 1. enumeration hooks (True, Nothing) -> return $ Just (Right "fromIntegral . fromEnum", CHSValArg) -- 2. naked and newtype pointer hooks (False, Just (Pointer CHSPtr _)) -> return $ Just (Left idIde, CHSValArg) -- 3. foreign pointer hooks (False, Just (Pointer (CHSForeignPtr _) False)) -> do addHsDependency "Foreign.ForeignPtr" return $ Just (Left withForeignPtrIde, CHSIOArg) -- 4. foreign newtype pointer hooks (False, Just (Pointer (CHSForeignPtr _) True)) -> return $ Just (Right $ "with" ++ hsty, CHSIOArg) _ -> return Nothing -- FIXME: handle array-list conversion -- | determine the default "out" marshaller for the given Haskell and C types -- lookupDftMarshOut :: String -> [ExtType] -> GB CHSMarsh lookupDftMarshOut "()" _ = return $ Just (Left voidIde, CHSVoidArg) lookupDftMarshOut hsTy [IOET cTy] = lookupDftMarshOut hsTy [cTy] lookupDftMarshOut "Bool" [PrimET pt] | isIntegralCPrimType pt = do addHsDependency "Foreign.Marshal.Utils" return $ Just (Left cToBoolIde, CHSValArg) lookupDftMarshOut hsTy [PrimET pt] | isIntegralHsType hsTy && isIntegralCPrimType pt = return $ Just (Left cIntConvIde, CHSValArg) lookupDftMarshOut hsTy [PrimET pt] | isFloatHsType hsTy && isFloatCPrimType pt = return $ Just (Left cFloatConvIde, CHSValArg) lookupDftMarshOut "Char" [PrimET CCharPT] = do addHsDependency "Foreign.C.String" return $ Just (Left castCCharToCharIde, CHSValArg) lookupDftMarshOut "Char" [PrimET CUCharPT] = do addHsDependency "Foreign.C.String" return $ Just (Left castCUCharToCharIde, CHSValArg) lookupDftMarshOut "Char" [PrimET CSCharPT] = do addHsDependency "Foreign.C.String" return $ Just (Left castCSCharToCharIde, CHSValArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT)] = do addHsDependency "Foreign.C.String" return $ Just (Left peekCStringIde, CHSIOArg) lookupDftMarshOut "CString" [PtrET (PrimET CCharPT)] = return $ Just (Left returnIde, CHSIOArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT), PrimET pt] | isIntegralCPrimType pt = do addHsDependency "Foreign.C.String" return $ Just (Right $ "\\(s, n) -> " ++ impm "peekCStringLen" ++ " (s, fromIntegral n)", CHSIOArg) lookupDftMarshOut hsTy [PtrET UnitET] | "Ptr " `isPrefixOf` hsTy = return $ Just (Left idIde, CHSValArg) lookupDftMarshOut hsTy [PrimET (CAliasedPT tds hsAlias _)] = do mm <- queryDefaultMarsh $ (Out, tds, False) case mm of Nothing -> if hsTy == hsAlias then return $ Just (Left idIde, CHSValArg) else return Nothing Just m -> return $ Just m lookupDftMarshOut hsTy [PtrET (PrimET (CAliasedPT tds hsAlias _pt))] = do mm <- queryDefaultMarsh $ (Out, tds, True) case mm of Nothing -> if hsTy == hsAlias then return $ Just (Left idIde, CHSValArg) else return Nothing Just m -> return $ Just m lookupDftMarshOut hsty _ = do om <- readCT objmap isenum <- queryEnum hsty res <- case (isenum, (internalIdent hsty) `lookup` om) of -- 1. enumeration hooks (True, Nothing) -> return $ Just (Right "toEnum . fromIntegral", CHSValArg) -- 2. naked and newtype pointer hooks (False, Just (Pointer CHSPtr _)) -> return $ Just (Left idIde, CHSValArg) -- 3. foreign pointer hooks (False, Just (Pointer (CHSForeignPtr Nothing) False)) -> do addHsDependency "Foreign.ForeignPtr" return $ Just (Left newForeignPtr_Ide, CHSIOArg) (False, Just (Pointer (CHSForeignPtr (Just fin)) False)) -> do code <- newForeignPtrCode fin return $ Just (Right $ code, CHSIOArg) -- 4. foreign newtype pointer hooks (False, Just (Pointer (CHSForeignPtr Nothing) True)) -> do addHsDependency "Foreign.ForeignPtr" return $ Just (Right $ "\\x -> " ++ impm "newForeignPtr_ x >>= " ++ " (return . " ++ hsty ++ ")", CHSIOArg) (False, Just (Pointer (CHSForeignPtr (Just fin)) True)) -> do code <- newForeignPtrCode fin return $ Just (Right $ "\\x -> " ++ code ++ " x >>= (return . " ++ hsty ++ ")", CHSIOArg) _ -> return Nothing return res -- FIXME: add combination, such as "peek" plus "cIntConv" etc -- FIXME: handle array-list conversion newForeignPtrCode :: (Ident, Maybe Ident) -> GB String newForeignPtrCode (cide, ohside) = do (_, cide') <- findFunObj cide True let fin = (identToString cide') `maybe` identToString $ ohside addHsDependency "Foreign.ForeignPtr" return $ impm "newForeignPtr" ++ " " ++ fin -- | check for integral Haskell types -- isIntegralHsType :: String -> Bool isIntegralHsType "Int" = True isIntegralHsType "Int8" = True isIntegralHsType "Int16" = True isIntegralHsType "Int32" = True isIntegralHsType "Int64" = True isIntegralHsType "Word8" = True isIntegralHsType "Word16" = True isIntegralHsType "Word32" = True isIntegralHsType "Word64" = True isIntegralHsType "CShort" = True isIntegralHsType "CUShort" = True isIntegralHsType "CInt" = True isIntegralHsType "CUInt" = True isIntegralHsType "CLong" = True isIntegralHsType "CULong" = True isIntegralHsType _ = False -- | check for floating Haskell types -- isFloatHsType :: String -> Bool isFloatHsType "Float" = True isFloatHsType "Double" = True isFloatHsType "CFloat" = True isFloatHsType "CDouble" = True isFloatHsType _ = False isVariadic :: ExtType -> Bool isVariadic (FunET s t) = any isVariadic [s,t] isVariadic (IOET t) = isVariadic t isVariadic (PtrET t) = isVariadic t isVariadic (VarFunET _) = True isVariadic _ = False -- | check for integral C types -- -- * For marshalling purposes C char's are integral types (see also types -- classes for which the FFI guarantees instances for 'CChar', 'CSChar', and -- 'CUChar') -- isIntegralCPrimType :: CPrimType -> Bool isIntegralCPrimType = (`elem` [CCharPT, CSCharPT, CIntPT, CShortPT, CLongPT, CLLongPT, CUIntPT, CUCharPT, CUShortPT, CULongPT, CULLongPT, CBoolPT]) -- | check for floating C types -- isFloatCPrimType :: CPrimType -> Bool isFloatCPrimType = (`elem` [CFloatPT, CDoublePT, CLDoublePT]) -- | standard conversions -- voidIde, cFromBoolIde, cToBoolIde, cIntConvIde, cFloatConvIde, withCStringIde, peekCStringIde, idIde, newForeignPtr_Ide, withForeignPtrIde, returnIde, castCharToCCharIde, castCharToCUCharIde, castCharToCSCharIde, castCCharToCharIde, castCUCharToCharIde, castCSCharToCharIde :: Ident voidIde = internalIdent $ impm "void" -- never appears in the output cFromBoolIde = internalIdent $ impm "fromBool" cToBoolIde = internalIdent $ impm "toBool" cIntConvIde = internalIdent "fromIntegral" cFloatConvIde = internalIdent "realToFrac" withCStringIde = internalIdent $ impm "withCString" peekCStringIde = internalIdent $ impm "peekCString" idIde = internalIdent "id" newForeignPtr_Ide = internalIdent $ impm "newForeignPtr_" withForeignPtrIde = internalIdent $ impm "withForeignPtr" returnIde = internalIdent "return" castCharToCCharIde = internalIdent $ impm "castCharToCChar" castCharToCUCharIde = internalIdent $ impm "castCharToCUChar" castCharToCSCharIde = internalIdent $ impm "castCharToCSChar" castCCharToCharIde = internalIdent $ impm "castCCharToChar" castCUCharToCharIde = internalIdent $ impm "castCUCharToChar" castCSCharToCharIde = internalIdent $ impm "castCSCharToChar" -- expansion of binding hooks -- -------------------------- -- | given a C header file and a binding file, expand all hooks in the binding -- file using the C header information -- -- * together with the module, returns the contents of the .chi file -- -- * if any error (not warnings) is encountered, a fatal error is raised. -- -- * also returns all warning messages encountered (last component of result) -- expandHooks :: AttrC -> CHSModule -> CST s (CHSModule, String, [Wrapper], String) expandHooks ac mod' = do (_, res) <- runCT (expandModule mod') ac initialGBState return res expandModule :: CHSModule -> GB (CHSModule, String, [Wrapper], String) expandModule (CHSModule mfrags) = do -- expand hooks -- traceInfoExpand frags' <- expandFrags mfrags hsdeps <- getHsDependencies let frags'' = addImports frags' hsdeps delayedFrags <- getDelayedCode -- get .chi dump -- chi <- dumpMaps -- check for errors and finalise -- errs <- errorsPresent if errs then do traceInfoErr errmsgs <- showErrors fatal ("Errors during expansion of binding hooks:\n\n" -- fatal error ++ errmsgs) else do traceInfoOK warnmsgs <- showErrors wraps <- getWrappers return (CHSModule (frags'' ++ delayedFrags), chi, wraps, warnmsgs) where traceInfoExpand = putTraceStr tracePhasesSW ("...expanding binding hooks...\n") traceInfoErr = putTraceStr tracePhasesSW ("...error(s) detected.\n") traceInfoOK = putTraceStr tracePhasesSW ("...successfully completed.\n") -- | add import declarations for modules required internally by C2HS -- addImports :: [CHSFrag] -> [String] -> [CHSFrag] addImports fs imps = before ++ impfrags ++ after where impfrags = sp ++ concatMap impfrag imps ++ sp sp = [CHSVerb "\n" imppos] impfrag i = [CHSVerb ("import qualified " ++ i ++ " as " ++ imp) imppos, CHSVerb "\n" imppos] (before, after) = doSplit 0 Nothing False [] fs imppos = posOf $ last before -- Find the appropriate location to put the import -- declarations. This relies heavily on the details of the -- CHS parser to deal with Haskell comments, but a simple -- approach like this seems to be a better idea than using -- haskell-src-exts or something like that, mostly because -- none of the Haskell parsing packages deal with *all* GHC -- extensions. The approach taken here isn't pretty, but it -- seems to work. doSplit :: Int -> Maybe Int -> Bool -> [CHSFrag] -> [CHSFrag] -> ([CHSFrag], [CHSFrag]) doSplit _ Nothing _ _ [] = (fs, []) doSplit _ (Just ln) _ _ [] = splitAt (ln-1) fs doSplit 0 mln wh acc (f@(CHSVerb s pos) : fs') | "--" `isPrefixOf` s = doSplit 0 mln wh (f:acc) fs' | s == "{-" = doSplit 1 mln wh (f:acc) fs' | wh && "where" `isInfixOf` s = (reverse (f:acc), fs') | "module" `isPrefixOf` (dropWhile isSpace s) = if (" where" `isInfixOf` s || ")where" `isInfixOf` s) then (reverse (f:acc), fs') else doSplit 0 mln True (f:acc) fs' | otherwise = if null (dropWhile isSpace s) || isJust mln then doSplit 0 mln wh (f:acc) fs' else doSplit 0 (Just $ posRow pos) wh (f:acc) fs' doSplit cdep mln wh acc (f@(CHSVerb s _) : fs') | s == "-}" = doSplit (cdep-1) mln wh (f:acc) fs' | s == "{-" = doSplit (cdep+1) mln wh (f:acc) fs' | otherwise = doSplit cdep mln wh (f:acc) fs' doSplit cdep mln wh acc (f:fs') = doSplit cdep mln wh (f:acc) fs' expandFrags :: [CHSFrag] -> GB [CHSFrag] expandFrags = liftM concat . mapM expandFrag expandFrag :: CHSFrag -> GB [CHSFrag] expandFrag verb@(CHSVerb _ _ ) = return [verb] expandFrag line@(CHSLine _ ) = return [line] expandFrag (CHSHook h pos) = do code <- expandHook h pos return [CHSVerb code builtinPos] `ifCTExc` return [CHSVerb "** ERROR **" builtinPos] expandFrag (CHSCPP s _ _) = interr $ "GenBind.expandFrag: Left over CHSCPP!\n---\n" ++ s ++ "\n---" expandFrag (CHSC s _ ) = interr $ "GenBind.expandFrag: Left over CHSC!\n---\n" ++ s ++ "\n---" expandFrag (CHSCond alts dft) = do traceInfoCond select alts where select [] = do traceInfoDft dft expandFrags (maybe [] id dft) select ((ide, cfrags):alts') = do oobj <- findTag ide traceInfoVal ide oobj if isNothing oobj then select alts' else -- found right alternative expandFrags cfrags -- traceInfoCond = traceGenBind "** CPP conditional:\n" traceInfoVal ide oobj = traceGenBind $ identToString ide ++ " is " ++ (if isNothing oobj then "not " else "") ++ "defined.\n" traceInfoDft dft' = if isNothing dft' then return () else traceGenBind "Choosing else branch.\n" expandHook :: CHSHook -> Position -> GB String expandHook (CHSImport qual ide chi _) _ = do mergeMaps chi return $ "import " ++ (if qual then "qualified " else "") ++ identToString ide expandHook (CHSContext olib oprefix orepprefix _) _ = do setContext olib oprefix orepprefix -- enter context information -- use the prefix on name spaces when (isJust oprefix) $ applyPrefixToNameSpaces (fromJust oprefix) (maybe "" id orepprefix) return "" expandHook (CHSNonGNU _) _ = return "" expandHook (CHSType ide pos) _ = do traceInfoType decl <- findAndChaseDecl ide False True -- no indirection, but shadows ty <- extractSimpleType False pos decl traceInfoDump (render $ pretty decl) ty when (isVariadic ty) (variadicErr pos (posOf decl)) addExtTypeDependency ty return $ "(" ++ showExtType ty ++ ")" where traceInfoType = traceGenBind "** Type hook:\n" traceInfoDump decl ty = traceGenBind $ "Declaration\n" ++ show decl ++ "\ntranslates to\n" ++ showExtType ty ++ "\n" expandHook (CHSAlignof ide _) _ = do traceInfoAlignof decl <- findAndChaseDeclOrTag ide False True -- no indirection, but shadows checkForIncomplete decl (_, align) <- sizeAlignOf decl traceInfoDump (render $ pretty decl) align return $ show align where traceInfoAlignof = traceGenBind "** alignment hook:\n" traceInfoDump decl align = traceGenBind $ "Alignment of declaration\n" ++ show decl ++ "\nis " ++ show align ++ "\n" expandHook (CHSSizeof ide _) _ = do traceInfoSizeof decl <- findAndChaseDeclOrTag ide False True -- no indirection, but shadows checkForIncomplete decl (sz, _) <- sizeAlignOf decl traceInfoDump (render $ pretty decl) sz return $ show (padBits sz) where traceInfoSizeof = traceGenBind "** Sizeof hook:\n" traceInfoDump decl sz = traceGenBind $ "Size of declaration\n" ++ show decl ++ "\nis " ++ show (padBits sz) ++ "\n" expandHook (CHSEnumDefine _ _ _ _) _ = interr $ "Binding generation error : enum define hooks " ++ "should be eliminated via preprocessing " expandHook (CHSEnum cide oalias chsTrans emit oprefix orepprefix derive pos) _ = do -- get the corresponding C declaration -- enum <- lookupEnum cide True -- smart lookup incl error handling -- -- convert the translation table and generate data type definition code -- gprefix <- getPrefix let pfx = case oprefix of Nothing -> gprefix Just pref -> pref grepprefix <- getReplacementPrefix let reppfx = case orepprefix of Nothing -> grepprefix Just pref -> pref let trans = transTabToTransFun pfx reppfx chsTrans hide = identToString . fromMaybe cide $ oalias enumDef enum hide trans emit (map identToString derive) pos expandHook hook@(CHSCall isPure isUns (CHSRoot _ ide) oalias pos) _ = do traceEnter -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used -- afterwards instead of the original one -- (ObjCO cdecl, ide') <- findFunObj ide True let ideLexeme = identToString ide' -- orignl name might have been a shadow hsLexeme = ideLexeme `maybe` identToString $ oalias cdecl' = ide' `simplifyDecl` cdecl ty <- extractFunType pos cdecl' Nothing let args = concat [ " x" ++ show n | n <- [1..numArgs ty] ] callImport hook isUns [] ideLexeme hsLexeme cdecl' Nothing pos when isPure $ addHsDependency "System.IO.Unsafe" case (isPure, length args) of (False, _) -> return hsLexeme (True, 0) -> return $ "(" ++ impm "unsafePerformIO" ++ " " ++ hsLexeme ++ ")" (True, _) -> return $ "(\\" ++ args ++ " -> " ++ impm "unsafePerformIO" ++ " (" ++ hsLexeme ++ args ++ "))" where traceEnter = traceGenBind $ "** Call hook for `" ++ identToString ide ++ "':\n" expandHook hook@(CHSCall isPure isUns apath oalias pos) _ = do traceEnter (decl, offsets) <- accessPath apath ptrTy <- extractSimpleType False pos decl ty <- case ptrTy of PtrET f@(FunET _ _) -> return f _ -> funPtrExpectedErr pos traceValueType ty set_get <- setGet pos CHSGet offsets Nothing ptrTy Nothing -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used -- afterwards instead of the original one -- -- (ObjCO cdecl, ide) <- findFunObj ide True let ideLexeme = identToString $ apathToIdent apath hsLexeme = ideLexeme `maybe` identToString $ oalias -- cdecl' = ide `simplifyDecl` cdecl args = concat [ " x" ++ show n | n <- [1..numArgs ty] ] callImportDyn hook isUns ideLexeme hsLexeme decl ty pos let res = "(\\o" ++ args ++ " -> " ++ set_get ++ " o >>= \\f -> " ++ hsLexeme ++ " f" ++ args ++ ")" if isPure then do addHsDependency "System.IO.Unsafe" return $ "(" ++ impm "unsafePerformIO" ++ " " ++ res ++ ")" else return res where traceEnter = traceGenBind $ "** Indirect call hook for `" ++ identToString (apathToIdent apath) ++ "':\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n" expandHook (CHSFun isPure isUns _ inVarTypes (CHSRoot _ ide) oalias ctxt parms parm pos) hkpos = do traceEnter traceGenBind $ "ide = '" ++ show ide ++ "'\n" traceGenBind $ "inVarTypes = " ++ show inVarTypes ++ "\n" -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used -- afterwards instead of the original one -- (ObjCO cdecl, cide) <- findFunObj ide True let ideLexeme = identToString ide -- orignal name might have been a shadow hsLexeme = ideLexeme `maybe` identToString $ oalias fiLexeme = hsLexeme ++ "'_" -- Urgh - probably unqiue... fiIde = internalIdent fiLexeme cdecl' = cide `simplifyDecl` cdecl callHook = CHSCall isPure isUns (CHSRoot False cide) (Just fiIde) pos isWrapped (CHSParm _ _ twovals _ w _ _) | twovals = [w, w] | otherwise = [w] isWrapped _ = [False] wrapped = Just $ concatMap isWrapped parms varTypes <- convertVarTypes hsLexeme pos inVarTypes callImport callHook isUns varTypes (identToString cide) fiLexeme cdecl' wrapped pos extTy <- extractFunType pos cdecl' wrapped funDef isPure hsLexeme fiLexeme extTy varTypes ctxt parms parm Nothing pos hkpos where traceEnter = traceGenBind $ "** Fun hook for `" ++ identToString ide ++ "':\n" expandHook (CHSFun isPure isUns _ _ apath oalias ctxt parms parm pos) hkpos = do traceEnter (decl, offsets) <- accessPath apath ptrTy <- extractSimpleType False pos decl ty <- case ptrTy of PtrET f@(FunET _ _) -> return f _ -> funPtrExpectedErr pos traceValueType ty -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used -- afterwards instead of the original one -- -- (ObjCO cdecl, cide) <- findFunObj ide True let ideLexeme = identToString $ apathToIdent apath hsLexeme = ideLexeme `maybe` identToString $ oalias fiLexeme = hsLexeme ++ "'_" -- Urgh - probably unqiue... fiIde = internalIdent fiLexeme -- cdecl' = cide `simplifyDecl` cdecl -- args = concat [ " x" ++ show n | n <- [1..numArgs ty] ] callHook = CHSCall isPure isUns apath (Just fiIde) pos callImportDyn callHook isUns ideLexeme fiLexeme decl ty pos set_get <- setGet pos CHSGet offsets Nothing ptrTy Nothing funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) [] ctxt parms parm (Just set_get) pos hkpos where -- remove IO from the result type of a function ExtType. necessary -- due to an unexpected interaction with the way funDef works purify (FunET a b) = FunET a (purify b) purify (IOET b) = b purify a = a traceEnter = traceGenBind $ "** Fun hook for `" ++ identToString (apathToIdent apath) ++ "':\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n" expandHook (CHSField access path pos) _ = do traceInfoField traceGenBind $ "path = " ++ show path ++ "\n" onewtype <- apathNewtypeName path traceGenBind $ "onewtype = " ++ show onewtype ++ "\n" (decl, offsets) <- accessPath path traceDepth offsets ty <- extractSimpleType False pos decl traceValueType ty setGet pos access offsets (isArrDecl decl) ty onewtype where accessString = case access of CHSGet -> "Get" CHSSet -> "Set" traceInfoField = traceGenBind $ "** " ++ accessString ++ " hook:\n" traceDepth offsets = traceGenBind $ "Depth of access path: " ++ show (length offsets) ++ "\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n" expandHook (CHSOffsetof path pos) _ = do traceGenBind $ "** offsetof hook:\n" (decl, offsets) <- accessPath path traceGenBind $ "Depth of access path: " ++ show (length offsets) ++ "\n" checkType decl offsets >>= \ offset -> return $ "(" ++ show offset ++ ")" where checkType decl [BitSize offset _] = extractCompType True True False decl >>= \ compTy -> case compTy of (VarFunET _) -> variadicErr pos pos (IOET _) -> interr "GenBind.expandHook(CHSOffsetOf): Illegal type!" (UnitET ) -> voidFieldErr pos (DefinedET _ _) -> return offset (PrimET (CUFieldPT _)) -> offsetBitfieldErr pos (PrimET (CSFieldPT _)) -> offsetBitfieldErr pos _ -> return offset checkType _ _ = offsetDerefErr pos expandHook hook@(CHSPointer isStar cName oalias ptrKind isNewtype oRefType emit pos) _ = do traceInfoPointer let hsIde = fromMaybe cName oalias hsName = identToString hsIde hsIde `objIs` Pointer ptrKind isNewtype -- register Haskell object decl <- findAndChaseDeclOrTag cName False True (sz, _) <- sizeAlignOfPtr decl hsIde `sizeIs` (padBits sz) -- -- we check for a typedef declaration or tag (struct, union, or enum) -- declOrTag <- lookupDeclOrTag cName True case declOrTag of Left cdecl -> do -- found a typedef declaration cNameFull <- case declaredName cdecl of Just ide -> return ide Nothing -> interr "GenBind.expandHook: Where is the name?" cNameFull `refersToNewDef` ObjCD (TypeCO cdecl) -- assoc needed for chasing traceInfoCName "declaration" cNameFull unless (isStar || isPtrDecl cdecl) $ ptrExpectedErr (posOf cName) (hsType, isFun) <- case oRefType of [] -> do cDecl <- chaseDecl cNameFull (not isStar) et <- extractPtrType cDecl traceInfoPtrType et let et' = adjustPtr isStar et when (isVariadic et') (variadicErr pos (posOf cDecl)) addExtTypeDependency et' return (showExtType et', isFunExtType et') hsType -> return (identsToString hsType, False) -- FIXME: it is not possible to determine whether `hsType' -- is a function; we would need to extend the syntax to -- allow `... -> fun HSTYPE' to explicitly mark function -- types if this ever becomes important traceInfoHsType hsName hsType doFinalizer hook ptrKind (if isNewtype then hsName else "()") pointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun emit Right tag -> do -- found a tag definition let cNameFull = tagName tag traceInfoCName "tag definition" cNameFull unless isStar $ -- tags need an explicit `*' ptrExpectedErr (posOf cName) let hsType = case oRefType of [] -> "()" hsType' -> identsToString hsType' traceInfoHsType hsName hsType doFinalizer hook ptrKind (if isNewtype then hsName else "()") pointerDef isStar cNameFull hsName ptrKind isNewtype hsType False emit where -- remove a pointer level if the first argument is `False' -- adjustPtr True et = et adjustPtr False (PtrET et) = et adjustPtr False (DefinedET _ _) = interr "GenBind.adjustPtr: Can't adjust defined type" adjustPtr _ _ = interr "GenBind.adjustPtr: Where is the Ptr?" -- traceInfoPointer = traceGenBind "** Pointer hook:\n" traceInfoPtrType et = traceGenBind $ "extracted ptr type is `" ++ showExtType et ++ "'\n" traceInfoHsType name ty = traceGenBind $ "associated with Haskell entity `" ++ name ++ "'\nhaving type " ++ ty ++ "\n" traceInfoCName kind ide = traceGenBind $ "found C " ++ kind ++ " for `" ++ identToString ide ++ "'\n" identsToString :: [Ident] -> String identsToString = intercalate " " . map identToString expandHook (CHSClass oclassIde classIde typeIde pos) _ = do traceInfoClass classIde `objIs` Class (fmap identToString oclassIde) (identToString typeIde) -- register Haskell object superClasses <- collectClasses oclassIde Pointer ptrType isNewtype <- queryPointer typeIde when (ptrType == CHSStablePtr) $ illegalStablePtrErr pos classDef pos (identToString classIde) (identToString typeIde) ptrType isNewtype superClasses where -- compile a list of all super classes (the direct super class first) -- collectClasses :: Maybe Ident -> GB [(String, String, HsObject)] collectClasses Nothing = return [] collectClasses (Just ide) = do Class oclassIde' typeIde' <- queryClass ide ptr <- queryPointer (internalIdent typeIde') classes <- collectClasses (fmap internalIdent oclassIde') return $ (identToString ide, typeIde', ptr) : classes -- traceInfoClass = traceGenBind $ "** Class hook:\n" expandHook (CHSConst cIde _) _ = do traceGenBind "** Constant hook:\n" Just (ObjCO cdecl) <- findObj cIde let (Just ini) = initDeclr cdecl return . show . pretty $ ini expandHook (CHSTypedef cIde hsIde pos) _ = do traceGenBind $ "** Typedef hook: " ++ identToString cIde ++ " -> " ++ identToString hsIde ++ "\n" let def = "__c2hs_typedef__" ++ identToString cIde ++ "__" ++ identToString hsIde Just (ObjCO cdecl) <- findObj $ internalIdent def st <- extractCompType True True False cdecl et <- case st of PrimET e -> return e _ -> typeDefaultErr pos cIde `isC2HSTypedef` (hsIde, et) return "" expandHook (CHSDefault dir hsTy cTy cPtr marsh pos) _ = do traceGenBind $ "** Default hook: " ++ hsTy ++ " [" ++ cTy ++ (if cPtr then " *" else "") ++ "]\n" mtypedef <- queryTypedef $ internalIdent cTy case mtypedef of Nothing -> typeDefaultErr pos Just (tdide, _) -> do let def = "__c2hs_typedef__" ++ cTy ++ "__" ++ identToString tdide Just (ObjCO cdecl) <- findObj $ internalIdent def st <- extractCompType True True False cdecl case st of PrimET _ -> do (dir, cTy, cPtr) `isDefaultMarsh` marsh return "" _ -> typeDefaultErr pos apathNewtypeName :: CHSAPath -> GB (Maybe Ident) apathNewtypeName path = do let ide = apathRootIdent path pm <- readCT ptrmap case (True, ide) `lookup` pm of Nothing -> return Nothing Just (hsty, _) -> do om <- readCT objmap let hside = internalIdent hsty case hside `lookup` om of Just (Pointer _ True) -> return (Just hside) _ -> return Nothing -- | produce code for an enumeration -- -- * an extra instance declaration is required when any of the enumeration -- constants is explicitly assigned a value in its definition -- -- * the translation function strips prefixes where possible (different -- enumerators maye have different prefixes) -- enumDef :: CEnum -> String -> TransFun -> Bool -> [String] -> Position -> GB String enumDef (CEnum _ Nothing _ _) _ _ _ _ pos = undefEnumErr pos enumDef (CEnum _ (Just list) _ _) hident trans emit userDerive _ = do (list', enumAuto) <- evalTagVals list let enumVals = map (\(Just i, e) -> (i, e)) $ filter (isJust . fst) $ fixTags [(trans ide, cexpr) | (ide, cexpr) <- list'] defHead = enumHead hident defBody = enumBody (length defHead - 2) enumVals dataDef = if emit then defHead ++ defBody else "" inst = makeDerives (if enumAuto then "Enum" : userDerive else userDerive) ++ "\n" ++ if enumAuto then "" else enumInst hident enumVals isEnum hident return $ dataDef ++ inst where evalTagVals = liftM (second and . unzip) . mapM (uncurry evalTag) evalTag ide Nothing = return ((ide, Nothing), True) evalTag ide (Just exp) = do val <- evalConstCExpr exp case val of IntResult v -> return ((ide, Just v), False) FloatResult _ -> illegalConstExprErr (posOf exp) "a float result" makeDerives [] = "" makeDerives dList = "\n deriving (" ++ intercalate "," dList ++ ")" -- Fix implicit tag values fixTags = go 0 where go _ [] = [] go n ((ide, exp):rest) = let val = case exp of Nothing -> n Just m -> m in (ide, val) : go (val+1) rest -- | Haskell code for the head of an enumeration definition -- enumHead :: String -> String enumHead ident = "data " ++ ident ++ " = " -- | Haskell code for the body of an enumeration definition -- enumBody :: Int -> [(String, Integer)] -> String enumBody indent ides = constrs where constrs = intercalate separator . map fst $ sortBy (comparing snd) ides separator = "\n" ++ replicate indent ' ' ++ "| " -- | Num instance for C Integers -- We should preserve type flags and repr if possible instance Num CInteger where fromInteger = cInteger (+) a b = cInteger (getCInteger a + getCInteger b) (*) a b = cInteger (getCInteger a * getCInteger b) (-) a b = cInteger (getCInteger a - getCInteger b) abs a = cInteger (abs $ getCInteger a) signum a = cInteger (signum $ getCInteger a) -- | Haskell code for an instance declaration for 'Enum' -- -- * the expression of all explicitly specified tag values already have to be -- in normal form, ie, to be an int constant -- -- * enumerations start at 0 and whenever an explicit value is specified, -- following tags are assigned values continuing from the explicitly -- specified one -- enumInst :: String -> [(String, Integer)] -> String enumInst ident list' = intercalate "\n" [ "instance Enum " ++ wrap ident ++ " where" , succDef , predDef , enumFromToDef , enumFromDef , fromDef , toDef ] where wrap s = if ' ' `elem` s then "(" ++ s ++ ")" else s concatFor = flip concatMap -- List of _all values_ (including aliases) and their associated tags list = sortBy (comparing snd) list' -- List of values without aliases and their associated tags toList = stripAliases list -- Generate explicit tags for all values: succDef = let idents = map fst toList aliases = map (map fst) $ groupBy ((==) `on` snd) list defs = concat $ zipWith (\is s -> concatFor is $ \i -> " succ " ++ i ++ " = " ++ s ++ "\n") aliases (tail idents) lasts = concatFor (last aliases) $ \i -> " succ " ++ i ++ " = error \"" ++ ident ++ ".succ: " ++ i ++ " has no successor\"\n" in defs ++ lasts predDef = let idents = map fst toList aliases = map (map fst) $ groupBy ((==) `on` snd) list defs = concat $ zipWith (\is s -> concatFor is $ \i -> " pred " ++ i ++ " = " ++ s ++ "\n") (tail aliases) idents firsts = concatFor (head aliases) $ \i -> " pred " ++ i ++ " = error \"" ++ ident ++ ".pred: " ++ i ++ " has no predecessor\"\n" in defs ++ firsts enumFromToDef = intercalate "\n" [ " enumFromTo from to = go from" , " where" , " end = fromEnum to" , " go v = case compare (fromEnum v) end of" , " LT -> v : go (succ v)" , " EQ -> [v]" , " GT -> []" , "" ] enumFromDef = let lastIdent = fst $ last list in " enumFrom from = enumFromTo from " ++ lastIdent ++ "\n" fromDef = concatFor list (\(ide, val) -> " fromEnum " ++ ide ++ " = " ++ show' val ++ "\n") toDef = (concatFor toList (\(ide, val) -> " toEnum " ++ show' val ++ " = " ++ ide ++ "\n")) -- Default case: ++ " toEnum unmatched = error (\"" ++ ident ++ ".toEnum: Cannot match \" ++ show unmatched)\n" show' x = if x < 0 then "(" ++ show x ++ ")" else show x stripAliases :: [(String, Integer)] -> [(String, Integer)] stripAliases = nubBy ((==) `on` snd) -- | generate a foreign import declaration that is put into the delayed code -- -- * the C declaration is a simplified declaration of the function that we -- want to import into Haskell land -- callImport :: CHSHook -> Bool -> [ExtType] -> String -> String -> CDecl -> Maybe [Bool] -> Position -> GB () callImport hook isUns varTypes ideLexeme hsLexeme cdecl owrapped pos = do -- compute the external type from the declaration, and delay the foreign -- export declaration -- extType <- extractFunType pos cdecl owrapped header <- getSwitch headerSB let bools@(boolres, boolargs) = boolArgs extType needwrapper1 = boolres || or boolargs (needwrapper2, wraps) = case owrapped of Nothing -> (False, replicate (numArgs extType) False) Just ws -> if or ws then (True, ws) else (False, replicate (numArgs extType) False) ide = if needwrapper1 || needwrapper2 then "__c2hs_wrapped__" ++ ideLexeme else ideLexeme addExtTypeDependency extType delayCode hook (foreignImport (extractCallingConvention cdecl) header ide hsLexeme isUns extType varTypes) when (needwrapper1 || needwrapper2) $ addWrapper ide ideLexeme cdecl wraps bools pos traceFunType extType where traceFunType et = traceGenBind $ "Imported function type: " ++ showExtType et ++ "\n" callImportDyn :: CHSHook -> Bool -> String -> String -> CDecl -> ExtType -> Position -> GB () callImportDyn hook isUns ideLexeme hsLexeme cdecl ty pos = do -- compute the external type from the declaration, and delay the foreign -- export declaration -- when (isVariadic ty) (variadicErr pos (posOf cdecl)) addExtTypeDependency ty delayCode hook (foreignImportDyn (extractCallingConvention cdecl) ideLexeme hsLexeme isUns ty) traceFunType ty where traceFunType et = traceGenBind $ "Imported function type: " ++ showExtType et ++ "\n" -- | Haskell code for the foreign import declaration needed by a call hook -- foreignImport :: CallingConvention -> String -> String -> String -> Bool -> ExtType -> [ExtType] -> String foreignImport cconv header ident hsIdent isUnsafe ty vas = "foreign import " ++ showCallingConvention cconv ++ " " ++ safety ++ " " ++ show entity ++ "\n " ++ hsIdent ++ " :: " ++ showExtFunType ty vas ++ "\n" where safety = if isUnsafe then "unsafe" else "safe" entity | null header = ident | otherwise = header ++ " " ++ ident -- | Haskell code for the foreign import dynamic declaration needed by -- a call hook -- foreignImportDyn :: CallingConvention -> String -> String -> Bool -> ExtType -> String foreignImportDyn cconv _ident hsIdent isUnsafe ty = "foreign import " ++ showCallingConvention cconv ++ " " ++ safety ++ " \"dynamic\"\n " ++ hsIdent ++ " :: " ++ impm "FunPtr" ++ "( " ++ showExtType ty ++ " ) -> " ++ showExtType ty ++ "\n" where safety = if isUnsafe then "unsafe" else "safe" -- | produce a Haskell function definition for a fun hook -- -- * FIXME: There's an ugly special case in here: to support dynamic fun hooks -- I had to add a special second marshaller for the first argument, -- which, if present, is inserted just before the function call. This -- is probably not the most elegant solution, it's just the only one I -- can up with at the moment. If present, this special marshaller is -- an io action (like 'peek' and unlike 'with'). -- US funDef :: Bool -- pure function? -> String -- name of the new Haskell function -> String -- Haskell name of the foreign imported C function -> ExtType -- simplified declaration of the C function -> [ExtType] -- simplified declaration of the C function -> Maybe String -- type context of the new Haskell function -> [CHSParm] -- parameter marshalling description -> CHSParm -- result marshalling description -> Maybe String -- optional additional marshaller for first arg -> Position -- source location of the hook -> Position -- source location of the start of the hook -> GB String -- Haskell code in text form funDef isPure hsLexeme fiLexeme extTy varExtTys octxt parms parm@(CHSParm _ hsParmTy _ _ _ _ _) marsh2 pos hkpos = do when (countPlus parms > 1 || isPlus parm) $ illegalPlusErr pos (parms', parm') <- addDftMarshaller pos parms parm extTy varExtTys traceMarsh parms' parm' marshs <- zipWithM marshArg [1..] parms' let sig = hsLexeme ++ " :: " ++ funTy parms' parm' ++ "\n" funArgs = [funArg | (funArg, _, _, _, _) <- marshs, funArg /= ""] marshIns = [marshIn | (_, marshIn, _, _, _) <- marshs] callArgs = [callArg | (_, _, cs, _, _) <- marshs, callArg <- cs] marshOuts = [marshOut | (_, _, _, marshOut, _) <- marshs, marshOut /= ""] retArgs = [retArg | (_, _, _, _, retArg) <- marshs, retArg /= ""] funHead = hsLexeme ++ join funArgs ++ " =\n" ++ if isPure then " " ++ impm "unsafePerformIO" ++ " $\n" else "" call = " " ++ fiLexeme ++ joinCallArgs ++ case parm of CHSParm _ "()" _ Nothing _ _ _ -> " >>\n" _ -> if countPlus parms == 1 then " >>\n" else " >>= \\res ->\n" joinCallArgs = case marsh2 of Nothing -> join callArgs Just _ -> join ("b1'" : drop 1 callArgs) mkMarsh2 = case marsh2 of Nothing -> "" Just m -> " " ++ m ++ " " ++ join (take 1 callArgs) ++ " >>= \\b1' ->\n" marshRes = if countPlus parms == 1 then "" else case parm' of CHSParm _ _ _twoCVal (Just (_, CHSVoidArg)) _ _ _ -> "" CHSParm _ _ _twoCVal (Just (omBody, CHSIOVoidArg)) _ _ _ -> " " ++ marshBody omBody ++ " res >> \n" CHSParm _ _ _twoCVal (Just (omBody, CHSIOArg)) _ _ _ -> " " ++ marshBody omBody ++ " res >>= \\res' ->\n" CHSParm _ _ _twoCVal (Just (omBody, CHSValArg)) _ _ _ -> " let {res' = " ++ marshBody omBody ++ " res} in\n" CHSParm _ _ _ Nothing _ _ _ -> interr "GenBind.funDef: marshRes: no default?" marshBody (Left ide) = identToString ide marshBody (Right str) = "(" ++ str ++ ")" retArgs' = case parm' of CHSParm _ _ _ (Just (_, CHSVoidArg)) _ _ _ -> retArgs CHSParm _ _ _ (Just (_, CHSIOVoidArg)) _ _ _ -> retArgs _ -> if countPlus parms == 0 then "res'":retArgs else retArgs ret = "(" ++ concat (intersperse ", " retArgs') ++ ")" funBody = joinLines marshIns ++ mkMarsh2 ++ call ++ marshRes ++ joinLines marshOuts ++ " return " ++ ret pad code = let padding = replicate (posColumn hkpos - 1) ' ' (l:ls) = lines code in unlines $ l : map (padding ++) ls when isPure $ addHsDependency "System.IO.Unsafe" return $ pad $ sig ++ funHead ++ funBody where countPlus :: [CHSParm] -> Int countPlus = sum . map (\p -> if isPlus p then 1 else 0) isPlus (CHSPlusParm _) = True isPlus _ = False join = concatMap (' ':) joinLines = concatMap (\s -> " " ++ s ++ "\n") -- -- construct the function type -- -- * specified types appear in the argument and result only if their "in" -- and "out" marshaller, respectively, is not the `void' marshaller -- funTy parms' parm' = let showComment str = if null str then "" else " --" ++ str ++ "\n" ctxt = case octxt of Nothing -> "" Just ctxtStr -> ctxtStr ++ " => " argTys = ["(" ++ ty ++ ")" ++ showComment c | CHSParm im ty _ _ _ _ c <- parms', notVoid im] resTys = ["(" ++ ty ++ ")" | CHSParm _ ty _ om _ _ _ <- parm':parms', notVoid om] resTup = let comment = case parm' of CHSParm _ _ _ _ _ _ c -> c (lp, rp) = if isPure && length resTys == 1 then ("", "") else ("(", ")") io = if isPure then "" else "IO " in io ++ lp ++ concat (intersperse ", " resTys) ++ rp ++ showComment comment in ctxt ++ concat (intersperse " -> " (argTys ++ [resTup])) where notVoid Nothing = interr "GenBind.funDef: No default marshaller?" notVoid (Just (_, kind)) = kind /= CHSVoidArg && kind /= CHSIOVoidArg -- -- for an argument marshaller, generate all "in" and "out" marshalling -- code fragments -- marshArg i (CHSParm (Just (imBody, imArgKind)) _ twoCVal (Just (omBody, omArgKind)) _ _ _ ) = do let a = "a" ++ show (i :: Int) imStr = marshBody imBody imApp = imStr ++ " " ++ a funArg = if imArgKind == CHSVoidArg then "" else a inBndr = if twoCVal then "(" ++ a ++ "'1, " ++ a ++ "'2)" else a ++ "'" marshIn = case imArgKind of CHSVoidArg -> imStr ++ " $ \\" ++ inBndr ++ " -> " CHSIOArg -> imApp ++ " $ \\" ++ inBndr ++ " -> " CHSValArg -> "let {" ++ inBndr ++ " = " ++ imApp ++ "} in " callArgs = if twoCVal then [a ++ "'1 ", a ++ "'2"] else [a ++ "'"] omApp = marshBody omBody ++ " " ++ join callArgs outBndr = a ++ "''" marshOut = case omArgKind of CHSVoidArg -> "" CHSIOVoidArg -> omApp ++ ">>" CHSIOArg -> omApp ++ ">>= \\" ++ outBndr ++ " -> " CHSValArg -> "let {" ++ outBndr ++ " = " ++ omApp ++ "} in " retArg = if omArgKind == CHSVoidArg || omArgKind == CHSIOVoidArg then "" else outBndr marshBody (Left ide) = identToString ide marshBody (Right str) = "(" ++ str ++ ")" return (funArg, marshIn, callArgs, marshOut, retArg) marshArg i (CHSPlusParm ptype) = do szstr <- case ptype of CHSPlusBare -> do msize <- querySize $ internalIdent hsParmTy case msize of Nothing -> interr "Missing size for \"+\" parameter allocation!" Just sz -> return $ show sz CHSPlusS -> return $ "(sizeOf (undefined :: " ++ hsParmTy ++ "))" CHSPlusNum sz -> return $ show sz let a = "a" ++ show (i :: Int) bdr1 = a ++ "'" bdr2 = a ++ "''" marshIn = impm "mallocForeignPtrBytes" ++ " " ++ szstr ++ " >>= \\" ++ bdr2 ++ " -> " ++ impm "withForeignPtr" ++ " " ++ bdr2 ++ " $ \\" ++ bdr1 ++ " -> " addHsDependency "Foreign.ForeignPtr" return ("", marshIn, [bdr1], "", hsParmTy ++ " " ++ bdr2) marshArg _ _ = interr "GenBind.funDef: Missing default?" -- traceMarsh parms' parm' = traceGenBind $ "Marshalling specification including defaults: \n" ++ showParms (parms' ++ [parm']) "\n" where showParms [] = id showParms (parm'':parms'') = showString " " . showCHSParm parm'' . showChar '\n' . showParms parms'' -- | add default marshallers for "in" and "out" marshalling -- addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> ExtType -> [ExtType] -> GB ([CHSParm], CHSParm) addDftMarshaller pos parms parm extTy varExTys = do let (resTy, argTys) = splitFunTy extTy varExTys parm' <- checkResMarsh parm resTy parms' <- addDft parms argTys return (parms', parm') where -- the result marshalling may not use an "in" marshaller and can only have -- one C value -- -- * a default marshaller maybe used for "out" marshalling -- checkResMarsh (CHSParm (Just _) _ _ _ _ pos' _) _ = resMarshIllegalInErr pos' checkResMarsh (CHSParm _ _ True _ _ pos' _) _ = resMarshIllegalTwoCValErr pos' checkResMarsh (CHSParm _ ty _ omMarsh _ pos' c) cTy = do imMarsh' <- addDftVoid Nothing omMarsh' <- addDftOut pos' omMarsh ty [cTy] return (CHSParm imMarsh' ty False omMarsh' False pos' c) -- splitFunTy (FunET UnitET ty) vts = splitFunTy ty vts splitFunTy (FunET ty1 ty2) vts = let (resTy, argTys) = splitFunTy ty2 vts in (resTy, ty1:argTys) splitFunTy (VarFunET ty2) vts = let (resTy, argTys) = splitFunTy ty2 [] in (resTy, argTys ++ vts) splitFunTy resTy _ = (resTy, []) -- -- match Haskell with C arguments (and results) -- addDft (p@(CHSPlusParm _):parms'') (_:cTys) = do parms' <- addDft parms'' cTys return (p : parms') addDft ((CHSParm imMarsh hsTy False omMarsh _ p c):parms'') (cTy:cTys) = do imMarsh' <- addDftIn p imMarsh hsTy [cTy] omMarsh' <- addDftVoid omMarsh parms' <- addDft parms'' cTys return (CHSParm imMarsh' hsTy False omMarsh' False p c : parms') addDft ((CHSParm imMarsh hsTy True omMarsh _ p c):parms'') (ct1:ct2:cts) = do imMarsh' <- addDftIn p imMarsh hsTy [ct1, ct2] omMarsh' <- addDftVoid omMarsh parms' <- addDft parms'' cts return (CHSParm imMarsh' hsTy True omMarsh' False p c : parms') addDft [] [] = return [] addDft ((CHSParm _ _ _ _ _ pos' _):_) [] = marshArgMismatchErr pos' "This parameter is in excess of the C arguments." addDft [] (_:_) = marshArgMismatchErr pos "Parameter marshallers are missing." -- addDftIn _ imMarsh@(Just (_, _)) _ _ = return imMarsh addDftIn pos' _imMarsh@Nothing hsTy cts = do marsh <- lookupDftMarshIn hsTy cts when (isNothing marsh) $ noDftMarshErr pos' "\"in\"" hsTy cts return marsh -- addDftOut _ omMarsh@(Just (_, _)) _ _ = return omMarsh addDftOut pos' _omMarsh@Nothing hsTy cts = do marsh <- lookupDftMarshOut hsTy cts when (isNothing marsh) $ noDftMarshErr pos' "\"out\"" hsTy cts return marsh -- -- add void marshaller if no explict one is given -- addDftVoid marsh@(Just (_, _)) = return marsh addDftVoid Nothing = return $ Just (Left (internalIdent "void"), CHSVoidArg) -- | compute from an access path, the declarator finally accessed and the index -- path required for the access -- -- * each element in the index path specifies dereferencing an address and the -- offset to be added to the address before dereferencing -- -- * the returned declaration is already normalised (ie, alias have been -- expanded) -- -- * it may appear as if `t.m' and `t->m' should have different access paths, -- as the latter specifies one more dereferencing; this is certainly true in -- C, but it doesn't apply here, as `t.m' is merely provided for the -- convenience of the interface writer - it is strictly speaking an -- impossible access paths, as in Haskell we always have a pointer to a -- structure, we can never have the structure as a value itself -- accessPath :: CHSAPath -> GB (CDecl, [BitSize]) accessPath (CHSRoot _ ide) = -- t do decl <- findAndChaseDecl ide False True return (ide `simplifyDecl` decl, [BitSize 0 0]) accessPath (CHSDeref (CHSRoot _ ide) _) = -- *t do decl <- findAndChaseDecl ide True True return (ide `simplifyDecl` decl, [BitSize 0 0]) accessPath (CHSRef (CHSRoot str ide1) ide2) = -- t.m do su <- lookupStructUnion ide1 str True (offset, decl') <- refStruct su ide2 adecl <- replaceByAlias decl' return (adecl, [offset]) accessPath (CHSRef (CHSDeref (CHSRoot str ide1) _) ide2) = -- t->m do su <- lookupStructUnion ide1 str True (offset, decl') <- refStruct su ide2 adecl <- replaceByAlias decl' return (adecl, [offset]) accessPath (CHSRef path ide) = -- a.m do (decl, offset:offsets) <- accessPath path assertPrimDeclr ide decl su <- structFromDecl (posOf ide) decl (addOffset, decl') <- refStruct su ide adecl <- replaceByAlias decl' return (adecl, offset `addBitSize` addOffset : offsets) where assertPrimDeclr ide' (CDecl _ [declr] _) = case declr of (Just (CDeclr _ [] _ _ _), _, _) -> return () _ -> structExpectedErr ide' accessPath (CHSDeref path _pos) = -- *a do (decl, offsets) <- accessPath path decl' <- derefOrErr decl adecl <- replaceByAlias decl' return (adecl, BitSize 0 0 : offsets) where derefOrErr (CDecl specs [(Just declr, oinit, oexpr)] at) = do declr' <- derefDeclr declr return $ CDecl specs [(Just declr', oinit, oexpr)] at derefDeclr (CDeclr oid (CPtrDeclr _ _: derived') asm ats n) = return $ CDeclr oid derived' asm ats n derefDeclr (CDeclr _oid _unexp_deriv _ _ n) = ptrExpectedErr (posOf n) -- | replaces a decleration by its alias if any -- -- * the alias inherits any field size specification that the original -- declaration may have -- -- * declaration must have exactly one declarator -- replaceByAlias :: CDecl -> GB CDecl replaceByAlias cdecl@(CDecl _ [(_, _, sz)] _at) = do ocdecl <- checkForAlias cdecl case ocdecl of Nothing -> return cdecl Just (CDecl specs [(declr, init', _)] at) -> -- form of an alias return $ CDecl specs [(declr, init', sz)] at -- | given a structure declaration and member name, compute the offset of the -- member in the structure and the declaration of the referenced member -- refStruct :: CStructUnion -> Ident -> GB (BitSize, CDecl) refStruct su ide = do -- get the list of fields and check for our selector -- let (fields, tag) = structMembers su (pre, post) = span (not . flip declNamed ide) fields when (null post) $ unknownFieldErr (posOf su) ide -- -- get sizes of preceding fields and the result type (`pre' are all -- declarators preceding `ide' and the first declarator in `post' defines -- `ide') -- let decl = head post offset <- case tag of CStructTag -> offsetInStruct pre decl tag CUnionTag -> return $ BitSize 0 0 return (offset, decl) -- | does the given declarator define the given name? -- declNamed :: CDecl -> Ident -> Bool (CDecl _ [(Nothing , _, _)] _) `declNamed` _ = False (CDecl _ [(Just declr, _, _)] _) `declNamed` ide = declr `declrNamed` ide cdecl@(CDecl _ [] _) `declNamed` _ = errorAtPos (posOf cdecl) ["GenBind.declNamed: Abstract declarator in structure!"] cdecl `declNamed` _ = errorAtPos (posOf cdecl) ["GenBind.declNamed: More than one declarator!"] -- | Haskell code for writing to or reading from a struct -- setGet :: Position -> CHSAccess -> [BitSize] -> Maybe Int -> ExtType -> Maybe Ident -> GB String setGet pos access offsets arrSize ty onewtype = do let pre = case (access, onewtype) of (CHSSet, Nothing) -> "(\\ptr val -> do {" (CHSGet, Nothing) -> "(\\ptr -> do {" (CHSSet, Just ide) -> "(\\(" ++ identToString ide ++ " ptr) val -> do {" (CHSGet, Just ide) -> "(\\(" ++ identToString ide ++ " ptr) -> do {" body <- setGetBody (reverse offsets) return $ pre ++ body ++ "})" where setGetBody [BitSize offset bitOffset] = do bf <- checkType ty case bf of Nothing -> case access of -- not a bitfield CHSGet -> peekOp offset ty arrSize CHSSet -> pokeOp offset ty "val" arrSize --FIXME: must take `bitfieldDirection' into account Just (_, bs) -> case access of -- a bitfield CHSGet -> do op <- peekOp offset ty arrSize addHsDependency "Data.Bits" addHsDependency "Foreign.C.Types" return $ "val <- " ++ op ++ extractBitfield CHSSet -> do op <- peekOp offset ty arrSize op2 <- pokeOp offset ty "val'" arrSize addHsDependency "Data.Bits" addHsDependency "Foreign.C.Types" return $ "org <- " ++ op ++ insertBitfield ++ op2 where -- we have to be careful here to ensure proper sign extension; -- in particular, shifting right followed by anding a mask is -- *not* sufficient; instead, we exploit in the following that -- `shiftR' performs sign extension -- extractBitfield = "; return $ (val `" ++ impm "shiftL" ++ "` (" ++ bitsPerField ++ " - " ++ show (bs + bitOffset) ++ ")) `" ++ impm "shiftR" ++ "` (" ++ bitsPerField ++ " - " ++ show bs ++ ")" bitsPerField = show $ size CIntPT * 8 -- insertBitfield = "; let {val' = (org " ++ impm ".&." ++ " " ++ middleMask ++ ") " ++ impm ".|." ++ " (val `" ++ impm "shiftL" ++ "` " ++ show bitOffset ++ ")}; " middleMask = "fromIntegral (((maxBound::" ++ impm "CUInt" ++ ") `" ++ impm "shiftL" ++ "` " ++ show bs ++ ") `" ++ impm "rotateL" ++ "` " ++ show bitOffset ++ ")" setGetBody (BitSize offset 0 : offsetsrem) = do code <- setGetBody offsetsrem addHsDependency "Foreign.Storable" return $ "ptr <- " ++ impm "peekByteOff" ++ " ptr " ++ show offset ++ "; " ++ code setGetBody (BitSize _ _ : _ ) = derefBitfieldErr pos -- -- check that the type can be marshalled and compute extra operations for -- bitfields -- checkType (VarFunET _ ) = variadicErr pos pos checkType (IOET _ ) = errorAtPos pos ["GenBind.setGet: Illegal \ \type!"] checkType (UnitET ) = voidFieldErr pos checkType (DefinedET _ _ ) = return Nothing-- can't check further checkType (PrimET (CUFieldPT bs)) = return $ Just (False, bs) checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs) checkType _ = return Nothing -- peekOp off (PrimET CBoolPT) Nothing = do addHsDependency "Foreign.Marshal.Utils" addHsDependency "Foreign.C.Types" addHsDependency "Foreign.Storable" return $ impm "toBool" ++ " `fmap` (" ++ impm "peekByteOff" ++ " ptr " ++ show off ++ " :: IO " ++ impm "CInt" ++ ")" peekOp off t Nothing = do addHsDependency "Foreign.Storable" addExtTypeDependency t return $ impm "peekByteOff" ++ " ptr " ++ show off ++ " :: IO " ++ showExtType t peekOp off t (Just _) = do addHsDependency "Foreign.Ptr" addExtTypeDependency t return $ "return $ ptr `" ++ impm "plusPtr" ++ "` " ++ show off ++ " :: IO " ++ showExtType t pokeOp off (PrimET CBoolPT) var Nothing = do addHsDependency "Foreign.Marshal.Utils" addHsDependency "Foreign.C.Types" addHsDependency "Foreign.Storable" return $ impm "pokeByteOff" ++ " ptr " ++ show off ++ " (" ++ impm "fromBool" ++ " " ++ var ++ " :: " ++ impm "CInt" ++ ")" pokeOp off t var Nothing = do addHsDependency "Foreign.Storable" addExtTypeDependency t return $ impm "pokeByteOff" ++ " ptr " ++ show off ++ " (" ++ var ++ " :: " ++ showExtType t ++ ")" pokeOp off t var (Just sz) = do addHsDependency "Foreign.Ptr" addHsDependency "Foreign.Marshal.Array" addExtTypeDependency t return $ impm "copyArray" ++ " (ptr `" ++ impm "plusPtr" ++ "` " ++ show off ++ ") (" ++ var ++ " :: " ++ showExtType t ++ ") " ++ show sz -- | generate the type definition for a pointer hook and enter the required type -- mapping into the 'ptrmap' -- pointerDef :: Bool -- explicit `*' in pointer hook -> Ident -- full C name -> String -- Haskell name -> CHSPtrType -- kind of the pointer -> Bool -- explicit newtype tag -> String -- Haskell type expression of pointer argument -> Bool -- do we have a pointer to a function? -> Bool -- shall we emit code? -> GB String pointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun emit = do let ptrArg = if isNewtype then hsName -- abstract type else hsType -- concrete type ptrCon = case ptrKind of CHSPtr | isFun -> impm "FunPtr" _ -> impm $ show ptrKind ptrType = ptrCon ++ " (" ++ ptrArg ++ ")" thePtr = (isStar, cNameFull) case ptrKind of CHSPtr -> addHsDependency "Foreign.Ptr" CHSForeignPtr _ -> do addHsDependency "Foreign.ForeignPtr" addHsDependency "Foreign.Ptr" CHSStablePtr -> addHsDependency "Foreign.StablePtr" case ptrKind of CHSForeignPtr _ -> do thePtr `ptrMapsTo` (impm "Ptr (" ++ ptrArg ++ ")", impm "Ptr (" ++ ptrArg ++ ")") _ -> thePtr `ptrMapsTo` (hsName, hsName) return $ case (emit, isNewtype) of (False, _) -> "" -- suppress code generation (True , True) -> "newtype " ++ hsName ++ " = " ++ hsName ++ " (" ++ ptrType ++ ")" ++ withForeignFun (True , False) -> "type " ++ hsName ++ " = " ++ ptrType where -- if we have a foreign pointer wrapped into a newtype, provide a -- safe unwrapping function automatically -- withForeignFun | isForeign ptrKind = "\nwith" ++ hsName ++ " :: " ++ hsName ++ " -> (" ++ impm "Ptr" ++ " " ++ hsName ++ " -> IO b) -> IO b" ++ "\n" ++ "with" ++ hsName ++ " (" ++ hsName ++ " fptr) = " ++ impm "withForeignPtr" ++ " fptr" | otherwise = "" isForeign (CHSForeignPtr _) = True isForeign _ = False -- | generate a foreign pointer finalizer import declaration that is -- put into the delayed code -- doFinalizer :: CHSHook -> CHSPtrType -> String -> GB () doFinalizer hook (CHSForeignPtr (Just (cide, ohside))) ptrHsIde = do (ObjCO cdecl, cide') <- findFunObj cide True let finCIde = identToString cide' finHsIde = finCIde `maybe` identToString $ ohside cdecl' = cide' `simplifyDecl` cdecl header <- getSwitch headerSB addHsDependency "Foreign.ForeignPtr" delayCode hook (finalizerImport (extractCallingConvention cdecl') header finCIde finHsIde ptrHsIde) traceFunType ptrHsIde where traceFunType et = traceGenBind $ "Imported finalizer function type: " ++ et ++ "\n" doFinalizer _ _ _ = return () -- | Haskell code for the foreign import declaration needed by foreign -- pointer finalizers. -- finalizerImport :: CallingConvention -> String -> String -> String -> String -> String finalizerImport cconv header ident hsIdent hsPtrName = "foreign import " ++ showCallingConvention cconv ++ " " ++ show entity ++ "\n " ++ hsIdent ++ " :: " ++ impm "FinalizerPtr" ++ " " ++ hsPtrName ++ "\n" where entity | null header = "&" ++ ident | otherwise = header ++ " &" ++ ident -- | generate the class and instance definitions for a class hook -- -- * the pointer type must not be a stable pointer -- -- * the first super class (if present) must be the direct superclass -- -- * all Haskell objects in the superclass list must be pointer objects -- classDef :: Position -- for error messages -> String -- class name -> String -- pointer type name -> CHSPtrType -- type of the pointer -> Bool -- is a newtype? -> [(String, String, HsObject)] -- superclasses -> GB String classDef pos className typeName ptrType isNewtype superClasses = do let toMethodName = case typeName of "" -> errorAtPos pos ["GenBind.classDef: Illegal identifier!"] c:cs -> toLower c : cs fromMethodName = "from" ++ typeName classDefContext = case superClasses of [] -> "" (superName, _, _):_ -> superName ++ " p => " classDefStr = "class " ++ classDefContext ++ className ++ " p where\n" ++ " " ++ toMethodName ++ " :: p -> " ++ typeName ++ "\n" ++ " " ++ fromMethodName ++ " :: " ++ typeName ++ " -> p\n" instDef = "instance " ++ className ++ " " ++ typeName ++ " where\n" ++ " " ++ toMethodName ++ " = id\n" ++ " " ++ fromMethodName ++ " = id\n" instDefs <- castInstDefs superClasses return $ classDefStr ++ instDefs ++ instDef where castInstDefs [] = return "" castInstDefs ((superName, ptrName, Pointer ptrType' isNewtype'):classes) = do unless (ptrType == ptrType') $ pointerTypeMismatchErr pos className superName let toMethodName = case ptrName of "" -> errorAtPos pos ["GenBind.classDef: Illegal identifier - 2!"] c:cs -> toLower c : cs fromMethodName = "from" ++ ptrName castFun = impm $ "cast" ++ show ptrType typeConstr = if isNewtype then typeName ++ " " else "" superConstr = if isNewtype' then ptrName ++ " " else "" instDef = "instance " ++ superName ++ " " ++ typeName ++ " where\n" ++ " " ++ toMethodName ++ " (" ++ typeConstr ++ "p) = " ++ superConstr ++ "(" ++ castFun ++ " p)\n" ++ " " ++ fromMethodName ++ " (" ++ superConstr ++ "p) = " ++ typeConstr ++ "(" ++ castFun ++ " p)\n" addHsDependency "Foreign.Ptr" instDefs <- castInstDefs classes return $ instDef ++ instDefs -- C code computations -- ------------------- -- | the result of a constant expression -- data ConstResult = IntResult Integer | FloatResult Float -- | types that may occur in foreign declarations, ie, Haskell land types -- -- * we reprsent C functions with no arguments (ie, the ANSI C `void' -- argument) by `FunET UnitET res' rather than just `res' internally, -- although the latter representation is finally emitted into the binding -- file; this is because we need to know which types are functions (in -- particular, to distinguish between `Ptr a' and `FunPtr a') -- -- * aliased types (`DefinedET') are represented by a string plus their C -- declaration; the latter is for functions interpreting the following -- structure; an aliased type is always a pointer type that is contained in -- the pointer map (and got there either from a .chi or from a pointer hook -- in the same module) -- -- * the representation for pointers does not distinguish between normal, -- function, foreign, and stable pointers; function pointers are identified -- by their argument and foreign and stable pointers are only used -- indirectly, by referring to type names introduced by a `pointer' hook -- data ExtType = FunET ExtType ExtType -- function | IOET ExtType -- operation with side effect | PtrET ExtType -- typed pointer | DefinedET CDecl String -- aliased type | PrimET CPrimType -- basic C type | UnitET -- void | VarFunET ExtType -- variadic function | SUET CStructUnion -- structure or union deriving Show instance Eq ExtType where (FunET t1 t2) == (FunET t1' t2') = t1 == t1' && t2 == t2' (IOET t ) == (IOET t' ) = t == t' (PtrET t ) == (PtrET t' ) = t == t' (DefinedET _ s ) == (DefinedET _ s' ) = s == s' (PrimET t ) == (PrimET t' ) = t == t' (VarFunET t ) == (VarFunET t' ) = t == t' (SUET (CStruct _ i _ _ _)) == (SUET (CStruct _ i' _ _ _)) = i == i' UnitET == UnitET = True -- | check whether an external type denotes a function type -- isFunExtType :: ExtType -> Bool isFunExtType (FunET _ _) = True isFunExtType (VarFunET _ ) = True isFunExtType (IOET _ ) = True isFunExtType _ = False numArgs :: ExtType -> Int numArgs (FunET UnitET f) = numArgs f numArgs (FunET _ f) = 1 + numArgs f numArgs _ = 0 boolArgs :: ExtType -> (Bool, [Bool]) boolArgs (FunET a rest@(FunET _ _)) = let (res, as) = boolArgs rest in (res, boolArg a : as) boolArgs (FunET a (IOET res) ) = boolArgs (FunET a res) boolArgs (FunET a (PrimET CBoolPT)) = (True, [boolArg a]) boolArgs (FunET a _ ) = (False, [boolArg a]) boolArgs _ = (False, []) boolArg :: ExtType -> Bool boolArg (PrimET CBoolPT) = True boolArg _ = False -- | pretty print an external type -- -- * a previous version of this function attempted to not print unnecessary -- brackets; this however doesn't work consistently due to `DefinedET'; so, -- we give up on the idea (preferring simplicity) -- showExtType :: ExtType -> String showExtType (FunET UnitET res) = showExtType res showExtType (FunET arg res) = "(" ++ showExtType arg ++ " -> " ++ showExtType res ++ ")" showExtType (VarFunET res) = "( ... -> " ++ showExtType res ++ ")" showExtType (IOET t) = "(IO " ++ showExtType t ++ ")" showExtType (PtrET t) = let ptrCon = if isFunExtType t then impm "FunPtr" else impm "Ptr" in "(" ++ ptrCon ++ " " ++ showExtType t ++ ")" showExtType (DefinedET _ str) = "(" ++ str ++ ")" showExtType (PrimET CPtrPT) = "(" ++ impm "Ptr" ++ " ())" showExtType (PrimET CFunPtrPT) = "(" ++ impm "FunPtr" ++ " ())" showExtType (PrimET CCharPT) = impm "CChar" showExtType (PrimET CUCharPT) = impm "CUChar" showExtType (PrimET CSCharPT) = impm "CSChar" showExtType (PrimET CIntPT) = impm "CInt" showExtType (PrimET CShortPT) = impm "CShort" showExtType (PrimET CLongPT) = impm "CLong" showExtType (PrimET CLLongPT) = impm "CLLong" showExtType (PrimET CUIntPT) = impm "CUInt" showExtType (PrimET CUShortPT) = impm "CUShort" showExtType (PrimET CULongPT) = impm "CULong" showExtType (PrimET CULLongPT) = impm "CULLong" showExtType (PrimET CFloatPT) = impm "CFloat" showExtType (PrimET CDoublePT) = impm "CDouble" showExtType (PrimET CLDoublePT) = impm "CLDouble" showExtType (PrimET CBoolPT) = impm "CInt{-bool-}" showExtType (PrimET (CSFieldPT bs)) = impm "CInt{-:" ++ show bs ++ "-}" showExtType (PrimET (CUFieldPT bs)) = impm "CUInt{-:" ++ show bs ++ "-}" showExtType (PrimET (CAliasedPT _ hs _)) = hs showExtType UnitET = "()" showExtType (SUET _) = "(" ++ impm "Ptr" ++ " ())" addExtTypeDependency :: ExtType -> GB () addExtTypeDependency (FunET UnitET res) = addExtTypeDependency res addExtTypeDependency (FunET arg res) = do addExtTypeDependency arg addExtTypeDependency res addExtTypeDependency (VarFunET res) = addExtTypeDependency res addExtTypeDependency (IOET t) = addExtTypeDependency t addExtTypeDependency (PtrET t) = do addHsDependency "Foreign.Ptr" addExtTypeDependency t addExtTypeDependency (PrimET CPtrPT) = addHsDependency "Foreign.Ptr" addExtTypeDependency (PrimET CFunPtrPT) = addHsDependency "Foreign.Ptr" addExtTypeDependency (PrimET (CAliasedPT _ _ _)) = return () addExtTypeDependency (PrimET _) = addHsDependency "Foreign.C.Types" addExtTypeDependency (SUET _) = addHsDependency "Foreign.Ptr" addExtTypeDependency _ = return () showExtFunType :: ExtType -> [ExtType] -> String showExtFunType (FunET UnitET res) _ = showExtType res showExtFunType (FunET arg res) vas = "(" ++ showExtType arg ++ " -> " ++ showExtFunType res vas ++ ")" showExtFunType (VarFunET res) [] = showExtFunType res [] showExtFunType t@(VarFunET _) (va:vas) = "(" ++ showExtType va ++ " -> " ++ showExtFunType t vas ++ ")" showExtFunType (IOET t) vas = "(IO " ++ showExtFunType t vas ++ ")" showExtFunType t _ = showExtType t -- | compute the type of the C function declared by the given C object -- -- * the identifier specifies in which of the declarators we are interested -- -- * the function result is wrapped into an 'IO' type -- -- * the caller has to guarantee that the object does indeed refer to a -- function -- extractFunType :: Position -> CDecl -> Maybe [Bool] -> GB ExtType extractFunType pos cdecl wrapped = do -- remove all declarators except that of the function we are processing; -- then, extract the functions arguments and result type (also check that -- the function is not variadic); finally, compute the external type for -- the result -- let (args, resultDecl, variadic) = funResultAndArgs cdecl preResultType <- extractSimpleType True pos resultDecl -- -- we can now add the 'IO' monad if this is no pure function -- let protoResultType = IOET preResultType let resultType = if variadic then VarFunET protoResultType else protoResultType -- -- compute function arguments and create a function type (a function -- prototype with `void' as its single argument declares a nullary -- function) -- let wrap = case wrapped of Just w -> w ++ repeat False Nothing -> repeat False argTypes <- zipWithM (extractCompType False True) wrap args return $ foldr FunET resultType argTypes -- | compute a non-struct/union type from the given declaration -- -- * the declaration may have at most one declarator -- extractSimpleType :: Bool -> Position -> CDecl -> GB ExtType extractSimpleType isResult _ cdecl = extractCompType isResult True False cdecl -- | compute a Haskell type for a type referenced in a C pointer type -- -- * the declaration may have at most one declarator -- -- * unknown struct/union types are mapped to '()' -- -- * do *not* take aliases into account -- -- * NB: this is by definition not a result type -- extractPtrType :: CDecl -> GB ExtType extractPtrType cdecl = do ct <- extractCompType False False False cdecl case ct of SUET _ -> return UnitET _ -> return ct -- | compute a Haskell type from the given C declaration, where C functions are -- represented by function pointers -- -- * the declaration may have at most one declarator -- -- * typedef'ed types are chased -- -- * the first argument specifies whether the type specifies the result of a -- function (this is only applicable to direct results and not to type -- parameters for pointers that are a result) -- -- * takes the pointer map into account -- -- * IMPORTANT NOTE: `sizeAlignOf' relies on `DefinedET' only being produced -- for pointer types; if this ever changes, we need to -- handle `DefinedET's differently. The problem is that -- entries in the pointer map currently prevent -- `extractCompType' from looking further "into" the -- definition of that pointer. -- extractCompType :: Bool -> Bool -> Bool -> CDecl -> GB ExtType extractCompType isResult usePtrAliases isPtr cdecl@(CDecl specs' declrs ats) = if length declrs > 1 then errorAtPos (posOf cdecl) ["GenBind.extractCompType: Too many declarators!"] else case declrs of [(Just declr, _, sz)] | isPtr || isPtrDeclr declr -> ptrType declr | isFunDeclr declr -> funType | otherwise -> aliasOrSpecType sz _ -> aliasOrSpecType Nothing where -- handle explicit pointer types -- ptrType declr = do tracePtrType let declrs' = if isPtr -- remove indirection then declr else dropPtrDeclr declr cdecl' = CDecl specs' [(Just declrs', Nothing, Nothing)] ats oalias = checkForOneAliasName cdecl' -- is only an alias remaining? osu = checkForOneCUName cdecl' oname = if oalias == Nothing then osu else oalias oHsRepr <- case oname of Nothing -> return $ Nothing Just ide -> queryPtr (True, ide) case oHsRepr of Just repr | usePtrAliases -> ptrAlias repr -- got an alias _ -> do -- no alias => recurs ct <- extractCompType False usePtrAliases False cdecl' return $ case ct of SUET _ -> PtrET UnitET _ -> PtrET ct -- -- handle explicit function types -- -- FIXME: we currently regard any functions as being impure (ie, being IO -- functions); is this ever going to be a problem? -- funType = do traceFunType -- ??? IS Nothing OK HERE? extractFunType (posOf cdecl) cdecl Nothing makeAliasedCompType :: Ident -> CHSTypedefInfo -> GB ExtType makeAliasedCompType cIde (hsIde, et) = do return $ PrimET $ CAliasedPT (identToString cIde) (identToString hsIde) et -- -- handle all types, which are not obviously pointers or functions -- aliasOrSpecType :: Maybe CExpr -> GB ExtType aliasOrSpecType sz = do traceAliasOrSpecType sz case checkForOneAliasName cdecl of Nothing -> specType (posOf cdecl) specs' sz Just ide -> do -- this is a typedef alias oDefault <- queryTypedef ide case oDefault of Just tdefault -> makeAliasedCompType ide tdefault Nothing -> do traceAlias ide oHsRepr <- queryPtr (False, ide) -- check for pointer hook alias case oHsRepr of Just repr | usePtrAliases -> ptrAlias repr -- found a pointer hook alias _ -> do -- skip current alias (only one) cdecl' <- getDeclOf ide let CDecl specs [(declr, init', _)] at = ide `simplifyDecl` cdecl' sdecl = CDecl specs [(declr, init', sz)] at -- propagate `sz' down (slightly kludgy) extractCompType isResult usePtrAliases False sdecl -- -- compute the result for a pointer alias -- ptrAlias (repr1, repr2) = return $ DefinedET cdecl (if isResult then repr2 else repr1) -- tracePtrType = traceGenBind $ "extractCompType: explicit pointer type\n" traceFunType = traceGenBind $ "extractCompType: explicit function type\n" traceAliasOrSpecType Nothing = traceGenBind $ "extractCompType: checking for alias\n" traceAliasOrSpecType (Just _) = traceGenBind $ "extractCompType: checking for alias of bitfield\n" traceAlias ide = traceGenBind $ "extractCompType: found an alias called `" ++ identToString ide ++ "'\n" -- | C to Haskell type mapping described in the DOCU section -- typeMap :: [([CTypeSpec], ExtType)] typeMap = [([void] , UnitET ), ([char] , PrimET CCharPT ), ([unsigned, char] , PrimET CUCharPT ), ([signed, char] , PrimET CSCharPT ), ([signed] , PrimET CIntPT ), ([int] , PrimET CIntPT ), ([signed, int] , PrimET CIntPT ), ([short] , PrimET CShortPT ), ([short, int] , PrimET CShortPT ), ([signed, short] , PrimET CShortPT ), ([signed, short, int] , PrimET CShortPT ), ([long] , PrimET CLongPT ), ([long, int] , PrimET CLongPT ), ([signed, long] , PrimET CLongPT ), ([signed, long, int] , PrimET CLongPT ), ([long, long] , PrimET CLLongPT ), ([long, long, int] , PrimET CLLongPT ), ([signed, long, long] , PrimET CLLongPT ), ([signed, long, long, int] , PrimET CLLongPT ), ([unsigned] , PrimET CUIntPT ), ([unsigned, int] , PrimET CUIntPT ), ([unsigned, short] , PrimET CUShortPT ), ([unsigned, short, int] , PrimET CUShortPT ), ([unsigned, long] , PrimET CULongPT ), ([unsigned, long, int] , PrimET CULongPT ), ([unsigned, long, long] , PrimET CULLongPT ), ([unsigned, long, long, int] , PrimET CULLongPT ), ([float] , PrimET CFloatPT ), ([double] , PrimET CDoublePT ), ([bool] , PrimET CBoolPT ), ([long, double] , PrimET CLDoublePT), ([enum] , PrimET CIntPT )] where void = CVoidType undefined char = CCharType undefined short = CShortType undefined int = CIntType undefined long = CLongType undefined float = CFloatType undefined double = CDoubleType undefined bool = CBoolType undefined signed = CSignedType undefined unsigned = CUnsigType undefined enum = CEnumType undefined undefined convertVarTypes :: String -> Position -> [String] -> GB [ExtType] convertVarTypes base pos ts = do let vaIdent i = internalIdent $ "__c2hs__vararg__" ++ base ++ "_" ++ show i ides = map vaIdent [0..length ts - 1] doone ide = do Just (ObjCO cdecl) <- findObj ide return cdecl cdecls <- mapM doone ides forM cdecls $ \cdecl -> do st <- extractCompType True True False cdecl case st of SUET _ -> variadicTypeErr pos _ -> return st -- | compute the complex (external) type determined by a list of type specifiers -- -- * may not be called for a specifier that defines a typedef alias -- specType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB ExtType specType cpos specs'' osize = let tspecs = [ts | CTypeSpec ts <- specs''] in case lookupTSpec tspecs typeMap of Just et | isUnsupportedType et -> unsupportedTypeSpecErr cpos | isNothing osize -> return et -- not a bitfield | otherwise -> bitfieldSpec tspecs et osize -- bitfield Nothing -> case tspecs of [CSUType cu _] -> return $ SUET cu -- struct or union [CEnumType _ _] -> return $ PrimET CIntPT -- enum [CTypeDef _ _] -> errorAtPos cpos ["GenBind.specType: Illegal typedef alias!"] _ -> illegalTypeSpecErr cpos where lookupTSpec = lookupBy matches -- -- can't be a bitfield (yet) isUnsupportedType (PrimET et) = et /= CBoolPT && size et == 0 isUnsupportedType _ = False -- -- check whether two type specifier lists denote the same type; handles -- types like `long long' correctly, as `deleteBy' removes only the first -- occurrence of the given element -- matches :: [CTypeSpec] -> [CTypeSpec] -> Bool [] `matches` [] = True [] `matches` (_:_) = False (spec:specs) `matches` specs' | any (eqSpec spec) specs' = specs `matches` deleteBy eqSpec spec specs' | otherwise = False -- eqSpec (CVoidType _) (CVoidType _) = True eqSpec (CCharType _) (CCharType _) = True eqSpec (CShortType _) (CShortType _) = True eqSpec (CIntType _) (CIntType _) = True eqSpec (CLongType _) (CLongType _) = True eqSpec (CFloatType _) (CFloatType _) = True eqSpec (CDoubleType _) (CDoubleType _) = True eqSpec (CBoolType _) (CBoolType _) = True eqSpec (CSignedType _) (CSignedType _) = True eqSpec (CUnsigType _) (CUnsigType _) = True eqSpec (CSUType _ _) (CSUType _ _) = True eqSpec (CEnumType _ _) (CEnumType _ _) = True eqSpec (CTypeDef _ _) (CTypeDef _ _) = True eqSpec _ _ = False -- bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB ExtType bitfieldSpec tspecs et (Just sizeExpr) = -- never called with 'Nothing' do PlatformSpec {bitfieldIntSignedPS = bitfieldIntSigned} <- getPlatform let pos = posOf sizeExpr sizeResult <- evalConstCExpr sizeExpr case sizeResult of FloatResult _ -> illegalConstExprErr pos "a float result" IntResult size' -> do let sz = fromInteger size' case et of PrimET CUIntPT -> returnCT $ CUFieldPT sz PrimET CIntPT | [signed] `matches` tspecs || [signed, int] `matches` tspecs -> returnCT $ CSFieldPT sz | [int] `matches` tspecs -> returnCT $ if bitfieldIntSigned then CSFieldPT sz else CUFieldPT sz _ -> illegalFieldSizeErr pos where returnCT = return . PrimET -- int = CIntType undefined signed = CSignedType undefined -- handle calling convention -- ------------------------- data CallingConvention = StdCallConv | CCallConv deriving (Eq) -- | determine the calling convention for the provided decl extractCallingConvention :: CDecl -> CallingConvention extractCallingConvention cdecl | hasStdCallAttr cdecl = StdCallConv | otherwise = CCallConv where isStdCallAttr (CAttr x _ _) = identToString x == "stdcall" || identToString x == "__stdcall__" hasStdCallAttr = any isStdCallAttr . funAttrs funAttrs (CDecl specs declrs _) = let (_,attrs',_,_,_) = partitionDeclSpecs specs in attrs' ++ funEndAttrs declrs ++ funPtrAttrs declrs -- attrs after the function name, e.g. void foo() __attribute__((...)); funEndAttrs [(Just ((CDeclr _ (CFunDeclr _ _ _ : _) _ attrs _)), _, _)] = attrs funEndAttrs _ = [] -- attrs appearing within the declarator of a function pointer. As an -- example: -- typedef int (__stdcall *fp)(); funPtrAttrs [(Just ((CDeclr _ (CPtrDeclr _ _ : CFunDeclr _ attrs _ : _) _ _ _)), _, _)] = attrs funPtrAttrs _ = [] -- | generate the necessary parameter for "foreign import" for the -- provided calling convention showCallingConvention :: CallingConvention -> String showCallingConvention StdCallConv = "stdcall" showCallingConvention CCallConv = "ccall" -- offset and size computations -- ---------------------------- -- | precise size representation -- -- * this is a pair of a number of octets and a number of bits -- -- * if the number of bits is nonzero, the octet component is aligned by the -- alignment constraint for 'CIntPT' (important for accessing bitfields with -- more than 8 bits) -- data BitSize = BitSize Int Int deriving (Eq, Show) -- | ordering relation compares in terms of required storage units -- instance Ord BitSize where bs1@(BitSize o1 b1) < bs2@(BitSize o2 b2) = padBits bs1 < padBits bs2 || (o1 == o2 && b1 < b2) bs1 <= bs2 = bs1 < bs2 || bs1 == bs2 -- the <= instance is needed for Ord's compare functions, which is used in -- the defaults for all other members -- | add two bit size values -- addBitSize :: BitSize -> BitSize -> BitSize addBitSize (BitSize o1 b1) (BitSize o2 b2) = BitSize (o1 + o2 + overflow * size CIntPT) rest where bitsPerBitfield = size CIntPT * 8 (overflow, rest) = (b1 + b2) `divMod` bitsPerBitfield -- | multiply a bit size by a constant (gives size of an array) -- -- * not sure if this makes sense if the number of bits is non-zero. -- scaleBitSize :: Int -> BitSize -> BitSize scaleBitSize n (BitSize o1 b1) = BitSize (n * o1 + overflow) rest where bitsPerBitfield = size CIntPT * 8 (overflow, rest) = (n * b1) `divMod` bitsPerBitfield -- | pad any storage unit that is partially used by a bitfield -- padBits :: BitSize -> Int padBits (BitSize o 0) = o padBits (BitSize o _) = o + size CIntPT -- | compute the offset of the declarator in the second argument when it is -- preceded by the declarators in the first argument -- offsetInStruct :: [CDecl] -> CDecl -> CStructTag -> GB BitSize offsetInStruct [] _ _ = return $ BitSize 0 0 offsetInStruct decls decl tag = do PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform (offset, _) <- sizeAlignOfStruct decls tag (_, align) <- sizeAlignOf decl return $ alignOffset offset align bitfieldAlignment -- | compute the size and alignment (no padding at the end) of a set of -- declarators from a struct -- sizeAlignOfStruct :: [CDecl] -> CStructTag -> GB (BitSize, Int) sizeAlignOfStruct [] _ = return (BitSize 0 0, 1) sizeAlignOfStruct decls CStructTag = do PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform (offset, preAlign) <- sizeAlignOfStruct (init decls) CStructTag (sz, align) <- sizeAlignOf (last decls) let sizeOfStruct = alignOffset offset align bitfieldAlignment `addBitSize` sz align' = if align > 0 then align else bitfieldAlignment alignOfStruct = preAlign `max` align' return (sizeOfStruct, alignOfStruct) sizeAlignOfStruct decls CUnionTag = do PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform (sizes, aligns) <- mapAndUnzipM sizeAlignOf decls let aligns' = [if align > 0 then align else bitfieldAlignment | align <- aligns] return (maximum sizes, maximum aligns') -- | compute the size and alignment of the declarators forming a struct -- including any end-of-struct padding that is needed to make the struct ``tile -- in an array'' (K&R A7.4.8) -- sizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int) sizeAlignOfStructPad decls tag = do (sz, align) <- sizeAlignOfStruct decls tag let b = size CIntPT return (alignOffset sz (align `max` b) b, align) -- | compute the size and alignment constraint of a given C declaration -- sizeAlignOf :: CDecl -> GB (BitSize, Int) sizeAlignOfPtr :: CDecl -> GB (BitSize, Int) sizeAlignOfBase :: Bool -> CDecl -> GB (BitSize, Int) sizeAlignOfSingle :: Bool -> CDecl -> GB (BitSize, Int) -- -- * we make use of the assertion that 'extractCompType' can only return a -- 'DefinedET' when the declaration is a pointer declaration -- * for arrays, alignment is the same as for the base type and the size -- is the size of the base type multiplied by the number of elements. -- FIXME: I'm not sure whether anything of this is guaranteed by ISO C -- and I have no idea what happens when an array-of-bitfield is -- declared. At this time I don't care. -- U.S. 05/2006 -- sizeAlignOf = sizeAlignOfBase False sizeAlignOfPtr = sizeAlignOfBase True sizeAlignOfBase _ (CDecl dclspec [(Just (CDeclr oide (CArrDeclr _ (CArrSize _ lexpr) _ : derived') _asm _ats n), init', expr)] attr) = do (bitsize, align) <- sizeAlignOf (CDecl dclspec [(Just (CDeclr oide derived' Nothing [] n), init', expr)] attr) IntResult len <- evalConstCExpr lexpr return (fromIntegral len `scaleBitSize` bitsize, align) sizeAlignOfBase _ cdecl@(CDecl _ [(Just (CDeclr _ (CArrDeclr _ (CNoArrSize _) _ : _) _ _ _), _init, _expr)] _) = errorAtPos (posOf cdecl) ["GenBind.sizeAlignOf: array of undeclared size."] sizeAlignOfBase ptr cdecl = do traceAliasCheck case checkForOneAliasName cdecl of Nothing -> sizeAlignOfSingle ptr cdecl Just ide -> do -- this is a typedef alias traceAlias ide cdecl' <- getDeclOf ide let CDecl specs [(declr, init', _)] at = ide `simplifyDecl` cdecl' sdecl = CDecl specs [(declr, init', Nothing)] at sizeAlignOf sdecl where traceAliasCheck = traceGenBind $ "extractCompType: checking for alias\n" traceAlias ide = traceGenBind $ "extractCompType: found an alias called `" ++ identToString ide ++ "'\n" checkForIncomplete :: CDecl -> GB () checkForIncomplete cdecl = do ct <- extractCompType False False False cdecl case ct of SUET su -> do let (fields, _) = structMembers su ide = structName su if (not . null $ fields) || isNothing ide then return () else do -- get the real... tag' <- findTag (fromJust ide) -- ...definition case tag' of Just (StructUnionCT (CStruct _ _ Nothing _ _)) -> incompleteTypeErr $ posOf cdecl _ -> return () _ -> return () sizeAlignOfSingle ptr cdecl = do ct <- extractCompType False False False cdecl case ct of FunET _ _ -> do align <- alignment CFunPtrPT return (bitSize CFunPtrPT, align) VarFunET _ -> do align <- alignment CFunPtrPT return (bitSize CFunPtrPT, align) IOET _ -> errorAtPos (posOf cdecl) ["GenBind.sizeof: Illegal IO type!"] PtrET t | isFunExtType t -> do align <- alignment CFunPtrPT return (bitSize CFunPtrPT, align) | otherwise -> do align <- alignment CPtrPT return (bitSize CPtrPT, align) DefinedET _ _ -> errorAtPos (posOf cdecl) ["GenBind.sizeAlignOf: Should never get a defined type"] PrimET pt -> do align <- alignment pt return (bitSize pt, align) UnitET -> if ptr then do align <- alignment CPtrPT return (bitSize CPtrPT, align) else voidFieldErr (posOf cdecl) SUET su -> do let (fields, tag) = structMembers su fields' <- let ide = structName su in if (not . null $ fields) || isNothing ide then return fields else do -- get the real... tag' <- findTag (fromJust ide) -- ...definition case tag' of Just (StructUnionCT su') -> return (fst . structMembers $ su') _ -> return fields sizeAlignOfStructPad fields' tag where bitSize et | sz < 0 = BitSize 0 (-sz) -- size is in bits | otherwise = BitSize sz 0 where sz = size et -- | apply the given alignment constraint at the given offset -- -- * if the alignment constraint is negative or zero, it is the alignment -- constraint for a bitfield -- -- * the third argument gives the platform-specific bitfield alignment -- alignOffset :: BitSize -> Int -> Int -> BitSize alignOffset offset@(BitSize octetOffset bitOffset) align bitfieldAlignment | align > 0 && bitOffset /= 0 = -- close bitfield first alignOffset (BitSize (octetOffset + (bitOffset + 7) `div` 8) 0) align bitfieldAlignment | align > 0 && bitOffset == 0 = -- no bitfields involved BitSize (((octetOffset - 1) `div` align + 1) * align) 0 | bitOffset == 0 -- start a bitfield || overflowingBitfield = -- .. or overflowing bitfield alignOffset offset bitfieldAlignment bitfieldAlignment | otherwise = -- stays in current bitfield offset where bitsPerBitfield = size CIntPT * 8 overflowingBitfield = bitOffset - align > bitsPerBitfield -- note, `align' is negative -- constant folding -- ---------------- -- | evaluate a constant expression -- -- FIXME: this is a bit too simplistic, as the range of expression allowed as -- constant expression varies depending on the context in which the -- constant expression occurs -- evalConstCExpr :: CExpr -> GB ConstResult evalConstCExpr (CComma _ at) = illegalConstExprErr (posOf at) "a comma expression" evalConstCExpr (CAssign _ _ _ at) = illegalConstExprErr (posOf at) "an assignment" evalConstCExpr (CCond b (Just t) e _) = do bv <- evalConstCExpr b case bv of IntResult bvi -> if bvi /= 0 then evalConstCExpr t else evalConstCExpr e FloatResult _ -> illegalConstExprErr (posOf b) "a float result" evalConstCExpr (CBinary op lhs rhs at) = do lhsVal <- evalConstCExpr lhs rhsVal <- evalConstCExpr rhs let (lhsVal', rhsVal') = usualArithConv lhsVal rhsVal applyBin (posOf at) op lhsVal' rhsVal' evalConstCExpr c@(CCast _ _ _) = evalCCast c evalConstCExpr (CUnary op arg at) = do argVal <- evalConstCExpr arg applyUnary (posOf at) op argVal evalConstCExpr (CSizeofExpr _ _) = todo "GenBind.evalConstCExpr: sizeof not implemented yet." evalConstCExpr (CSizeofType decl _) = do (sz, _) <- sizeAlignOf decl return $ IntResult (fromIntegral . padBits $ sz) evalConstCExpr (CAlignofExpr _ _) = todo "GenBind.evalConstCExpr: alignof (GNU C extension) not implemented yet." evalConstCExpr (CAlignofType decl _) = do (_, align) <- sizeAlignOf decl return $ IntResult (fromIntegral align) evalConstCExpr (CIndex _ _ at) = illegalConstExprErr (posOf at) "array indexing" evalConstCExpr (CCall _ _ at) = illegalConstExprErr (posOf at) "function call" evalConstCExpr (CMember _ _ _ at) = illegalConstExprErr (posOf at) "a . or -> operator" evalConstCExpr cdecl@(CVar ide''' at) = do (cobj, _) <- findValueObj ide''' False case cobj of EnumCO ide'' (CEnum _ (Just enumrs) _ _) -> liftM IntResult $ enumTagValue ide'' enumrs 0 _ -> todo $ "GenBind.evalConstCExpr: variable names not implemented yet " ++ show (posOf at) where -- FIXME: this is not very nice; instead, CTrav should have some support -- for determining enum tag values (but then, constant folding needs -- to be moved to CTrav, too) -- -- Compute the tag value for `ide' defined in the given enumerator list -- enumTagValue _ [] _ = errorAtPos (posOf cdecl) ["GenBind.enumTagValue: enumerator not in declaration"] enumTagValue ide ((ide', oexpr):enumrs) val = do val' <- case oexpr of Nothing -> return val Just exp -> do val' <- evalConstCExpr exp case val' of IntResult val'' -> return val'' FloatResult _ -> illegalConstExprErr (posOf exp) "a float result" if ide == ide' then -- found the right enumerator return val' else -- continue down the enumerator list enumTagValue ide enumrs (val' + 1) evalConstCExpr (CConst c) = evalCConst c evalCCast :: CExpr -> GB ConstResult evalCCast (CCast decl expr _) = do compType <- extractCompType False False False decl evalCCast' compType (getConstInt expr) where getConstInt (CConst (CIntConst (CInteger i _ _) _)) = i getConstInt _ = todo $ "GenBind.evalCCast: Casts are implemented " ++ "only for integral constants" evalCCast' :: ExtType -> Integer -> GB ConstResult evalCCast' (PrimET primType) i | isIntegralCPrimType primType = return $ IntResult i evalCCast' _ _ = todo $ "GenBind.evalCCast': Only integral trivial " ++ "casts are implemented" evalCConst :: CConst -> GB ConstResult evalCConst (CIntConst i _ ) = return $ IntResult (getCInteger i) evalCConst (CCharConst c@(C2HS.C.CChar _ _) _ ) = return $ IntResult (getCCharAsInt c) evalCConst (CCharConst (CChars cs _) _ ) = return $ IntResult (foldl' add 0 cs) where add tot ch = tot * 0x100 + fromIntegral (fromEnum ch) evalCConst (CFloatConst _ _ ) = todo "GenBind.evalCConst: Float conversion from literal misses." evalCConst (CStrConst _ at) = illegalConstExprErr (posOf at) "a string constant" usualArithConv :: ConstResult -> ConstResult -> (ConstResult, ConstResult) usualArithConv lhs@(FloatResult _) rhs = (lhs, toFloat rhs) usualArithConv lhs rhs@(FloatResult _) = (toFloat lhs, rhs) usualArithConv lhs rhs = (lhs, rhs) toFloat :: ConstResult -> ConstResult toFloat x@(FloatResult _) = x toFloat (IntResult i) = FloatResult . fromIntegral $ i applyBin :: Position -> CBinaryOp -> ConstResult -> ConstResult -> GB ConstResult applyBin _ CMulOp (IntResult x) (IntResult y) = return $ IntResult (x * y) applyBin _ CMulOp (FloatResult x) (FloatResult y) = return $ FloatResult (x * y) applyBin _ CDivOp (IntResult x) (IntResult y) = return $ IntResult (x `div` y) applyBin _ CDivOp (FloatResult x) (FloatResult y) = return $ FloatResult (x / y) applyBin _ CRmdOp (IntResult x) (IntResult y) = return$ IntResult (x `mod` y) applyBin cpos CRmdOp (FloatResult _) (FloatResult _) = illegalConstExprErr cpos "a % operator applied to a float" applyBin _ CAddOp (IntResult x) (IntResult y) = return $ IntResult (x + y) applyBin _ CAddOp (FloatResult x) (FloatResult y) = return $ FloatResult (x + y) applyBin _ CSubOp (IntResult x) (IntResult y) = return $ IntResult (x - y) applyBin _ CSubOp (FloatResult x) (FloatResult y) = return $ FloatResult (x - y) applyBin _ CShlOp (IntResult x) (IntResult y) = return $ IntResult (x * 2^y) applyBin cpos CShlOp (FloatResult _) (FloatResult _) = illegalConstExprErr cpos "a << operator applied to a float" applyBin _ CShrOp (IntResult x) (IntResult y) = return $ IntResult (x `div` 2^y) applyBin cpos CShrOp (FloatResult _) (FloatResult _) = illegalConstExprErr cpos "a >> operator applied to a float" applyBin _ COrOp (IntResult x) (IntResult y) = return $ IntResult (x .|. y) applyBin _ CAndOp (IntResult x) (IntResult y) = return $ IntResult (x .&. y) applyBin pos _ (IntResult _) (IntResult _) = todo $ "GenBind.applyBin: Not yet implemented operator in constant expression. " ++ show pos applyBin pos _ (FloatResult _) (FloatResult _) = todo $ "GenBind.applyBin: Not yet implemented operator in constant expression. " ++ show pos applyBin pos _ _ _ = errorAtPos pos ["GenBind.applyBinOp: Illegal combination!"] applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult applyUnary cpos CPreIncOp _ = illegalConstExprErr cpos "a ++ operator" applyUnary cpos CPreDecOp _ = illegalConstExprErr cpos "a -- operator" applyUnary cpos CPostIncOp _ = illegalConstExprErr cpos "a ++ operator" applyUnary cpos CPostDecOp _ = illegalConstExprErr cpos "a -- operator" applyUnary cpos CAdrOp _ = illegalConstExprErr cpos "a & operator" applyUnary cpos CIndOp _ = illegalConstExprErr cpos "a * operator" applyUnary _ CPlusOp arg = return arg applyUnary _ CMinOp (IntResult x) = return (IntResult (-x)) applyUnary _ CMinOp (FloatResult x) = return (FloatResult (-x)) applyUnary pos CCompOp _ = todo $ "GenBind.applyUnary: ~ not yet implemented. " ++ show pos applyUnary _ CNegOp (IntResult x) = let r = toInteger . fromEnum $ (x == 0) in return (IntResult r) applyUnary cpos CNegOp (FloatResult _) = illegalConstExprErr cpos "! applied to a float" -- auxilliary functions -- -------------------- -- | print trace message -- traceGenBind :: String -> GB () traceGenBind = putTraceStr traceGenBindSW -- | generic lookup -- lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b lookupBy eq x = fmap snd . find (eq x . fst) -- error messages -- -------------- unknownFieldErr :: Position -> Ident -> GB a unknownFieldErr cpos ide = raiseErrorCTExc (posOf ide) ["Unknown member name!", "The structure has no member called `" ++ identToString ide ++ "'. The structure is defined at", show cpos ++ "."] illegalTypeSpecErr :: Position -> GB a illegalTypeSpecErr cpos = raiseErrorCTExc cpos ["Illegal type!", "The type specifiers of this declaration do not form a " ++ "legal ANSI C(89) type." ] unsupportedTypeSpecErr :: Position -> GB a unsupportedTypeSpecErr cpos = raiseErrorCTExc cpos ["Unsupported type!", "The type specifier of this declaration is not supported by your " ++ "combination of C compiler and Haskell compiler." ] variadicErr :: Position -> Position -> GB a variadicErr pos cpos = raiseErrorCTExc pos ["Variadic function!", "Calling variadic functions is not supported by the FFI; the function", "is defined at " ++ show cpos ++ "."] variadicTypeErr :: Position -> GB a variadicTypeErr pos = raiseErrorCTExc pos ["Variadic function argument type!", "Calling variadic functions is only supported for simple C types"] typeDefaultErr :: Position -> GB a typeDefaultErr pos = raiseErrorCTExc pos ["Internal type default error!", "Something went wrong."] illegalPlusErr :: Position -> GB a illegalPlusErr pos = raiseErrorCTExc pos ["Illegal plus parameter!", "The special parameter `+' may only be used in a single input " ++ "parameter position in a function hook"] illegalConstExprErr :: Position -> String -> GB a illegalConstExprErr cpos hint = raiseErrorCTExc cpos ["Illegal constant expression!", "Encountered " ++ hint ++ " in a constant expression,", "which ANSI C89 does not permit."] voidFieldErr :: Position -> GB a voidFieldErr cpos = raiseErrorCTExc cpos ["Void field in struct!", "Attempt to access a structure field of type void."] structExpectedErr :: Ident -> GB a structExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected a structure or union!", "Attempt to access member `" ++ identToString ide ++ "' in something not", "a structure or union."] ptrExpectedErr :: Position -> GB a ptrExpectedErr pos = raiseErrorCTExc pos ["Expected a pointer object!", "Attempt to dereference a non-pointer object or to use it in a " ++ "`pointer' hook."] funPtrExpectedErr :: Position -> GB a funPtrExpectedErr pos = raiseErrorCTExc pos ["Expected a pointer-to-function object!", "Attempt to use a non-pointer object in a `call' or `fun' hook."] illegalStablePtrErr :: Position -> GB a illegalStablePtrErr pos = raiseErrorCTExc pos ["Illegal use of a stable pointer!", "Class hooks cannot be used for stable pointers."] pointerTypeMismatchErr :: Position -> String -> String -> GB a pointerTypeMismatchErr pos className superName = raiseErrorCTExc pos ["Pointer type mismatch!", "The pointer of the class hook for `" ++ className ++ "' is of a different kind", "than that of the class hook for `" ++ superName ++ "'; this is illegal", "as the latter is defined to be an (indirect) superclass of the former."] illegalFieldSizeErr :: Position -> GB a illegalFieldSizeErr cpos = raiseErrorCTExc cpos ["Illegal field size!", "Only signed and unsigned `int' types may have a size annotation."] derefBitfieldErr :: Position -> GB a derefBitfieldErr pos = raiseErrorCTExc pos ["Illegal dereferencing of a bit field!", "Bit fields cannot be dereferenced."] offsetBitfieldErr :: Position -> GB a offsetBitfieldErr pos = raiseErrorCTExc pos ["Illegal offset of a bit field!", "Bit fields do not necessarily lie " ++ "on a whole-byte boundary."] offsetDerefErr :: Position -> GB a offsetDerefErr pos = raiseErrorCTExc pos ["Disallowed offset of using a dereference!", "While calculable, it would almost certainly " ++ "be confusing to give the offset from the " ++ "beginning of a not-obviously-related struct"] resMarshIllegalInErr :: Position -> GB a resMarshIllegalInErr pos = raiseErrorCTExc pos ["Malformed result marshalling!", "An \"in\" marshaller is not allowed for the function result type.", "Note that \"out\" marshallers are specified *after* the type, like:", " {# fun ... -> `MyType' mkMyType #} "] resMarshIllegalTwoCValErr :: Position -> GB a resMarshIllegalTwoCValErr pos = raiseErrorCTExc pos ["Malformed result marshalling!", "Two C values (i.e., the `&' symbol) are not allowed for the result."] marshArgMismatchErr :: Position -> String -> GB a marshArgMismatchErr pos reason = raiseErrorCTExc pos ["Function arity mismatch!", reason] noDftMarshErr :: Position -> String -> String -> [ExtType] -> GB a noDftMarshErr pos inOut hsTy cTys = raiseErrorCTExc pos ["Missing " ++ inOut ++ " marshaller!", "There is no default marshaller for this combination of Haskell and " ++ "C type:", "Haskell type: " ++ hsTy, "C type : " ++ concat (intersperse " " (map showExtType cTys))] undefEnumErr :: Position -> GB a undefEnumErr pos = raiseErrorCTExc pos ["Incomplete enum type!"] incompleteTypeErr :: Position -> GB a incompleteTypeErr pos = raiseErrorCTExc pos ["Illegal use of incomplete type!", "Expected a fully defined structure or union tag; instead found incomplete type."] -- | size of primitive type of C -- -- * negative size implies that it is a bit, not an octet size -- size :: CPrimType -> Int size CPtrPT = Storable.sizeOf (undefined :: Ptr ()) size CFunPtrPT = Storable.sizeOf (undefined :: FunPtr ()) size CCharPT = 1 size CUCharPT = 1 size CSCharPT = 1 size CIntPT = Storable.sizeOf (undefined :: CInt) size CShortPT = Storable.sizeOf (undefined :: CShort) size CLongPT = Storable.sizeOf (undefined :: CLong) size CLLongPT = Storable.sizeOf (undefined :: CLLong) size CUIntPT = Storable.sizeOf (undefined :: CUInt) size CUShortPT = Storable.sizeOf (undefined :: CUShort) size CULongPT = Storable.sizeOf (undefined :: CULong) size CULLongPT = Storable.sizeOf (undefined :: CLLong) size CFloatPT = Storable.sizeOf (undefined :: Foreign.C.CFloat) size CDoublePT = Storable.sizeOf (undefined :: CDouble) #if MIN_VERSION_base(4,2,0) size CLDoublePT = 0 --marks it as an unsupported type, see 'specType' #else size CLDoublePT = Storable.sizeOf (undefined :: CLDouble) #endif size CBoolPT = cBoolSize size (CSFieldPT bs) = -bs size (CUFieldPT bs) = -bs size (CAliasedPT _ _ pt) = size pt -- | alignment of C's primitive types -- -- * more precisely, the padding put before the type's member starts when the -- preceding component is a char -- alignment :: CPrimType -> GB Int alignment CPtrPT = return $ Storable.alignment (undefined :: Ptr ()) alignment CFunPtrPT = return $ Storable.alignment (undefined :: FunPtr ()) alignment CCharPT = return $ 1 alignment CUCharPT = return $ 1 alignment CSCharPT = return $ 1 alignment CIntPT = return $ Storable.alignment (undefined :: CInt) alignment CShortPT = return $ Storable.alignment (undefined :: CShort) alignment CLongPT = return $ Storable.alignment (undefined :: CLong) alignment CLLongPT = return $ Storable.alignment (undefined :: CLLong) alignment CUIntPT = return $ Storable.alignment (undefined :: CUInt) alignment CUShortPT = return $ Storable.alignment (undefined :: CUShort) alignment CULongPT = return $ Storable.alignment (undefined :: CULong) alignment CULLongPT = return $ Storable.alignment (undefined :: CULLong) alignment CFloatPT = return $ Storable.alignment (undefined :: Foreign.C.CFloat) alignment CDoublePT = return $ Storable.alignment (undefined :: CDouble) #if MIN_VERSION_base(4,2,0) alignment CLDoublePT = interr "Info.alignment: CLDouble not supported" #else alignment CLDoublePT = return $ Storable.alignment (undefined :: CLDouble) #endif alignment CBoolPT = return cBoolSize alignment (CSFieldPT bs) = fieldAlignment bs alignment (CUFieldPT bs) = fieldAlignment bs alignment (CAliasedPT _ _ pt) = alignment pt -- | alignment constraint for a C bitfield -- -- * gets the bitfield size (in bits) as an argument -- -- * alignments constraints smaller or equal to zero are reserved for bitfield -- alignments -- -- * bitfields of size 0 always trigger padding; thus, they get the maximal -- size -- -- * if bitfields whose size exceeds the space that is still available in a -- partially filled storage unit trigger padding, the size of a storage unit -- is provided as the alignment constraint; otherwise, it is 0 (meaning it -- definitely starts at the current position) -- -- * here, alignment constraint /= 0 are somewhat subtle; they mean that is -- the given number of bits doesn't fit in what's left in the current -- storage unit, alignment to the start of the next storage unit has to be -- triggered -- fieldAlignment :: Int -> GB Int fieldAlignment 0 = return $ - (size CIntPT - 1) fieldAlignment bs = do PlatformSpec {bitfieldPaddingPS = bitfieldPadding} <- getPlatform return $ if bitfieldPadding then - bs else 0 -- | obtain platform from switchboard -- getPlatform :: GB PlatformSpec getPlatform = getSwitch platformSB -- All this is slightly horrible, but it's the only way to find the -- size of the C99 _Bool type which is needed for marshalling -- structures containing C 'bool' values. (Marshalling of 'bool' -- function arguments and return values can be done by passing them -- through the FFI as C 'int', but calculating offsets into structures -- requires knowledge of the size of the type, which isn't provided by -- the Haskell FFI.) {-# NOINLINE cBoolSizeRef #-} cBoolSizeRef :: IORef (Maybe Int) cBoolSizeRef = unsafePerformIO $ newIORef Nothing findBoolSize :: IO Int findBoolSize = do withFile "c2hs__bool_size.c" WriteMode $ \h -> do hPutStrLn h "#include " hPutStrLn h $ "int main(int argc, char *argv[]) " ++ "{ printf(\"%u\\n\", sizeof(_Bool)); return 0; }" gcccode <- system $ cCompiler ++ " -o c2hs__bool_size c2hs__bool_size.c" when (gcccode /= ExitSuccess) $ error "Failed to compile 'bool' size test program!" (code, stdout, _) <- readProcessWithExitCode "./c2hs__bool_size" [] "" when (code /= ExitSuccess) $ error "Failed to run 'bool' size test program!" let sz = read stdout :: Int removeFile "c2hs__bool_size.c" removeFile "c2hs__bool_size" return sz cBoolSize :: Int cBoolSize = unsafePerformIO $ do msz <- readIORef cBoolSizeRef case msz of Just sz -> return sz Nothing -> do sz <- findBoolSize writeIORef cBoolSizeRef $ Just sz return sz {-# NOINLINE cCompilerRef #-} cCompilerRef :: IORef (Maybe String) cCompilerRef = unsafePerformIO $ newIORef Nothing cCompiler :: String cCompiler = unsafePerformIO $ do mcc <- readIORef cCompilerRef case mcc of Just cc -> return cc Nothing -> do (code, stdout, _) <- readProcessWithExitCode "ghc" ["--info"] "" when (code /= ExitSuccess) $ error "Failed to determine C compiler from 'ghc --info'!" let vals = read stdout :: [(String, String)] case Prelude.lookup "C compiler command" vals of Nothing -> error "Failed to determine C compiler from 'ghc --info'!" Just cc -> do writeIORef cCompilerRef $ Just cc return cc c2hs-0.28.1/src/C2HS/Gen/Monad.hs0000644000000000000000000005340112677513064014236 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} -- C->Haskell Compiler: monad for the binding generator -- -- Author : Manuel M T Chakravarty -- Derived: 18 February 2 (extracted from GenBind.hs) -- -- Copyright (c) [2002..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This modules defines the monad and related utility routines for the code -- that implements the expansion of the binding hooks. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Translation table handling for enumerators: -- ------------------------------------------- -- -- First a translation table lookup on the original identifier of the -- enumerator is done. If that doesn't match and the prefix can be removed -- from the identifier, a second lookup on the identifier without the prefix -- is performed. If this also doesn't match, the identifier without prefix -- (possible after underscoreToCase or similar translation is returned). If -- there is a match, the translation (without any further stripping of -- prefix) is returned. -- -- Pointer map -- ----------- -- -- Pointer hooks allow the use to customise the Haskell types to which C -- pointer types are mapped. The globally maintained map essentially maps C -- pointer types to Haskell pointer types. The representation of the Haskell -- types is defined by the `type' or `newtype' declaration emitted by the -- corresponding pointer hook. However, the map stores a flag that tells -- whether the C type is itself the pointer type in question or whether it is -- pointers to this C type that should be mapped as specified. The pointer -- map is dumped into and read from `.chi' files. -- -- Haskell object map -- ------------------ -- -- Some features require information about Haskell objects defined by c2hs. -- Therefore, the Haskell object map maintains the necessary information -- about these Haskell objects. The Haskell object map is dumped into and -- read from `.chi' files. -- -- Enumeration map -- --------------- -- -- Map maintaining information about enum hooks for use in generation -- of default marshalling code. -- --- TODO ---------------------------------------------------------------------- -- -- * Look up in translation tables is naive - this probably doesn't affect -- costs much, but at some point a little profiling might be beneficial. -- module C2HS.Gen.Monad ( TransFun, transTabToTransFun, HsObject(..), Wrapper(..), GB, GBState(..), initialGBState, setContext, getLibrary, getPrefix, getReplacementPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, queryObj, sizeIs, querySize, queryClass, queryPointer, mergeMaps, dumpMaps, queryEnum, isEnum, queryTypedef, isC2HSTypedef, queryDefaultMarsh, isDefaultMarsh, addWrapper, getWrappers, addHsDependency, getHsDependencies ) where -- standard libraries import Data.Char (toUpper, toLower) import Data.List (find) import Data.Maybe (fromMaybe) import qualified Data.Map as Map (empty, insert, lookup, union, toList, fromList) import Data.Map (Map) import Data.Set (Set) import qualified Data.Set as Set (empty, insert, member, union, toList, fromList) -- Language.C import Language.C.Data.Position import Language.C.Data.Ident import Language.C.Syntax import Data.Errors -- C -> Haskell import C2HS.C (CT, readCT, transCT, raiseErrorCTExc) -- friends import C2HS.CHS (CHSFrag(..), CHSHook(..), CHSTrans(..), CHSChangeCase(..), CHSPtrType(..), CHSTypedefInfo, CHSDefaultMarsh, Direction(..)) -- translation tables -- ------------------ -- | takes an identifier to a lexeme including a potential mapping by a -- translation table -- type TransFun = Ident -> Maybe String -- | translation function for the 'underscoreToCase' flag -- underscoreToCase :: String -> String underscoreToCase lexeme = let ps = filter (not . null) . parts $ lexeme in concat . map adjustCase $ ps where parts s = let (l, s') = break (== '_') s in l : case s' of [] -> [] (_:s'') -> parts s'' adjustCase (c:cs) = toUpper c : map toLower cs -- | translation function for the 'upcaseFirstLetter' flag -- upcaseFirstLetter :: String -> String upcaseFirstLetter "" = "" upcaseFirstLetter (c:cs) = toUpper c : cs -- | translation function for the 'downcaseFirstLetter' flag -- downcaseFirstLetter :: String -> String downcaseFirstLetter "" = "" downcaseFirstLetter (c:cs) = toLower c : cs -- | takes an identifier association table to a translation function -- -- * if first argument is 'True', identifiers that are not found in the -- translation table are subjected to 'underscoreToCase' and friends -- -- * the details of handling the prefix are given in the DOCU section at the -- beginning of this file -- transTabToTransFun :: String -> String -> CHSTrans -> TransFun transTabToTransFun prefx rprefx (CHSTrans _2Case chgCase table omits) = \ide -> let caseTrafo = (if _2Case then underscoreToCase else id) . (case chgCase of CHSSameCase -> id CHSUpCase -> upcaseFirstLetter CHSDownCase -> downcaseFirstLetter) lexeme = identToString ide dft = caseTrafo lexeme -- default uses case trafo in if ide `elem` omits then Nothing else Just $ case lookup ide table of -- lookup original ident Just ide' -> identToString ide' -- original ident matches Nothing -> case eat prefx lexeme of Nothing -> dft -- no match & no prefix Just eatenLexeme -> let eatenIde = internalIdentAt (posOf ide) (rprefx ++ eatenLexeme) eatenDft = caseTrafo rprefx ++ caseTrafo eatenLexeme in case lookup eatenIde table of -- lookup without prefix Nothing -> eatenDft -- orig ide without prefix Just ide' -> identToString ide' -- without prefix matched where -- try to eat prefix and return `Just partialLexeme' if successful -- eat [] ('_':cs) = eat [] cs eat [] cs = Just cs eat (p:prefx') (c:cs) | toUpper p == toUpper c = eat prefx' cs | otherwise = Nothing eat _ _ = Nothing -- the local monad -- --------------- -- | map that for maps C pointer types to Haskell types for pointer that have -- been registered using a pointer hook -- -- * the 'Bool' indicates whether for a C type "ctype", we map "ctype" itself -- or "*ctype" -- -- * in the co-domain, the first string is the type for function arguments and -- the second string is for function results; this distinction is necessary -- as 'ForeignPtr's cannot be returned by a foreign function; the -- restriction on function result types is only for the actual result, not -- for type arguments to parametrised pointer types, ie, it holds for @res@ -- in `Int -> IO res', but not in `Int -> Ptr res' -- type PointerMap = Map (Bool, Ident) (String, String) -- | map that maintains key information about some of the Haskell objects -- generated by c2hs -- -- NB: using records here avoids to run into a bug with deriving 'Read' in GHC -- 5.04.1 -- data HsObject = Pointer { ptrTypeHO :: CHSPtrType, -- kind of pointer isNewtypeHO :: Bool -- newtype? } | Class { superclassHO :: (Maybe String),-- superclass ptrHO :: String -- pointer } deriving (Show, Read) type HsObjectMap = Map Ident HsObject type SizeMap = Map Ident Int -- | set of Haskell type names corresponding to C enums. type EnumSet = Set String -- Map from C type names to type default definitions. type TypedefMap = Map Ident CHSTypedefInfo -- Map from C type names to type default definitions. type DefaultMarshMap = Map (Direction, String, Bool) CHSDefaultMarsh -- Definitions for bare structure function wrappers. data Wrapper = Wrapper { wrapFn :: String , wrapOrigFn ::String , wrapDecl :: CDecl , wrapArgs :: [Bool] , wrapBools :: (Bool, [Bool]) , wrapPos :: Position } deriving Show instance Eq Wrapper where w1 == w2 = wrapFn w1 == wrapFn w2 instance Ord Wrapper where compare w1 w2 = compare (wrapFn w1) (wrapFn w2) type WrapperSet = Set Wrapper type Dependencies = Set String {- FIXME: What a mess... instance Show HsObject where show (Pointer ptrType isNewtype) = "Pointer " ++ show ptrType ++ show isNewtype show (Class osuper pointer ) = "Class " ++ show ptrType ++ show isNewtype -} -- Remove everything until the next element in the list (given by a -- ","), the end of the list (marked by "]"), or the end of a record -- "}". Everything inside parenthesis is ignored. chopIdent :: String -> String chopIdent str = goChop 0 str where goChop :: Int -> String -> String goChop 0 rest@('}':_) = rest goChop 0 rest@(',':_) = rest goChop 0 rest@(']':_) = rest goChop level ('(':rest) = goChop (level+1) rest goChop level (')':rest) = goChop (level-1) rest goChop level (_ :rest) = goChop level rest goChop _ [] = [] extractIdent :: String -> (Ident, String) extractIdent str = let isQuote c = c == '\'' || c == '"' (ideChars, rest) = span (not . isQuote) . tail . dropWhile (not . isQuote) $ str in if null ideChars then error $ "Could not interpret " ++ show str ++ "as an Ident." else (internalIdent ideChars, (chopIdent . tail) rest) -- super kludgy (depends on Show instance of Ident) instance Read Ident where readsPrec _ str = [extractIdent str] -- | the local state consists of -- -- (1) the dynamic library specified by the context hook, -- (2) the prefix specified by the context hook, -- (3) the set of delayed code fragaments, ie, pieces of Haskell code that, -- finally, have to be appended at the CHS module together with the hook -- that created them (the latter allows avoid duplication of foreign -- export declarations), and -- (4) a map associating C pointer types with their Haskell representation -- -- access to the attributes of the C structure tree is via the 'CT' monad of -- which we use an instance here -- data GBState = GBState { lib :: String, -- dynamic library prefix :: String, -- prefix repprefix :: String, -- replacement prefix frags :: [(CHSHook, CHSFrag)], -- delayed code (with hooks) ptrmap :: PointerMap, -- pointer representation objmap :: HsObjectMap, -- generated Haskell objects szmap :: SizeMap, -- object sizes enums :: EnumSet, -- enumeration hooks tdmap :: TypedefMap, -- typedefs dmmap :: DefaultMarshMap, -- user-defined default marshallers wrappers :: WrapperSet, -- C wrapper functions deps :: Dependencies -- Haskell dependencies (for imports) } type GB a = CT GBState a initialGBState :: GBState initialGBState = GBState { lib = "", prefix = "", repprefix = "", frags = [], ptrmap = Map.empty, objmap = Map.empty, szmap = Map.empty, enums = Set.empty, tdmap = Map.empty, dmmap = Map.empty, wrappers = Set.empty, deps = Set.empty } -- | set the dynamic library and library prefix -- setContext :: (Maybe String) -> (Maybe String) -> (Maybe String) -> GB () setContext lib' prefix' repprefix' = transCT $ \state -> (state {lib = fromMaybe "" lib', prefix = fromMaybe "" prefix', repprefix = fromMaybe "" repprefix'}, ()) -- | get the dynamic library -- getLibrary :: GB String getLibrary = readCT lib -- | get the prefix string -- getPrefix :: GB String getPrefix = readCT prefix -- | get the replacement prefix string -- getReplacementPrefix :: GB String getReplacementPrefix = readCT repprefix -- | add code to the delayed fragments (the code is made to start at a new line) -- -- * currently only code belonging to call hooks can be delayed -- -- * if code for the same call hook (ie, same C function) is delayed -- repeatedly only the first entry is stored; it is checked that the hooks -- specify the same flags (ie, produce the same delayed code) -- delayCode :: CHSHook -> String -> GB () delayCode hook str = do frags'' <- readCT frags frags' <- delay hook frags'' transCT (\state -> (state {frags = frags'}, ())) where newEntry = (hook, (CHSVerb ("\n" ++ str) (posOf hook))) -- delay hook'@(CHSCall isFun isUns ide _oalias _) frags' = case find (\(hook'', _) -> hook'' == hook') frags' of Just (CHSCall isFun' isUns' ide' _ _, _) | isFun == isFun' && isUns == isUns' && ide == ide' -> return frags' | otherwise -> err (posOf ide) (posOf ide') Nothing -> return $ frags' ++ [newEntry] delay hook'@(CHSPointer _ _ _ _ _ _ _ _) frags' = case find (\(hook'', _) -> hook'' == hook') frags' of Just (CHSPointer _ _ _ _ _ _ _ _, _) -> return frags' Nothing -> return $ frags' ++ [newEntry] delay _ _ = interr "GBMonad.delayCode: Illegal delay!" -- err = incompatibleCallHooksErr -- | get the complete list of delayed fragments -- getDelayedCode :: GB [CHSFrag] getDelayedCode = readCT (map snd . frags) -- | add an entry to the pointer map -- ptrMapsTo :: (Bool, Ident) -> (String, String) -> GB () (isStar, cName) `ptrMapsTo` hsRepr = transCT (\state -> (state { ptrmap = Map.insert (isStar, cName) hsRepr (ptrmap state) }, ())) -- | query the pointer map -- queryPtr :: (Bool, Ident) -> GB (Maybe (String, String)) queryPtr pcName = do fm <- readCT ptrmap return $ Map.lookup pcName fm -- | add an entry to the Haskell object map -- objIs :: Ident -> HsObject -> GB () hsName `objIs` obj = transCT (\state -> (state { objmap = Map.insert hsName obj (objmap state) }, ())) -- | query the Haskell object map -- queryObj :: Ident -> GB (Maybe HsObject) queryObj hsName = do fm <- readCT objmap return $ Map.lookup hsName fm -- | add an entry to the size map -- sizeIs :: Ident -> Int -> GB () hsName `sizeIs` sz = transCT (\state -> (state { szmap = Map.insert hsName sz (szmap state) }, ())) -- | query the size map -- querySize :: Ident -> GB (Maybe Int) querySize hsName = do sm <- readCT szmap return $ Map.lookup hsName sm -- | query the Haskell object map for a class -- -- * raise an error if the class cannot be found -- queryClass :: Ident -> GB HsObject queryClass hsName = do oobj <- queryObj hsName case oobj of Just obj@(Class _ _) -> return obj Just _ -> classExpectedErr hsName Nothing -> hsObjExpectedErr hsName -- | query the Haskell object map for a pointer -- -- * raise an error if the pointer cannot be found -- queryPointer :: Ident -> GB HsObject queryPointer hsName = do oobj <- queryObj hsName case oobj of Just obj@(Pointer _ _) -> return obj Just _ -> pointerExpectedErr hsName Nothing -> hsObjExpectedErr hsName -- | merge the pointer and Haskell object maps -- -- * currently, the read map overrides any entires for shared keys in the map -- that is already in the monad; this is so that, if multiple import hooks -- add entries for shared keys, the textually latest prevails; any local -- entries are entered after all import hooks anyway -- -- FIXME: This currently has several shortcomings: -- * It just dies in case of a corrupted .chi file -- * We should at least have the option to raise a warning if two -- entries collide in the 'objmap'. But it would be better to -- implement qualified names. -- * Do we want position information associated with the read idents? -- mergeMaps :: String -> GB () mergeMaps str = transCT (\state -> (state { ptrmap = Map.union readPtrMap (ptrmap state), objmap = Map.union readObjMap (objmap state), enums = Set.union readEnumSet (enums state) }, ())) where -- Deal with variant interface file formats (old .chi files don't -- contain the list of enumerations). (ptrAssoc, objAssoc, enumList) = case reads str of [] -> let (ptr, obj) = read str in (ptr, obj, []) [(r, "")] -> r readPtrMap = Map.fromList [((isStar, internalIdent ide), repr) | ((isStar, ide), repr) <- ptrAssoc] readObjMap = Map.fromList [(internalIdent ide, obj) | (ide, obj) <- objAssoc] readEnumSet = Set.fromList enumList -- | convert the whole pointer and Haskell object maps into printable form -- dumpMaps :: GB String dumpMaps = do ptrFM <- readCT ptrmap objFM <- readCT objmap enumS <- readCT enums let dumpable = ([((isStar, identToString ide), repr) | ((isStar, ide), repr) <- Map.toList ptrFM], [(identToString ide, obj) | (ide, obj) <- Map.toList objFM], Set.toList enumS) return $ show dumpable -- | query the enum map -- queryEnum :: String -> GB Bool queryEnum hsName = do es <- readCT enums return $ hsName `Set.member` es -- | add an entry to the enum map -- isEnum :: String -> GB () isEnum hsName = transCT (\state -> (state { enums = Set.insert hsName (enums state) }, ())) -- | query the type default map -- queryTypedef :: Ident -> GB (Maybe CHSTypedefInfo) queryTypedef cIde = do tds <- readCT tdmap return $ cIde `Map.lookup` tds -- | add an entry to the type default map -- isC2HSTypedef :: Ident -> CHSTypedefInfo -> GB () isC2HSTypedef cIde td = transCT (\state -> (state { tdmap = Map.insert cIde td (tdmap state) }, ())) -- | query the default marshaller map -- queryDefaultMarsh :: (Direction, String, Bool) -> GB (Maybe CHSDefaultMarsh) queryDefaultMarsh k = do dms <- readCT dmmap return $ k `Map.lookup` dms -- | add an entry to the type default map -- isDefaultMarsh :: (Direction, String, Bool) -> CHSDefaultMarsh -> GB () isDefaultMarsh k dm = transCT (\state -> (state { dmmap = Map.insert k dm (dmmap state) }, ())) -- | add a wrapper definition addWrapper :: String -> String -> CDecl -> [Bool] -> (Bool, [Bool]) -> Position -> GB () addWrapper wfn ofn cdecl args bools pos = let w = Wrapper wfn ofn cdecl args bools pos in transCT (\st -> (st { wrappers = Set.insert w (wrappers st) }, ())) getWrappers :: GB [Wrapper] getWrappers = Set.toList `fmap` readCT wrappers -- | add Haskell module dependency for import generation addHsDependency :: String -> GB () addHsDependency m = transCT (\st -> (st { deps = Set.insert m (deps st) }, ())) getHsDependencies :: GB [String] getHsDependencies = Set.toList `fmap` readCT deps -- error messages -- -------------- incompatibleCallHooksErr :: Position -> Position -> GB a incompatibleCallHooksErr here there = raiseErrorCTExc here ["Incompatible call hooks!", "There is a another call hook for the same C function at " ++ show there, "The flags and C function name of the two hooks should be identical,", "but they are not."] classExpectedErr :: Ident -> GB a classExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected a class name!", "Expected `" ++ identToString ide ++ "' to refer to a class introduced", "by a class hook."] pointerExpectedErr :: Ident -> GB a pointerExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected a pointer name!", "Expected `" ++ identToString ide ++ "' to be a type name introduced by", "a pointer hook."] hsObjExpectedErr :: Ident -> GB a hsObjExpectedErr ide = raiseErrorCTExc (posOf ide) ["Unknown name!", "`" ++ identToString ide ++ "' is unknown; it has *not* been defined by", "a previous hook."] c2hs-0.28.1/src/C2HS/Gen/Header.hs0000644000000000000000000003335312677513064014374 0ustar0000000000000000-- C->Haskell Compiler: custom header generator -- -- Author : Manuel M T Chakravarty -- Created: 5 February 2003 -- -- Copyright (c) 2004 Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module implements the generation of a custom header from a binding -- module. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Computing CPP Conditionals -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- We obtain information about which branches of CPP conditions are taken -- during pre-processing of the custom header file by introducing new -- struct declarations. Specifically, after each #if[[n]def] or #elif, -- we place a declaration of the form -- -- struct C2HS_COND_SENTRY; -- -- We can, then, determine which branch of a conditional has been taken by -- checking whether the struct corresponding to that conditional has been -- declared. -- --- TODO ---------------------------------------------------------------------- -- -- * Ideally, `ghFrag[s]' should be tail recursive module C2HS.Gen.Header ( genHeader ) where -- standard libraries import Control.Monad (when,liftM) -- Language.C / Compiler Toolkit import Language.C.Data import Language.C.Pretty import Language.C.Syntax import Data.Errors (interr) import Data.DList (DList) import qualified Data.DList as DL -- C->Haskell import C2HS.State (CST, runCST, transCST, raiseError, catchExc, throwExc, errorsPresent, showErrors, fatal) -- friends import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSChangeCase(..), CHSTrans(..), CHSAPath(..)) -- | The header generation monad -- type GH a = CST [Name] a -- | Generate a custom C header from a CHS binding module. -- -- * All CPP directives and inline-C fragments are moved into the custom header -- -- * The CPP and inline-C fragments are removed from the .chs tree and -- conditionals are replaced by structured conditionals -- genHeader :: CHSModule -> CST s ([String], CHSModule, String) genHeader mod' = do (header, mod'') <- runCST (ghModule mod') newNameSupply `ifGHExc` return ([], CHSModule []) -- check for errors and finalise -- errs <- errorsPresent if errs then do errmsgs <- showErrors fatal ("Errors during generation of C header:\n\n" -- fatal error ++ errmsgs) else do warnmsgs <- showErrors return (header, mod'', warnmsgs) -- | Obtain a new base name that may be used, in C, to encode the result of a -- preprocessor conditional. -- newName :: CST [Name] String newName = transCST $ \supply -> (tail supply, "C2HS_COND_SENTRY_" ++ (show.nameId) (head supply)) -- | Various forms of processed fragments -- data FragElem = Frag CHSFrag | Elif String Position | Else Position | Endif Position | EOF instance Pos FragElem where posOf (Frag frag ) = posOf frag posOf (Elif _ pos) = pos posOf (Else pos) = pos posOf (Endif pos) = pos posOf EOF = nopos -- | check for end of file -- isEOF :: FragElem -> Bool isEOF EOF = True isEOF _ = False -- | Generate the C header for an entire .chs module. -- -- * This works more or less like a recursive decent parser for a statement -- sequence that may contain conditionals, where 'ghFrag' implements most of -- the state transition system of the associated automaton -- ghModule :: CHSModule -> GH ([String], CHSModule) ghModule (CHSModule frags) = do (header, frags', last', _rest) <- ghFrags frags when (not . isEOF $ last') $ notOpenCondErr (posOf last') return (DL.toList header, CHSModule frags') -- | Collect header and fragments up to eof or a CPP directive that is part of a -- conditional -- -- * We collect the header (ie, CPP directives and inline-C) using a -- difference list to avoid worst case O(n^2) complexity due to -- concatenation of lines that go into the header. -- ghFrags :: [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag]) ghFrags [] = return (DL.empty, [], EOF, []) ghFrags frags = do (header, frag, rest) <- ghFrag frags case frag of Frag aFrag -> do (header2, frags', frag', rest') <- ghFrags rest -- FIXME: Not tail rec return (header `DL.append` header2, aFrag:frags', frag', rest') _ -> return (header, [], frag, rest) -- | Process a single fragment *structure*; i.e., if the first fragment -- introduces a conditional, process the whole conditional; otherwise, process -- the first fragment -- ghFrag :: [CHSFrag] -> GH (DList String, -- partial header file FragElem, -- processed fragment [CHSFrag]) -- not yet processed fragments ghFrag [] = return (DL.empty, EOF, []) ghFrag (frag@(CHSVerb _ _ ) : frags) = return (DL.empty, Frag frag, frags) -- generate an -- enum __c2hs__enum__'id { __c2hs_enr__'id = DEF1, ... } -- and then process an ordinary enum directive ghFrag (_frag@(CHSHook (CHSEnumDefine hsident trans instances pos) hkpos) : frags) = do ide <- newEnumIdent (enrs,trans') <- createEnumerators trans return (DL.fromList [show.pretty $ enumDef ide enrs,";\n"], Frag (enumFrag (identToString ide) trans'), frags) where newEnumIdent = liftM internalIdent $ transCST $ \supply -> (tail supply, "__c2hs_enum__" ++ show (nameId $ head supply)) newEnrIdent = liftM internalIdent $ transCST $ \supply -> (tail supply, "__c2hs_enr__" ++ show (nameId $ head supply)) createEnumerators (CHSTrans isUnderscore changeCase aliases omits) | isUnderscore = raiseErrorGHExc pos ["underScoreToCase is meaningless " ++ "for `enum define' hooks"] | changeCase /= CHSSameCase = raiseErrorGHExc pos ["changing case is meaningless " ++ "for `enum define' hooks"] | otherwise = do (enrs,transtbl') <- liftM unzip (mapM createEnumerator aliases) return (enrs,CHSTrans False CHSSameCase transtbl' omits) createEnumerator (cid,hsid) = liftM (\enr -> ((enr,cid),(enr,hsid))) newEnrIdent enumDef ide enrs = CEnum (Just ide) (Just$ map mkEnr enrs) [] undefNode where mkEnr (name,value) = (name, Just $ CVar value undefNode) enumFrag ide trans' = CHSHook (CHSEnum (internalIdent ide) (Just hsident) trans' True Nothing Nothing instances pos) hkpos ghFrag (_frag@(CHSHook (CHSConst cident pos) hkpos) : frags) = do ide <- newConstIdent return (DL.fromList [show.pretty $ constDef ide,";\n"], Frag (CHSHook (CHSConst ide pos) hkpos), frags) where newConstIdent = liftM internalIdent $ transCST $ \supply -> (tail supply, "__c2hs__const__" ++ show (nameId $ head supply)) constDef ide = -- This is a little nasty. We write a definition of an *integer* -- C value into the header, regardless of what type it really -- is... CDecl [CTypeSpec (CIntType undefNode)] [(Just (CDeclr (Just ide) [] Nothing [] undefNode), Just (CInitExpr (CVar cident undefNode) undefNode), Nothing)] undefNode ghFrag (frag@(CHSHook (CHSFun _ _ True varTypes (CHSRoot _ ide) oalias _ _ _ _) _) : frags) = do let ideLexeme = identToString ide hsLexeme = ideLexeme `maybe` identToString $ oalias vaIdent base idx = "__c2hs__vararg__" ++ base ++ "_" ++ show idx ides = map (vaIdent hsLexeme) [0..length varTypes - 1] defs = zipWith (\t i -> t ++ " " ++ i ++ ";\n") varTypes ides return (DL.fromList defs, Frag frag, frags) ghFrag (frag@(CHSHook (CHSTypedef cIde hsIde _) _) : frags) = do let cTypLexeme = identToString cIde hsTypLexeme = identToString hsIde defs = [cTypLexeme ++ " __c2hs_typedef__" ++ cTypLexeme ++ "__" ++ hsTypLexeme ++ ";\n"] return (DL.fromList defs, Frag frag, frags) ghFrag (frag@(CHSHook _ _) : frags) = return (DL.empty, Frag frag, frags) ghFrag (frag@(CHSLine _ ) : frags) = return (DL.empty, Frag frag, frags) ghFrag ( (CHSC s _ ) : frags) = do (header, frag, frags' ) <- ghFrag frags -- scan for next CHS fragment return (DL.singleton s `DL.append` header, frag, frags') -- FIXME: this is not tail recursive... ghFrag ( (CHSCond _ _ ) : _ ) = interr "GenHeader.ghFrags: There can't be a structured conditional yet!" ghFrag ( (CHSCPP s pos nl) : frags) = let (directive, _) = break (`elem` " \t") . dropWhile (`elem` " \t") $ s in case directive of "if" -> openIf s pos frags "ifdef" -> openIf s pos frags "ifndef" -> openIf s pos frags "else" -> return (DL.empty , Else pos , frags) "elif" -> return (DL.empty , Elif s pos , frags) "endif" -> return (DL.empty , Endif pos , frags) _ -> return (DL.fromList ['#':s, "\n"], Frag (CHSVerb (if nl then "\n" else "") pos), frags) where -- enter a new conditional (may be an #if[[n]def] or #elif) -- -- * Arguments are the lexeme of the directive `s', the position of that -- directive `pos', and the fragments following the directive `frags' -- openIf s' _pos frags' = do (headerTh, fragsTh, last', rest) <- ghFrags frags' case last' of Else _pos' -> do (headerEl, fragsEl, last'', rest') <- ghFrags rest case last'' of Else pos' -> notOpenCondErr pos' Elif _ pos' -> notOpenCondErr pos' Endif _ -> closeIf ((headerTh `DL.snoc` "#else\n") `DL.append` (headerEl `DL.snoc` "#endif\n")) (s', fragsTh) [] (Just fragsEl) rest' EOF -> notClosedCondErr pos Elif s'' pos' -> do (headerEl, condFrag, rest') <- openIf s'' pos' rest case condFrag of Frag (CHSCond alts dft) -> closeIf (headerTh `DL.append` headerEl) (s, fragsTh) alts dft rest' _ -> interr "GenHeader.ghFrag: Expected CHSCond!" Endif _ -> closeIf (headerTh `DL.snoc` "#endif\n") (s', fragsTh) [] (Just []) rest EOF -> notClosedCondErr pos -- -- turn a completed conditional into a 'CHSCond' fragment -- -- * `(s, fragsTh)' is the CPP directive `s' containing the condition under -- which `fragTh' should be executed; `alts' are alternative branches -- (with conditions); and `oelse' is an optional else-branch -- closeIf headerTail (s', fragsTh) alts oelse rest = do sentryName <- newName let sentry = internalIdent sentryName -- don't use an internal ident, as we need to test for -- equality with identifiers read from the .i file -- during binding hook expansion header = DL.fromList ['#':s', "\n", "struct ", sentryName, ";\n"] `DL.append` headerTail return (header, Frag (CHSCond ((sentry, fragsTh):alts) oelse), rest) -- exception handling -- ------------------ -- | exception identifier -- ghExc :: String ghExc = "ghExc" -- | throw an exception -- throwGHExc :: GH a throwGHExc = throwExc ghExc "Error during C header generation" -- | catch a 'ghExc' -- ifGHExc :: CST s a -> CST s a -> CST s a ifGHExc m handler = m `catchExc` (ghExc, const handler) -- | raise an error followed by throwing a GH exception -- raiseErrorGHExc :: Position -> [String] -> GH a raiseErrorGHExc pos errs = raiseError pos errs >> throwGHExc -- error messages -- -------------- notClosedCondErr :: Position -> GH a notClosedCondErr pos = raiseErrorGHExc pos ["Unexpected end of file!", "File ended while the conditional block starting here was not closed \ \properly."] notOpenCondErr :: Position -> GH a notOpenCondErr pos = raiseErrorGHExc pos ["Missing #if[[n]def]!", "There is a #else, #elif, or #endif without an #if, #ifdef, or #ifndef."] c2hs-0.28.1/src/C2HS/C/0000755000000000000000000000000012677513064012312 5ustar0000000000000000c2hs-0.28.1/src/C2HS/C/Names.hs0000644000000000000000000001773712677513064013730 0ustar0000000000000000-- C->Haskell Compiler: C name analysis -- -- Author : Manuel M. T. Chakravarty -- Created: 16 October 99 -- -- Copyright (c) 1999 Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- Name analysis of C header files. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * Member names are not looked up, because this requires type information -- about the expressions before the `.' or `->'. -- --- TODO ---------------------------------------------------------------------- -- -- * `defObjOrErr': currently, repeated declarations are completely ignored; -- eventually, the consistency of the declarations should be checked -- module C2HS.C.Names (nameAnalysis) where import Language.C.Data.Ident import Language.C.Data.Position import Language.C.Syntax import C2HS.State (CST) import C2HS.C.Attrs (AttrC, emptyAttrC, CObj(..), CTag(..), CDef(..)) import C2HS.C.Trav (CT, runCT, enterObjs, leaveObjs, ifCTExc, raiseErrorCTExc, defObj, findTypeObj, findValueObj, defTag, refersToDef, isTypedef) import C2HS.C.Builtin -- monad and wrapper -- ----------------- -- | local instance of the C traversal monad -- type NA a = CT () a -- | name analysis of C header files -- nameAnalysis :: CTranslUnit -> CST s AttrC nameAnalysis headder = do (ac', _) <- runCT (naCTranslUnit headder) emptyAttrC () return ac' -- name analyis traversal -- ---------------------- -- | traverse a complete header file -- -- * in case of an error, back off the current declaration -- naCTranslUnit :: CTranslUnit -> NA () naCTranslUnit (CTranslUnit decls _) = do -- establish definitions for builtins -- mapM_ (uncurry defObjOrErr) builtinTypeNames -- -- analyse the header -- mapM_ (\decl -> naCExtDecl decl `ifCTExc` return ()) decls -- | Processing of toplevel declarations -- -- * We turn function definitions into prototypes, as we are not interested in -- function bodies. -- naCExtDecl :: CExtDecl -> NA () naCExtDecl (CDeclExt decl ) = naCDecl decl naCExtDecl (CFDefExt (CFunDef specs declr _ _ at)) = naCDecl $ CDecl specs [(Just declr, Nothing, Nothing)] at naCExtDecl _ = return () naCDecl :: CDecl -> NA () naCDecl decl@(CDecl specs decls _) = do mapM_ naCDeclSpec specs mapM_ naTriple decls where naTriple (odeclr, oinit, oexpr) = do let obj = if isTypedef decl then TypeCO decl else ObjCO decl mapMaybeM_ (naCDeclr obj) odeclr mapMaybeM_ naCInit oinit mapMaybeM_ naCExpr oexpr naCDeclSpec :: CDeclSpec -> NA () naCDeclSpec (CTypeSpec tspec) = naCTypeSpec tspec naCDeclSpec _ = return () naCTypeSpec :: CTypeSpec -> NA () naCTypeSpec (CSUType su _) = naCStructUnion (StructUnionCT su) su naCTypeSpec (CEnumType enum _) = naCEnum (EnumCT enum) enum naCTypeSpec (CTypeDef ide _) = do (obj, _) <- findTypeObj ide False ide `refersToDef` ObjCD obj naCTypeSpec _ = return () naCStructUnion :: CTag -> CStructUnion -> NA () naCStructUnion tag (CStruct _ oide decls _ _) = do mapMaybeM_ (`defTagOrErr` tag) oide enterObjs -- enter local struct range for objects mapM_ naCDecl (maybe [] id decls) leaveObjs -- leave range naCEnum :: CTag -> CEnum -> NA () naCEnum tag enum@(CEnum oide enumrs _ _) = do mapMaybeM_ (`defTagOrErr` tag) oide mapM_ naEnumr (maybe [] id enumrs) where naEnumr (ide, oexpr) = do ide `defObjOrErr` EnumCO ide enum mapMaybeM_ naCExpr oexpr -- Name analysis of a declarator -- The derivations are analysed in order, only THEN -- the object itself is entered into the symboltable naCDeclr :: CObj -> CDeclr -> NA () naCDeclr obj (CDeclr oide derived _ _ _) = do mapM_ (naCDerivedDeclr obj) derived mapMaybeM_ (`defObjOrErr` obj) oide naCDerivedDeclr :: CObj -> CDerivedDeclr -> NA () naCDerivedDeclr _obj (CFunDeclr (Right (params,_)) _ _) = do enterObjs mapM_ naCDecl params leaveObjs naCDerivedDeclr _obj (CArrDeclr _ (CArrSize _ expr) _) = naCExpr expr naCDerivedDeclr _obj _ = return () naCInit :: CInit -> NA () naCInit (CInitExpr expr _) = naCExpr expr naCInit (CInitList inits _) = mapM_ (naCInit . snd) inits naCExpr :: CExpr -> NA () naCExpr (CComma exprs _) = mapM_ naCExpr exprs naCExpr (CAssign _ expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2 naCExpr (CCond expr1 expr2 expr3 _) = naCExpr expr1 >> mapMaybeM_ naCExpr expr2 >> naCExpr expr3 naCExpr (CBinary _ expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2 naCExpr (CCast decl expr _) = naCDecl decl >> naCExpr expr naCExpr (CUnary _ expr _) = naCExpr expr naCExpr (CSizeofExpr expr _) = naCExpr expr naCExpr (CSizeofType decl _) = naCDecl decl naCExpr (CAlignofExpr expr _) = naCExpr expr naCExpr (CAlignofType decl _) = naCDecl decl naCExpr (CIndex expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2 naCExpr (CCall expr exprs _) = naCExpr expr >> mapM_ naCExpr exprs naCExpr (CMember expr _ide _ _) = naCExpr expr naCExpr (CVar ide _) = do (obj, _) <- findValueObj ide False ide `refersToDef` ObjCD obj naCExpr (CConst _ ) = return () naCExpr (CCompoundLit _ inits _) = mapM_ (naCInit . snd) inits naCExpr (CComplexImag expr _) = naCExpr expr naCExpr (CComplexReal expr _) = naCExpr expr naCExpr (CLabAddrExpr _lab _) = error "Names.hs: adress of label expression analysis isn't supported" naCExpr (CBuiltinExpr _ ) = error "Names.hs: builtin expression analysis isn't supported" naCExpr (CStatExpr _ _) = error "Names.hs: analysis of GNU statement - expression isn't supported" -- auxilliary functions -- -------------------- -- | raise an error and exception if the identifier is defined twice defTagOrErr :: Ident -> CTag -> NA () ide `defTagOrErr` tag = do otag <- ide `defTag` tag case otag of Nothing -> return () Just tag' -> declaredTwiceErr ide (posOf tag') -- | associate an object with a referring identifier -- -- * currently, repeated declarations are completely ignored; eventually, the -- consistency of the declarations should be checked -- defObjOrErr :: Ident -> CObj -> NA () ide `defObjOrErr` obj = ide `defObj` obj >> return () -- | maps some monad operation into a 'Maybe', discarding the result -- mapMaybeM_ :: Monad m => (a -> m b) -> Maybe a -> m () mapMaybeM_ _ Nothing = return () mapMaybeM_ m (Just a) = m a >> return () -- error messages -- -------------- declaredTwiceErr :: Ident -> Position -> NA a declaredTwiceErr ide otherPos = raiseErrorCTExc (posOf ide) ["Identifier declared twice!", "The identifier `" ++ identToString ide ++ "' was already declared at " ++ show otherPos ++ "."] c2hs-0.28.1/src/C2HS/C/Builtin.hs0000644000000000000000000000425112677513064014256 0ustar0000000000000000-- C->Haskell Compiler: C builtin information -- -- Author : Manuel M. T. Chakravarty -- Created: 12 February 01 -- -- Copyright (c) 2001 Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides information about builtin entities. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Currently, only builtin type names are supported. The only builtin type -- name is `__builtin_va_list', which is a builtin of GNU C. -- --- TODO ---------------------------------------------------------------------- -- module C2HS.C.Builtin ( builtinTypeNames ) where -- Language.C / compiler toolkit import Language.C.Data.Position import Language.C.Data.Ident import Language.C.Syntax import Language.C.Data import C2HS.C.Attrs (CObj(BuiltinCO)) -- | predefined type names -- builtinTypeNames :: [(Ident, CObj)] builtinTypeNames = [(va_list_ide, BuiltinCO $ Just ptrVoidDecl)] where va_list_ide :: Ident va_list_ide = builtinIdent "__builtin_va_list" ptrVoidDecl :: CDecl ptrVoidDecl = CDecl [ CStorageSpec (CTypedef builtin) , CTypeSpec (CVoidType builtin) ] [( Just $ CDeclr (Just va_list_ide) [CPtrDeclr [] builtin] Nothing [] builtin , Nothing , Nothing )] builtin builtin :: NodeInfo builtin = mkNodeInfoOnlyPos builtinPos c2hs-0.28.1/src/C2HS/C/Info.hs0000644000000000000000000000717512677513064013553 0ustar0000000000000000{-# LANGUAGE CPP #-} -- C->Haskell Compiler: information about the C implementation -- -- Author : Manuel M T Chakravarty -- Created: 5 February 01 -- -- Copyright (c) [2001..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provide some information about the specific implementation of -- C that we are dealing with. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Bit fields -- ~~~~~~~~~~ -- Bit fields in C can be signed and unsigned. According to K&R A8.3, they -- can only be formed from `int', `signed int', and `unsigned int', where for -- `int' it is implementation dependent whether the field is signed or -- unsigned. Moreover, the following parameters are implementation -- dependent: -- -- * the direction of packing bits into storage units, -- * the size of storage units, and -- * whether when a field that doesn't fit a partially filled storage unit -- is split across units or the partially filled unit is padded. -- -- Generally, unnamed fields (those without an identifier) with a width of 0 -- are guaranteed to forces the above padding. Note that in `CPrimType' we -- only represent 0 width fields *if* they imply padding. In other words, -- whenever they are unnamed, they are represented by a `CPrimType', and if -- they are named, they are represented by a `CPrimType' only if that -- targeted C compiler chooses to let them introduce padding. If a field -- does not have any effect, it is dropped during the conversion of a C type -- into a `CPrimType'-based representation. -- -- In the code, we assume that the alignment of a bitfield (as determined by -- `bitfieldAlignment') is independent of the size of the bitfield. -- --- TODO ---------------------------------------------------------------------- -- module C2HS.C.Info ( CPrimType(..) ) where -- calibration of C's primitive types -- ---------------------------------- -- | C's primitive types -- -- * 'CFunPtrPT' doesn't occur in Haskell representations of C types, but we -- need to know their size, which may be different from 'CPtrPT' -- data CPrimType = CPtrPT -- void * | CFunPtrPT -- void *() | CCharPT -- char | CUCharPT -- unsigned char | CSCharPT -- signed char | CIntPT -- int | CShortPT -- short int | CLongPT -- long int | CLLongPT -- long long int | CUIntPT -- unsigned int | CUShortPT -- unsigned short int | CULongPT -- unsigned long int | CULLongPT -- unsigned long long int | CFloatPT -- float | CDoublePT -- double | CLDoublePT -- long double | CBoolPT -- bool (C99 _Bool) | CSFieldPT Int -- signed bit field | CUFieldPT Int -- unsigned bit field | CAliasedPT String String CPrimType deriving (Eq, Show) c2hs-0.28.1/src/C2HS/C/Trav.hs0000644000000000000000000010777512677513064013603 0ustar0000000000000000-- C->Haskell Compiler: traversals of C structure tree -- -- Author : Manuel M. T. Chakravarty -- Created: 16 October 99 -- -- Copyright (c) [1999..2001] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This modules provides for traversals of C structure trees. The C -- traversal monad supports traversals that need convenient access to the -- attributes of an attributed C structure tree. The monads state can still -- be extended. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Handling of redefined tag values -- -------------------------------- -- -- Structures allow both -- -- struct s {...} ...; -- struct s ...; -- -- and -- -- struct s ...; /* this is called a forward reference */ -- struct s {...} ...; -- -- In contrast enumerations only allow (in ANSI C) -- -- enum e {...} ...; -- enum e ...; -- -- The function `defTag' handles both types and establishes an object -- association from the tag identifier in the empty declaration (ie, the one -- without `{...}') to the actually definition of the structure of -- enumeration. This implies that when looking for the details of a -- structure or enumeration, possibly a chain of references on tag -- identifiers has to be chased. Note that the object association attribute -- is _not_defined_ when the `{...}' part is present in a declaration. -- --- TODO ---------------------------------------------------------------------- -- -- * `extractStruct' doesn't account for forward declarations that have no -- full declaration yet; if `extractStruct' is called on such a declaration, -- we have a user error, but currently an internal error is raised -- module C2HS.C.Trav (CT, readCT, transCT, runCT, throwCTExc, ifCTExc, raiseErrorCTExc, enter, enterObjs, leave, leaveObjs, defObj, findObj, findObjShadow, defTag, findTag, findTagShadow, applyPrefixToNameSpaces, getDefOf, refersToDef, refersToNewDef, getDeclOf, findTypeObjMaybe, findTypeObj, findValueObj, findFunObj, -- -- C structure tree query functions -- isTypedef, simplifyDecl, declrFromDecl, declrNamed, declaredDeclr, initDeclr, declaredName, structMembers, expandDecl, structName, enumName, tagName, isPtrDeclr, isArrDeclr, dropPtrDeclr, isPtrDecl, isArrDecl, isFunDeclr, structFromDecl, funResultAndArgs, chaseDecl, findAndChaseDecl, findAndChaseDeclOrTag, checkForAlias, checkForOneCUName, checkForOneAliasName, lookupEnum, lookupStructUnion, lookupDeclOrTag) where import Data.List (find) import Control.Monad (liftM) import Control.Exception (assert) import Language.C.Data import Language.C.Data.Ident (dumpIdent) import Language.C.Syntax import Data.Attributes import Data.Errors import C2HS.State (CST, readCST, transCST, runCST, raiseError, catchExc, throwExc, Traces(..), putTraceStr) import C2HS.C.Attrs (AttrC(..), enterNewRangeC, enterNewObjRangeC, leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC, lookupDefObjCShadow, addDefTagC, lookupDefTagC, lookupDefTagCShadow, applyPrefix, getDefOfIdentC, setDefOfIdentC, updDefOfIdentC, CObj(..), CTag(..), CDef(..)) -- the C traversal monad -- --------------------- -- | C traversal monad -- type CState s = (AttrC, s) type CT s a = CST (CState s) a -- | read attributed struture tree -- readAttrCCT :: (AttrC -> a) -> CT s a readAttrCCT reader = readCST $ \(ac, _) -> reader ac -- | transform attributed structure tree -- transAttrCCT :: (AttrC -> (AttrC, a)) -> CT s a transAttrCCT trans = transCST $ \(ac, s) -> let (ac', r) = trans ac in ((ac', s), r) -- | access to the user-defined state -- -- | read user-defined state -- readCT :: (s -> a) -> CT s a readCT reader = readCST $ \(_, s) -> reader s -- | transform user-defined state -- transCT :: (s -> (s, a)) -> CT s a transCT trans = transCST $ \(ac, s) -> let (s', r) = trans s in ((ac, s'), r) -- usage of a traversal monad -- -- | execute a traversal monad -- -- * given a traversal monad, an attribute structure tree, and a user -- state, the transformed structure tree and monads result are returned -- runCT :: CT s a -> AttrC -> s -> CST t (AttrC, a) runCT m ac s = runCST m' (ac, s) where m' = do r <- m (ac', _) <- readCST id return (ac', r) -- exception handling -- ------------------ -- | exception identifier -- ctExc :: String ctExc = "ctExc" -- | throw an exception -- throwCTExc :: CT s a throwCTExc = throwExc ctExc "Error during traversal of a C structure tree" -- | catch a `ctExc' -- ifCTExc :: CT s a -> CT s a -> CT s a ifCTExc m handler = m `catchExc` (ctExc, const handler) -- | raise an error followed by throwing a CT exception -- raiseErrorCTExc :: Position -> [String] -> CT s a raiseErrorCTExc pos errs = raiseError pos errs >> throwCTExc -- attribute manipulation -- ---------------------- -- name spaces -- -- | enter a new local range -- enter :: CT s () enter = transAttrCCT $ \ac -> (enterNewRangeC ac, ()) -- | enter a new local range, only for objects -- enterObjs :: CT s () enterObjs = transAttrCCT $ \ac -> (enterNewObjRangeC ac, ()) -- | leave the current local range -- leave :: CT s () leave = transAttrCCT $ \ac -> (leaveRangeC ac, ()) -- | leave the current local range, only for objects -- leaveObjs :: CT s () leaveObjs = transAttrCCT $ \ac -> (leaveObjRangeC ac, ()) -- | enter an object definition into the object name space -- -- * if a definition of the same name was already present, it is returned -- defObj :: Ident -> CObj -> CT s (Maybe CObj) defObj ide obj = do traceCTrav $ "Defining object "++show ide++"...\n" transAttrCCT $ \ac -> addDefObjC ac ide obj -- | find a definition in the object name space -- findObj :: Ident -> CT s (Maybe CObj) findObj ide = readAttrCCT $ \ac -> lookupDefObjC ac ide -- | find a definition in the object name space; if nothing found, try -- whether there is a shadow identifier that matches -- findObjShadow :: Ident -> CT s (Maybe (CObj, Ident)) findObjShadow ide = readAttrCCT $ \ac -> lookupDefObjCShadow ac ide -- | enter a tag definition into the tag name space -- -- * empty definitions of structures get overwritten with complete ones and a -- forward reference is added to their tag identifier; furthermore, both -- structures and enums may be referenced using an empty definition when -- there was a full definition earlier and in this case there is also an -- object association added; otherwise, if a definition of the same name was -- already present, it is returned (see DOCU section) -- -- * it is checked that the first occurence of an enumeration tag is -- accompanied by a full definition of the enumeration -- defTag :: Ident -> CTag -> CT s (Maybe CTag) defTag ide tag = do traceCTrav $ "Defining tag "++show ide++"...\n" otag <- transAttrCCT $ \ac -> addDefTagC ac ide tag case otag of Nothing -> return Nothing -- no collision Just prevTag -> case isRefinedOrUse prevTag tag of Nothing -> return otag Just (fullTag, foreIde) -> do _ <- transAttrCCT $ \ac -> addDefTagC ac ide fullTag foreIde `refersToDef` TagCD fullTag return Nothing -- transparent for env where -- compute whether we have the case of a non-conflicting redefined tag -- definition, and if so, return the full definition and the foreward -- definition's tag identifier -- -- * the first argument contains the _previous_ definition -- -- * in the case of a structure, a foreward definition after a full -- definition is allowed, so we have to handle this case; enumerations -- don't allow foreward definitions -- -- * there may also be multiple foreward definition; if we have two of -- them here, one is arbitrarily selected to take the role of the full -- definition -- isRefinedOrUse (StructUnionCT (CStruct _ (Just ide') Nothing _ _)) tag'@(StructUnionCT (CStruct _ (Just _ ) _ _ _)) = Just (tag', ide') isRefinedOrUse tag'@(StructUnionCT (CStruct _ (Just _ ) _ _ _)) (StructUnionCT (CStruct _ (Just ide') Nothing _ _)) = Just (tag', ide') isRefinedOrUse (EnumCT (CEnum (Just ide') Nothing _ _)) tag'@(EnumCT (CEnum (Just _ ) _ _ _)) = Just (tag', ide') isRefinedOrUse tag'@(EnumCT (CEnum (Just ide') _ _ _)) (EnumCT (CEnum (Just _ ) _ _ _)) = Just (tag', ide') isRefinedOrUse _ _ = Nothing -- | find an definition in the tag name space -- findTag :: Ident -> CT s (Maybe CTag) findTag ide = readAttrCCT $ \ac -> lookupDefTagC ac ide -- | find an definition in the tag name space; if nothing found, try -- whether there is a shadow identifier that matches -- findTagShadow :: Ident -> CT s (Maybe (CTag, Ident)) findTagShadow ide = readAttrCCT $ \ac -> lookupDefTagCShadow ac ide -- | enrich the object and tag name space with identifiers obtained by dropping -- the given prefix from the identifiers already in the name space -- -- * if a new identifier would collides with an existing one, the new one is -- discarded, ie, all associations that existed before the transformation -- started are still in effect after the transformation -- applyPrefixToNameSpaces :: String -> String -> CT s () applyPrefixToNameSpaces prefix repprefix = transAttrCCT $ \ac -> (applyPrefix ac prefix repprefix, ()) -- definition attribute -- -- | get the definition of an identifier -- -- * the attribute must be defined, ie, a definition must be associated with -- the given identifier -- getDefOf :: Ident -> CT s CDef getDefOf ide = do def <- readAttrCCT $ \ac -> getDefOfIdentC ac ide assert (not . isUndef $ def) $ return def -- | set the definition of an identifier -- refersToDef :: Ident -> CDef -> CT s () refersToDef ide def = do traceCTrav $ "linking identifier: "++ dumpIdent ide ++ " --> " ++ show def transAttrCCT $ \akl -> (setDefOfIdentC akl ide def, ()) -- | update the definition of an identifier -- refersToNewDef :: Ident -> CDef -> CT s () refersToNewDef ide def = transAttrCCT $ \akl -> (updDefOfIdentC akl ide def, ()) -- | get the declarator of an identifier -- getDeclOf :: Ident -> CT s CDecl getDeclOf ide = do traceEnter def <- getDefOf ide case def of UndefCD -> interr "CTrav.getDeclOf: Undefined!" DontCareCD -> interr "CTrav.getDeclOf: Don't care!" TagCD _ -> interr "CTrav.getDeclOf: Illegal tag!" ObjCD obj -> case obj of TypeCO decl -> traceTypeCO decl >> return decl ObjCO decl -> traceObjCO decl >> return decl EnumCO _ _ -> illegalEnum BuiltinCO Nothing -> illegalBuiltin BuiltinCO (Just decl) -> traceBuiltinCO >> return decl where illegalEnum = interr "CTrav.getDeclOf: Illegal enum!" illegalBuiltin = interr "CTrav.getDeclOf: Attempted to get declarator of \ \builtin entity!" -- if the latter ever becomes necessary, we have to -- change the representation of builtins and give them -- some dummy declarator traceEnter = traceCTrav $ "Entering `getDeclOf' for `" ++ identToString ide ++ "'...\n" traceTypeCO decl = traceCTrav $ "...found a type object:\n" ++ show decl ++ "\n" traceObjCO decl = traceCTrav $ "...found a vanilla object:\n" ++ show decl ++ "\n" traceBuiltinCO = traceCTrav $ "...found a builtin object with a proxy decl.\n" -- convenience functions -- findTypeObjMaybeWith :: Bool -> Ident -> Bool -> CT s (Maybe (CObj, Ident)) findTypeObjMaybeWith soft ide useShadows = do oobj <- if useShadows then findObjShadow ide else liftM (fmap (\obj -> (obj, ide))) $ findObj ide case oobj of Just obj@(TypeCO _ , _) -> return $ Just obj Just obj@(BuiltinCO _, _) -> return $ Just obj Just _ -> if soft then return Nothing else typedefExpectedErr ide Nothing -> return $ Nothing -- | find a type object in the object name space; returns 'Nothing' if the -- identifier is not defined -- -- * if the second argument is 'True', use 'findObjShadow' -- findTypeObjMaybe :: Ident -> Bool -> CT s (Maybe (CObj, Ident)) findTypeObjMaybe = findTypeObjMaybeWith False -- | find a type object in the object name space; raises an error and exception -- if the identifier is not defined -- -- * if the second argument is 'True', use 'findObjShadow' -- findTypeObj :: Ident -> Bool -> CT s (CObj, Ident) findTypeObj ide useShadows = do oobj <- findTypeObjMaybe ide useShadows case oobj of Nothing -> unknownObjErr ide Just obj -> return obj -- | find an object, function, or enumerator in the object name space; raises an -- error and exception if the identifier is not defined -- -- * if the second argument is 'True', use 'findObjShadow' -- findValueObj :: Ident -> Bool -> CT s (CObj, Ident) findValueObj ide useShadows = do oobj <- if useShadows then findObjShadow ide else liftM (fmap (\obj -> (obj, ide))) $ findObj ide case oobj of Just obj@(ObjCO _ , _) -> return obj Just obj@(EnumCO _ _, _) -> return obj Just _ -> unexpectedTypedefErr (posOf ide) Nothing -> unknownObjErr ide -- | find a function in the object name space; raises an error and exception if -- the identifier is not defined -- -- * if the second argument is 'True', use 'findObjShadow' -- findFunObj :: Ident -> Bool -> CT s (CObj, Ident) findFunObj ide useShadows = do (obj, ide') <- findValueObj ide useShadows case obj of EnumCO _ _ -> funExpectedErr (posOf ide) ObjCO decl -> do let declr = ide' `declrFromDecl` decl assertFunDeclr (posOf ide) declr return (obj, ide') -- C structure tree query routines -- ------------------------------- -- | test if this is a type definition specification -- isTypedef :: CDecl -> Bool isTypedef (CDecl specs _ _) = not . null $ [() | CStorageSpec (CTypedef _) <- specs] -- | discard all declarators but the one declaring the given identifier -- -- * the declaration must contain the identifier -- simplifyDecl :: Ident -> CDecl -> CDecl ide `simplifyDecl` (CDecl specs declrs at) = case find (`declrPlusNamed` ide) declrs of Nothing -> err Just declr -> CDecl specs [declr] at where (Just declr, _, _) `declrPlusNamed` ide' = declr `declrNamed` ide' _ `declrPlusNamed` _ = False -- err = interr $ "CTrav.simplifyDecl: Wrong C object!\n\ \ Looking for `" ++ identToString ide ++ "' in decl \ \at " ++ show (posOf at) -- | extract the declarator that declares the given identifier -- -- * the declaration must contain the identifier -- declrFromDecl :: Ident -> CDecl -> CDeclr ide `declrFromDecl` decl = let CDecl _ [(Just declr, _, _)] _ = ide `simplifyDecl` decl in declr -- | tests whether the given declarator has the given name -- declrNamed :: CDeclr -> Ident -> Bool declr `declrNamed` ide = declrName declr == Just ide -- | get the declarator of a declaration that has at most one declarator -- declaredDeclr :: CDecl -> Maybe CDeclr declaredDeclr (CDecl _ [] _) = Nothing declaredDeclr (CDecl _ [(odeclr, _, _)] _) = odeclr declaredDeclr decl = interr $ "CTrav.declaredDeclr: Too many declarators!\n\ \ Declaration at " ++ show (posOf decl) -- | get the initialiser of a declaration that has at most one initialiser -- initDeclr :: CDecl -> Maybe (CInitializer NodeInfo) initDeclr (CDecl _ [] _) = Nothing initDeclr (CDecl _ [(_, ini, _)] _) = ini initDeclr decl = interr $ "CTrav.initDeclr: Too many declarators!\n\ \ Declaration at " ++ show (posOf decl) -- | get the name declared by a declaration that has exactly one declarator -- declaredName :: CDecl -> Maybe Ident declaredName decl = declaredDeclr decl >>= declrName -- | obtains the member definitions and the tag of a struct -- -- * member definitions are expanded -- structMembers :: CStructUnion -> ([CDecl], CStructTag) structMembers (CStruct tag _ members _ _) = (concat . map expandDecl $ maybe [] id members, tag) -- | expand declarators declaring more than one identifier into multiple -- declarators, eg, `int x, y;' becomes `int x; int y;' -- expandDecl :: CDecl -> [CDecl] expandDecl (CDecl specs decls at) = map (\decl -> CDecl specs [decl] at) decls -- | get a struct's name -- structName :: CStructUnion -> Maybe Ident structName (CStruct _ oide _ _ _) = oide -- | get an enum's name -- enumName :: CEnum -> Maybe Ident enumName (CEnum oide _ _ _) = oide -- | get a tag's name -- -- * fail if the tag is anonymous -- tagName :: CTag -> Ident tagName tag = case tag of StructUnionCT struct -> maybe err id $ structName struct EnumCT enum -> maybe err id $ enumName enum where err = interr "CTrav.tagName: Anonymous tag definition" -- | checks whether the given declarator defines an object that is a pointer to -- some other type -- -- * as far as parameter passing is concerned, arrays are also pointer -- isPtrDeclr :: CDeclr -> Bool isPtrDeclr (CDeclr _ (CPtrDeclr _ _:_) _ _ _) = True isPtrDeclr (CDeclr _ (CArrDeclr _ _ _:_) _ _ _) = True isPtrDeclr _ = False -- | Need to distinguish between pointer and array declarations within -- structures. -- isArrDeclr :: CDeclr -> Maybe Int isArrDeclr (CDeclr _ (CArrDeclr _ sz _:_) _ _ _) = Just $ szToInt sz where szToInt (CArrSize _ (CConst (CIntConst s _))) = fromIntegral $ getCInteger s szToInt _ = 1 isArrDeclr _ = Nothing -- | drops the first pointer level from the given declarator -- -- * the declarator must declare a pointer object -- -- * arrays are considered to be pointers -- -- FIXME: this implementation isn't nice, because we retain the 'CVarDeclr' -- unchanged; as the declarator is changed, we should maybe make this -- into an anonymous declarator and also change its attributes -- dropPtrDeclr :: CDeclr -> CDeclr dropPtrDeclr (CDeclr ide (outermost:derived) asm ats node) = case outermost of (CPtrDeclr _ _) -> CDeclr ide derived asm ats node (CArrDeclr _ _ _) -> CDeclr ide derived asm ats node _ -> interr "CTrav.dropPtrDeclr: No pointer!" -- | checks whether the given declaration defines a pointer object -- -- * there may only be a single declarator in the declaration -- isPtrDecl :: CDecl -> Bool isPtrDecl (CDecl _ [] _) = False isPtrDecl (CDecl _ [(Just declr, _, _)] _) = isPtrDeclr declr isPtrDecl _ = interr "CTrav.isPtrDecl: There was more than one declarator!" isArrDecl :: CDecl -> Maybe Int isArrDecl (CDecl _ [] _) = Nothing isArrDecl (CDecl _ [(Just declr, _, _)] _) = isArrDeclr declr isArrDecl _ = interr "CTrav.isArrDecl: There was more than one declarator!" -- | checks whether the given declarator defines a function object -- isFunDeclr :: CDeclr -> Bool isFunDeclr (CDeclr _ (CFunDeclr _ _ _:_) _ _ _) = True isFunDeclr _ = False -- | extract the structure from the type specifiers of a declaration -- structFromDecl :: Position -> CDecl -> CT s CStructUnion structFromDecl pos (CDecl specs _ _) = case head [ts | CTypeSpec ts <- specs] of CSUType su _ -> extractStruct pos (StructUnionCT su) _ -> structExpectedErr pos structFromDecl' :: Position -> CDecl -> CT s (Maybe CStructUnion) structFromDecl' pos (CDecl specs _ _) = case head [ts | CTypeSpec ts <- specs] of CSUType su _ -> extractStruct' pos (StructUnionCT su) _ -> structExpectedErr pos -- | extracts the arguments from a function declaration (must be a unique -- declarator) and constructs a declaration for the result of the function -- -- * the boolean result indicates whether the function is variadic -- -- * returns an abstract declarator funResultAndArgs :: CDecl -> ([CDecl], CDecl, Bool) funResultAndArgs cdecl@(CDecl specs [(Just declr, _, _)] _) = let (args, declr', variadic) = funArgs declr result = CDecl specs [(Just declr', Nothing, Nothing)] (newAttrsOnlyPos (posOf cdecl)) in (args, result, variadic) where funArgs (CDeclr _ide derived _asm _ats node) = case derived of (CFunDeclr (Right (args,variadic)) _ats' _dnode : derived') -> (args, CDeclr Nothing derived' Nothing [] node, variadic) (CFunDeclr (Left _) _ _ : _) -> interr "CTrav.funResultAndArgs: Old style function definition" _ -> interr "CTrav.funResultAndArgs: Illegal declarator!" -- name chasing -- -- | find the declarator identified by the given identifier; if the declarator -- is itself only a 'typedef'ed name, the operation recursively searches for -- the declarator associated with that name (this is called ``typedef -- chasing'') -- -- * if `ind = True', we have to hop over one indirection -- -- * remove all declarators except the one we just looked up -- chaseDecl :: Ident -> Bool -> CT s CDecl -- -- * cycles are no issue, as they cannot occur in a correct C header (we would -- have spotted the problem during name analysis) -- chaseDecl ide ind = do traceEnter cdecl <- getDeclOf ide let sdecl = ide `simplifyDecl` cdecl case extractAlias sdecl ind of Just (ide', ind') -> chaseDecl ide' ind' Nothing -> return sdecl where traceEnter = traceCTrav $ "Entering `chaseDecl' for `" ++ identToString ide ++ "' " ++ (if ind then "" else "not ") ++ "following indirections...\n" -- | find type object in object name space and then chase it -- -- * see also 'chaseDecl' -- -- * also create an object association from the given identifier to the object -- that it _directly_ represents -- -- * if the third argument is 'True', use 'findObjShadow' -- findAndChaseDecl :: Ident -> Bool -> Bool -> CT s CDecl findAndChaseDecl ide ind useShadows = do traceCTrav $ "findAndChaseDecl: " ++ show ide ++ " (" ++ show useShadows ++ ")\n" (obj, ide') <- findTypeObj ide useShadows -- is there an object def? ide `refersToNewDef` ObjCD obj ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing chaseDecl ide' ind findAndChaseDeclOrTag :: Ident -> Bool -> Bool -> CT s CDecl findAndChaseDeclOrTag ide ind useShadows = do traceCTrav $ "findAndChaseDeclOrTag: " ++ show ide ++ " (" ++ show useShadows ++ ")\n" mobjide <- findTypeObjMaybeWith True ide useShadows -- is there an object def? case mobjide of Just (obj, ide') -> do ide `refersToNewDef` ObjCD obj ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing chaseDecl ide' ind Nothing -> do otag <- if useShadows then findTagShadow ide else liftM (fmap (\tag -> (tag, ide))) $ findTag ide case otag of Just (StructUnionCT su, _) -> do let (CStruct _ _ _ _ nodeinfo) = su return $ CDecl [CTypeSpec (CSUType su nodeinfo)] [] nodeinfo _ -> unknownObjErr ide -- | given a declaration (which must have exactly one declarator), if the -- declarator is an alias, chase it to the actual declaration -- checkForAlias :: CDecl -> CT s (Maybe CDecl) checkForAlias decl = case extractAlias decl False of Nothing -> return Nothing Just (ide', _) -> liftM Just $ chaseDecl ide' False -- | given a declaration (which must have exactly one declarator), if the -- declarator is an alias, yield the alias name; *no* chasing -- checkForOneAliasName :: CDecl -> Maybe Ident checkForOneAliasName decl = fmap fst $ extractAlias decl False -- | given a declaration, find the name of the struct/union type checkForOneCUName :: CDecl -> Maybe Ident checkForOneCUName decl@(CDecl specs _ _) = case [ts | CTypeSpec ts <- specs] of [CSUType (CStruct _ n _ _ _) _] -> case declaredDeclr decl of Nothing -> n Just (CDeclr _ [] _ _ _) -> n -- no type derivations _ -> Nothing _ -> Nothing -- smart lookup -- -- | for the given identifier, either find an enumeration in the tag name space -- or a type definition referring to an enumeration in the object name space; -- raises an error and exception if the identifier is not defined -- -- * if the second argument is 'True', use 'findTagShadow' -- lookupEnum :: Ident -> Bool -> CT s CEnum lookupEnum ide useShadows = do otag <- if useShadows then liftM (fmap fst) $ findTagShadow ide else findTag ide case otag of Just (StructUnionCT _ ) -> enumExpectedErr ide -- wrong tag definition Just (EnumCT enum) -> return enum -- enum tag definition Nothing -> do -- no tag definition oobj <- if useShadows then liftM (fmap fst) $ findObjShadow ide else findObj ide case oobj of Just (EnumCO _ enum) -> return enum -- anonymous enum _ -> do -- no value definition (CDecl specs _ _) <- findAndChaseDecl ide False useShadows case head [ts | CTypeSpec ts <- specs] of CEnumType enum _ -> return enum _ -> enumExpectedErr ide -- | for the given identifier, either find a struct/union in the tag name space -- or a type definition referring to a struct/union in the object name space; -- raises an error and exception if the identifier is not defined -- -- * the parameter `preferTag' determines whether tags or typedefs are -- searched first -- -- * if the third argument is `True', use `findTagShadow' -- -- * when finding a forward definition of a tag, follow it to the real -- definition -- lookupStructUnion :: Ident -> Bool -> Bool -> CT s CStructUnion lookupStructUnion ide preferTag useShadows = do traceCTrav $ "lookupStructUnion: ide=" ++ show ide ++ " preferTag=" ++ show preferTag ++ " useShadows=" ++ show useShadows ++ "\n" otag <- if useShadows then liftM (fmap fst) $ findTagShadow ide else findTag ide mobj <- if useShadows then findObjShadow ide else liftM (fmap (\obj -> (obj, ide))) $ findObj ide let oobj = case mobj of Just obj@(TypeCO{}, _) -> Just obj Just obj@(BuiltinCO{}, _) -> Just obj _ -> Nothing case preferTag of True -> case otag of Just tag -> extractStruct (posOf ide) tag Nothing -> do decl <- findAndChaseDecl ide True useShadows structFromDecl (posOf ide) decl False -> case oobj of Just _ -> do decl <- findAndChaseDecl ide True useShadows mres <- structFromDecl' (posOf ide) decl case mres of Just su -> return su Nothing -> case otag of Just tag -> extractStruct (posOf ide) tag Nothing -> unknownObjErr ide Nothing -> case otag of Just tag -> extractStruct (posOf ide) tag Nothing -> unknownObjErr ide -- | for the given identifier, check for the existance of both a type definition -- or a struct, union, or enum definition -- -- * if a typedef and a tag exists, the typedef takes precedence -- -- * typedefs are chased -- -- * if the second argument is `True', look for shadows, too -- lookupDeclOrTag :: Ident -> Bool -> CT s (Either CDecl CTag) lookupDeclOrTag ide useShadows = do oobj <- findTypeObjMaybeWith True ide useShadows case oobj of Just (_, ide') -> liftM Left $ findAndChaseDecl ide' False False -- already did check shadows Nothing -> do otag <- if useShadows then liftM (fmap fst) $ findTagShadow ide else findTag ide case otag of Nothing -> unknownObjErr ide Just tag -> return $ Right tag -- auxiliary routines (internal) -- -- | if the given declaration (which may have at most one declarator) is a -- `typedef' alias, yield the referenced name -- -- * a `typedef' alias has one of the following forms -- -- at x, ...; -- at *x, ...; -- -- where `at' is the alias type, which has been defined by a `typedef', and -- are arbitrary specifiers and qualifiers. Note that `x' may be a -- variable, a type name (if `typedef' is in ), or be entirely -- omitted. -- -- * if `ind = True', the alias may be via an indirection -- -- * if `ind = True' and the alias is _not_ over an indirection, yield `True'; -- otherwise `False' (ie, the ability to hop over an indirection is consumed) -- -- * this may be an anonymous declaration, ie, the name in `CVarDeclr' may be -- omitted or there may be no declarator at all -- extractAlias :: CDecl -> Bool -> Maybe (Ident, Bool) extractAlias decl@(CDecl specs _ _) ind = case [ts | CTypeSpec ts <- specs] of [CTypeDef ide' _] -> -- type spec is aliased ident case declaredDeclr decl of Nothing -> Just (ide', ind) Just (CDeclr _ [] _ _ _) -> Just (ide', ind) -- no type derivations Just (CDeclr _ [CPtrDeclr _ _] _ _ _) -- one pointer indirection | ind -> Just (ide', False) | otherwise -> Nothing _ -> Nothing _ -> Nothing -- | if the given tag is a forward declaration of a structure, follow the -- reference to the full declaration -- -- * the recursive call is not dangerous as there can't be any cycles -- extractStruct :: Position -> CTag -> CT s CStructUnion extractStruct pos (EnumCT _ ) = structExpectedErr pos extractStruct pos (StructUnionCT su) = do traceCTrav $ "extractStruct: " ++ show su ++ "\n" case su of CStruct _ (Just ide') Nothing _ _ -> do -- found forward definition def <- getDefOf ide' traceCTrav $ "def=" ++ show def ++ "\n" case def of TagCD tag -> extractStruct pos tag UndefCD -> incompleteTypeErr pos bad_obj -> err ide' bad_obj _ -> return su where err ide bad_obj = do interr $ "CTrav.extractStruct: Illegal reference! Expected " ++ dumpIdent ide ++ " to link to TagCD but refers to "++ (show bad_obj) ++ "\n" extractStruct' :: Position -> CTag -> CT s (Maybe CStructUnion) extractStruct' pos (EnumCT _ ) = structExpectedErr pos extractStruct' pos (StructUnionCT su) = do traceCTrav $ "extractStruct': " ++ show su ++ "\n" case su of CStruct _ (Just ide') Nothing _ _ -> do def <- getDefOf ide' traceCTrav $ "def=" ++ show def ++ "\n" case def of TagCD tag -> do res <- extractStruct pos tag return . Just $ res _ -> return Nothing _ -> return . Just $ su -- | yield the name declared by a declarator if any -- declrName :: CDeclr -> Maybe Ident declrName (CDeclr oide _ _ _ _) = oide -- | raise an error if the given declarator does not declare a C function or if -- the function is supposed to return an array (the latter is illegal in C) -- assertFunDeclr :: Position -> CDeclr -> CT s () assertFunDeclr pos (CDeclr _ (CFunDeclr _ _ _:retderiv) _ _ _) = case retderiv of (CArrDeclr _ _ _:_) -> illegalFunResultErr pos _ -> return () -- ok, we have a function which doesn't return an array assertFunDeclr pos _ = funExpectedErr pos -- | trace for this module -- traceCTrav :: String -> CT s () traceCTrav = putTraceStr traceCTravSW -- error messages -- -------------- unknownObjErr :: Ident -> CT s a unknownObjErr ide = raiseErrorCTExc (posOf ide) ["Unknown identifier!", "Cannot find a definition for `" ++ identToString ide ++ "' in the \ \header file."] typedefExpectedErr :: Ident -> CT s a typedefExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected type definition!", "The identifier `" ++ identToString ide ++ "' needs to be a C type name."] unexpectedTypedefErr :: Position -> CT s a unexpectedTypedefErr pos = raiseErrorCTExc pos ["Unexpected type name!", "An object, function, or enum constant is required here."] illegalFunResultErr :: Position -> CT s a illegalFunResultErr pos = raiseErrorCTExc pos ["Function cannot return an array!", "ANSI C does not allow functions to return an array."] funExpectedErr :: Position -> CT s a funExpectedErr pos = raiseErrorCTExc pos ["Function expected!", "A function is needed here, but this declarator does not declare", "a function."] enumExpectedErr :: Ident -> CT s a enumExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected enum!", "Expected `" ++ identToString ide ++ "' to denote an enum; instead found", "a struct, union, or object."] structExpectedErr :: Position -> CT s a structExpectedErr pos = raiseErrorCTExc pos ["Expected a struct!", "Expected a structure or union; instead found an enum or basic type."] incompleteTypeErr :: Position -> CT s a incompleteTypeErr pos = raiseErrorCTExc pos ["Illegal use of incomplete type!", "Expected a fully defined structure or union tag; instead found incomplete type."] c2hs-0.28.1/src/C2HS/C/Attrs.hs0000644000000000000000000003363712677513064013757 0ustar0000000000000000-- C->Haskell Compiler: C attribute definitions and manipulation routines -- -- Author : Manuel M. T. Chakravarty -- Created: 12 August 99 -- -- Copyright (c) [1999..2001] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides the attributed version of the C structure tree. -- -- * C has several name spaces of which two are represented in this module: -- - `CObj' in `defObjsAC': The name space of objects, functions, typedef -- names, and enum constants. -- - `CTag' in `defTagsAC': The name space of tags of structures, unions, -- and enumerations. -- -- * The final state of the names spaces are preserved in the attributed -- structure tree. This allows further fast lookups for globally defined -- identifiers after the name anaysis is over. -- -- * In addition to the name spaces, the attribute structure tree contains -- a ident-definition table, which for attribute handles of identifiers -- refers to the identifiers definition. These are only used in usage -- occurences, except for one exception: The tag identifiers in forward -- definitions of structures or enums get a reference to the corresponding -- full definition - see `CTrav' for full details. -- -- * We maintain a shadow definition table, it can be populated with aliases -- to other objects and maps identifiers to identifiers. It is populated by -- using the `applyPrefix' function. When looksup performed via the shadow -- variant of a lookup function, shadow aliases are also considered, but -- they are used only if no normal entry for the identifiers is present. -- -- * Only ranges delimited by a block open a new range for tags (see -- `enterNewObjRangeC' and `leaveObjRangeC'). -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- --- TODO ---------------------------------------------------------------------- -- module C2HS.C.Attrs (-- attributed C -- AttrC(..), emptyAttrC, enterNewRangeC, enterNewObjRangeC, leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC, lookupDefObjCShadow, addDefTagC, lookupDefTagC, lookupDefTagCShadow, applyPrefix, getDefOfIdentC, setDefOfIdentC, updDefOfIdentC, freezeDefOfIdentsAttrC, softenDefOfIdentsAttrC, -- -- C objects -- CObj(..), CTag(..), CDef(..)) where import Data.Char (toUpper) import Data.Maybe (mapMaybe) import Language.C.Data.Node import Language.C.Data.Ident import Language.C.Data.Position import Language.C.Syntax import Language.C.Pretty import Text.PrettyPrint.HughesPJ import Data.Errors (interr) import Data.Attributes (Attr(..), AttrTable, getAttr, setAttr, updAttr, newAttrTable, freezeAttrTable, softenAttrTable) import Data.NameSpaces (NameSpace, nameSpace, enterNewRange, leaveRange, defLocal, defGlobal, find, nameSpaceToList) -- attributed C structure tree -- --------------------------- -- | attributes relevant to the outside world gathjered from a C unit -- data AttrC = AttrC { defObjsAC :: CObjNS, -- defined objects defTagsAC :: CTagNS, -- defined tags shadowsAC :: CShadowNS, -- shadow definitions (prefix) defsAC :: CDefTable -- ident-def associations } deriving (Show) -- | empty headder attribute set -- emptyAttrC :: AttrC emptyAttrC = AttrC { defObjsAC = cObjNS, defTagsAC = cTagNS, shadowsAC = cShadowNS, defsAC = cDefTable } -- the name space operations -- -- | enter a new range -- enterNewRangeC :: AttrC -> AttrC enterNewRangeC ac = ac { defObjsAC = enterNewRange . defObjsAC $ ac, defTagsAC = enterNewRange . defTagsAC $ ac } -- | enter a new range, only for objects -- enterNewObjRangeC :: AttrC -> AttrC enterNewObjRangeC ac = ac { defObjsAC = enterNewRange . defObjsAC $ ac } -- | leave the current range -- leaveRangeC :: AttrC -> AttrC leaveRangeC ac = ac { defObjsAC = fst . leaveRange . defObjsAC $ ac, defTagsAC = fst . leaveRange . defTagsAC $ ac } -- | leave the current range, only for objects -- leaveObjRangeC :: AttrC -> AttrC leaveObjRangeC ac = ac { defObjsAC = fst . leaveRange . defObjsAC $ ac } -- | add another definitions to the object name space -- -- * if a definition of the same name was already present, it is returned -- addDefObjC :: AttrC -> Ident -> CObj -> (AttrC, Maybe CObj) addDefObjC ac ide obj = let om = defObjsAC ac (ac', obj') = defLocal om ide obj in (ac {defObjsAC = ac'}, obj') -- | lookup an identifier in the object name space -- lookupDefObjC :: AttrC -> Ident -> Maybe CObj lookupDefObjC ac ide = find (defObjsAC ac) ide -- | lookup an identifier in the object name space; if nothing found, try -- whether there is a shadow identifier that matches -- -- * the returned identifier is the _real_ identifier of the object -- lookupDefObjCShadow :: AttrC -> Ident -> Maybe (CObj, Ident) lookupDefObjCShadow ac ide = case lookupDefObjC ac ide of Just obj -> Just (obj, ide) Nothing -> case find (shadowsAC ac) ide of Nothing -> Nothing Just ide' -> case lookupDefObjC ac ide' of Just obj -> Just (obj, ide') Nothing -> Nothing -- | add another definition to the tag name space -- -- * if a definition of the same name was already present, it is returned -- addDefTagC :: AttrC -> Ident -> CTag -> (AttrC, Maybe CTag) addDefTagC ac ide obj = let tm = defTagsAC ac (ac', obj') = defLocal tm ide obj in (ac {defTagsAC = ac'}, obj') -- | lookup an identifier in the tag name space -- lookupDefTagC :: AttrC -> Ident -> Maybe CTag lookupDefTagC ac ide = find (defTagsAC ac) ide -- | lookup an identifier in the tag name space; if nothing found, try -- whether there is a shadow identifier that matches -- -- * the returned identifier is the _real_ identifier of the tag -- lookupDefTagCShadow :: AttrC -> Ident -> Maybe (CTag, Ident) lookupDefTagCShadow ac ide = case lookupDefTagC ac ide of Just tag -> Just (tag, ide) Nothing -> case find (shadowsAC ac) ide of Nothing -> Nothing Just ide' -> case lookupDefTagC ac ide' of Just tag -> Just (tag, ide') Nothing -> Nothing -- | enrich the shadow name space with identifiers obtained by dropping -- the given prefix from the identifiers already in the object or tag name -- space -- -- * in case of a collisions, a random entry is selected -- -- * case is not relevant in the prefix and underscores between the prefix and -- the stem of an identifier are also dropped -- applyPrefix :: AttrC -> String -> String -> AttrC applyPrefix ac prefix repprefix = let shadows = shadowsAC ac names = map fst (nameSpaceToList (defObjsAC ac)) ++ map fst (nameSpaceToList (defTagsAC ac)) newShadows = mapMaybe (strip prefix) names in ac {shadowsAC = foldl define shadows newShadows} where strip prefx ide = case eat prefx (identToString ide) of Nothing -> Nothing Just "" -> Nothing Just newName -> Just (internalIdentAt (posOf ide) (repprefix ++ newName), ide) -- eat [] ('_':cs) = eat [] cs eat [] cs = Just cs eat (p:prefx) (c:cs) | toUpper p == toUpper c = eat prefx cs | otherwise = Nothing eat _ _ = Nothing -- define ns (ide, def) = fst (defGlobal ns ide def) -- the attribute table operations on the attributes -- -- | get the definition associated with the given identifier -- getDefOfIdentC :: AttrC -> Ident -> CDef getDefOfIdentC ac = getAttr (defsAC ac) . nodeInfo setDefOfIdentC :: AttrC -> Ident -> CDef -> AttrC setDefOfIdentC ac ide def = let tot' = setAttr (defsAC ac) (nodeInfo ide) def in ac {defsAC = tot'} updDefOfIdentC :: AttrC -> Ident -> CDef -> AttrC updDefOfIdentC ac ide def = let tot' = updAttr (defsAC ac) (nodeInfo ide) def in ac {defsAC = tot'} freezeDefOfIdentsAttrC :: AttrC -> AttrC freezeDefOfIdentsAttrC ac = ac {defsAC = freezeAttrTable (defsAC ac)} softenDefOfIdentsAttrC :: AttrC -> AttrC softenDefOfIdentsAttrC ac = ac {defsAC = softenAttrTable (defsAC ac)} pshow :: (Pretty a) => a -> String pshow = renderStyle (Style OneLineMode 80 1.5) . pretty -- C objects including operations -- ------------------------------ -- | C objects data definition -- data CObj = TypeCO CDecl -- typedef declaration | ObjCO CDecl -- object or function declaration | EnumCO Ident CEnum -- enumerator | BuiltinCO (Maybe CDecl) -- builtin object, with equivalent -- C decl if one exists instance Show CObj where show (TypeCO decl) = "TypeCO { " ++ pshow decl ++ " }" show (ObjCO decl) = "ObjCO { "++ pshow decl ++ " }" show (EnumCO ide enum) = "EnumCO "++ show ide ++ " { " ++ pshow enum ++ " }" show (BuiltinCO _) = "BuiltinCO" -- two C objects are equal iff they are defined by the same structure -- tree node (i.e., the two nodes referenced have the same attribute -- identifier) -- instance Eq CObj where (TypeCO decl1 ) == (TypeCO decl2 ) = decl1 `eqByName` decl2 (ObjCO decl1 ) == (ObjCO decl2 ) = decl1 `eqByName` decl2 (EnumCO ide1 enum1) == (EnumCO ide2 enum2) = ide1 == ide2 && enum1 `eqByName` enum2 _ == _ = False instance Pos CObj where posOf (TypeCO def ) = posOf def posOf (ObjCO def ) = posOf def posOf (EnumCO ide _) = posOf ide posOf (BuiltinCO _ ) = builtinPos -- C tagged objects including operations -- ------------------------------------- -- | C tagged objects data definition -- data CTag = StructUnionCT CStructUnion -- toplevel struct-union declaration | EnumCT CEnum -- toplevel enum declaration instance Show CTag where show (StructUnionCT su) = "StructUnionCT {" ++ pshow su ++ "}" show (EnumCT e) = "EnumCT {"++ pshow e ++ "}" -- | two C tag objects are equal iff they are defined by the same structure -- tree node (i.e., the two nodes referenced have the same attribute -- identifier) -- instance Eq CTag where (StructUnionCT struct1) == (StructUnionCT struct2) = struct1 `eqByName` struct2 (EnumCT enum1 ) == (EnumCT enum2 ) = enum1 `eqByName` enum2 _ == _ = False instance Pos CTag where posOf (StructUnionCT def) = posOf def posOf (EnumCT def) = posOf def -- C general definition -- -------------------- -- | C general definition -- data CDef = UndefCD -- undefined object | DontCareCD -- don't care object | ObjCD CObj -- C object | TagCD CTag -- C tag instance Show CDef where show UndefCD = "UndefCD" show DontCareCD = "DontCareCD" show (ObjCD cobj) = "ObjCD { " ++ show cobj ++ "}" show (TagCD ctag) = "TagCD { " ++ show ctag ++ "}" -- two C definitions are equal iff they are defined by the same structure -- tree node (i.e., the two nodes referenced have the same attribute -- identifier), but don't care objects are equal to everything and undefined -- objects may not be compared -- instance Eq CDef where (ObjCD obj1) == (ObjCD obj2) = obj1 == obj2 (TagCD tag1) == (TagCD tag2) = tag1 == tag2 DontCareCD == _ = True _ == DontCareCD = True UndefCD == _ = interr "CAttrs: Attempt to compare an undefined C definition!" _ == UndefCD = interr "CAttrs: Attempt to compare an undefined C definition!" _ == _ = False instance Attr CDef where undef = UndefCD dontCare = DontCareCD isUndef UndefCD = True isUndef _ = False isDontCare DontCareCD = True isDontCare _ = False instance Pos CDef where posOf UndefCD = nopos posOf DontCareCD = nopos posOf (ObjCD obj) = posOf obj posOf (TagCD tag) = posOf tag -- object tables (internal use only) -- --------------------------------- -- | the object name spavce -- type CObjNS = NameSpace CObj -- | creating a new object name space -- cObjNS :: CObjNS cObjNS = nameSpace -- the tag name space -- type CTagNS = NameSpace CTag -- creating a new tag name space -- cTagNS :: CTagNS cTagNS = nameSpace -- | the shadow name space -- type CShadowNS = NameSpace Ident -- | creating a shadow name space -- cShadowNS :: CShadowNS cShadowNS = nameSpace -- | the general definition table -- type CDefTable = AttrTable CDef -- | creating a new definition table -- cDefTable :: CDefTable cDefTable = newAttrTable "C General Definition Table for Idents"