packages feed

c2hs 0.16.5 → 0.16.6

raw patch · 123 files changed

+4273/−892 lines, 123 filesdep +HUnitdep +shellydep +test-frameworkdep ~base

Dependencies added: HUnit, shelly, test-framework, test-framework-hunit, text

Dependency ranges changed: base

Files

C2HS.hs view
@@ -34,7 +34,7 @@ --  with the C->HS-specific higher-level marshalling routines. -- -module C2HS (+module C2HS {-# DEPRECATED "The C2HS module should no longer be used." #-} (    -- * Re-export the language-independent component of the FFI    module Foreign,
+ ChangeLog view
@@ -0,0 +1,40 @@+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.
+ ChangeLog.old view
@@ -0,0 +1,1187 @@+CHANGES 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  <chak@cse.unsw.edu.au>++	* 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 <jelmer@samba.org>++	* c2hs/c/CTrav.hs: only match in `checkForOneCUName' if there are +	no indirections++2005-12-05	Jelmer Vernooij <jelmer@samba.org>++	* 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 <jelmer@samba.org>++	* add prettify functions for structs, enums and unions++2005-08-10  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* c2hs/gen/CInfo.hs: exports `getPlatform'++2005-08-08  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* c2hs/toplevel/Main.hs: Added --platform switch for cross compilation++	* c2hs.cabal: 0.14.3++2005-08-08  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* c2hs.cabal: 0.14.2+	* Support asm construct (Duncon Coutts)+	* Hierachical modules  (Duncon Coutts)++2005-07-13  Duncan Coutts  <duncan.coutts@worc.ox.ac.uk>++	* Remove old C lexer & parser and replace them with new ones using+	alex and happy++2005-07-14  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* C2HS library as a single file added to the generated binding+	code++2005-07-13  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* Cabal-ised the build system+	* c2hs.cabal (Version): 0.14.0++2005-05-18  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* toplevel/Version.hs (versnum): 0.13.6++2005-03-14  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* c/CParser.hs: Allow lists of GNU C attributes (patch contributed+	by Duncan Coutts <duncan.coutts@worc.ox.ac.uk>)++	* chs/CHSLexer.hs (instr): Allow 8-bit characters (Volker Wysk+	<post@volker-wysk.de> requested support for umlauts in strings)++	* toplevel/Version.hs (versnum): 0.13.5++2004-10-18  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* tests/Makefile: use configured $HC (courtesy Don Stewart+	<dons@cse.unsw.edu.au>)++2004-06-11  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (pointerDef): Adapted to the standard interface+	for foreign pointers++2004-06-10  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* c/CParser.hs (parseCHeader): Duncan Coutts+	<duncan.coutts@worcester.oxford.ac.uk> 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  <chak@cse.unsw.edu.au>++	* toplevel/Version.hs (versnum): 0.13.0 "Pressing Forward"++2003-10-20  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* c2hs.spec.in: Contributions by Jens Petersen+	<petersen@haskell.org>: 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 <sseefried@cse.unsw.edu.au>++	* gen/GBMonad.hs (delayCode): Generate appropriate line numbers+	for delayed code; problem reported by Sean Seefried+	<sseefried@cse.unsw.edu.au>++	* chs/CHS.hs (showCHSModule): Never generate negative line numbers++	* toplevel/Version.hs (versnum): 0.12.0 "Springtime"++2003-06-10  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* toplevel/Version.hs (versnum): 0.11.5++2003-05-30  Jens Petersen  <petersen@redhat.com>++	* configure.in: Search for compiler named HC too.++2003-05-30  Jens Petersen  <petersen@redhat.com>++	* 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  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (Ord): Need instance for `<=' for indirectly+	defined `compare'; bug reported by Ian Lynagh <igloo@earth.li>++	* toplevel/Version.hs (versnum): 0.11.4++2003-04-16  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* 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 <A.Simon@ukc.ac.uk>++	* toplevel/Version.hs (versnum): 0.11.3++2003-03-04  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (evalConstCExpr): supporting enumerators in+	constant expressions++	* toplevel/Version.hs (versnum): 0.11.2++2003-02-13  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* chs/CHS.hs: removed the "header" tag (we now support the CPP+	#include directive)++	* Configuration-related patch by Ian Lynagh <igloo@earth.li> that+	removes issues with GHC 5.05++2003-02-12  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* toplevel/Main.hs (process): Now reading the binding module+	before the C header++2003-01-30  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* c/CParser.hs: Allow more GNU attributes contributed by Axel+	Simon <A.Simon@ukc.ac.uk>++2002-09-17  Manuel M T Chakravarty  <chak@AttitudeAdjuster>++	* gen/GBMonad.hs (HsObject): working around a problem with+	deriving Read in GHC 5.04.1++2002-09-16  Manuel M T Chakravarty  <chak@AttitudeAdjuster>++	* Makefile (ghci): target to load all of c2hs into GHCi++2002-09-13  Manuel M T Chakravarty  <chak@AttitudeAdjuster>++	* toplevel/c2hs_config.c: removed the `signed' modifier on+	suggestion of Seth Kurtzberg <seth@cql.com> as it apparently+	confuses the Solaris 8 C compiler++2002-09-07  Manuel M T Chakravarty  <chak@AttitudeAdjuster>++	* 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  <chak@AttitudeAdjuster>++	* 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  <chak@AttitudeAdjuster>++	* 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  <chak@cse.unsw.edu.au>++	* toplevel/Version.hs (versnum): 0.10.15++2002-05-16  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* lib/C2HSMarsh.hs: added support for bit masks++	* toplevel/Version.hs (versnum): 0.10.14++2002-05-10  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (setGet): corrected bug in bit fiddling++2002-05-02  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* toplevel/Version.hs (versnum): 0.10.13++2002-04-16  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* toplevel/Version.hs (versnum): 0.10.12++2002-03-20  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* chs/CHSLexer.hs (haskell): Debug the handling of character literals++	* toplevel/Version.hs (versnum): 0.10.11++2002-03-12  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* chs/CHSLexer.hs (haskell): Escape characters in Haskell strings+	haven't been handled correctly in all cases as reported by Volker+	Wysk <post@volker-wysk.de>; we also have to handle character+	constants specially, because '"' is a legal Haskell character+	constant++2002-03-03  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* configure.in: Package handling fix by Jens Petersen++	* toplevel/Version.hs (versnum): 0.10.9++2002-02-25  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs: debugging++2002-02-24  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* lib/C2HSMarsh.hs: added some more convenience functions++2002-02-21  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs: Completed processing of function hooks++2002-02-18  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* Makefile: adapted to using GHC package management++2002-02-11  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* lib/Makefile (depend): increase portability++2002-02-06  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* configure.in: probe for `grep'++2002-02-05  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* aclocal.m4 (CTK_GHC_VERSION): no \+ in sed on Solaris++	* toplevel/Version.hs (versnum): 0.10.7++2002-01-15  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <juhp@01.246.ne.jp>++	* 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  <chak@cse.unsw.edu.au>++	* toplevel/Version.hs (versnum): 0.10.5++2001-12-20  Manuel M T Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (expandHook): fixed a sizeof bug pointed out by Jens+	Petersen <petersen@redhat.com>++	* toplevel/Version.hs (versnum): 0.10.4++2001-12-11  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* toplevel/c2hs_config.c: now conforms to ISO C++	* toplevel/Version.hs (versnum): 0.10.3++2001-11-14  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (setGet): debugged++2001-11-13  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* toplevel/Version.hs (versnum): 0.10.2++2001-10-17  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* c/CParser.hs (parseCDecl): corrected the precise locatio where+	an __attribute__ annotation may occur.++2001-10-16  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* chs/CHS.hs: debugged++2001-10-07  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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+	<simonb@cse.unsw.edu.au> and Michael Zinn <michaelz@cse.unsw.edu.au>++2001-08-23  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (expandHook): adding parenthesis around the+	generated type; problem pointed out by Matthew Tarnawsky+	<matthewt@ics.mq.edu.au>++	* toplevel/Version.hs (versnum): 0.9.9++2001-06-20  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* c/CParser.hs (parseCExpr): `CComma' requires at least two+	expressions; patch by Armin Sander <armin@mindwalker.org>++	* toplevel/Version.hs (versnum): 0.9.7++2001-06-16  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* chs/CHS.hs: local prefix for enum hooks; courtesy of Armin+	Sander <armin@mindwalker.org>++	* 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 <armin@mindwalker.org>+	(expandHook): local prefix for enum hooks; courtesy of Armin+	Sander <armin@mindwalker.org>++	* toplevel/Version.hs (versnum): 0.9.6++2001-05-20  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (enumInst): Fix for avoiding warnings when+	generated bindings are compiled with -Wall contributed by Armin+	Sander <armin@mindwalker.org>++2001-05-14  Axel Simon <simona@i2.informatik.rwth-aachen.de>++ 	* 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  <chak@cse.unsw.edu.au>++	* 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 <qrczak@knm.org.pl>++	* c/CTrav.hs (findTypeObjMaybe): added+	(lookupDeclOrTag): added+	(enumName): added+	(tagName): added++	* c/CLexer.hs (charconst): Patch from Armin Sander+	<armin@mindwalker.org> regarding character constants++2001-05-11  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* c2hs-config.in: Patch from Jens-Ulrik Petersen+	<juhp@01.246.ne.jp> fixes $sys variable setting++	* toplevel/Version.hs (versnum): 0.9.4++2001-05-06  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (extractCompType): rewrote that thing again++	* c/CTrav.hs (checkForOneAliasName): added++2001-05-05  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (setGet): uses FunPtr for functions+	(extractPtrType): added++2001-04-28  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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 <simona_@web.de> (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 <simona_@web.de>++	* gen/GenBind.hs: The following patch was contributed by Axel+	Simon <simona_@web.de>: `extractCompType' generates addresses+	of type `Ptr <type>' 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  <chak@cse.unsw.edu.au>++	* lib/C2HSDeprecated.hs: Corrected String marshalling for 4.11;+	suggested by Marcin 'Qrczak' Kowalczyk <qrczak@knm.org.pl>++2001-02-19  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* lib/NewStablePtr.hs.in: Adaptation layer for StablePtr for the+	legacy FFI interface++2001-02-12  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* lib/Makefile: Debugging for 4.11++2001-02-05  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* lib/C2HSDeprecated.hs: contains a compatibility interface to the+	"Afterthought" series++2000-08-18  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* lib/C2HSBase.hs (IntConv): instances for Int8, Word8, and Char++	* toplevel/Version.hs (versnum): 0.7.10++2000-08-06  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (usualArithConv): forgot a case; patch+	contributed by Axel Simon <simona@pool.Informatik.rwth-aachen.de>++	* toplevel/Version.hs (versnum): 0.7.9++2000-07-06  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (specType.matches): forgot a case; bug spotted by+	Axel Simon <simona@pool.Informatik.rwth-aachen.de>++	* 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  <chak@cse.unsw.edu.au>++	* c/CLexer.hs (pragma): ignores `#pragma's++	* toplevel/Version.hs (versnum): 0.7.7++2000-04-09  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* configure.in: corrected sed expression for Solaris++2000-03-02  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* tests/Makefile: added & revised all the tests++	* configure.in: debugging++2000-03-01  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* lib/C2HSMarsh.hs (addrWithMarkerToList): debugged++2000-02-28  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* 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  <chak@cse.unsw.edu.au>++	* 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"+	  <qrczak@knm.org.pl> for pointing this out++2000-02-24  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* gen/GenBind.hs (foreignImport): system-dependent library suffix++	* configure.in,toplevel/C2HSConfig.hs.in: DLSUFFIX++2000-02-23  Manuel M. T. Chakravarty  <chak@cse.unsw.edu.au>++	* toplevel/Version.hs (versnum): 0.7.5++1999-12-04  Manuel M. T. Chakravarty  <chak@is.tsukuba.ac.jp>++	* lib/C2HSBase.hs (BoolConv): added++1999-11-24  Manuel M. T. Chakravarty  <chak@is.tsukuba.ac.jp>++	* ../doc/c2hs/Makefile: corrections by Michael Weber+ 	<michael.weber@Post.RWTH-Aachen.DE>++1999-11-17  Manuel M. T. Chakravarty  <chak@is.tsukuba.ac.jp>++	* Man pages and debianisation, courtesy of Michael Weber+	<michael.weber@Post.RWTH-Aachen.DE>++	* 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 <volker.wysk@student.uni-tuebingen.de> for the bug report++	* c/CAttrs.hs (enterNewObjRangeC): added+	(leaveObjRangeC): added++1999-11-16  Manuel M. T. Chakravarty  <chak@is.tsukuba.ac.jp>++	* c/CTrav.hs (extractAlias): now correctly handles anonymous+	declarations; introduced new function `declaredDeclr'; thanks to+	Michael Weber <michael.weber@Post.RWTH-Aachen.DE> for the bug report++	* toplevel/Version.hs (versnum): 0.7.4++1999-11-07  Manuel M. T. Chakravarty  <chak@is.tsukuba.ac.jp>++	* 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  <chak@is.tsukuba.ac.jp>++	* 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  <chak@is.tsukuba.ac.jp>++	* lib/C2HSMarsh.hs: more instances for `ToAddr' & `FromAddr'++	* toplevel/Version.hs (versnum): 0.7.3++1999-10-30  Manuel M. T. Chakravarty  <chak@is.tsukuba.ac.jp>++	* 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  <chak@is.tsukuba.ac.jp>++	* 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  <chak@is.tsukuba.ac.jp>++	* configure.in: no sizeof or align tests for char++1999-10-25  Manuel M. T. Chakravarty  <chak@is.tsukuba.ac.jp>++	* 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  <chak@is.tsukuba.ac.jp>++	* examples/libghttpHS/Ghttp.chs: adapted to new syntax & features++	* configure.in: Solaris patch from Michael Weber+	<michael.weber@Post.RWTH-Aachen.DE>++	* gen/GenBind.hs: new hook syntax++	* chs/CHS.hs (and friends): grok new hook syntax++1999-10-23  Manuel M. T. Chakravarty  <chak@is.tsukuba.ac.jp>++	* 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  <chak@is.tsukuba.ac.jp>++	* c/CNames.hs: sets up the object associations for usage positions++1999-10-21  Manuel M. T. Chakravarty  <chak@is.tsukuba.ac.jp>++	* c/CTrav.hs (defTag): handles refined struct definitions++	* toplevel/Main.hs: Command line option patch from Michael Weber+	<michael.weber@Post.RWTH-Aachen.DE>++	* 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  <chak@is.tsukuba.ac.jp>++	* 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  <chak@is.tsukuba.ac.jp>++	* c/CLexer.hs: computes attributes for identifiers++1999-10-17  Manuel M. T. Chakravarty  <chak@is.tsukuba.ac.jp>++	* 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  <chak@is.tsukuba.ac.jp>++	* lib/C2HSMarsh.hs: Marshaling idioms & exception handling++1999-10-13  Manuel M. T. Chakravarty  <chak@is.tsukuba.ac.jp>++	* 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.cabal view
@@ -1,5 +1,5 @@ Name:           c2hs-Version:        0.16.5+Version:        0.16.6 License:        GPL-2 License-File:   COPYING Copyright:      Copyright (c) 1999-2007 Manuel M T Chakravarty@@ -15,23 +15,50 @@                 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-                hsch2s), this ensures that C functions are imported with the+                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-Cabal-Version:  >= 1.6+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-                doc/c2hs.xml doc/c2hs.css doc/man1/c2hs.1 doc/Makefile--                tests/system/*.chs tests/system/*.h tests/system/*.c-                tests/system/structs.expect-                tests/system/Makefile+  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-10/*.chs tests/bugs/issue-10/*.h tests/bugs/issue-10/*.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-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-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-37/*.chs tests/bugs/issue-37/*.h tests/bugs/issue-37/*.c+  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-47/*.chs tests/bugs/issue-47/*.h tests/bugs/issue-47/*.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  source-repository head   type:         git@@ -82,3 +109,28 @@     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 >= 0.15.4.1 && < 1.0,+                       text++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 >= 0.15.4.1 && < 1.0,+                       text
src/C2HS/C/Attrs.hs view
@@ -207,8 +207,8 @@ -- * case is not relevant in the prefix and underscores between the prefix and --   the stem of an identifier are also dropped ---applyPrefix           :: AttrC -> String -> AttrC-applyPrefix ac prefix  =+applyPrefix           :: AttrC -> String -> String -> AttrC+applyPrefix ac prefix repprefix  =   let     shadows    = shadowsAC ac     names      =    map fst (nameSpaceToList (defObjsAC ac))@@ -218,11 +218,10 @@   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) newName,-                                           ide)+      Nothing      -> Nothing+      Just ""      -> Nothing+      Just newName ->+        Just (internalIdentAt (posOf ide) (repprefix ++ newName), ide)     --     eat []        ('_':cs)                        = eat [] cs     eat []        cs                              = Just cs
src/C2HS/C/Trav.hs view
@@ -240,9 +240,7 @@     traceCTrav $ "Defining tag "++show ide++"...\n"     otag <- transAttrCCT $ \ac -> addDefTagC ac ide tag     case otag of-      Nothing      -> do-                        assertIfEnumThenFull tag-                        return Nothing                  -- no collision+      Nothing      -> return Nothing                  -- no collision       Just prevTag -> case isRefinedOrUse prevTag tag of                          Nothing                 -> return otag                          Just (fullTag, foreIde) -> do@@ -270,9 +268,12 @@     isRefinedOrUse tag'@(StructUnionCT (CStruct _ (Just _  ) _  _ _))                         (StructUnionCT (CStruct _ (Just ide') Nothing _ _)) =       Just (tag', ide')-    isRefinedOrUse tag'@(EnumCT        (CEnum (Just _  ) _  _ _))-                        (EnumCT        (CEnum (Just ide') Nothing _ _))     =+    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@@ -293,9 +294,9 @@ --   discarded, ie, all associations that existed before the transformation --   started are still in effect after the transformation ---applyPrefixToNameSpaces        :: String -> CT s ()-applyPrefixToNameSpaces prefix  =-  transAttrCCT $ \ac -> (applyPrefix ac prefix, ())+applyPrefixToNameSpaces        :: String -> String -> CT s ()+applyPrefixToNameSpaces prefix repprefix  =+  transAttrCCT $ \ac -> (applyPrefix ac prefix repprefix, ())  -- definition attribute --@@ -632,6 +633,7 @@ findAndChaseDecl                    :: Ident -> Bool -> Bool -> CT s CDecl findAndChaseDecl ide ind useShadows  =   do+    traceCTrav $ "findAndChaseDecl: " ++ show ide ++ "\n"     (obj, ide') <- findTypeObj ide useShadows   -- is there an object def?     ide  `refersToNewDef` ObjCD obj     ide' `refersToNewDef` ObjCD obj             -- assoc needed for chasing@@ -682,20 +684,23 @@       Just (StructUnionCT _   ) -> enumExpectedErr ide  -- wrong tag definition       Just (EnumCT        enum) -> return enum          -- enum tag definition       Nothing                   -> do                   -- no tag definition-        (CDecl specs _ _) <- findAndChaseDecl ide False useShadows-        case head [ts | CTypeSpec ts <- specs] of-          CEnumType enum _ -> return enum-          _                -> enumExpectedErr ide+        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 ----- * if `ind = True', the identifier names a reference type to the searched---   for struct/union------ * typedef chasing is used only if there is no tag of the same name or an---   indirection (ie, `ind = True') is explicitly required+-- * the parameter `preferTag' determines whether tags or typedefs are+--   searched first -- -- * if the third argument is `True', use `findTagShadow' --@@ -703,19 +708,30 @@ --   definition -- lookupStructUnion :: Ident -> Bool -> Bool -> CT s CStructUnion-lookupStructUnion ide ind useShadows-  | ind       = chase-  | otherwise =-    do-      otag <- if useShadows-              then liftM (fmap fst) $ findTagShadow ide-              else findTag ide-      maybe chase (extractStruct (posOf ide)) otag  -- `chase' if `Nothing'-  where-    chase =-      do-        decl <- findAndChaseDecl ide ind useShadows+lookupStructUnion ide preferTag useShadows = do+  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+        structFromDecl (posOf ide) decl+      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@@ -814,13 +830,6 @@ assertFunDeclr pos _                                                 =   funExpectedErr pos --- | raise an error if the given tag defines an enumeration, but does not fully--- define it----assertIfEnumThenFull                          :: CTag -> CT s ()-assertIfEnumThenFull (EnumCT (CEnum _ Nothing _ at))  = enumForwardErr (posOf at)-assertIfEnumThenFull _                         = return ()- -- | trace for this module -- traceCTrav :: String -> CT s ()@@ -873,9 +882,3 @@   raiseErrorCTExc pos     ["Expected a struct!",      "Expected a structure or union; instead found an enum or basic type."]--enumForwardErr     :: Position -> CT s a-enumForwardErr pos  =-  raiseErrorCTExc pos-    ["Forward definition of enumeration!",-     "ANSI C does not permit foreward definitions of enumerations!"]
src/C2HS/CHS.hs view
@@ -51,16 +51,19 @@ --            | `context' ctxt --            | `type' ident --            | `sizeof' ident---            | `enum' idalias trans [`with' prefix] [deriving]+--            | `alignof' ident+--            | `enum' idalias trans [`with' prefix] [`add' prefix] [deriving]+--            | `enum` `define` idalias [deriving] --            | `call' [`pure'] [`unsafe'] idalias --            | `fun' [`pure'] [`unsafe'] idalias parms---            | `get' apath---            | `set' apath+--            | `get' [`struct'] apath+--            | `set' [`struct'] apath+--            | `offsetof` apath --            | `pointer' ['*'] idalias ptrkind ['nocode'] --            | `class' [ident `=>'] ident ident --  ctxt     -> [`lib' `=' string] [prefix] --  idalias  -> ident [`as' (ident | `^')]---  prefix   -> `prefix' `=' string+--  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 [`*'] [`-']]@@ -143,6 +146,7 @@              | CHSHook CHSHook                  -- binding hook              | CHSCPP  String                   -- pre-processor directive                        Position+                       Bool              | CHSLine Position                 -- line pragma              | CHSC    String                   -- C code                        Position@@ -151,12 +155,12 @@                        (Maybe [CHSFrag])        -- else branch  instance Pos CHSFrag where-  posOf (CHSVerb _ pos ) = pos-  posOf (CHSHook hook  ) = posOf hook-  posOf (CHSCPP  _ pos ) = pos-  posOf (CHSLine   pos ) = pos-  posOf (CHSC    _ pos ) = pos-  posOf (CHSCond alts _) = case alts of+  posOf (CHSVerb _ pos  ) = pos+  posOf (CHSHook hook   ) = posOf hook+  posOf (CHSCPP  _ pos _) = pos+  posOf (CHSLine   pos  ) = pos+  posOf (CHSC    _ pos  ) = pos+  posOf (CHSCond alts _ ) = case alts of                              (_, frag:_):_ -> posOf frag                              _             -> nopos @@ -168,6 +172,7 @@                           Position              | CHSContext (Maybe String)        -- library name                           (Maybe String)        -- prefix+                          (Maybe String)        -- replacement prefix                           Position              | CHSType    Ident                 -- C type                           Position@@ -179,6 +184,7 @@                           (Maybe Ident)         -- Haskell name                           CHSTrans              -- translation table                           (Maybe String)        -- local prefix+                          (Maybe String)        -- local replacement prefix                           [Ident]               -- instance requests from user                           Position              | CHSEnumDefine Ident              -- Haskell name@@ -201,6 +207,8 @@              | 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@@ -216,15 +224,16 @@  instance Pos CHSHook where   posOf (CHSImport  _ _ _         pos) = pos-  posOf (CHSContext _ _           pos) = pos+  posOf (CHSContext _ _ _         pos) = pos   posOf (CHSType    _             pos) = pos   posOf (CHSSizeof  _             pos) = pos   posOf (CHSAlignof _             pos) = pos-  posOf (CHSEnum    _ _ _ _ _     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 @@ -232,31 +241,32 @@ -- same C object -- instance Eq CHSHook where-  (CHSImport qual1 ide1 _      _) == (CHSImport qual2 ide2 _      _) =+  (CHSImport qual1 ide1 _           _) == (CHSImport qual2 ide2 _           _) =     qual1 == qual2 && ide1 == ide2-  (CHSContext olib1 opref1  _   ) == (CHSContext olib2 opref2  _   ) =-    olib1 == olib2 && opref1 == opref2-  (CHSType ide1                _) == (CHSType 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              _) =+  (CHSSizeof ide1                   _) == (CHSSizeof ide2                   _) =     ide1 == ide2-  (CHSAlignof ide1             _) == (CHSAlignof ide2             _) =-    ide1 == ide2    -  (CHSEnum ide1 oalias1 _ _ _  _) == (CHSEnum ide2 oalias2 _ _ _  _) =+  (CHSAlignof ide1                  _) == (CHSAlignof ide2                  _) =+    ide1 == ide2+  (CHSEnum ide1 oalias1 _ _ _ _     _) == (CHSEnum ide2 oalias2 _ _ _ _     _) =     oalias1 == oalias2 && ide1 == ide2-  (CHSEnumDefine ide1 _ _      _) == (CHSEnumDefine ide2 _ _      _) =+  (CHSEnumDefine ide1 _ _           _) == (CHSEnumDefine ide2 _ _           _) =     ide1 == ide2-  (CHSCall _ _ ide1 oalias1    _) == (CHSCall _ _ ide2 oalias2    _) =+  (CHSCall _ _ ide1 oalias1         _) == (CHSCall _ _ ide2 oalias2         _) =     oalias1 == oalias2 && ide1 == ide2-  (CHSFun  _ _ ide1 oalias1 _ _ _ _)-                                  == (CHSFun _ _ ide2 oalias2 _ _ _ _) =+  (CHSFun  _ _ ide1 oalias1 _ _ _   _) == (CHSFun _ _ ide2 oalias2 _ _ _    _) =     oalias1 == oalias2 && ide1 == ide2-  (CHSField acc1 path1         _) == (CHSField acc2 path2         _) =+  (CHSField acc1 path1              _) == (CHSField acc2 path2              _) =     acc1 == acc2 && path1 == path2+  (CHSOffsetof path1                _) == (CHSOffsetof path2                _) =+    path1 == path2   (CHSPointer _ ide1 oalias1 _ _ _ _ _)-                                  == (CHSPointer _ ide2 oalias2 _ _ _ _ _) =+                                      == (CHSPointer _ ide2 oalias2 _ _ _ _ _) =     ide1 == ide2 && oalias1 == oalias2-  (CHSClass _ ide1 _           _) == (CHSClass _ ide2 _           _) =+  (CHSClass _ ide1 _                _) == (CHSClass _ ide2 _                _) =     ide1 == ide2   _                               == _                          = False @@ -300,13 +310,15 @@  -- | structure access path ---data CHSAPath = CHSRoot  Ident                  -- root of 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 (CHSRoot _ ide)  = posOf ide     posOf (CHSDeref _ pos) = pos     posOf (CHSRef _ ide)   = posOf ide @@ -442,7 +454,7 @@       in         (if emitNow then            showString ("\n{-# LINE " ++ show (line `max` 0) ++ " " ++-                       show fname ++ " #-}")+                       show fname ++ " #-}\n")          else id)       . showString s       . showFrags pureHs nextState frags@@ -451,10 +463,10 @@       . showCHSHook hook       . showString "#}"       . showFrags False Wait frags-    showFrags False  _     (CHSCPP  s    _     : frags) =-        showChar '#'+    showFrags False  _     (CHSCPP  s    _ nl  : frags) =+      (if nl then showChar '\n' else id)+      . showChar '#'       . showString s---      . showChar '\n'       . showFrags False Emit frags     showFrags pureHs _     (CHSLine _s         : frags) =         showFrags pureHs Emit frags@@ -473,12 +485,13 @@     showString "import "   . (if isQual then showString "qualified " else id)   . showCHSIdent ide-showCHSHook (CHSContext olib oprefix _) =+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@@ -488,11 +501,12 @@ showCHSHook (CHSAlignof   ide _) =    showString "alignof "   . showCHSIdent ide-showCHSHook (CHSEnum ide oalias trans oprefix derive _) =+showCHSHook (CHSEnum ide oalias trans oprefix oreplprefix derive _) =     showString "enum "   . showIdAlias ide oalias   . showCHSTrans trans   . showPrefix oprefix True+  . showReplacementPrefix oreplprefix   . if null derive then id else showString $       "deriving ("       ++ concat (intersperse ", " (map identToString derive))@@ -527,6 +541,9 @@        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 "")@@ -560,6 +577,12 @@   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@@ -617,7 +640,10 @@ showCHSChangeCase CHSDownCase = showString "downcaseFirstLetter"  showCHSAPath :: CHSAPath -> ShowS-showCHSAPath (CHSRoot ide) =+showCHSAPath (CHSRoot True ide) =+    showString "struct "+  . showCHSIdent ide+showCHSAPath (CHSRoot False ide) =   showCHSIdent ide showCHSAPath (CHSDeref path _) =     showString "* "@@ -777,9 +803,9 @@     parseFrags0 (CHSTokCtrl    pos c:toks) = do                                                frags <- parseFrags toks                                                return $ CHSVerb [c] pos : frags-    parseFrags0 (CHSTokCPP     pos s:toks) = do+    parseFrags0 (CHSTokCPP     pos s nl:toks) = do                                                frags <- parseFrags toks-                                               return $ CHSCPP s pos : frags+                                               return $ CHSCPP s pos nl : frags     parseFrags0 (CHSTokLine    pos  :toks) = do                                                frags <- parseFrags toks                                                return $ CHSLine pos : frags@@ -794,6 +820,7 @@     parseFrags0 (CHSTokFun     pos  :toks) = parseFun     pos        toks     parseFrags0 (CHSTokGet     pos  :toks) = parseField   pos CHSGet toks     parseFrags0 (CHSTokSet     pos  :toks) = parseField   pos CHSSet toks+    parseFrags0 (CHSTokOffsetof pos :toks) = parseOffsetof pos       toks     parseFrags0 (CHSTokClass   pos  :toks) = parseClass   pos        toks     parseFrags0 (CHSTokPointer pos  :toks) = parsePointer pos        toks     parseFrags0 toks                       = syntaxError toks@@ -853,12 +880,13 @@  parseContext          :: Position -> [CHSToken] -> CST s [CHSFrag] parseContext pos toks  = do-                           (olib    , toks'2 ) <- parseOptLib          toks-                           (opref   , toks'3) <- parseOptPrefix False toks'2-                           toks'4            <- parseEndHook         toks'3-                           frags               <- parseFrags           toks'4-                           let frag = CHSContext olib opref pos-                           return $ CHSHook frag : frags+  (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 : frags  parseType :: Position -> [CHSToken] -> CST s [CHSFrag] parseType pos (CHSTokIdent _ ide:toks) =@@ -899,13 +927,15 @@ -- {#enum cid [as hsid] {alias_1,...,alias_n}  [with prefix = pref] [deriving (clid_1,...,clid_n)] #} parseEnum pos (CHSTokIdent _ ide:toks) =   do-    (oalias, toks' )   <- parseOptAs ide True toks-    (trans , toks'')   <- parseTrans          toks'-    (oprefix, toks''') <- parseOptPrefix True toks''-    (derive, toks'''') <- parseDerive         toks'''-    toks'''''          <- parseEndHook        toks''''-    frags              <- parseFrags          toks'''''-    return $ CHSHook (CHSEnum ide (norm oalias) trans oprefix derive pos) : frags+    (oalias,      toks2) <- parseOptAs ide True toks+    (trans,       toks3) <- parseTrans          toks2+    (oprefix,     toks4) <- parseOptPrefix True toks3+    (oreplprefix, toks5) <- parseOptReplPrefix  toks4+    (derive,      toks6) <- parseDerive         toks5+    toks7                <- parseEndHook        toks6+    frags                <- parseFrags          toks7+    return $ CHSHook (CHSEnum ide (norm oalias) trans+                      oprefix oreplprefix derive pos) : frags   where     norm Nothing                   = Nothing     norm (Just ide') | ide == ide' = Nothing@@ -973,7 +1003,7 @@ parseIsUnsafe toks                  = return (False, toks)  apathToIdent :: CHSAPath -> Ident-apathToIdent (CHSRoot ide) =+apathToIdent (CHSRoot _ ide) =     let lowerFirst (c:cs) = toLower c : cs     in internalIdentAt (posOf ide) (lowerFirst $ identToString ide) apathToIdent (CHSDeref apath _) =@@ -1028,6 +1058,14 @@     frags         <- parseFrags toks''     return $ CHSHook (CHSField access path pos) : frags +parseOffsetof :: Position -> [CHSToken] -> CST s [CHSFrag]+parseOffsetof pos toks =+  do+    (path, toks') <- parsePath toks+    toks''        <- parseEndHook toks'+    frags         <- parseFrags toks''+    return $ CHSHook (CHSOffsetof path pos) : frags+ parsePointer :: Position -> [CHSToken] -> CST s [CHSFrag] parsePointer pos toks =   do@@ -1107,6 +1145,16 @@ 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 --@@ -1155,12 +1203,19 @@   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 ide), toks')+        return (pathWithHole (CHSRoot False ide), toks')     _ -> syntaxError (tok:toks) parsePath toks = syntaxError toks
src/C2HS/CHS/Lexer.hs view
@@ -87,11 +87,11 @@ --    transfers control to the following binding-hook lexer: -- --      ident       -> letter (letter | digit | `\'')*---      reservedid  -> `as' | `call' | `class' | `context' | `deriving'+--      reservedid  -> `add' | `as' | `call' | `class' | `context' | `deriving' --                   | `enum' | `foreign' | `fun' | `get' | `lib' --                   | `downcaseFirstLetter' --                   | `newtype' | `nocode' | `pointer' | `prefix' | `pure'---                   | `set' | `sizeof' | `stable' | `type'+--                   | `set' | `sizeof' | `stable' | `struct' | `type' --                   | `underscoreToCase' | `upcaseFirstLetter' | `unsafe' | --                   | `with' --      reservedsym -> `{#' | `#}' | `{' | `}' | `,' | `.' | `->' | `='@@ -205,6 +205,7 @@               | CHSTokLParen  Position          -- `('               | CHSTokRParen  Position          -- `)'               | CHSTokEndHook Position          -- `#}'+              | CHSTokAdd     Position          -- `add'               | CHSTokAs      Position          -- `as'               | CHSTokCall    Position          -- `call'               | CHSTokClass   Position          -- `class'@@ -219,6 +220,7 @@               | CHSTokLib     Position          -- `lib'               | CHSTokNewtype Position          -- `newtype'               | CHSTokNocode  Position          -- `nocode'+              | CHSTokOffsetof Position         -- `offsetof'               | CHSTokPointer Position          -- `pointer'               | CHSTokPrefix  Position          -- `prefix'               | CHSTokPure    Position          -- `pure'@@ -227,6 +229,7 @@               | CHSTokSizeof  Position          -- `sizeof'               | CHSTokAlignof Position          -- `alignof'               | CHSTokStable  Position          -- `stable'+              | CHSTokStruct  Position          -- `struct'               | CHSTokType    Position          -- `type'               | CHSTok_2Case  Position          -- `underscoreToCase'               | CHSTokUnsafe  Position          -- `unsafe'@@ -237,7 +240,7 @@               | CHSTokHSQuot  Position String   -- quoted Haskell ('...')               | CHSTokIdent   Position Ident    -- identifier               | CHSTokHaskell Position String   -- verbatim Haskell code-              | CHSTokCPP     Position String   -- pre-processor directive+              | CHSTokCPP     Position String Bool -- pre-processor directive               | CHSTokLine    Position          -- line pragma               | CHSTokC       Position String   -- verbatim C code               | CHSTokCtrl    Position Char     -- control code@@ -257,6 +260,7 @@   posOf (CHSTokLParen  pos  ) = pos   posOf (CHSTokRParen  pos  ) = pos   posOf (CHSTokEndHook pos  ) = pos+  posOf (CHSTokAdd     pos  ) = pos   posOf (CHSTokAs      pos  ) = pos   posOf (CHSTokCall    pos  ) = pos   posOf (CHSTokClass   pos  ) = pos@@ -271,6 +275,7 @@   posOf (CHSTokLib     pos  ) = pos   posOf (CHSTokNewtype pos  ) = pos   posOf (CHSTokNocode  pos  ) = pos+  posOf (CHSTokOffsetof pos ) = pos   posOf (CHSTokPointer pos  ) = pos   posOf (CHSTokPrefix  pos  ) = pos   posOf (CHSTokPure    pos  ) = pos@@ -279,6 +284,7 @@   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@@ -289,7 +295,7 @@   posOf (CHSTokHSQuot  pos _) = pos   posOf (CHSTokIdent   pos _) = pos   posOf (CHSTokHaskell pos _) = pos-  posOf (CHSTokCPP     pos _) = pos+  posOf (CHSTokCPP     pos _ _) = pos   posOf (CHSTokLine    pos  ) = pos   posOf (CHSTokC       pos _) = pos   posOf (CHSTokCtrl    pos _) = pos@@ -309,6 +315,7 @@   (CHSTokLParen   _  ) == (CHSTokLParen   _  ) = True   (CHSTokRParen   _  ) == (CHSTokRParen   _  ) = True   (CHSTokEndHook  _  ) == (CHSTokEndHook  _  ) = True+  (CHSTokAdd      _  ) == (CHSTokAdd      _  ) = True   (CHSTokAs       _  ) == (CHSTokAs       _  ) = True   (CHSTokCall     _  ) == (CHSTokCall     _  ) = True   (CHSTokClass    _  ) == (CHSTokClass    _  ) = True@@ -323,6 +330,7 @@   (CHSTokLib      _  ) == (CHSTokLib      _  ) = True   (CHSTokNewtype  _  ) == (CHSTokNewtype  _  ) = True   (CHSTokNocode   _  ) == (CHSTokNocode   _  ) = True+  (CHSTokOffsetof _  ) == (CHSTokOffsetof _  ) = True   (CHSTokPointer  _  ) == (CHSTokPointer  _  ) = True   (CHSTokPrefix   _  ) == (CHSTokPrefix   _  ) = True   (CHSTokPure     _  ) == (CHSTokPure     _  ) = True@@ -331,6 +339,7 @@   (CHSTokSizeof   _  ) == (CHSTokSizeof   _  ) = True   (CHSTokAlignof  _  ) == (CHSTokAlignof  _  ) = True   (CHSTokStable   _  ) == (CHSTokStable   _  ) = True+  (CHSTokStruct   _  ) == (CHSTokStruct   _  ) = True   (CHSTokType     _  ) == (CHSTokType     _  ) = True   (CHSTok_2Case   _  ) == (CHSTok_2Case   _  ) = True   (CHSTokUnsafe   _  ) == (CHSTokUnsafe   _  ) = True@@ -341,7 +350,7 @@   (CHSTokHSQuot   _ _) == (CHSTokHSQuot   _ _) = True   (CHSTokIdent    _ _) == (CHSTokIdent    _ _) = True   (CHSTokHaskell  _ _) == (CHSTokHaskell  _ _) = True-  (CHSTokCPP      _ _) == (CHSTokCPP      _ _) = True+  (CHSTokCPP    _ _ _) == (CHSTokCPP    _ _ _) = True   (CHSTokLine     _  ) == (CHSTokLine     _  ) = True   (CHSTokC        _ _) == (CHSTokC        _ _) = True   (CHSTokCtrl     _ _) == (CHSTokCtrl     _ _) = True@@ -362,6 +371,7 @@   showsPrec _ (CHSTokLParen  _  ) = showString "("   showsPrec _ (CHSTokRParen  _  ) = showString ")"   showsPrec _ (CHSTokEndHook _  ) = showString "#}"+  showsPrec _ (CHSTokAdd     _  ) = showString "add"   showsPrec _ (CHSTokAs      _  ) = showString "as"   showsPrec _ (CHSTokCall    _  ) = showString "call"   showsPrec _ (CHSTokClass   _  ) = showString "class"@@ -376,6 +386,7 @@   showsPrec _ (CHSTokLib     _  ) = showString "lib"   showsPrec _ (CHSTokNewtype _  ) = showString "newtype"   showsPrec _ (CHSTokNocode  _  ) = showString "nocode"+  showsPrec _ (CHSTokOffsetof _ ) = showString "offsetof"   showsPrec _ (CHSTokPointer _  ) = showString "pointer"   showsPrec _ (CHSTokPrefix  _  ) = showString "prefix"   showsPrec _ (CHSTokPure    _  ) = showString "pure"@@ -384,6 +395,7 @@   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"@@ -394,7 +406,7 @@   showsPrec _ (CHSTokHSQuot  _ s) = showString ("'" ++ s ++ "'")   showsPrec _ (CHSTokIdent   _ i) = (showString . identToString) i   showsPrec _ (CHSTokHaskell _ s) = showString s-  showsPrec _ (CHSTokCPP     _ 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@@ -465,6 +477,7 @@             >||< 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) --@@ -588,6 +601,14 @@ hook  = string "{#"         `lexmeta` \_ pos s -> (Nothing, 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`+              \lexeme 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@@ -598,21 +619,23 @@ cpp = directive       where         directive =-          string "\n#" +> alt ('\t':inlineSet)`star` epsilon+          (string "\n#" >|< string "\0#") +>+          alt ('\t':inlineSet)`star` epsilon           `lexmeta`-             \(_:_:dir) pos s ->        -- strip off the "\n#"+             \t@(ld:_:dir) pos s ->      -- strip off the "\n#" or "\0#"                case dir of                  ['c']                      ->          -- #c-                   (Nothing, retPos pos, s, Just cLexer)+                   (Nothing, incPos pos (length t), s, Just cLexer)                  -- a #c may be followed by whitespace                  'c':sp:_ | sp `elem` " \t" ->          -- #c-                   (Nothing, retPos pos, s, Just cLexer)+                   (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),-                    retPos pos, s, Nothing)+                   (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@@ -684,6 +707,7 @@        (letter +> (letter >|< digit >|< char '\'')`star` epsilon        `lexactionName` \cs pos name -> (idkwtok $!pos) cs name)   where+    idkwtok pos "add"              _    = CHSTokAdd     pos     idkwtok pos "as"               _    = CHSTokAs      pos     idkwtok pos "call"             _    = CHSTokCall    pos     idkwtok pos "class"            _    = CHSTokClass   pos@@ -698,6 +722,7 @@     idkwtok pos "lib"              _    = CHSTokLib     pos     idkwtok pos "newtype"          _    = CHSTokNewtype pos     idkwtok pos "nocode"           _    = CHSTokNocode  pos+    idkwtok pos "offsetof"         _    = CHSTokOffsetof pos     idkwtok pos "pointer"          _    = CHSTokPointer pos     idkwtok pos "prefix"           _    = CHSTokPrefix  pos     idkwtok pos "pure"             _    = CHSTokPure    pos@@ -706,6 +731,7 @@     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@@ -718,6 +744,7 @@ 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"@@ -732,6 +759,7 @@     CHSTokLib     pos -> mkid pos "lib"     CHSTokNewtype pos -> mkid pos "newtype"     CHSTokNocode  pos -> mkid pos "nocode"+    CHSTokOffsetof pos -> mkid pos "offsetof"     CHSTokPointer pos -> mkid pos "pointer"     CHSTokPrefix  pos -> mkid pos "prefix"     CHSTokPure    pos -> mkid pos "pure"@@ -740,6 +768,7 @@     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"@@ -797,7 +826,7 @@ -- | character sets -- anySet, inlineSet, specialSet, commentSpecialSet, ctrlSet :: [Char]-anySet            = ['\0'..'\255']+anySet            = ['\1'..'\255'] inlineSet         = anySet \\ ctrlSet specialSet        = ['{', '-', '"', '\''] commentSpecialSet = ['{', '-']@@ -819,7 +848,7 @@   do     nameSupply <- getNameSupply     state <- initialState nameSupply-    let (ts, lstate, errs) = execLexer chslexer (cs, pos, state)+    let (ts, lstate, errs) = execLexer chslexer ('\0':cs, pos, state)         (_, pos', state')  = lstate     mapM_ raise errs     assertFinalState pos' state'
src/C2HS/Gen/Bind.hs view
@@ -104,12 +104,14 @@ module C2HS.Gen.Bind (expandHooks) where -import Prelude hiding (exp)+import Prelude hiding (exp, lookup)  -- standard libraries import Data.Char     (toLower)-import Data.List     (deleteBy, intersperse, find)-import Data.Maybe    (isNothing, fromJust, fromMaybe)+import Data.Function (on)+import Data.List     (deleteBy, groupBy, sortBy, intersperse, find)+import Data.Map      (lookup)+import Data.Maybe    (isNothing, isJust, fromJust, fromMaybe) import Data.Bits     ((.|.), (.&.)) import Control.Monad (when, unless, liftM, mapAndUnzipM) @@ -134,10 +136,13 @@ import C2HS.C.Info      (CPrimType(..), alignment, getPlatform) import qualified C2HS.C.Info as CInfo import C2HS.Gen.Monad    (TransFun, transTabToTransFun, HsObject(..), GB,-                   initialGBState, setContext, getPrefix,+                          GBState(..),+                   initialGBState, setContext, getPrefix, getReplacementPrefix,                    delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs,-                   queryClass, queryPointer, mergeMaps, dumpMaps)+                   queryClass, queryPointer, mergeMaps, dumpMaps,+                   queryEnum, isEnum) + -- default marshallers -- ------------------- @@ -147,6 +152,10 @@ --   pointers defined via (newtype) pointer hooks) -- - the checks for the Haskell types are quite kludgy +stringIn :: String+stringIn = "\\s f -> 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@@ -162,22 +171,37 @@   return $ Just (Left withCStringIde, CHSIOArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt]   | isIntegralCPrimType pt                                     =-  return $ Just (Left withCStringLenIde, CHSIOArg)+  return $ Just (Right stringIn , CHSIOArg) lookupDftMarshIn hsTy     [PtrET ty]  | showExtType ty == hsTy =-  return $ Just (Left withIde, CHSIOArg)+  return $ Just (Right stringIn, CHSIOArg) lookupDftMarshIn hsTy     [PtrET (PrimET pt)]   | isIntegralHsType hsTy && isIntegralCPrimType pt            =-  return $ Just (Left withIntConvIde, CHSIOArg)+  return $ Just (Right "with . fromIntegral", CHSIOArg) lookupDftMarshIn hsTy     [PtrET (PrimET pt)]   | isFloatHsType hsTy && isFloatCPrimType pt                  =-  return $ Just (Left withFloatConvIde, CHSIOArg)+  return $ Just (Right "with . realToFrac", CHSIOArg) lookupDftMarshIn "Bool"   [PtrET (PrimET pt)]   | isIntegralCPrimType pt                                     =-  return $ Just (Left withFromBoolIde, CHSIOArg)+  return $ Just (Right "with . fromBool", CHSIOArg)+-- Default case deals with:+lookupDftMarshIn hsty _ = do+  om <- readCT objmap+  isenum <- queryEnum hsty+  return $ case (isenum, (internalIdent hsty) `lookup` om) of+    --  1. enumeration hooks+    (True, Nothing) -> Just (Right "fromIntegral . fromEnum", CHSValArg)+    --  2. naked and newtype pointer hooks+    (False, Just (Pointer CHSPtr _)) -> Just (Left idIde, CHSValArg)+    --  3. foreign pointer hooks+    (False, Just (Pointer CHSForeignPtr False)) ->+      Just (Left withForeignPtrIde, CHSIOArg)+    --  4. foreign newtype pointer hooks+    (False, Just (Pointer CHSForeignPtr True)) ->+      Just (Right $ "with" ++ hsty, CHSIOArg)+    _ -> Nothing -- FIXME: handle array-list conversion-lookupDftMarshIn _        _                                    =-  return Nothing + -- | determine the default "out" marshaller for the given Haskell and C types -- lookupDftMarshOut :: String -> [ExtType] -> GB CHSMarsh@@ -195,13 +219,28 @@   return $ Just (Left peekCStringIde, CHSIOArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT), PrimET pt]   | isIntegralCPrimType pt                                      =-  return $ Just (Left peekCStringLenIde, CHSIOArg)+  return $ Just (Right "\\(s, n) -> peekCStringLen (s, fromIntegral n)",+                 CHSIOArg) lookupDftMarshOut hsTy     [PtrET ty]  | showExtType ty == hsTy =   return $ Just (Left peekIde, CHSIOArg)+-- Default case deals with:+lookupDftMarshOut hsty _ = do+  om <- readCT objmap+  isenum <- queryEnum hsty+  return $ case (isenum, (internalIdent hsty) `lookup` om) of+    --  1. enumeration hooks+    (True, Nothing) -> Just (Right "toEnum . fromIntegral", CHSValArg)+    --  2. naked and newtype pointer hooks+    (False, Just (Pointer CHSPtr _)) -> Just (Left idIde, CHSValArg)+    --  3. foreign pointer hooks+    (False, Just (Pointer CHSForeignPtr False)) ->+      Just (Left newForeignPtrIde, CHSIOArg)+    --  4. foreign newtype pointer hooks+    (False, Just (Pointer CHSForeignPtr True)) ->+      Just (Right $ "newForeignPtr_ >=> (return . " ++ hsty ++ ")", CHSIOArg)+    _ -> Nothing -- FIXME: add combination, such as "peek" plus "cIntConv" etc -- FIXME: handle array-list conversion-lookupDftMarshOut _        _                                    =-  return Nothing   -- | check for integral Haskell types@@ -251,28 +290,20 @@ -- | standard conversions -- voidIde, cFromBoolIde, cToBoolIde, cIntConvIde, cFloatConvIde,-  withIde, withCStringIde, withCStringLenIde, withIntConvIde,-  withFloatConvIde, withFromBoolIde, peekIde, peekCStringIde,-  peekCStringLenIde :: Ident+  withCStringIde, peekIde, peekCStringIde, idIde,+  newForeignPtrIde, withForeignPtrIde :: Ident voidIde           = internalIdent "void"         -- never appears in the output cFromBoolIde      = internalIdent "fromBool" cToBoolIde        = internalIdent "toBool" cIntConvIde       = internalIdent "fromIntegral" cFloatConvIde     = internalIdent "realToFrac"-withIde           = internalIdent "with" withCStringIde    = internalIdent "withCString"-withCStringLenIde = internalIdent "withCStringLenIntConv" --TODO: kill off-withIntConvIde    = internalIdent "withIntConv"           --TODO: kill off-withFloatConvIde  = internalIdent "withFloatConv"         --TODO: kill off-withFromBoolIde   = internalIdent "withFromBoolConv"      --TODO: kill off peekIde           = internalIdent "peek" peekCStringIde    = internalIdent "peekCString"-peekCStringLenIde = internalIdent "peekCStringLenIntConv" --TODO: kill off+idIde             = internalIdent "id"+newForeignPtrIde  = internalIdent "newForeignPtr_"+withForeignPtrIde = internalIdent "withForeignPtr" ---TODO: c2hs should not generate these references to externally defined--- non-standard utility functions. It's annoying and they are all trivial.--- The solutionis to generate expressions inline, rather than requiring all--- marshalers be single identifiers.  -- expansion of binding hooks -- --------------------------@@ -292,12 +323,12 @@                         return res  expandModule                   :: CHSModule -> GB (CHSModule, String, String)-expandModule (CHSModule frags)  =+expandModule (CHSModule mfrags)  =   do     -- expand hooks     --     traceInfoExpand-    frags'       <- expandFrags frags+    frags'       <- expandFrags mfrags     delayedFrags <- getDelayedCode      -- get .chi dump@@ -336,7 +367,7 @@     code <- expandHook h     return [CHSVerb code builtinPos]   `ifCTExc` return [CHSVerb "** ERROR **" builtinPos]-expandFrag      (CHSCPP  s _     ) =+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---"@@ -348,14 +379,14 @@     select []                   = do                                     traceInfoDft dft                                     expandFrags (maybe [] id dft)-    select ((ide, frags):alts') = do-                                   oobj <- findTag ide-                                   traceInfoVal ide oobj-                                   if isNothing oobj-                                     then-                                       select alts'-                                     else            -- found right alternative-                                       expandFrags frags+    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 " ++@@ -373,10 +404,12 @@     mergeMaps chi     return $       "import " ++ (if qual then "qualified " else "") ++ identToString ide-expandHook (CHSContext olib oprefix _) =+expandHook (CHSContext olib oprefix orepprefix _) =   do-    setContext olib oprefix                   -- enter context information-    mapMaybeM_ applyPrefixToNameSpaces oprefix -- use the prefix on name spaces+    setContext olib oprefix orepprefix         -- enter context information+    -- use the prefix on name spaces+    when (isJust oprefix) $+      applyPrefixToNameSpaces (fromJust oprefix) (maybe "" id orepprefix)     return "" expandHook (CHSType ide pos) =   do@@ -418,7 +451,7 @@       ++ show (padBits size) ++ "\n" expandHook (CHSEnumDefine _ _ _ _) =   interr "Binding generation error : enum define hooks should be eliminated via preprocessing "-expandHook (CHSEnum cide oalias chsTrans oprefix derive _) =+expandHook (CHSEnum cide oalias chsTrans oprefix orepprefix derive pos) =   do     -- get the corresponding C declaration     --@@ -427,14 +460,18 @@     -- convert the translation table and generate data type definition code     --     gprefix <- getPrefix-    let prefix = case oprefix of-                   Nothing -> gprefix-                   Just pref -> pref+    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 prefix chsTrans+    let trans = transTabToTransFun pfx reppfx chsTrans         hide  = identToString . fromMaybe cide $ oalias-    enumDef enum hide trans (map identToString derive)-expandHook hook@(CHSCall isPure isUns (CHSRoot ide) oalias pos) =+    enumDef enum hide trans (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@@ -481,7 +518,7 @@       "** Indirect call hook for `" ++ identToString (apathToIdent apath) ++ "':\n"     traceValueType et  = traceGenBind $       "Type of accessed value: " ++ showExtType et ++ "\n"-expandHook (CHSFun isPure isUns (CHSRoot ide) oalias ctxt parms parm pos) =+expandHook (CHSFun isPure isUns (CHSRoot _ ide) oalias ctxt parms parm pos) =   do     traceEnter     -- get the corresponding C declaration; raises error if not found or not a@@ -494,7 +531,7 @@         fiLexeme  = hsLexeme ++ "'_"   -- Urgh - probably unqiue...         fiIde     = internalIdent fiLexeme         cdecl'    = cide `simplifyDecl` cdecl-        callHook  = CHSCall isPure isUns (CHSRoot cide) (Just fiIde) pos+        callHook  = CHSCall isPure isUns (CHSRoot False cide) (Just fiIde) pos     callImport callHook isPure isUns (identToString cide) fiLexeme cdecl' pos      extTy <- extractFunType pos cdecl' True@@ -545,6 +582,7 @@ expandHook (CHSField access path pos) =   do     traceInfoField+    traceGenBind $ "path = " ++ show path ++ "\n"     (decl, offsets) <- accessPath path     traceDepth offsets     ty <- extractSimpleType False pos decl@@ -559,6 +597,28 @@                                         ++ 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 decl >>= \ compTy ->+        case compTy of+          ExtType et ->+            case et 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+          SUType _ -> return offset+    checkType _ _ = offsetDerefErr pos expandHook (CHSPointer isStar cName oalias ptrKind isNewtype oRefType emit               pos) =   do@@ -646,7 +706,7 @@         Class oclassIde' typeIde' <- queryClass ide         ptr                       <- queryPointer typeIde'         classes                   <- collectClasses oclassIde'-        return $ (identToString ide, identToString typeIde, ptr) : classes+        return $ (identToString ide, identToString typeIde', ptr) : classes     --     traceInfoClass = traceGenBind $ "** Class hook:\n" @@ -658,16 +718,19 @@ -- * the translation function strips prefixes where possible (different --   enumerators maye have different prefixes) ---enumDef :: CEnum -> String -> TransFun -> [String] -> GB String-enumDef (CEnum _ (Just list) _ _) hident trans userDerive =+enumDef :: CEnum -> String -> TransFun -> [String] -> Position -> GB String+enumDef (CEnum _ Nothing _ _) _ _ _ pos = undefEnumErr pos+enumDef (CEnum _ (Just list) _ _) hident trans userDerive _ =   do     (list', enumAuto) <- evalTagVals list-    let enumVals = [(trans ide, cexpr) | (ide, cexpr) <-  list']  -- translate+    let enumVals = [(trans ide, cexpr) |+                    (ide, cexpr) <- stripEnumAliases list']  -- translate         defHead  = enumHead hident         defBody  = enumBody (length defHead - 2) enumVals         inst     = makeDerives                    (if enumAuto then "Enum" : userDerive else userDerive) ++                    if enumAuto then "\n" else "\n" ++ enumInst hident enumVals+    isEnum hident     return $ defHead ++ defBody ++ inst   where     evalTagVals []                     = return ([], True)@@ -689,6 +752,18 @@         at1 = newAttrsOnlyPos nopos     makeDerives [] = ""     makeDerives dList = "deriving (" ++ concat (intersperse "," dList) ++")"+    stripEnumAliases :: [(Ident, Maybe CExpr)] -> [(Ident, Maybe CExpr)]+    stripEnumAliases vs =+      let okids = map (fst . head) .+                  groupBy ((==) `on` snd) .+                  sortBy (compare `on` snd) .+                  extractEnumVals $ vs+      in filter ((`elem` okids) . fst) vs+    extractEnumVals :: [(Ident, Maybe CExpr)] -> [(Ident, CInteger)]+    extractEnumVals = go 0+      where go _ [] = []+            go k ((i, Nothing):vs') = (i,k) : go (k+1) vs'+            go _ ((i, Just (CConst (CIntConst j _))):vs') = (i,j) : go (j+1) vs'  -- | Haskell code for the head of an enumeration definition --@@ -848,7 +923,9 @@                   if isPure && isImpure then "  unsafePerformIO $\n" else ""       call      = if isPure                   then "  let {res = " ++ fiLexeme ++ joinCallArgs ++ "} in\n"-                  else "  " ++ fiLexeme ++ joinCallArgs ++ " >>= \\res ->\n"+                  else "  " ++ fiLexeme ++ joinCallArgs ++ case parm of+                    CHSParm _ "()" _ _ _ -> " >>\n"+                    _                    -> " >>= \\res ->\n"       joinCallArgs = case marsh2 of                         Nothing -> join callArgs                         Just _  -> join ("b1'" : drop 1 callArgs)@@ -883,7 +960,13 @@                   joinLines marshOuts ++                   "  " ++                   (if isImpure || not isPure then "return " else "") ++ ret-    return $ sig ++ funHead ++ funBody++      pad code = let col = posColumn pos+                     padding = replicate (col - 3) ' '+                     (l:ls) = lines code+                 in unlines $ l : map (padding ++) ls++    return $ pad $ sig ++ funHead ++ funBody   where     join      = concatMap (' ':)     joinLines = concatMap (\s -> "  " ++ s ++ "\n")@@ -1055,23 +1138,23 @@ --   structure, we can never have the structure as a value itself -- accessPath :: CHSAPath -> GB (CDecl, [BitSize])-accessPath (CHSRoot ide) =                              -- t+accessPath (CHSRoot _ ide) =                            -- t   do     decl <- findAndChaseDecl ide False True     return (ide `simplifyDecl` decl, [BitSize 0 0])-accessPath (CHSDeref (CHSRoot ide) _) =                 -- *t+accessPath (CHSDeref (CHSRoot _ ide) _) =               -- *t   do     decl <- findAndChaseDecl ide True True     return (ide `simplifyDecl` decl, [BitSize 0 0])-accessPath (CHSRef  (CHSRoot ide1) ide2) =              -- t.m+accessPath (CHSRef (CHSRoot str ide1) ide2) =           -- t.m   do-    su <- lookupStructUnion ide1 False True+    su <- lookupStructUnion ide1 str True     (offset, decl') <- refStruct su ide2     adecl <- replaceByAlias decl'     return (adecl, [offset])-accessPath (CHSRef (CHSDeref (CHSRoot ide1) _) ide2) =  -- t->m+accessPath (CHSRef (CHSDeref (CHSRoot str ide1) _) ide2) =  -- t->m   do-    su <- lookupStructUnion ide1 True True+    su <- lookupStructUnion ide1 str True     (offset, decl') <- refStruct su ide2     adecl <- replaceByAlias decl'     return (adecl, [offset])@@ -1259,8 +1342,9 @@       --       withForeignFun         | ptrKind == CHSForeignPtr =-          "\n" ++-          "with" ++ hsName ++ " (" ++ hsName ++ " fptr) = withForeignPtr fptr"+          "\nwith" ++ hsName ++ " :: " +++          hsName ++ " -> (Ptr " ++ hsName ++ " -> IO b) -> IO b" +++          "\nwith" ++ hsName ++ " (" ++ hsName ++ " fptr) = withForeignPtr fptr"         | otherwise                = ""  -- | generate the class and instance definitions for a class hook@@ -1772,7 +1856,7 @@ -- | add two bit size values -- addBitSize                                 :: BitSize -> BitSize -> BitSize-addBitSize (BitSize o1 b1) (BitSize o2 b2)  = BitSize (o1 + o2 + overflow) rest+addBitSize (BitSize o1 b1) (BitSize o2 b2)  = BitSize (o1 + o2 + overflow * CInfo.size CIntPT) rest   where     bitsPerBitfield  = CInfo.size CIntPT * 8     (overflow, rest) = (b1 + b2) `divMod` bitsPerBitfield@@ -1939,7 +2023,7 @@     offset   where     bitsPerBitfield     = CInfo.size CIntPT * 8-    overflowingBitfield = bitOffset - align >= bitsPerBitfield+    overflowingBitfield = bitOffset - align > bitsPerBitfield                                     -- note, `align' is negative  @@ -1969,8 +2053,8 @@     rhsVal <- evalConstCExpr rhs     let (lhsVal', rhsVal') = usualArithConv lhsVal rhsVal     applyBin (posOf at) op lhsVal' rhsVal'-evalConstCExpr (CCast _ _ _) =-  todo "GenBind.evalConstCExpr: Casts are not implemented yet."+evalConstCExpr c@(CCast _ _ _) =+  evalCCast c evalConstCExpr (CUnary op arg at) =   do     argVal <- evalConstCExpr arg@@ -2029,6 +2113,19 @@             enumTagValue ide enumrs (val' + 1) evalConstCExpr (CConst c) = evalCConst c +evalCCast :: CExpr -> GB ConstResult+evalCCast (CCast decl expr _) = do+    compType <- extractCompType 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' :: CompType -> Integer -> GB ConstResult+evalCCast' (ExtType (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 _ ) = return $ IntResult (getCCharAsInt c)@@ -2133,13 +2230,7 @@ lookupBy      :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b lookupBy eq x  = fmap snd . find (eq x . fst) --- | 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 -- -------------- @@ -2240,6 +2331,19 @@     ["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@@ -2268,3 +2372,6 @@      \C type:",      "Haskell type: " ++ hsTy,      "C type      : " ++ concat (intersperse " " (map showExtType cTys))]++undefEnumErr :: Position -> GB a+undefEnumErr pos = raiseErrorCTExc pos ["Incomplete enum type!"]
src/C2HS/Gen/Header.hs view
@@ -184,7 +184,7 @@   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' Nothing instances pos)+  enumFrag ide trans' = CHSHook (CHSEnum (internalIdent ide) (Just hsident) trans' Nothing Nothing instances pos)  ghFrag (frag@(CHSHook  _    ) : frags) =   return (DL.zero, Frag frag, frags)@@ -198,7 +198,7 @@  ghFrag (     (CHSCond _  _  ) : _    ) =   interr "GenHeader.ghFrags: There can't be a structured conditional yet!"-ghFrag (     (CHSCPP  s  pos) : frags) =+ghFrag (     (CHSCPP s pos nl) : frags) =   let     (directive, _) =   break (`elem` " \t")                      . dropWhile (`elem` " \t")@@ -211,7 +211,8 @@     "else"   -> return (DL.zero              , Else   pos               , frags)     "elif"   -> return (DL.zero              , Elif s pos               , frags)     "endif"  -> return (DL.zero              , Endif  pos               , frags)-    _        -> return (DL.open ['#':s, "\n"], Frag   (CHSVerb "" nopos), frags)+    _        -> return (DL.open ['#':s, "\n"],+                        Frag (CHSVerb (if nl then "\n" else "") pos), frags)   where     -- enter a new conditional (may be an #if[[n]def] or #elif)     --
src/C2HS/Gen/Monad.hs view
@@ -55,6 +55,12 @@ --  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@@ -64,9 +70,10 @@ module C2HS.Gen.Monad (   TransFun, transTabToTransFun, -  HsObject(..), GB, initialGBState, setContext, getLibrary, getPrefix,-  delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, queryObj, queryClass,-  queryPointer, mergeMaps, dumpMaps+  HsObject(..), GB, GBState(..), initialGBState, setContext, getLibrary, getPrefix,+  getReplacementPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr,+  objIs, queryObj, queryClass, queryPointer, mergeMaps, dumpMaps,+  queryEnum, isEnum ) where  -- standard libraries@@ -75,6 +82,8 @@ 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)  -- Language.C import Language.C.Data.Position@@ -134,8 +143,8 @@ -- * the details of handling the prefix are given in the DOCU section at the --   beginning of this file ---transTabToTransFun :: String -> CHSTrans -> TransFun-transTabToTransFun prefx (CHSTrans _2Case chgCase table) =+transTabToTransFun :: String -> String -> CHSTrans -> TransFun+transTabToTransFun prefx rprefx (CHSTrans _2Case chgCase table) =   \ide -> let             caseTrafo = (if _2Case then underscoreToCase else id) .                         (case chgCase of@@ -152,8 +161,9 @@                 Nothing          -> dft             -- no match & no prefix                 Just eatenLexeme ->                   let-                    eatenIde = internalIdentAt (posOf ide) eatenLexeme-                    eatenDft = caseTrafo eatenLexeme+                    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@@ -203,6 +213,9 @@                  deriving (Show, Read) type HsObjectMap = Map Ident HsObject +-- | set of Haskell type names corresponding to C enums.+type EnumSet = Set String+ {- FIXME: What a mess... instance Show HsObject where   show (Pointer ptrType isNewtype) =@@ -235,12 +248,14 @@ -- which we use an instance here -- data GBState  = GBState {-                  lib     :: String,               -- dynamic library-                  prefix  :: String,               -- prefix-                  frags   :: [(CHSHook, CHSFrag)], -- delayed code (with hooks)-                  ptrmap  :: PointerMap,           -- pointer representation-                  objmap  :: HsObjectMap           -- generated Haskell objects-               }+  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+  enums     :: EnumSet               -- enumeration hooks+  }  type GB a = CT GBState a @@ -248,17 +263,20 @@ initialGBState  = GBState {                     lib    = "",                     prefix = "",+                    repprefix = "",                     frags  = [],                     ptrmap = Map.empty,-                    objmap = Map.empty+                    objmap = Map.empty,+                    enums = Set.empty                   }  -- | set the dynamic library and library prefix ---setContext             :: (Maybe String) -> (Maybe String) -> GB ()-setContext lib' prefix' =-  transCT $ \state -> (state {lib    = fromMaybe "" lib',-                              prefix = fromMaybe "" 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@@ -271,6 +289,11 @@ 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@@ -398,6 +421,19 @@                               [(identToString ide, obj)                               | (ide, obj)            <- Map.toList objFM])               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) }, ()))   -- error messages
src/C2HS/Switches.hs view
@@ -64,17 +64,19 @@ -- | all switches of the toolkit -- data SwitchBoard = SwitchBoard {-                     cppOptsSB :: [String],     -- cpp options-                     cppSB     :: FilePath,     -- cpp executable-                     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-                   }+  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 --@@ -82,6 +84,8 @@ initialSwitchBoard  = SwitchBoard {                         cppOptsSB  = [],                         cppSB      = "cpp",+                        noGnuSB    = False,+                        noBlocksSB = False,                         keepSB     = False,                         librarySB  = False,                         tracesSB   = initialTraces,
src/Main.hs view
@@ -69,8 +69,8 @@ -- --  -i DIRS --  --include=DIRS---        Search the colon separated list of directories DIRS when searching---        for .chi files.+--        Search the colon (Linux) or semicolon (Windows) separated+--        list of directories DIRS when searching for .chi files. -- --  -k --  --keep@@ -125,7 +125,7 @@                   (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) import qualified System.FilePath as FilePath                   (takeExtension, dropExtension, takeBaseName)-import System.FilePath ((<.>), (</>))+import System.FilePath ((<.>), (</>), splitSearchPath) import System.IO (stderr, openFile, IOMode(..)) import System.IO.Error (ioeGetErrorString, ioeGetFileName) import System.Process (runProcess, waitForProcess)@@ -178,6 +178,8 @@ -- data Flag = CPPOpts  String     -- ^ additional options for C preprocessor           | CPP      String     -- ^ program name of C preprocessor+          | NoGNU               -- ^ suppress GNU preprocessor symbols+          | NoBlocks            -- ^ suppress MacOS __BLOCKS__ preproc. symbol           | Dump     DumpType   -- ^ dump internal information           | Help                -- ^ print brief usage information           | Keep                -- ^ keep the .i file@@ -209,6 +211,14 @@          ["cpp"]          (ReqArg CPP "CPP")          "use executable CPP to invoke C preprocessor",+  Option ['n']+         ["no-gnu"]+         (NoArg NoGNU)+         "suppress GNU preprocessor symbols",+  Option ['b']+         ["no-blocks"]+         (NoArg NoBlocks)+         "suppress MacOS __BLOCKS__ preprocessor symbol",   Option ['d']          ["dump"]          (ReqArg dumpArg "TYPE")@@ -393,6 +403,8 @@ processOpt :: Flag -> CST s () processOpt (CPPOpts  cppopt ) = addCPPOpts  [cppopt] processOpt (CPP      cpp    ) = setCPP      cpp+processOpt (NoGNU           ) = setNoGNU+processOpt (NoBlocks        ) = setNoBlocks processOpt (Dump     dt     ) = setDump     dt processOpt (Keep            ) = setKeep processOpt (Library         ) = setLibrary@@ -453,6 +465,16 @@ setCPP       :: FilePath -> CST s () setCPP fname  = setSwitch $ \sb -> sb {cppSB = fname} +-- | set flag to suppress GNU preprocessor symbols+--+setNoGNU :: CST s ()+setNoGNU  = setSwitch $ \sb -> sb {noGnuSB = True}++-- | set flag to suppress MacOS __BLOCKS__ preprocessor symbols+--+setNoBlocks :: CST s ()+setNoBlocks = setSwitch $ \sb -> sb {noBlocksSB = True}+ -- set the given dump option -- setDump         :: DumpType -> CST s ()@@ -479,18 +501,8 @@ --   standard value in the compiler state. -- setInclude :: String -> CST s ()-setInclude str = do-  let fp = makePath str ""-  setSwitch $ \sb -> sb {chiPathSB = fp ++ (chiPathSB sb)}-  where-    makePath ('\\':r:em)   path = makePath em (path ++ ['\\',r])-    makePath (' ':r)       path = makePath r path-    makePath (':':r)       ""   = makePath r ""-    makePath (':':r)       path = path : makePath r ""-    makePath ('/':':':r)   path = path : makePath r ""-    makePath (r:emain)     path = makePath emain (path ++ [r])-    makePath ""            ""   = []-    makePath ""            path = [path]+setInclude str =+  setSwitch $ \sb -> sb {chiPathSB = splitSearchPath str ++ (chiPathSB sb)}  -- | set the output file name --@@ -572,9 +584,16 @@     --     -- run C preprocessor over the header     ---    cpp     <- getSwitch cppSB-    cppOpts <- getSwitch cppOptsSB-    let args = cppOpts ++ [newHeaderFile]+    cpp      <- getSwitch cppSB+    cppOpts  <- getSwitch cppOptsSB+    noGnu    <- getSwitch noGnuSB+    noBlocks <- getSwitch noBlocksSB+    let noGnuOpts =+          if noGnu+          then ["-U__GNUC__", "-U__GNUC_MINOR__", "-U__GNUC_PATCHLEVEL__"]+          else []+        noBlocksOpts = if noBlocks then ["-U__BLOCKS__"] else []+        args = cppOpts ++ noGnuOpts ++ noBlocksOpts ++ [newHeaderFile]     tracePreproc (unwords (cpp:args))     exitCode <- CIO.liftIO $ do       preprocHnd <- openFile preprocFile WriteMode
+ tests/bugs/call_capital/Capital.c view
@@ -0,0 +1,4 @@+#include "Capital.h"+#include <stdio.h>+void c() { printf("lower c();\n"); }+void C() { printf("upper C();\n"); }
+ tests/bugs/call_capital/Capital.chs view
@@ -0,0 +1,7 @@+module Main where++#include "Capital.h"+main = do+  {# call C as ^ #}+  {# call c as c' #}+  {# call C as c'' #}
+ tests/bugs/call_capital/Capital.h view
@@ -0,0 +1,2 @@+void c();+void C();
+ tests/bugs/issue-10/Issue10.chs view
@@ -0,0 +1,21 @@+module Main where++import Control.Monad+import Foreign.C++#include "issue10.h"++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+  putStrLn $ if sz1 == sz1expect then "SAME" else "DIFF"+  putStrLn $ if sz2 == sz2expect then "SAME" else "DIFF"+  putStrLn $ if sz3 == sz3expect then "SAME" else "DIFF"+  putStrLn $ if sz4 == sz4expect then "SAME" else "DIFF"
+ tests/bugs/issue-10/issue10.c view
@@ -0,0 +1,6 @@+#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); }
+ tests/bugs/issue-10/issue10.h view
@@ -0,0 +1,31 @@+#include <stdlib.h>++size_t size_of_s1(void);+size_t size_of_s2(void);+size_t size_of_s3(void);+size_t size_of_s4(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;
+ tests/bugs/issue-16/Issue16.chs view
@@ -0,0 +1,5 @@+#include "issue16.h"++main :: IO ()+main = return ()+
+ tests/bugs/issue-16/issue16.c view
+ tests/bugs/issue-16/issue16.h view
+ tests/bugs/issue-19/Issue19.chs view
@@ -0,0 +1,17 @@+module 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!"
+ tests/bugs/issue-19/issue19.c view
@@ -0,0 +1,1 @@+#include "issue19.h"
+ tests/bugs/issue-19/issue19.h view
@@ -0,0 +1,11 @@+enum enums1 {+  ENUMS_ONE   = 1,+  ENUMS_TWO   = 2,+  ENUMS_THREE = 3+};++enum enums2 {+  ENUMS_FOUR = 4,+  ENUMS_FIVE = 5,+  ENUMS_SIX  = 6+};
+ tests/bugs/issue-22/Issue22.chs view
@@ -0,0 +1,33 @@+module 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
+ tests/bugs/issue-22/issue22.c view
@@ -0,0 +1,14 @@+#include <string.h>+#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;+}
+ tests/bugs/issue-22/issue22.h view
@@ -0,0 +1,11 @@+typedef struct {+    int field;+} substruct_t;++typedef struct {+    char somefield[32];+    substruct_t substruct;+    substruct_t* substruct_p;+} struct_t;++struct_t *foo(int n);
+ tests/bugs/issue-23/Issue23.chs view
@@ -0,0 +1,15 @@+module Main where++import Foreign.C++#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
+ tests/bugs/issue-23/issue23.c view
@@ -0,0 +1,11 @@+#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;+  }+}
+ tests/bugs/issue-23/issue23.h view
@@ -0,0 +1,1 @@+extern enum hello hello_fn(int);
+ tests/bugs/issue-23/issue23x.h view
@@ -0,0 +1,1 @@+enum hello { H1, H2, H3 };
+ tests/bugs/issue-29/Issue29.chs view
@@ -0,0 +1,6 @@+module Main where++#include "issue29.h"++main :: IO ()+main = return ()
+ tests/bugs/issue-29/issue29.h view
@@ -0,0 +1,10 @@+#ifndef _STDLIB_H_+#define _STDLIB_H_++int atexit(void (*)(void));++#ifdef __BLOCKS__+int atexit_b(void (^)(void));+#endif++#endif
+ tests/bugs/issue-30/Issue30.chs view
@@ -0,0 +1,20 @@+module 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
+ tests/bugs/issue-30/Issue30Aux1.chs view
@@ -0,0 +1,8 @@+module Issue30Aux1 where++import Foreign+import Foreign.C++#include "issue30aux1.h"++{#fun foo1 {`Int'} -> `Int'#}
+ tests/bugs/issue-30/Issue30Aux2.chs view
@@ -0,0 +1,8 @@+module Issue30Aux2 where++import Foreign+import Foreign.C++#include "issue30aux2.h"++{#fun foo2 {`Int'} -> `Int'#}
+ tests/bugs/issue-30/issue30.c view
@@ -0,0 +1,1 @@+int foo(int n) { return n + 1; }
+ tests/bugs/issue-30/issue30.h view
@@ -0,0 +1,1 @@+int foo(int);
+ tests/bugs/issue-30/issue30aux1.c view
@@ -0,0 +1,1 @@+int foo1(int n) { return n * 2; }
+ tests/bugs/issue-30/issue30aux1.h view
@@ -0,0 +1,1 @@+int foo1(int);
+ tests/bugs/issue-30/issue30aux2.c view
@@ -0,0 +1,1 @@+int foo2(int n) { return n * 4; }
+ tests/bugs/issue-30/issue30aux2.h view
@@ -0,0 +1,1 @@+int foo2(int);
+ tests/bugs/issue-31/Issue31.chs view
@@ -0,0 +1,92 @@+module Main where++import Control.Monad+import Foreign+import Foreign.C++#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 ()
+ tests/bugs/issue-31/issue31.c view
@@ -0,0 +1,53 @@+#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; }
+ tests/bugs/issue-31/issue31.h view
@@ -0,0 +1,23 @@+typedef 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 *);
+ tests/bugs/issue-32/Issue32.chs view
@@ -0,0 +1,17 @@+module Main where++import Data.Bits+import Foreign.C+import Foreign.Ptr+import Foreign.Storable++#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)
+ tests/bugs/issue-32/issue32.c view
@@ -0,0 +1,12 @@+#include "issue32.h"++static testStruct makeItFrom;++testStruct *makeIt(void)+{+  makeItFrom.a = 1234;+  makeItFrom.b = 1;+  makeItFrom.c = 523;+  makeItFrom.d = 24;+  return &makeItFrom;+}
+ tests/bugs/issue-32/issue32.h view
@@ -0,0 +1,10 @@+typedef struct testStruct_ testStruct;++struct testStruct_ {+  unsigned a: 27;+  unsigned b:  1;+  unsigned c: 13;+  unsigned d:  8;+};++testStruct *makeIt(void);
+ tests/bugs/issue-37/Issue37.chs view
@@ -0,0 +1,17 @@+module Main where++import Foreign+import Foreign.C++#include "issue37.h"++{#fun f1 {`Int'} -> `Int'#}++{#fun f2 {`Float'} -> `Float'#}++main :: IO ()+main = do+  tst1 <- f1 7+  tst2 <- f2 23+  putStrLn $ if tst1 == 14 then "SAME" else "DIFF"+  putStrLn $ if tst2 == 69 then "SAME" else "DIFF"
+ tests/bugs/issue-37/issue37.c view
@@ -0,0 +1,12 @@+#include "issue37.h"++int f1(int *np)+{+  return *np * 2;+}+++float f2(float *np)+{+  return *np * 3;+}
+ tests/bugs/issue-37/issue37.h view
@@ -0,0 +1,2 @@+int f1(int *np);+float f2(float *np);
+ tests/bugs/issue-38/Issue38.chs view
@@ -0,0 +1,17 @@+module Main where++import Foreign.C++#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"
+ tests/bugs/issue-38/issue38.c view
@@ -0,0 +1,10 @@+#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;+  }+}
+ tests/bugs/issue-38/issue38.h view
@@ -0,0 +1,10 @@+typedef 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);+
+ tests/bugs/issue-43/Issue43.chs view
@@ -0,0 +1,16 @@+module 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)
+ tests/bugs/issue-43/issue43.c view
+ tests/bugs/issue-43/issue43.h view
@@ -0,0 +1,14 @@+enum Test1 {+  TEST1_A,+  TEST1_B,+  TEST1_C = 5,+  TEST1_D+};++enum {+  ANON_A = 8,+  ANON_B,+  ANON_C = 15,+  ANON_D+};+
+ tests/bugs/issue-44/Issue44.chs view
@@ -0,0 +1,10 @@+module Main where++import Foreign++#include "issue44.h"++{#pointer *foo as ^ foreign newtype#}++main :: IO ()+main = putStrLn "dummy"
+ tests/bugs/issue-44/issue44.c view
+ tests/bugs/issue-44/issue44.h view
@@ -0,0 +1,1 @@+typedef struct { int a; } foo;
+ tests/bugs/issue-45/Issue45.chs view
@@ -0,0 +1,9 @@+module Main where++import Foreign.C++#include "issue45.h"++main :: IO ()+main = foo 2+  where {#fun foo {`Int'} -> `()'#}
+ tests/bugs/issue-45/issue45.c view
@@ -0,0 +1,1 @@+void foo(int n) { }
+ tests/bugs/issue-45/issue45.h view
@@ -0,0 +1,1 @@+void foo(int);
+ tests/bugs/issue-47/Issue47.chs view
@@ -0,0 +1,10 @@+module Main where++import Foreign.C++#include "issue47.h"++{#fun foo {`Int'} -> `()'#}++main :: IO ()+main = foo 2
+ tests/bugs/issue-47/issue47.c view
@@ -0,0 +1,1 @@+void foo(int n) { }
+ tests/bugs/issue-47/issue47.h view
@@ -0,0 +1,1 @@+void foo(int);
+ tests/bugs/issue-51/Issue51.chs view
@@ -0,0 +1,15 @@+module 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
+ tests/bugs/issue-51/issue51.c view
@@ -0,0 +1,2 @@+int fooGnu(int n) { return 1; }+int fooNonGnu(int n) { return 0; }
+ tests/bugs/issue-51/issue51.h view
@@ -0,0 +1,2 @@+int fooGnu(int);+int fooNonGnu(int);
+ tests/bugs/issue-54/Issue54.chs view
@@ -0,0 +1,41 @@+module Main where++import Foreign+import Foreign.C++#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
+ tests/bugs/issue-54/issue54.c view
@@ -0,0 +1,18 @@+#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;+}
+ tests/bugs/issue-54/issue54.h view
@@ -0,0 +1,12 @@+typedef struct {+  int c;+  double d;+} bar;++struct foo {+  int a;+  double b;+};++bar *get_bar(int n);+struct foo *get_foo(int n);
+ tests/bugs/issue-60/Issue60.chs view
@@ -0,0 +1,6 @@+module Main where++#include "stdlib.h"++main :: IO ()+main = putStrLn "OK"
+ tests/bugs/issue-60/_mingw.h view
@@ -0,0 +1,286 @@+#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  <khan@xraylith.wisc.edu>+ *+ *  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 */
+ tests/bugs/issue-60/issue60.c view
+ tests/bugs/issue-60/stdlib.h view
@@ -0,0 +1,555 @@+/*+ * 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 <stddef.h>+#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_ */+
+ tests/bugs/issue-7/Issue7.chs view
@@ -0,0 +1,9 @@+module Main where++#include "issue7.h"++tst :: String+tst = "命令行"++main :: IO ()+main  = {#call foo#}
+ tests/bugs/issue-7/issue7.h view
@@ -0,0 +1,1 @@+void foo ();
− tests/system/Calls.chs 
@@ -1,36 +0,0 @@--- -*-haskell-*---module Main-where--import Monad-import C2HS--{#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'#}
− tests/system/Cpp.chs 
@@ -1,36 +0,0 @@--- -*-haskell-*---module Cpp-where--import C2HS---- 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
− tests/system/Enums.chs 
@@ -1,40 +0,0 @@--- -*-haskell-*--import Monad-import C2HS--{#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-};-#endc-{#enum ThisThat {}#}---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
− tests/system/Marsh.chs 
@@ -1,21 +0,0 @@--- To build, do						          -*-haskell-*----   {-% gcc -c marsh.c-}---   % ../c2hs marsh.h Marsh.chs---   % ghc -fglasgow-exts '-#include<marsh.h>' -o marsh\---         -i../lib -L../lib Marsh.hs {-marsh.o-} -lc2hs--import C2HS--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"
− tests/system/Pointer.chs 
@@ -1,55 +0,0 @@--- -*-haskell-*--import Monad-import C2HS--{#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."
− tests/system/Simple.chs 
@@ -1,5 +0,0 @@-module Main-where--main :: IO ()-main  = {#call foo#}
− tests/system/Sizeof.chs 
@@ -1,54 +0,0 @@-module Main where--import Monad (liftM, when)-import Foreign.C--main = do-  size-  alignment--size = do-  let sz1 = {# sizeof S1 #}-  sz1expect <- liftM fromIntegral {# call size_of_s1 #}-  when (sz1 /= sz1expect) $ fail "Fatal: sizeof s1 != size_of_s1()"--  let sz2 = {# sizeof S2 #}-  sz2expect <- liftM fromIntegral {# call size_of_s2 #}-  when (sz2 /= sz2expect) $ fail "Fatal: sizeof s2 != 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 #}-  when (sz3 /= sz3expect) $ fail $ "Fatal: sizeof s3 != size_of_s3(): " ++ show sz3 ++ " but expected " ++ show sz3expect--  let sz4 = {# sizeof S4 #}-  sz4expect <- liftM fromIntegral {# call size_of_s4 #}-  when (sz4 /= sz4expect) $ fail $ "Fatal: sizeof s4 != size_of_s4(): " ++ show sz4 ++ " but expected " ++ show sz4expect--  putStrLn $ show sz1 ++ " & "-          ++ show sz2 ++ " & "-          ++ show sz3 ++ " & "-          ++ show sz4--alignment = do-  let al1 = {# alignof S1 #}-  al1expect <- liftM fromIntegral {# call align_of_s1 #}-  when (al1 /= al1expect) $ fail "Fatal: alignment s1 != align_of_s1()"--  let al2 = {# alignof S2 #}-  al2expect <- liftM fromIntegral {# call align_of_s2 #}-  when (al2 /= al2expect) $ fail "Fatal: alignment s2 != align_of_s2()"--  let al3 = {# alignof S3 #}-  al3expect <- liftM fromIntegral {# call align_of_s3 #}-  when (al3 /= al3expect) $ fail $ "Fatal: alignment s3 != align_of_s3(): " ++ show al3 ++ " but expected " ++ show al3expect--  let al4 = {# alignof S4 #}-  al4expect <- liftM fromIntegral {# call align_of_s4 #}-  when (al4 /= al4expect) $ fail $ "Fatal: alignment s4 != align_of_s4(): " ++ show al4 ++ " but expected " ++ show al4expect--  putStrLn $ show al1 ++ " & "-          ++ show al2 ++ " & "-          ++ show al3 ++ " & "-          ++ show al4
− tests/system/Structs.chs 
@@ -1,54 +0,0 @@--- To build, do                                                   -*-haskell-*----   % gcc -c structs.c---   % ../c2hs structs.h Structs.chs---   % ghc -fglasgow-exts '-#include<structs.h>' -o structs\---         -i../lib -L../lib Structs.hs structs.o -lc2hs--import Monad (liftM, when)-import C2HS--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 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 ()
− tests/system/calls.h 
@@ -1,17 +0,0 @@-#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 */
+ tests/system/calls/Calls.chs view
@@ -0,0 +1,43 @@+-- -*-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'#}
+ tests/system/calls/calls.h view
@@ -0,0 +1,17 @@+#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 */
− tests/system/cpp.h 
@@ -1,1 +0,0 @@-/* dummy file */
+ tests/system/cpp/Cpp.chs view
@@ -0,0 +1,36 @@+-- -*-haskell-*-++module Cpp where++import Foreign+import Foreign.C++-- 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
− tests/system/enums.c 
@@ -1,9 +0,0 @@-#include <stdlib.h>--#include "enums.h"--enum colour colourOfSide (side aside)-{-  /* not executed, but needed for linking */-  abort ();-}
− tests/system/enums.h 
@@ -1,49 +0,0 @@-#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--#endif /* !_ENUMS_H */
+ tests/system/enums/Enums.chs view
@@ -0,0 +1,53 @@+-- -*-haskell-*-+import Control.Monad+import Foreign+import Foreign.C++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
+ tests/system/enums/enums.c view
@@ -0,0 +1,9 @@+#include <stdlib.h>++#include "enums.h"++enum colour colourOfSide (side aside)+{+  /* not executed, but needed for linking */+  abort ();+}
+ tests/system/enums/enums.h view
@@ -0,0 +1,56 @@+#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 */
− tests/system/marsh.h 
@@ -1,6 +0,0 @@-#ifndef __MARSH_H__-#define __MARSH_H__--int x;--#endif /* __MARSH_H__ */
+ tests/system/marsh/Marsh.chs view
@@ -0,0 +1,22 @@+-- To build, do						          -*-haskell-*-+--   {-% gcc -c marsh.c-}+--   % ../c2hs marsh.h Marsh.chs+--   % ghc -fglasgow-exts '-#include<marsh.h>' -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"
+ tests/system/marsh/marsh.h view
@@ -0,0 +1,6 @@+#ifndef __MARSH_H__+#define __MARSH_H__++int x;++#endif /* __MARSH_H__ */
− tests/system/pointer.c 
@@ -1,32 +0,0 @@-#include <stdlib.h>-#include <stdio.h>--#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;-}
− tests/system/pointer.h 
@@ -1,31 +0,0 @@-#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 */
+ tests/system/pointer/Pointer.chs view
@@ -0,0 +1,59 @@+-- -*-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."
+ tests/system/pointer/pointer.c view
@@ -0,0 +1,32 @@+#include <stdlib.h>+#include <stdio.h>++#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;+}
+ tests/system/pointer/pointer.h view
@@ -0,0 +1,31 @@+#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 */
− tests/system/simple.c 
@@ -1,5 +0,0 @@-#include <stdio.h>--void foo () {-  printf ("I am the mighty foo!\n");-}
− tests/system/simple.h 
@@ -1,1 +0,0 @@-void foo ();
+ tests/system/simple/Simple.chs view
@@ -0,0 +1,5 @@+module Main+where++main :: IO ()+main  = {#call foo#}
+ tests/system/simple/simple.c view
@@ -0,0 +1,5 @@+#include <stdio.h>++void foo () {+  printf ("I am the mighty foo!\n");+}
+ tests/system/simple/simple.h view
@@ -0,0 +1,1 @@+void foo ();
− tests/system/sizeof.c 
@@ -1,26 +0,0 @@-#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);-}
− tests/system/sizeof.h 
@@ -1,46 +0,0 @@-#include <stdlib.h>-#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();--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;
+ tests/system/sizeof/Sizeof.chs view
@@ -0,0 +1,50 @@+module 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
+ tests/system/sizeof/sizeof.c view
@@ -0,0 +1,26 @@+#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);+}
+ tests/system/sizeof/sizeof.h view
@@ -0,0 +1,47 @@+#include <stdlib.h>+#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;
− tests/system/structs.c 
@@ -1,45 +0,0 @@-#include <stdlib.h>--#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;-}
− tests/system/structs.expect 
@@ -1,1 +0,0 @@-42 & -1 & 2 & 200 & ' '
− tests/system/structs.h 
@@ -1,70 +0,0 @@-#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__ */
+ tests/system/structs/Structs.chs view
@@ -0,0 +1,58 @@+-- To build, do                                                   -*-haskell-*-+--   % gcc -c structs.c+--   % ../c2hs structs.h Structs.chs+--   % ghc -fglasgow-exts '-#include<structs.h>' -o structs\+--         -i../lib -L../lib Structs.hs structs.o -lc2hs++import Control.Monad (liftM, when)+import Foreign+import Foreign.C++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 ()
+ tests/system/structs/structs.c view
@@ -0,0 +1,45 @@+#include <stdlib.h>++#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;+}
+ tests/system/structs/structs.h view
@@ -0,0 +1,70 @@+#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__ */
+ tests/test-bugs.hs view
@@ -0,0 +1,178 @@+{-# 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 Shelly+import Data.Text.Lazy (Text)+import Data.Monoid+import qualified Data.Text.Lazy as LT+default (LT.Text)++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests =+  [ testGroup "Bugs"+    [ testCase "call_capital (issue #??)" call_capital+    , testCase "Issue #60" issue60+    , testCase "Issue #51" issue51+    , testCase "Issue #47" issue47+    , testCase "Issue #31" issue31+    , testCase "Issue #30" issue30+    , testCase "Issue #23" issue23+    , testCase "Issue #22" issue22+    , testCase "Issue #54" issue54+    , testCase "Issue #45" issue45+    , testCase "Issue #44" issue44+    , testCase "Issue #43" issue43+    , testCase "Issue #32" issue32+    , testCase "Issue #38" issue38+    , testCase "Issue #29" issue29+    , testCase "Issue #19" issue19+    , testCase "Issue #16" issue16+--    , testCase "Issue #10" issue10+    , testCase "Issue #7" issue7+    ]+  ]++call_capital :: Assertion+call_capital = shelly $ 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 "" (LT.lines res == expected)++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 = expect_issue_with 51 ["--no-gnu"] ["0"]++issue47 :: Assertion+issue47 = build_issue 47++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"]++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 = shelly $ 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 =  "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 "" (LT.lines res == expected)++issue29 :: Assertion+issue29 = shelly $ do+  errExit False $ do+      cd "tests/bugs/issue-29"+      mapM_ rm_f ["Issue29.hs", "Issue29.chs.h", "Issue29.chi"]+      run "c2hs" $ ["--no-blocks", toTextIgnore "Issue29.chs"]+  code <- lastExitCode+  liftIO $ assertBool "" (code == 0)++issue23 :: Assertion+issue23 = expect_issue 23 ["H1"]++issue22 :: Assertion+issue22 = expect_issue 22 ["abcdef", "2", "20"]++issue19 :: Assertion+issue19 = expect_issue 19 ["Did it!"]++issue16 :: Assertion+issue16 = build_issue 16++issue10 :: Assertion+issue10 = expect_issue 10 ["SAME", "SAME", "SAME"]++issue7 :: Assertion+issue7 = shelly $ 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 :: Int -> [Text] -> Sh ()+do_issue_build n c2hsargs =+  let wdir = "tests/bugs" </> ("issue-" <> show n)+      lc = "issue" <> show n+      lcc = lc <> "_c"+      uc = fromText $ LT.pack $ "Issue" <> show n+  in do+    cd wdir+    mapM_ rm_f [uc <.> "hs", uc <.> "chs.h", uc <.> "chi", lcc <.> "o", uc]+    run "c2hs" $ c2hsargs ++ [toTextIgnore $ uc <.> "chs"]+    cmd "cc" "-c" "-o" (lcc <.> "o") (lc <.> "c")+    cmd "ghc" "-Wall" "-Werror" "--make" (lcc <.> "o") (uc <.> "hs")++expect_issue :: Int -> [Text] -> Assertion+expect_issue n expected = expect_issue_with n [] expected++expect_issue_with :: Int -> [Text] -> [Text] -> Assertion+expect_issue_with n c2hsargs expected = shelly $ do+  do_issue_build n c2hsargs+  res <- absPath ("." </> (fromText $ LT.pack $ "Issue" <> show n)) >>= cmd+  liftIO $ assertBool "" (LT.lines res == expected)++build_issue_with :: Int -> [Text] -> Assertion+build_issue_with n c2hsargs = shelly $ do+  errExit False $ do_issue_build n c2hsargs+  code <- lastExitCode+  liftIO $ assertBool "" (code == 0)++build_issue :: Int -> Assertion+build_issue n = build_issue_with n []
+ tests/test-system.hs view
@@ -0,0 +1,105 @@+{-# 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 Shelly+import qualified Shelly as Sh+import Control.Monad (forM_)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as LT+default (LT.Text)++main :: IO ()+main = defaultMain tests++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 = shelly $ 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 = shelly $ chdir dir $ do+  forM_ cmds $ \(c, as) -> run c as+  res <- absPath expcmd >>= cmd+  liftIO $ assertBool "" (LT.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 & ' '"]