diff --git a/C2HS.hs b/C2HS.hs --- a/C2HS.hs +++ b/C2HS.hs @@ -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, diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -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. diff --git a/ChangeLog.old b/ChangeLog.old new file mode 100644 --- /dev/null +++ b/ChangeLog.old @@ -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 + + * c2hs/gen/GenBind.hs: When translating the target type of a + pointer hook into a Haskell type, don't take the pointer hook + alias map into account. + + * c2hs.cabal: version 0.14.5 + + * c2hs/gen/GenBind.hs: Suppress code generation if requested + + * c2hs/chs/CHS.hs: Added `nocode' to pointer hooks + + * c2hs/chs/CHSLexer.hs: Added `nocode' + +2005-12-05 Jelmer Vernooij + + * c2hs/c/CTrav.hs: only match in `checkForOneCUName' if there are + no indirections + +2005-12-05 Jelmer Vernooij + + * c2hs/gen/GenBind.hs: support mapping struct and union names to haskell + types + + * c2hs/c/CTrav.hs: added `checkForOneCUName' + +Fri Nov 25 10:54:56 EST 2005 Jelmer Vernooij + + * add prettify functions for structs, enums and unions + +2005-08-10 Manuel M T Chakravarty + + * c2hs/gen/GBMonad.hs: apply `upcaseFirstLetter' and + `downcaseFirstLetter' if specified + + * c2hs/chs/CHS.hs: added `upcaseFirstLetter' and `downcaseFirstLetter' + +2005-08-09 Manuel M T Chakravarty + + * c2hs/gen/CInfo.hs: exports `getPlatform' + +2005-08-08 Manuel M T Chakravarty + + * c2hs/toplevel/Main.hs: Added --platform switch for cross compilation + + * c2hs.cabal: 0.14.3 + +2005-08-08 Manuel M T Chakravarty + + * c2hs.cabal: 0.14.2 + * Support asm construct (Duncon Coutts) + * Hierachical modules (Duncon Coutts) + +2005-07-13 Duncan Coutts + + * Remove old C lexer & parser and replace them with new ones using + alex and happy + +2005-07-14 Manuel M. T. Chakravarty + + * C2HS library as a single file added to the generated binding + code + +2005-07-13 Manuel M. T. Chakravarty + + * Cabal-ised the build system + * c2hs.cabal (Version): 0.14.0 + +2005-05-18 Manuel M. T. Chakravarty + + * toplevel/Version.hs (versnum): 0.13.6 + +2005-03-14 Manuel M. T. Chakravarty + + * c/CParser.hs: Allow lists of GNU C attributes (patch contributed + by Duncan Coutts ) + + * chs/CHSLexer.hs (instr): Allow 8-bit characters (Volker Wysk + requested support for umlauts in strings) + + * toplevel/Version.hs (versnum): 0.13.5 + +2004-10-18 Manuel M. T. Chakravarty + + * chs/CHS.hs (showCHSModule): Don't add extra '\n' after directive + during pretty printing + + * chs/CHSLexer.hs (cpp): forgot to adapt lexing of #c to the new + situation where directives don't consume the following '\n' + +2004-10-17 Manuel M. T. Chakravarty + + * c2hs.conf.in: Modernised package deps and options + + * gen/GenBind.hs (expandHook): We use the shadow identifier for + generating the Haskell name. + + * chs/CHSLexer.hs (identOrKW): Identifier may be put in single quotes + + * toplevel/Version.hs (versnum): 0.13.4 + +2004-10-13 Manuel M. T. Chakravarty + + * chs/CHSLexer.hs (cpp): fixed lexing of directives such that they + don't consume the '\n' that ends them + + * toplevel/Version.hs (versnum): 0.13.3 + + * toplevel/Main.hs (Flag): Added `--output-dir' option and removed + `--old-ffi'. + + * gen/GenBind.hs (noDftMarshErr): better error message when + default marshallers are not available + (isIntegralCPrimType): handle C chars as integral types for marshalling + + * toplevel/Main.hs (process): if there is no explicit output file + specified, the header file is put in the same directory as the + binding file; otherwise, it goes in the directory where the output + file is put + +2004-10-09 Manuel M. T. Chakravarty + + * toplevel/Main.hs (process): store header file name in switch board + + * state/Switches.hs: Store the name of the generated header file + (needed to generate complete foreign import declarations) + + * gen/GenBind.hs (foreignImport): Add name of header file to + extent strings of generated foreign import declarations + + * c/CAttrs.hs (applyPrefix): never create empty shadow identifiers + +2004-10-08 Manuel M. T. Chakravarty + + * chs/CHS.hs (dumpCHS): Header doesn't contain the "-- **" + sequence anymore that Haddock dislikes. + + * c/CParser.hs (parseCStructUnion): We allow structs and unions + with no declarations, as GNU C does + + * toplevel/Version.hs (versnum): 0.13.2 + +2004-08-21 Manuel M. T. Chakravarty + + * tests/Makefile: use configured $HC (courtesy Don Stewart + ) + +2004-06-11 Manuel M. T. Chakravarty + + * gen/GenBind.hs (pointerDef): Adapted to the standard interface + for foreign pointers + +2004-06-10 Manuel M. T. Chakravarty + + * c/CParser.hs: Added parsing of function bodies + + * c/CLexer.hs: Added tokens occuring in the statement syntax + +2004-06-09 Manuel M. T. Chakravarty + + * c/CAST.hs: Added function bodies + + * c/CPretty.hs: Added `auto' and `register' storage specifiers + + * c/CLexer.hs: Added tokens for `auto' and `register' keywords + + * toplevel/Version.hs (versnum): 0.13.1 + +2004-05-15 Manuel M. T. Chakravarty + + * c/CParser.hs (parseCHeader): Duncan Coutts + identified a space (and + time) leak in the old typedef-name morphing setup; this has been + rewritten now + +2004-05-14 Manuel M. T. Chakravarty + + * toplevel/Version.hs (versnum): 0.13.0 "Pressing Forward" + +2003-10-20 Manuel M T Chakravarty + + * gen/GenBind.hs (foreignImport): brought generated foreign import + declarations in line with FFI Addendum + + * toplevel/C2HSConfig.hs.in: removed legacy FFI support + + * configure.in: removed legacy FFI support + + * mk/config.mk.in: removed legacy FFI support + + * lib/Makefile: Removed all deprecated code and support code for + old versions of the FFI + + * toplevel/Version.hs (versnum): 0.12.1 + +2003-10-19 Manuel M T Chakravarty + + * c2hs.spec.in: Contributions by Jens Petersen + : specify ghc version to build with; + don't redundantly provide c2hs; separate library out into + separate ghc version specific subpackage; put docs into separate + subpackage; disable empty debuginfo subpackage generation - + remove buildroot before installing; remove installed doc files, + since they're explicitly listed + + * c/CLexer.hs (linedir): allow an arbitrary number of ints after + the filename in a #line directive; problem was first reported by Sean + Seefried + + * gen/GBMonad.hs (delayCode): Generate appropriate line numbers + for delayed code; problem reported by Sean Seefried + + + * chs/CHS.hs (showCHSModule): Never generate negative line numbers + + * toplevel/Version.hs (versnum): 0.12.0 "Springtime" + +2003-06-10 Manuel M T Chakravarty + + * toplevel/Version.hs (versnum): 0.11.5 + +2003-05-30 Jens Petersen + + * configure.in: Search for compiler named HC too. + +2003-05-30 Jens Petersen + + * c2hs.spec.in (Version): Set directly. + (Release): Ditto. + (%prep): Quieten setup. + (%build): Use configure macro. + (%install): Use makeinstall macro. + (%post): Use _bindir. + (%files): Make root own files. Use _bindir, _libdir and _mandir. + +2003-05-22 Manuel M T Chakravarty + + * gen/GenBind.hs (Ord): Need instance for `<=' for indirectly + defined `compare'; bug reported by Ian Lynagh + + * toplevel/Version.hs (versnum): 0.11.4 + +2003-04-16 Manuel M T Chakravarty + + * gen/GenHeader.hs (ghFrag): sentries for conditionals must not be + turned into internal identifiers, as this spoils later equality + tests with identifiers read from the pre-processed header file; + bug reported by Axel Simon + + * toplevel/Version.hs (versnum): 0.11.3 + +2003-03-04 Manuel M T Chakravarty + + * gen/GenBind.hs (evalConstCExpr): supporting enumerators in + constant expressions + + * toplevel/Version.hs (versnum): 0.11.2 + +2003-02-13 Manuel M T Chakravarty + + * chs/CHS.hs: removed the "header" tag (we now support the CPP + #include directive) + + * Configuration-related patch by Ian Lynagh that + removes issues with GHC 5.05 + +2003-02-12 Manuel M T Chakravarty + + * gen/GenBind.hs (expandFrag): Expanding conditionals + + * chs/CHSLexer.hs (haskell): the lexeme for one-line comments + shouldn't include the terminating newline, as this removes the + newline for following lexemes (eg, CPP directives) and is not + really necessary due to the Principle of the Longest Match + + * gen/GenHeader.hs: debugging + +2003-02-05 Manuel M T Chakravarty + + * gen/GenHeader.hs: New module extracting CPP directives and + inline-C from a .chs file + + * toplevel/Main.hs (process): Integrated generation of custom C header + + * c/CParser.hs (parseCHeader): Header file may be empty + +2003-02-01 Manuel M T Chakravarty + + * chs/CHS.hs (showCHSModule): emitting GHC line pragmas + (CHSFrag): added representations for cpp directives and inline-C + code, and adapted the functions processind the representations + + * chs/CHSLexer.hs: Added support for pre-processor directives and + inline-C code + +2003-01-31 Manuel M T Chakravarty + + * toplevel/Main.hs (process): Now reading the binding module + before the C header + +2003-01-30 Manuel M T Chakravarty + + * c/CParser.hs: Allow more GNU attributes contributed by Axel + Simon + +2002-09-17 Manuel M T Chakravarty + + * gen/GBMonad.hs (HsObject): working around a problem with + deriving Read in GHC 5.04.1 + +2002-09-16 Manuel M T Chakravarty + + * Makefile (ghci): target to load all of c2hs into GHCi + +2002-09-13 Manuel M T Chakravarty + + * toplevel/c2hs_config.c: removed the `signed' modifier on + suggestion of Seth Kurtzberg as it apparently + confuses the Solaris 8 C compiler + +2002-09-07 Manuel M T Chakravarty + + * c2hs.spec.in: add post install and uninstall scripts to register + and deregister the package with GHC + + * configure.in: fixed REQUIRES_HASKELL for ghc + + * toplevel/Version.hs (versnum): 0.10.17 + +2002-09-06 Manuel M T Chakravarty + + * toplevel/C2HSConfig.hs.in (cppopts): Added "-x c" on suggestion + by Axel Simon + + * Makefile (install): using --update-package instead of --add-package + + * configure.in: Fixed some nhc98 related issues + + * toplevel/Version.hs (versnum): 0.10.16 + +2002-07-12 Manuel M T Chakravarty + + * c2hs-config.in: added the system for which the package was + compiled to the output of the --version option + + * c/CParser.hs (parseCStructUnion): Allow __extension__ in + structure declarations and added `inline'. + + * c/CAST.hs: Added `inline' + + * c/CLexer.hs: Added support for `inline' keyword + +2002-07-06 Manuel M T Chakravarty + + * toplevel/Version.hs (versnum): 0.10.15 + +2002-05-16 Manuel M T Chakravarty + + * lib/C2HSMarsh.hs: added support for bit masks + + * toplevel/Version.hs (versnum): 0.10.14 + +2002-05-10 Manuel M T Chakravarty + + * gen/GenBind.hs (setGet): corrected bug in bit fiddling + +2002-05-02 Manuel M T Chakravarty + + * toplevel/Version.hs (versnum): 0.10.13 + +2002-04-16 Manuel M T Chakravarty + + * toplevel/Version.hs (versnum): 0.10.12 + +2002-03-20 Manuel M T Chakravarty + + * chs/CHSLexer.hs (haskell): Debug the handling of character literals + + * toplevel/Version.hs (versnum): 0.10.11 + +2002-03-12 Manuel M T Chakravarty + + * c2hs.spec.in: we now require the Haskell compiler to be the one + for which the package was build + + * Makefile: adapted to revised build system + + * toplevel/Version.hs (versnum): 0.10.10 + +2002-03-06 Manuel M T Chakravarty + + * chs/CHSLexer.hs (haskell): Escape characters in Haskell strings + haven't been handled correctly in all cases as reported by Volker + Wysk ; we also have to handle character + constants specially, because '"' is a legal Haskell character + constant + +2002-03-03 Manuel M T Chakravarty + + * configure.in: Package handling fix by Jens Petersen + + * toplevel/Version.hs (versnum): 0.10.9 + +2002-02-25 Manuel M T Chakravarty + + * gen/GenBind.hs: debugging + +2002-02-24 Manuel M T Chakravarty + + * chs/CHS.hs (parseOptAs): `^' as synonym for previous identifier, + but with underscores rewritten to caps + + * chs/CHSLexer.hs: added `CHSTokHat' + +2002-02-23 Manuel M T Chakravarty + + * lib/C2HSMarsh.hs: added some more convenience functions + +2002-02-21 Manuel M T Chakravarty + + * gen/GenBind.hs: Completed processing of function hooks + +2002-02-18 Manuel M T Chakravarty + + * chs/CHSLexer.hs: Added `CHSTokMinus' + + * chs/CHS.hs: Revised the syntax of fun hooks + + * chs/CHSLexer.hs: Added `CHSTokAmp' (representing `&') + + * gen/GenBind.hs (foreignImport): factorised the code for call + hook generation to make those portions that are also useful for + fun hooks reusable + (expandHook): implemented fun hooks + + * gen/GBMonad.hs: extracted monad-related code from `GenBind.hs' + + * gen/GenBind.hs: split off the monad definition and operations + into `GBMonad.hs' + +2002-02-17 Manuel M T Chakravarty + + * chs/CHSLexer.hs: introduced `hsverb' tokens + + * chs/CHS.hs: `pure' instead of `fun' to indicate calls to pure + C functions (`fun' retained for backwards compatibility) + + * chs/CHSLexer.hs: introduced the keyword `pure' + +2002-02-13 Manuel M T Chakravarty + + * Makefile: adapted to using GHC package management + +2002-02-11 Manuel M T Chakravarty + + * lib/Makefile (depend): increase portability + +2002-02-06 Manuel M T Chakravarty + + * configure.in: probe for `grep' + +2002-02-05 Manuel M T Chakravarty + + * aclocal.m4 (CTK_GHC_VERSION): no \+ in sed on Solaris + + * toplevel/Version.hs (versnum): 0.10.7 + +2002-01-15 Manuel M T Chakravarty + + * gen/GenBind.hs (mergeMaps): now, the read map overrides any + entires for shared keys in the map that is already in the monad; + this is so that, if multiple import hooks add entries for shared + keys, the textually latest prevails; any local entries are entered + after all import hooks anyway + + * toplevel/Version.hs (versnum): 0.10.6 + +2002-01-10 Jens Petersen + + * c/CParser.hs (parseC): corrected "contained contained" in + proceeding comments. + + * ../doc/c2hs/c2hs.sgml (Set Hooks): correct #get to #set + + * ../doc/c2hs/Makefile (TOP): "../../.." to "../.." + +2002-01-10 Manuel M T Chakravarty + + * toplevel/Version.hs (versnum): 0.10.5 + +2001-12-20 Manuel M T Chakravarty + + * gen/GenBind.hs (expandHook): fixed a sizeof bug pointed out by Jens + Petersen + + * toplevel/Version.hs (versnum): 0.10.4 + +2001-12-11 Manuel M. T. Chakravarty + + * toplevel/c2hs_config.c: now conforms to ISO C + + * toplevel/Version.hs (versnum): 0.10.3 + +2001-11-14 Manuel M. T. Chakravarty + + * gen/GenBind.hs (setGet): debugged + +2001-11-13 Manuel M. T. Chakravarty + + * gen/GenBind.hs (setGet): reading and writing of bitfields + (alignOffset): now handles alignment of bit fields + (extractCompType): debugging + +2001-11-12 Manuel M. T. Chakravarty + + * gen/GenBind.hs (specType): added bitfield handling + (BitSize): introduced size specs for partially filled storage units + + * toplevel/C2HSConfig.hs.in (bitfieldDirection): added + (bitfieldPadding): added + (bitfieldIntSigned): added + + * toplevel/c2hs_config.c: runtime configuration query functions + + * gen/CInfo.hs (CPrimType): extended by variants for bitfields + (size): now a function instead of an array + (alignment): now a function instead of an array + + * gen/GenBind.hs (showExtType): simplified `showExtType' again; + the brace level idea doen't work for `DefinedET' anyway; so, let's + simplify the code + +2001-11-08 Manuel M. T. Chakravarty + + * toplevel/Version.hs (versnum): 0.10.2 + +2001-10-17 Manuel M. T. Chakravarty + + * c/CParser.hs (parseCDecl): corrected the precise locatio where + an __attribute__ annotation may occur. + +2001-10-16 Manuel M. T. Chakravarty + + * gen/GenBind.hs (evalConstCExpr): added `alignof' + + * c/CNames.hs (naCExpr): added `alignof' + + * c/CAST.hs: added `alignof' + + * c/CParser.hs (parseCUnaryExpr): added `alignof' expressions + + * c/CLexer.hs: added keyword `alignof' + + * toplevel/Version.hs (versnum): 0.10.1 + +2001-10-08 Manuel M. T. Chakravarty + + * chs/CHS.hs: debugged + +2001-10-07 Manuel M. T. Chakravarty + + * gen/GenBind.hs: handling class hooks + + * Makefile: improved cleaning targets + + * chs/CHS.hs (parseClass): added class hooks + + * chs/CHSLexer.hs: added tokens `class' and `=>' + + * gen/GenBind.hs (isFunExtType): IO types are function types + + * toplevel/Version.hs (versnum): 0.10.0 "Altocumulus Stratiformis + Perlucidus Undulatus" + +2001-08-26 Manuel M. T. Chakravarty + + * gen/GenBind.hs (foreignImport): `libName' removed until the new + FFI conventions for libs are implemented in GHC + + * c/CTrav.hs (dropPtrDeclr): fixed pointer to pointer case + + * c/CPretty.hs: implemented pretty-printing for part of the C AST + +2001-08-25 Manuel M. T. Chakravarty + + * gen/GenBind.hs (setGet): missed ";" in code generation + + * c/CParser.hs (cidOrTN): after struct or union tag we may have a + normal idenifier or a type name; spotted by Simon Bowden + and Michael Zinn + +2001-08-23 Manuel M. T. Chakravarty + + * gen/GenBind.hs (expandHook): adding parenthesis around the + generated type; problem pointed out by Matthew Tarnawsky + + + * toplevel/Version.hs (versnum): 0.9.9 + +2001-06-20 Manuel M. T. Chakravarty + + * gen/GenBind.hs (expandHook): added sizeof hook + (sizeAlignOf): corrected size computation for structures to + conform to [K&R A7.4.8] + (sizeAlignOf): improved handling of `DefinedET', which led to an + endless loop + + * chs/CHS.hs: added sizeof hook + + * chs/CHSLexer.hs: added keyword `sizeof' + + * gen/GenBind.hs (evalConstCExpr): sizeof now supported + + * lib/C2HSDeprecated.hs: includes Storable methods of the new + Storable in addition to those of the old + + * toplevel/Version.hs (versnum): 0.9.8 + +2001-06-18 Manuel M. T. Chakravarty + + * c/CParser.hs (parseCExpr): `CComma' requires at least two + expressions; patch by Armin Sander + + * toplevel/Version.hs (versnum): 0.9.7 + +2001-06-16 Manuel M. T. Chakravarty + + * chs/CHS.hs: local prefix for enum hooks; courtesy of Armin + Sander + + * gen/GenBind.hs (expandHook): correctly uses a `FunPtr' for + pointers to functional types + (setGet): no deep check required as set/get do not perform a deep + copy; bug reported by Armin Sander + (expandHook): local prefix for enum hooks; courtesy of Armin + Sander + + * toplevel/Version.hs (versnum): 0.9.6 + +2001-05-20 Manuel M. T. Chakravarty + + * gen/GenBind.hs (enumInst): Fix for avoiding warnings when + generated bindings are compiled with -Wall contributed by Armin + Sander + +2001-05-14 Axel Simon + + * toplevel/Main.hs, state/Switchboard.hs, chs/CHS.hs: add + -i flag which takes a colon separated list of search paths for + .chi files. + + * fixed some bugs in parsing import hooks + +2001-05-13 Manuel M. T. Chakravarty + + * toplevel/Version.hs (versnum): 0.9.5 + + * gen/GenBind.hs (expandHook): revised to properly handle struct, + union, and enum tags as C identifiers in pointer hooks; also + handles non-abstract pointers with explicit "*" now better; the + problems were pointed out by Marcin Kowalczyk + + * c/CTrav.hs (findTypeObjMaybe): added + (lookupDeclOrTag): added + (enumName): added + (tagName): added + + * c/CLexer.hs (charconst): Patch from Armin Sander + regarding character constants + +2001-05-11 Manuel M. T. Chakravarty + + * c2hs-config.in: Patch from Jens-Ulrik Petersen + fixes $sys variable setting + + * toplevel/Version.hs (versnum): 0.9.4 + +2001-05-06 Manuel M. T. Chakravarty + + * gen/GenBind.hs (extractCompType): rewrote that thing again + + * c/CTrav.hs (checkForOneAliasName): added + +2001-05-05 Manuel M. T. Chakravarty + + * c/CTrav.hs (chaseDecl): simplified + + * gen/GenBind.hs (expandHook): debugged the pointer hook + + * c/CTrav.hs (findAndChaseDecl): correction + + * toplevel/Version.hs (versnum): 0.9.3 + +2001-05-03 Manuel M. T. Chakravarty + + * gen/GenBind.hs (expandHook): added import hook + (mergePtrMap): added + (dumpPtrMap): added + + * chs/CHS.hs (loadCHI): added + (dumpCHI): added + (CHSHook): added `import' hook + + * chs/CHSLexer.hs: Added the keywords `import' and `qualified' + + * toplevel/Version.hs (versnum): 0.9.2 + +2001-05-02 Manuel M. T. Chakravarty + + * gen/GenBind.hs (extractCompType): as pointed out by Axel Simon, + we can't return `ForeignPtr's from imported foreign functions + (setGet): the `accessType' story is largely redundant with the new + formulation of `extractCompType', but we still need to check the + marshaled type + (setGet): `DefinedET' now takes a declaration rather than an + identifier as its first argument; this is necessary for anonymous + declerators + (extractCompType): functions are now extracted correctly + + * c/CTrav.hs (isPtrDecl): works on identifiers now and chases + declarations + (dropPtrDeclr): added + + * gen/GenBind.hs (extractCompType): completely rewrote this + function to properly handle pointer and function types and honour + aliases introduced by pointer hooks + +2001-05-01 Manuel M. T. Chakravarty + + * c/CTrav.hs (isPtrDeclr): functions types without an explizit + pointer constructor are no longer regarded as pointers + + * gen/CInfo.hs: renamed `CAddrPT' and `CFunAddrPT' to `CPtrPT' and + `CFunPtrPT', respectively + + * gen/GenBind.hs (extractCompType): revised for pointer hooks + +2001-04-30 Manuel M. T. Chakravarty + + * gen/GenBind.hs (setGet): uses FunPtr for functions + (extractPtrType): added + +2001-04-28 Manuel M. T. Chakravarty + + * gen/GenBind.hs (expandHook): rewrote `alias'hook into `pointer' hook + + * chs/CHS.hs: rewrote the `alias' hook into the `pointer' hook + + * chs/CHSLexer.hs: removed `alias' token and added `pointer' and + `newtype' + + * toplevel/Version.hs (versnum): 0.9.1 + + * gen/GenBind.hs: clean up + +2001-04-21 Manuel M. T. Chakravarty + + * chs/CHSLexer.hs: Added `(' and `)' + + * chs/CHS.hs: Added code implementing the `alias' hook and the + `deriving' option for the `enum' hook. This code was contributed + by Axel Simon (also related code in CHSLexer.hs); + but added parenthesis to `deriving' + + * c/CTrav.hs: Added code implementing the `alias' hook, which + was contributed by Axel Simon + + * gen/GenBind.hs: The following patch was contributed by Axel + Simon : `extractCompType' generates addresses + of type `Ptr ' instead of `Addr' (if `--old-ffi=no', which + is the default) + + * configure.in: Adapted for ghc 5.00 + + * toplevel/Version.hs (versnum): 0.9.0 "Blue Ginger" + +2001-02-22 Manuel M. T. Chakravarty + + * lib/C2HSDeprecated.hs: Corrected String marshalling for 4.11; + suggested by Marcin 'Qrczak' Kowalczyk + +2001-02-19 Manuel M. T. Chakravarty + + * c2hs-config.in: generated code needs -package lang for + compilation and linking + + * toplevel/Version.hs (versnum): 0.8.3 "Gentle Moon" + +2001-02-13 Manuel M. T. Chakravarty + + * lib/NewStablePtr.hs.in: Adaptation layer for StablePtr for the + legacy FFI interface + +2001-02-12 Manuel M. T. Chakravarty + + * lib/C2HS.hs: Forgot to export `FunPtr' and associated functions + + * lib/C2HSDeprecated.hs: Some exports had been missing + + * c/CTrav.hs: Handle `CAttrs.BuiltinCO' + + * c/CNames.hs (nameAnalysis): add builtin type definitions + + * c/CBuiltin.hs: predefine `__builtin_va_list' as a + typedef'd name + + * c/CParser.hs (parseCHeader): use `CBuiltin' + + * toplevel/Version.hs (versnum): 0.8.2 + +2001-02-11 Manuel M. T. Chakravarty + + * releasing version 0.8.1 "Gentle Moon" + * ../doc/c2hs/: Documentation updated & added the Haskell FFI + Marshalling Library specification + +2001-02-09 Manuel M. T. Chakravarty + + * lib/Makefile: Debugging for 4.11 + +2001-02-05 Manuel M. T. Chakravarty + + * toplevel/C2HSConfig.hs.in: Moved the primitive characteristics + table to `CInfo' (it is based now on getting the information from + the FFI of the Haskell compiler compiling c2hs) + + * gen/CInfo.hs: Added + +2001-02-04 Manuel M. T. Chakravarty + + * lib/C2HSMarsh.hs: Moved almost everything to `C2HSDeprecated' + + * lib/C2HSBase.hs: Much simplified conversion routines and the old + `Storable' definition died + +2001-02-03 Manuel M. T. Chakravarty + + * configure.in: Removed all the stuff that had to be there for the + late `lib/C2HSConfig.hs.in' + + * lib/C2HSConfig.hs.in: RIP - All the relevant information is now + available from the Standard FFI + + * C2HSDeprecated.hs: Added old C type names + + * lib/C2HS.hs: Added support for the New FFI Libraries (so that + they are also useable with Haskell systems only supporting the old + libraries) + +2000-08-22 Manuel M. T. Chakravarty + + * lib/C2HSDeprecated.hs: contains a compatibility interface to the + "Afterthought" series + +2000-08-18 Manuel M. T. Chakravarty + + * toplevel/Version.hs (versnum): 0.8.0 "Gentle Moon" + + ** WARNING: Only the FFI of GHC 4.08 upwards is supported ** + + ** WARNING: Code breaking changes to the marshalling library ** + ** Compatibility library provided ** + +2000-08-12 Manuel M. T. Chakravarty + + * lib/C2HSBase.hs (IntConv): instances for Int8, Word8, and Char + + * toplevel/Version.hs (versnum): 0.7.10 + +2000-08-06 Manuel M. T. Chakravarty + + * chs/CHS.hs (showCHSTrans): corrected syntax + (parseTrans): comma now correctly required after underscoreToCase + + * gen/GenBind.hs (transTabToTransFun): properly handles prefixes + in the translation function + (enumDef): prefixes are now generally removed from enumerators + without the constraint that the prefix has to be removed from all + enumerators or none + +2000-08-04 Manuel M. T. Chakravarty + + * gen/GenBind.hs (usualArithConv): forgot a case; patch + contributed by Axel Simon + + * toplevel/Version.hs (versnum): 0.7.9 + +2000-07-06 Manuel M. T. Chakravarty + + * gen/GenBind.hs (specType.matches): forgot a case; bug spotted by + Axel Simon + + * lib/C2HSBase.hs (plusAddr): ugly kludge for GHC 4.08 (doesn't + work with any older version for the moment) + + * toplevel/Version.hs (versnum): 0.7.8 + +2000-04-15 Manuel M. T. Chakravarty + + * c/CLexer.hs (pragma): ignores `#pragma's + + * toplevel/Version.hs (versnum): 0.7.7 + +2000-04-09 Manuel M. T. Chakravarty + + * mk/config.mk.in: added + + * gen/GenBind.hs: added `long long's + (specType): added error message for unsupported types + + * lib/C2HSConfig.hs.in: added `long long's + + * toplevel/C2HSConfig.hs.in: added `long long's + + * toplevel/Version.hs (versnum): 0.7.6 + +2000-04-08 Manuel M. T. Chakravarty + + * configure.in: corrected sed expression for Solaris + +2000-03-02 Manuel M. T. Chakravarty + + * tests/Makefile: added & revised all the tests + + * configure.in: debugging + +2000-03-01 Manuel M. T. Chakravarty + + * lib/C2HSMarsh.hs (addrWithMarkerToList): debugged + +2000-02-28 Manuel M. T. Chakravarty + + * gen/GenBind.hs (expandHook): adapted to new `CHSContext' def + + * c/CParser.hs: Using `Utils.Tag' class to make `CToken' an instance of + `Token' + + * c/CLexer.hs: Making `CToken' an instance of `Utils.Tag' instead + of `Eq' + +2000-02-25 Manuel M. T. Chakravarty + + * chs/CHS.hs: added `header' tag in context hook + + * chs/CHSLexer.hs: added keyword `header' + + * c/CLexer.hs, c/CParser.hs, c/CAST.hs: added C99 type qualifier + `restrict'; thanks to "Marcin 'Qrczak' Kowalczyk" + for pointing this out + +2000-02-24 Manuel M. T. Chakravarty + + * gen/GenBind.hs (foreignImport): system-dependent library suffix + + * configure.in,toplevel/C2HSConfig.hs.in: DLSUFFIX + +2000-02-23 Manuel M. T. Chakravarty + + * toplevel/Version.hs (versnum): 0.7.5 + +1999-12-04 Manuel M. T. Chakravarty + + * lib/C2HSBase.hs (BoolConv): added + +1999-11-24 Manuel M. T. Chakravarty + + * ../doc/c2hs/Makefile: corrections by Michael Weber + + +1999-11-17 Manuel M. T. Chakravarty + + * Man pages and debianisation, courtesy of Michael Weber + + + * c/CNames.hs: no new range for tag definitions is started when + entering a struct declaration list or a parameter list; thanks to + Volker Wysk for the bug report + + * c/CAttrs.hs (enterNewObjRangeC): added + (leaveObjRangeC): added + +1999-11-16 Manuel M. T. Chakravarty + + * c/CTrav.hs (extractAlias): now correctly handles anonymous + declarations; introduced new function `declaredDeclr'; thanks to + Michael Weber for the bug report + + * toplevel/Version.hs (versnum): 0.7.4 + +1999-11-07 Manuel M. T. Chakravarty + + * lib/C2HSBase.hs: adapted to new `assign' and `deref' routines + + * gen/GenBind.hs: debugged + + * c/CTrav.hs (extractStruct): takes care that forward declerations + of structs are followed to the full definition + + * lib/C2HSMarsh.hs: added `nothingIf', `nothingIfNull'; + generalised string handling to `listToAddrWithLen' and + `addrWithLenToList' + +1999-11-06 Manuel M. T. Chakravarty + + * toplevel/Main.hs: Header file search in standard directories and + directories passed in `-IDIR' options to cpp. + + * c2hs-config.in: Added `--c2hs' option to `c2hs-config' + + * lib/C2HSMarsh.hs: Michael's `Int'/`Word' patch + +1999-11-03 Manuel M. T. Chakravarty + + * lib/C2HSMarsh.hs: more instances for `ToAddr' & `FromAddr' + + * toplevel/Version.hs (versnum): 0.7.3 + +1999-10-30 Manuel M. T. Chakravarty + + * Makefile: adapted to modularised CTK and added installation support + + * c2hs-config.in: added + + * toplevel/Version.hs (versnum): 0.7.2 + +1999-10-28 Manuel M. T. Chakravarty + + * c/CNames.hs: multiple declarations for the same object are + now allowed (thanx Michael) + + * lib/C2HSMarsh.hs: added some suggestions from Michael Weber + + * c/CLexer.hs: #line directives + +1999-10-26 Manuel M. T. Chakravarty + + * configure.in: no sizeof or align tests for char + +1999-10-25 Manuel M. T. Chakravarty + + * gen/GenBind.hs: some clean up and improved error message with + more position information + + * chs/CHS.hs: Positions are maintained for improved error messages. + + * toplevel/Main.hs: removes intermediate file (but it can be + retained on explicit request) + + * toplevel/Version.hs (versnum): 0.7.1 + +1999-10-24 Manuel M. T. Chakravarty + + * examples/libghttpHS/Ghttp.chs: adapted to new syntax & features + + * configure.in: Solaris patch from Michael Weber + + + * gen/GenBind.hs: new hook syntax + + * chs/CHS.hs (and friends): grok new hook syntax + +1999-10-23 Manuel M. T. Chakravarty + + * toplevel/Version.hs (versnum): 0.7.0 (align hook syntax with paper) + + * c/CTrav.hs: routines from `CNames' and `GenBind' generalised and + exported from `CTrav' + (defTag): handles enum tags now correctly + +1999-10-22 Manuel M. T. Chakravarty + + * c/CNames.hs: sets up the object associations for usage positions + +1999-10-21 Manuel M. T. Chakravarty + + * c/CTrav.hs (defTag): handles refined struct definitions + + * toplevel/Main.hs: Command line option patch from Michael Weber + + + * c/CNames.hs: computes the object reference attributes now + + * c/CTrav.hs (isTypedef): added + + * toplevel/Version.hs (versnum): 0.6.2 + +1999-10-20 Manuel M. T. Chakravarty + + * examples/libghttpHS/Ghttp.chs: uses `C2HS's exception handling + + * lib/C2HSMarsh.hs: debugging + + * toplevel/Version.hs (versnum): 0.6.1 + +1999-10-18 Manuel M. T. Chakravarty + + * c/CLexer.hs: computes attributes for identifiers + +1999-10-17 Manuel M. T. Chakravarty + + * c/CNames.hs: moved gathering of definitions from `C', starting a + more standard name analysis pass + + * c/CTrav.hs: basic traversal support for name space and + definition attribute operations + + * c/CAttrs.hs: C definition attribute data type and operations + + * toplevel/Version.hs: 0.6.0 + +1999-10-16 Manuel M. T. Chakravarty + + * lib/C2HSMarsh.hs: Marshaling idioms & exception handling + +1999-10-13 Manuel M. T. Chakravarty + + * examples/libghttpHS/Ghttp.chs: compiles + + * toplevel/Main.hs (execute): debugged + + * lib/C2HS.hs: Advanced marshaling support + + +Pre-GNU style change log +------------------------ + +0.5.1 +~~~~~ +12Oct99 lib/C2HSMarsh -> lib/C2HSBase; lib/C2HSMarsh new + +0.5.0 +~~~~~ +08Oct99 Debugging +06Oct99 (# ... #) to {# ... #}; extended `C2HSMarsh'; `Ghttp' example + +0.4.1 +~~~~~ +01Oct99 Improved autoconf support for computing the information necessary for + determining struct offsets & corresponding changes in `GenBind' + plus full struct and union support + +0.4.0 +~~~~~ +29Sep99 Debugging +28Sep99 Improving marshaling lib +27Sep99 Autoconf support +26Sep99 More lexer debugging, typedef chasing & field hooks with indirections; + preprocessing of the C header implemented +21Sep99 Debugged CHS lexer (Haskell comments etc) + +0.3.0 +~~~~~ +06Sep99 Enums correctly lead to `CInt's in foreign import declarations +01Sep99 Added dot syntax for field hooks + +0.2.2 +~~~~~ +01Sep99 Added support for explicit tag values in enumerations +31Aug99 added tag objects to `CAttrs.hs' and `C.hs'; enumeration hooks are + partial functional + +0.2.1 +~~~~~ +30Aug99 context and call hooks are functional + +0.2.0 +~~~~~ +29Aug99 full path completed +19Aug99 started `lib' part +17Aug99 started `gen' part +17Aug99 finished the CHS parser and printing routines in `CHS.hs' +16Aug99 finished first version of CHS lexer; added `CHS.hs' +15Aug99 started `chs' part + +0.1.1 +~~~~~ +12Aug99 Various fixes to the C lexer and parser; added toplevel/Main.hs and + c/C.hs + +0.1.0 +~~~~~ +03Apr99 Finished first complete version of C lexer and parser +27Feb99 starting project diff --git a/c2hs.cabal b/c2hs.cabal --- a/c2hs.cabal +++ b/c2hs.cabal @@ -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 diff --git a/src/C2HS/C/Attrs.hs b/src/C2HS/C/Attrs.hs --- a/src/C2HS/C/Attrs.hs +++ b/src/C2HS/C/Attrs.hs @@ -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 diff --git a/src/C2HS/C/Trav.hs b/src/C2HS/C/Trav.hs --- a/src/C2HS/C/Trav.hs +++ b/src/C2HS/C/Trav.hs @@ -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!"] diff --git a/src/C2HS/CHS.hs b/src/C2HS/CHS.hs --- a/src/C2HS/CHS.hs +++ b/src/C2HS/CHS.hs @@ -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 diff --git a/src/C2HS/CHS/Lexer.hs b/src/C2HS/CHS/Lexer.hs --- a/src/C2HS/CHS/Lexer.hs +++ b/src/C2HS/CHS/Lexer.hs @@ -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' diff --git a/src/C2HS/Gen/Bind.hs b/src/C2HS/Gen/Bind.hs --- a/src/C2HS/Gen/Bind.hs +++ b/src/C2HS/Gen/Bind.hs @@ -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!"] diff --git a/src/C2HS/Gen/Header.hs b/src/C2HS/Gen/Header.hs --- a/src/C2HS/Gen/Header.hs +++ b/src/C2HS/Gen/Header.hs @@ -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) -- diff --git a/src/C2HS/Gen/Monad.hs b/src/C2HS/Gen/Monad.hs --- a/src/C2HS/Gen/Monad.hs +++ b/src/C2HS/Gen/Monad.hs @@ -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 diff --git a/src/C2HS/Switches.hs b/src/C2HS/Switches.hs --- a/src/C2HS/Switches.hs +++ b/src/C2HS/Switches.hs @@ -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, diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/tests/bugs/call_capital/Capital.c b/tests/bugs/call_capital/Capital.c new file mode 100644 --- /dev/null +++ b/tests/bugs/call_capital/Capital.c @@ -0,0 +1,4 @@ +#include "Capital.h" +#include +void c() { printf("lower c();\n"); } +void C() { printf("upper C();\n"); } diff --git a/tests/bugs/call_capital/Capital.chs b/tests/bugs/call_capital/Capital.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/call_capital/Capital.chs @@ -0,0 +1,7 @@ +module Main where + +#include "Capital.h" +main = do + {# call C as ^ #} + {# call c as c' #} + {# call C as c'' #} diff --git a/tests/bugs/call_capital/Capital.h b/tests/bugs/call_capital/Capital.h new file mode 100644 --- /dev/null +++ b/tests/bugs/call_capital/Capital.h @@ -0,0 +1,2 @@ +void c(); +void C(); diff --git a/tests/bugs/issue-10/Issue10.chs b/tests/bugs/issue-10/Issue10.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-10/Issue10.chs @@ -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" diff --git a/tests/bugs/issue-10/issue10.c b/tests/bugs/issue-10/issue10.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-10/issue10.c @@ -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); } diff --git a/tests/bugs/issue-10/issue10.h b/tests/bugs/issue-10/issue10.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-10/issue10.h @@ -0,0 +1,31 @@ +#include + +size_t size_of_s1(void); +size_t size_of_s2(void); +size_t size_of_s3(void); +size_t size_of_s4(void); + +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; diff --git a/tests/bugs/issue-16/Issue16.chs b/tests/bugs/issue-16/Issue16.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-16/Issue16.chs @@ -0,0 +1,5 @@ +#include "issue16.h" + +main :: IO () +main = return () + diff --git a/tests/bugs/issue-16/issue16.c b/tests/bugs/issue-16/issue16.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-16/issue16.c diff --git a/tests/bugs/issue-16/issue16.h b/tests/bugs/issue-16/issue16.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-16/issue16.h diff --git a/tests/bugs/issue-19/Issue19.chs b/tests/bugs/issue-19/Issue19.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-19/Issue19.chs @@ -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!" diff --git a/tests/bugs/issue-19/issue19.c b/tests/bugs/issue-19/issue19.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-19/issue19.c @@ -0,0 +1,1 @@ +#include "issue19.h" diff --git a/tests/bugs/issue-19/issue19.h b/tests/bugs/issue-19/issue19.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-19/issue19.h @@ -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 +}; diff --git a/tests/bugs/issue-22/Issue22.chs b/tests/bugs/issue-22/Issue22.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-22/Issue22.chs @@ -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 diff --git a/tests/bugs/issue-22/issue22.c b/tests/bugs/issue-22/issue22.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-22/issue22.c @@ -0,0 +1,14 @@ +#include +#include "issue22.h" + +struct_t s; +substruct_t subs; + +struct_t *foo(int n) +{ + strcpy(s.somefield, "abcdef"); + s.substruct.field = n; + s.substruct_p = &subs; + subs.field = n * 10; + return &s; +} diff --git a/tests/bugs/issue-22/issue22.h b/tests/bugs/issue-22/issue22.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-22/issue22.h @@ -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); diff --git a/tests/bugs/issue-23/Issue23.chs b/tests/bugs/issue-23/Issue23.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-23/Issue23.chs @@ -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 diff --git a/tests/bugs/issue-23/issue23.c b/tests/bugs/issue-23/issue23.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-23/issue23.c @@ -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; + } +} diff --git a/tests/bugs/issue-23/issue23.h b/tests/bugs/issue-23/issue23.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-23/issue23.h @@ -0,0 +1,1 @@ +extern enum hello hello_fn(int); diff --git a/tests/bugs/issue-23/issue23x.h b/tests/bugs/issue-23/issue23x.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-23/issue23x.h @@ -0,0 +1,1 @@ +enum hello { H1, H2, H3 }; diff --git a/tests/bugs/issue-29/Issue29.chs b/tests/bugs/issue-29/Issue29.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-29/Issue29.chs @@ -0,0 +1,6 @@ +module Main where + +#include "issue29.h" + +main :: IO () +main = return () diff --git a/tests/bugs/issue-29/issue29.h b/tests/bugs/issue-29/issue29.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-29/issue29.h @@ -0,0 +1,10 @@ +#ifndef _STDLIB_H_ +#define _STDLIB_H_ + +int atexit(void (*)(void)); + +#ifdef __BLOCKS__ +int atexit_b(void (^)(void)); +#endif + +#endif diff --git a/tests/bugs/issue-30/Issue30.chs b/tests/bugs/issue-30/Issue30.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-30/Issue30.chs @@ -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 diff --git a/tests/bugs/issue-30/Issue30Aux1.chs b/tests/bugs/issue-30/Issue30Aux1.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-30/Issue30Aux1.chs @@ -0,0 +1,8 @@ +module Issue30Aux1 where + +import Foreign +import Foreign.C + +#include "issue30aux1.h" + +{#fun foo1 {`Int'} -> `Int'#} diff --git a/tests/bugs/issue-30/Issue30Aux2.chs b/tests/bugs/issue-30/Issue30Aux2.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-30/Issue30Aux2.chs @@ -0,0 +1,8 @@ +module Issue30Aux2 where + +import Foreign +import Foreign.C + +#include "issue30aux2.h" + +{#fun foo2 {`Int'} -> `Int'#} diff --git a/tests/bugs/issue-30/issue30.c b/tests/bugs/issue-30/issue30.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-30/issue30.c @@ -0,0 +1,1 @@ +int foo(int n) { return n + 1; } diff --git a/tests/bugs/issue-30/issue30.h b/tests/bugs/issue-30/issue30.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-30/issue30.h @@ -0,0 +1,1 @@ +int foo(int); diff --git a/tests/bugs/issue-30/issue30aux1.c b/tests/bugs/issue-30/issue30aux1.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-30/issue30aux1.c @@ -0,0 +1,1 @@ +int foo1(int n) { return n * 2; } diff --git a/tests/bugs/issue-30/issue30aux1.h b/tests/bugs/issue-30/issue30aux1.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-30/issue30aux1.h @@ -0,0 +1,1 @@ +int foo1(int); diff --git a/tests/bugs/issue-30/issue30aux2.c b/tests/bugs/issue-30/issue30aux2.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-30/issue30aux2.c @@ -0,0 +1,1 @@ +int foo2(int n) { return n * 4; } diff --git a/tests/bugs/issue-30/issue30aux2.h b/tests/bugs/issue-30/issue30aux2.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-30/issue30aux2.h @@ -0,0 +1,1 @@ +int foo2(int); diff --git a/tests/bugs/issue-31/Issue31.chs b/tests/bugs/issue-31/Issue31.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-31/Issue31.chs @@ -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 () diff --git a/tests/bugs/issue-31/issue31.c b/tests/bugs/issue-31/issue31.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-31/issue31.c @@ -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; } diff --git a/tests/bugs/issue-31/issue31.h b/tests/bugs/issue-31/issue31.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-31/issue31.h @@ -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 *); diff --git a/tests/bugs/issue-32/Issue32.chs b/tests/bugs/issue-32/Issue32.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-32/Issue32.chs @@ -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) diff --git a/tests/bugs/issue-32/issue32.c b/tests/bugs/issue-32/issue32.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-32/issue32.c @@ -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; +} diff --git a/tests/bugs/issue-32/issue32.h b/tests/bugs/issue-32/issue32.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-32/issue32.h @@ -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); diff --git a/tests/bugs/issue-37/Issue37.chs b/tests/bugs/issue-37/Issue37.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-37/Issue37.chs @@ -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" diff --git a/tests/bugs/issue-37/issue37.c b/tests/bugs/issue-37/issue37.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-37/issue37.c @@ -0,0 +1,12 @@ +#include "issue37.h" + +int f1(int *np) +{ + return *np * 2; +} + + +float f2(float *np) +{ + return *np * 3; +} diff --git a/tests/bugs/issue-37/issue37.h b/tests/bugs/issue-37/issue37.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-37/issue37.h @@ -0,0 +1,2 @@ +int f1(int *np); +float f2(float *np); diff --git a/tests/bugs/issue-38/Issue38.chs b/tests/bugs/issue-38/Issue38.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-38/Issue38.chs @@ -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" diff --git a/tests/bugs/issue-38/issue38.c b/tests/bugs/issue-38/issue38.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-38/issue38.c @@ -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; + } +} diff --git a/tests/bugs/issue-38/issue38.h b/tests/bugs/issue-38/issue38.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-38/issue38.h @@ -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); + diff --git a/tests/bugs/issue-43/Issue43.chs b/tests/bugs/issue-43/Issue43.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-43/Issue43.chs @@ -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) diff --git a/tests/bugs/issue-43/issue43.c b/tests/bugs/issue-43/issue43.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-43/issue43.c diff --git a/tests/bugs/issue-43/issue43.h b/tests/bugs/issue-43/issue43.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-43/issue43.h @@ -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 +}; + diff --git a/tests/bugs/issue-44/Issue44.chs b/tests/bugs/issue-44/Issue44.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-44/Issue44.chs @@ -0,0 +1,10 @@ +module Main where + +import Foreign + +#include "issue44.h" + +{#pointer *foo as ^ foreign newtype#} + +main :: IO () +main = putStrLn "dummy" diff --git a/tests/bugs/issue-44/issue44.c b/tests/bugs/issue-44/issue44.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-44/issue44.c diff --git a/tests/bugs/issue-44/issue44.h b/tests/bugs/issue-44/issue44.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-44/issue44.h @@ -0,0 +1,1 @@ +typedef struct { int a; } foo; diff --git a/tests/bugs/issue-45/Issue45.chs b/tests/bugs/issue-45/Issue45.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-45/Issue45.chs @@ -0,0 +1,9 @@ +module Main where + +import Foreign.C + +#include "issue45.h" + +main :: IO () +main = foo 2 + where {#fun foo {`Int'} -> `()'#} diff --git a/tests/bugs/issue-45/issue45.c b/tests/bugs/issue-45/issue45.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-45/issue45.c @@ -0,0 +1,1 @@ +void foo(int n) { } diff --git a/tests/bugs/issue-45/issue45.h b/tests/bugs/issue-45/issue45.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-45/issue45.h @@ -0,0 +1,1 @@ +void foo(int); diff --git a/tests/bugs/issue-47/Issue47.chs b/tests/bugs/issue-47/Issue47.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-47/Issue47.chs @@ -0,0 +1,10 @@ +module Main where + +import Foreign.C + +#include "issue47.h" + +{#fun foo {`Int'} -> `()'#} + +main :: IO () +main = foo 2 diff --git a/tests/bugs/issue-47/issue47.c b/tests/bugs/issue-47/issue47.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-47/issue47.c @@ -0,0 +1,1 @@ +void foo(int n) { } diff --git a/tests/bugs/issue-47/issue47.h b/tests/bugs/issue-47/issue47.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-47/issue47.h @@ -0,0 +1,1 @@ +void foo(int); diff --git a/tests/bugs/issue-51/Issue51.chs b/tests/bugs/issue-51/Issue51.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-51/Issue51.chs @@ -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 diff --git a/tests/bugs/issue-51/issue51.c b/tests/bugs/issue-51/issue51.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-51/issue51.c @@ -0,0 +1,2 @@ +int fooGnu(int n) { return 1; } +int fooNonGnu(int n) { return 0; } diff --git a/tests/bugs/issue-51/issue51.h b/tests/bugs/issue-51/issue51.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-51/issue51.h @@ -0,0 +1,2 @@ +int fooGnu(int); +int fooNonGnu(int); diff --git a/tests/bugs/issue-54/Issue54.chs b/tests/bugs/issue-54/Issue54.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-54/Issue54.chs @@ -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 diff --git a/tests/bugs/issue-54/issue54.c b/tests/bugs/issue-54/issue54.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-54/issue54.c @@ -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; +} diff --git a/tests/bugs/issue-54/issue54.h b/tests/bugs/issue-54/issue54.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-54/issue54.h @@ -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); diff --git a/tests/bugs/issue-60/Issue60.chs b/tests/bugs/issue-60/Issue60.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-60/Issue60.chs @@ -0,0 +1,6 @@ +module Main where + +#include "stdlib.h" + +main :: IO () +main = putStrLn "OK" diff --git a/tests/bugs/issue-60/_mingw.h b/tests/bugs/issue-60/_mingw.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-60/_mingw.h @@ -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 + * + * 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 */ diff --git a/tests/bugs/issue-60/issue60.c b/tests/bugs/issue-60/issue60.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-60/issue60.c diff --git a/tests/bugs/issue-60/stdlib.h b/tests/bugs/issue-60/stdlib.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-60/stdlib.h @@ -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 +#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_ */ + diff --git a/tests/bugs/issue-7/Issue7.chs b/tests/bugs/issue-7/Issue7.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-7/Issue7.chs @@ -0,0 +1,9 @@ +module Main where + +#include "issue7.h" + +tst :: String +tst = "命令行" + +main :: IO () +main = {#call foo#} diff --git a/tests/bugs/issue-7/issue7.h b/tests/bugs/issue-7/issue7.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-7/issue7.h @@ -0,0 +1,1 @@ +void foo (); diff --git a/tests/system/Calls.chs b/tests/system/Calls.chs deleted file mode 100644 --- a/tests/system/Calls.chs +++ /dev/null @@ -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'#} diff --git a/tests/system/Cpp.chs b/tests/system/Cpp.chs deleted file mode 100644 --- a/tests/system/Cpp.chs +++ /dev/null @@ -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 diff --git a/tests/system/Enums.chs b/tests/system/Enums.chs deleted file mode 100644 --- a/tests/system/Enums.chs +++ /dev/null @@ -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 diff --git a/tests/system/Marsh.chs b/tests/system/Marsh.chs deleted file mode 100644 --- a/tests/system/Marsh.chs +++ /dev/null @@ -1,21 +0,0 @@ --- To build, do -*-haskell-*- --- {-% gcc -c marsh.c-} --- % ../c2hs marsh.h Marsh.chs --- % ghc -fglasgow-exts '-#include' -o marsh\ --- -i../lib -L../lib Marsh.hs {-marsh.o-} -lc2hs - -import 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" diff --git a/tests/system/Pointer.chs b/tests/system/Pointer.chs deleted file mode 100644 --- a/tests/system/Pointer.chs +++ /dev/null @@ -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." diff --git a/tests/system/Simple.chs b/tests/system/Simple.chs deleted file mode 100644 --- a/tests/system/Simple.chs +++ /dev/null @@ -1,5 +0,0 @@ -module Main -where - -main :: IO () -main = {#call foo#} diff --git a/tests/system/Sizeof.chs b/tests/system/Sizeof.chs deleted file mode 100644 --- a/tests/system/Sizeof.chs +++ /dev/null @@ -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 diff --git a/tests/system/Structs.chs b/tests/system/Structs.chs deleted file mode 100644 --- a/tests/system/Structs.chs +++ /dev/null @@ -1,54 +0,0 @@ --- To build, do -*-haskell-*- --- % gcc -c structs.c --- % ../c2hs structs.h Structs.chs --- % ghc -fglasgow-exts '-#include' -o structs\ --- -i../lib -L../lib Structs.hs structs.o -lc2hs - -import 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 () diff --git a/tests/system/calls.h b/tests/system/calls.h deleted file mode 100644 --- a/tests/system/calls.h +++ /dev/null @@ -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 */ diff --git a/tests/system/calls/Calls.chs b/tests/system/calls/Calls.chs new file mode 100644 --- /dev/null +++ b/tests/system/calls/Calls.chs @@ -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'#} diff --git a/tests/system/calls/calls.h b/tests/system/calls/calls.h new file mode 100644 --- /dev/null +++ b/tests/system/calls/calls.h @@ -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 */ diff --git a/tests/system/cpp.h b/tests/system/cpp.h deleted file mode 100644 --- a/tests/system/cpp.h +++ /dev/null @@ -1,1 +0,0 @@ -/* dummy file */ diff --git a/tests/system/cpp/Cpp.chs b/tests/system/cpp/Cpp.chs new file mode 100644 --- /dev/null +++ b/tests/system/cpp/Cpp.chs @@ -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 diff --git a/tests/system/enums.c b/tests/system/enums.c deleted file mode 100644 --- a/tests/system/enums.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -#include "enums.h" - -enum colour colourOfSide (side aside) -{ - /* not executed, but needed for linking */ - abort (); -} diff --git a/tests/system/enums.h b/tests/system/enums.h deleted file mode 100644 --- a/tests/system/enums.h +++ /dev/null @@ -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 */ diff --git a/tests/system/enums/Enums.chs b/tests/system/enums/Enums.chs new file mode 100644 --- /dev/null +++ b/tests/system/enums/Enums.chs @@ -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 diff --git a/tests/system/enums/enums.c b/tests/system/enums/enums.c new file mode 100644 --- /dev/null +++ b/tests/system/enums/enums.c @@ -0,0 +1,9 @@ +#include + +#include "enums.h" + +enum colour colourOfSide (side aside) +{ + /* not executed, but needed for linking */ + abort (); +} diff --git a/tests/system/enums/enums.h b/tests/system/enums/enums.h new file mode 100644 --- /dev/null +++ b/tests/system/enums/enums.h @@ -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 */ diff --git a/tests/system/marsh.h b/tests/system/marsh.h deleted file mode 100644 --- a/tests/system/marsh.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef __MARSH_H__ -#define __MARSH_H__ - -int x; - -#endif /* __MARSH_H__ */ diff --git a/tests/system/marsh/Marsh.chs b/tests/system/marsh/Marsh.chs new file mode 100644 --- /dev/null +++ b/tests/system/marsh/Marsh.chs @@ -0,0 +1,22 @@ +-- To build, do -*-haskell-*- +-- {-% gcc -c marsh.c-} +-- % ../c2hs marsh.h Marsh.chs +-- % ghc -fglasgow-exts '-#include' -o marsh\ +-- -i../lib -L../lib Marsh.hs {-marsh.o-} -lc2hs + +import Foreign +import Foreign.C + +main :: IO () +main = do + mem <- newCString "Hello World!\n" + str <- peekCString mem + free mem + putStr str + + let l = [5, 3, 7] :: [CInt] + len = length l + mem <- newArray l + l <- peekArray len mem + free mem + putStr $ show l ++ "\n" diff --git a/tests/system/marsh/marsh.h b/tests/system/marsh/marsh.h new file mode 100644 --- /dev/null +++ b/tests/system/marsh/marsh.h @@ -0,0 +1,6 @@ +#ifndef __MARSH_H__ +#define __MARSH_H__ + +int x; + +#endif /* __MARSH_H__ */ diff --git a/tests/system/pointer.c b/tests/system/pointer.c deleted file mode 100644 --- a/tests/system/pointer.c +++ /dev/null @@ -1,32 +0,0 @@ -#include -#include - -#include "pointer.h" - -string concat (string str1, string str2) -{ - printf ("concat doesn't do anything"); - return str1; -} - -Point *make_point (int x, int y) -{ - Point *pnt; - - pnt = (Point *) malloc (sizeof (Point)); - pnt->x = x; - pnt->x = y; - - return pnt; -} - -Point *trans_point (Point *pnt, int x, int y) -{ - Point *newPnt; - - newPnt = (Point *) malloc (sizeof (Point)); - newPnt->x = pnt->x + x; - newPnt->y = pnt->y + y; - - return newPnt; -} diff --git a/tests/system/pointer.h b/tests/system/pointer.h deleted file mode 100644 --- a/tests/system/pointer.h +++ /dev/null @@ -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 */ diff --git a/tests/system/pointer/Pointer.chs b/tests/system/pointer/Pointer.chs new file mode 100644 --- /dev/null +++ b/tests/system/pointer/Pointer.chs @@ -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." diff --git a/tests/system/pointer/pointer.c b/tests/system/pointer/pointer.c new file mode 100644 --- /dev/null +++ b/tests/system/pointer/pointer.c @@ -0,0 +1,32 @@ +#include +#include + +#include "pointer.h" + +string concat (string str1, string str2) +{ + printf ("concat doesn't do anything"); + return str1; +} + +Point *make_point (int x, int y) +{ + Point *pnt; + + pnt = (Point *) malloc (sizeof (Point)); + pnt->x = x; + pnt->x = y; + + return pnt; +} + +Point *trans_point (Point *pnt, int x, int y) +{ + Point *newPnt; + + newPnt = (Point *) malloc (sizeof (Point)); + newPnt->x = pnt->x + x; + newPnt->y = pnt->y + y; + + return newPnt; +} diff --git a/tests/system/pointer/pointer.h b/tests/system/pointer/pointer.h new file mode 100644 --- /dev/null +++ b/tests/system/pointer/pointer.h @@ -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 */ diff --git a/tests/system/simple.c b/tests/system/simple.c deleted file mode 100644 --- a/tests/system/simple.c +++ /dev/null @@ -1,5 +0,0 @@ -#include - -void foo () { - printf ("I am the mighty foo!\n"); -} diff --git a/tests/system/simple.h b/tests/system/simple.h deleted file mode 100644 --- a/tests/system/simple.h +++ /dev/null @@ -1,1 +0,0 @@ -void foo (); diff --git a/tests/system/simple/Simple.chs b/tests/system/simple/Simple.chs new file mode 100644 --- /dev/null +++ b/tests/system/simple/Simple.chs @@ -0,0 +1,5 @@ +module Main +where + +main :: IO () +main = {#call foo#} diff --git a/tests/system/simple/simple.c b/tests/system/simple/simple.c new file mode 100644 --- /dev/null +++ b/tests/system/simple/simple.c @@ -0,0 +1,5 @@ +#include + +void foo () { + printf ("I am the mighty foo!\n"); +} diff --git a/tests/system/simple/simple.h b/tests/system/simple/simple.h new file mode 100644 --- /dev/null +++ b/tests/system/simple/simple.h @@ -0,0 +1,1 @@ +void foo (); diff --git a/tests/system/sizeof.c b/tests/system/sizeof.c deleted file mode 100644 --- a/tests/system/sizeof.c +++ /dev/null @@ -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); -} diff --git a/tests/system/sizeof.h b/tests/system/sizeof.h deleted file mode 100644 --- a/tests/system/sizeof.h +++ /dev/null @@ -1,46 +0,0 @@ -#include -#define BFSZ(ty,bits) bits -size_t size_of_s1(); -size_t size_of_s2(); -size_t size_of_s3(); -size_t size_of_s4(); - -size_t align_of_s1(); -size_t align_of_s2(); -size_t align_of_s3(); - -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; diff --git a/tests/system/sizeof/Sizeof.chs b/tests/system/sizeof/Sizeof.chs new file mode 100644 --- /dev/null +++ b/tests/system/sizeof/Sizeof.chs @@ -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 diff --git a/tests/system/sizeof/sizeof.c b/tests/system/sizeof/sizeof.c new file mode 100644 --- /dev/null +++ b/tests/system/sizeof/sizeof.c @@ -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); +} diff --git a/tests/system/sizeof/sizeof.h b/tests/system/sizeof/sizeof.h new file mode 100644 --- /dev/null +++ b/tests/system/sizeof/sizeof.h @@ -0,0 +1,47 @@ +#include +#define BFSZ(ty,bits) bits +size_t size_of_s1(); +size_t size_of_s2(); +size_t size_of_s3(); +size_t size_of_s4(); + +size_t align_of_s1(); +size_t align_of_s2(); +size_t align_of_s3(); +size_t align_of_s4(); + +typedef struct s1 { + int x; + char y; + void* z; + } S1; +typedef struct s2 { + int* x[5]; + int (*y)[7]; + int (*f1)(void); + int (*f2)[11]; +} S2; + +typedef struct s3 { + int a:7; +} S3; + +typedef struct s4 { + struct { + int a : BFSZ(int,13); + int b : BFSZ(int,13); + int b_1: BFSZ(int,13); + int b_2: BFSZ(int,13); + int b_3: BFSZ(int,13); + } f0; + /* NOT SUPPORTED: c2hs does not allow char/short etc. as bitfield types + struct { + signed char c:BFSZ(signed char,4); + unsigned char d; + short e:BFSZ(short,7); + short f:BFSZ(short,7); + short f_1:BFSZ(short,7); + long long g; + long long h:BFSZ(long long, 15); + */ +} S4; diff --git a/tests/system/structs.c b/tests/system/structs.c deleted file mode 100644 --- a/tests/system/structs.c +++ /dev/null @@ -1,45 +0,0 @@ -#include - -#include "structs.h" - -point make_point (int x, int y) -{ - point pnt; - - pnt = (point) malloc (sizeof (*pnt)); - pnt->x = x; - pnt->y = y; - return pnt; -} - -weird make_weird (void) -{ - weird w; - - w = (weird) malloc (sizeof (*w)); - w->b = ' '; - w->x = -1; - w->nested.y = 4; - w->nested.z = 2; - w->nested.pnt = make_point (100, 200); - return w; -} - -mychar *getSpacePtr (void) -{ - static char c = ' '; - - return &c; -} - -struct bit_struct my_bit_struct; - -struct bit_struct *get_bit_struct() -{ - my_bit_struct.c1 = '\0'; - my_bit_struct.bit = 1; - my_bit_struct.very_small_int = -1; - my_bit_struct.c2 = '\0'; - - return &my_bit_struct; -} diff --git a/tests/system/structs.expect b/tests/system/structs.expect deleted file mode 100644 --- a/tests/system/structs.expect +++ /dev/null @@ -1,1 +0,0 @@ -42 & -1 & 2 & 200 & ' ' diff --git a/tests/system/structs.h b/tests/system/structs.h deleted file mode 100644 --- a/tests/system/structs.h +++ /dev/null @@ -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__ */ diff --git a/tests/system/structs/Structs.chs b/tests/system/structs/Structs.chs new file mode 100644 --- /dev/null +++ b/tests/system/structs/Structs.chs @@ -0,0 +1,58 @@ +-- To build, do -*-haskell-*- +-- % gcc -c structs.c +-- % ../c2hs structs.h Structs.chs +-- % ghc -fglasgow-exts '-#include' -o structs\ +-- -i../lib -L../lib Structs.hs structs.o -lc2hs + +import Control.Monad (liftM, when) +import Foreign +import Foreign.C + +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 () diff --git a/tests/system/structs/structs.c b/tests/system/structs/structs.c new file mode 100644 --- /dev/null +++ b/tests/system/structs/structs.c @@ -0,0 +1,45 @@ +#include + +#include "structs.h" + +point make_point (int x, int y) +{ + point pnt; + + pnt = (point) malloc (sizeof (*pnt)); + pnt->x = x; + pnt->y = y; + return pnt; +} + +weird make_weird (void) +{ + weird w; + + w = (weird) malloc (sizeof (*w)); + w->b = ' '; + w->x = -1; + w->nested.y = 4; + w->nested.z = 2; + w->nested.pnt = make_point (100, 200); + return w; +} + +mychar *getSpacePtr (void) +{ + static char c = ' '; + + return &c; +} + +struct bit_struct my_bit_struct; + +struct bit_struct *get_bit_struct() +{ + my_bit_struct.c1 = '\0'; + my_bit_struct.bit = 1; + my_bit_struct.very_small_int = -1; + my_bit_struct.c2 = '\0'; + + return &my_bit_struct; +} diff --git a/tests/system/structs/structs.h b/tests/system/structs/structs.h new file mode 100644 --- /dev/null +++ b/tests/system/structs/structs.h @@ -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__ */ diff --git a/tests/test-bugs.hs b/tests/test-bugs.hs new file mode 100644 --- /dev/null +++ b/tests/test-bugs.hs @@ -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 [] diff --git a/tests/test-system.hs b/tests/test-system.hs new file mode 100644 --- /dev/null +++ b/tests/test-system.hs @@ -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 & ' '"]