c2hs-0.16.4/0000755000000000000000000000000012044310770010625 5ustar0000000000000000c2hs-0.16.4/README0000644000000000000000000000557512044310770011521 0ustar0000000000000000 C->Haskell - Haskell Interface Generator -*-text-*- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ C->Haskell is a interfacing tool that eases Haskell access to C libraries. The tool gets information about the C data type definitions and function signatures by analysing the C header files of the library. It uses this information to compute the missing details in the template of a Haskell module---called the binding file---that implements a Haskell binding to the C library. Hooks embedded in the binding file signal where, which, and how C objects are accessed from Haskell. The Haskell code in the binding file determines Haskell types signatures and marshaling details. Further information is at http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ Also see the tutorial in `doc/c2hs/'. Contents: AUTHORS -- Author information COPYING -- GNU General Public License (GPL) INSTALL -- Help on installing this package README -- This file Setup.hs -- Cabal build script TODO -- Open problems, bugs, and ideas for future extensions c2hs.cabal -- Cabal package specification doc -- Documentation src -- Source code src/C2HS -- Main program sources src/Main.hs -- Compilation driver tests -- Small test cases -=-=-=-=-=-=-=-=-=-=-=-=-=-=-= INSTALLING =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= See the file `INSTALL'. -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- COPYLEFT -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= This system is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This system is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this system; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. NOTE: HOWEVER, all code included into generated bindings is under a BSD-style license that does not place any restrictions on the license of the inteface produced with C->Haskell (ie, closed proprietary licenses are possible, too). In other words, I do not care what you use C->Haskell for or to whom you are giving C->Haskell or any interfaces generated with C->Haskell, only if you modify or improve C->Haskell itself, you have to contribute your changes back to the community. Nevertheless, I will of course be particularly delighted if you choose to make your work freely available. -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- CREDITS -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- See the file `AUTHORS'. c2hs-0.16.4/Setup.hs0000644000000000000000000000011212044310770012253 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain c2hs-0.16.4/c2hs.cabal0000644000000000000000000000514612044310770012456 0ustar0000000000000000Name: c2hs Version: 0.16.4 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty 2005-2008 Duncan Coutts 2008 Benedikt Huber Author: Manuel M T Chakravarty Maintainer: chak@cse.unsw.edu.au, duncan@haskell.org Stability: Stable Homepage: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ Bug-Reports: http://hackage.haskell.org/trac/c2hs/ Synopsis: C->Haskell FFI tool that gives some cross-language type safety Description: C->Haskell assists in the development of Haskell bindings to C libraries. It extracts interface information from C header files and generates Haskell code with foreign imports and marshaling. Unlike writing foreign imports by hand (or using hsch2s), 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 Cabal-Version: >= 1.6 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 source-repository head type: darcs location: http://code.haskell.org/c2hs/ flag base3 Executable c2hs Build-Depends: base >= 2 && < 5, language-c >= 0.3.1.1 && < 0.4.0, filepath if flag(base3) Build-Depends: base >= 3, process, directory, array, containers, pretty else Build-Depends: base < 3 hs-source-dirs: src main-is: Main.hs other-modules: C2HS.C C2HS.C.Attrs C2HS.C.Builtin C2HS.C.Info C2HS.C.Names C2HS.C.Trav C2HS.CHS C2HS.CHS.Lexer C2HS.Gen.Monad C2HS.Gen.Bind C2HS.Gen.Header C2HS.State C2HS.Switches C2HS.Config C2HS.Version Control.StateBase Control.State Control.StateTrans Data.Attributes Data.DLists Data.Errors Data.NameSpaces System.CIO Text.Lexers extensions: ForeignFunctionInterface c-sources: src/C2HS/config.c --TODO: eliminate the need to suppress these warnings: ghc-options: -Wall -fno-warn-incomplete-patterns -fwarn-tabs c2hs-0.16.4/C2HS.hs0000644000000000000000000002233212044310770011662 0ustar0000000000000000-- C->Haskell Compiler: Marshalling library -- -- Copyright (c) [1999...2005] Manuel M T Chakravarty -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met: -- -- 1. Redistributions of source code must retain the above copyright notice, -- this list of conditions and the following disclaimer. -- 2. Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- 3. The name of the author may not be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR -- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES -- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN -- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- --- Description --------------------------------------------------------------- -- -- Language: Haskell 98 -- -- This module provides the marshaling routines for Haskell files produced by -- C->Haskell for binding to C library interfaces. It exports all of the -- low-level FFI (language-independent plus the C-specific parts) together -- with the C->HS-specific higher-level marshalling routines. -- module C2HS ( -- * Re-export the language-independent component of the FFI module Foreign, -- * Re-export the C language component of the FFI module Foreign.C, -- * Composite marshalling functions withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv, peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum, -- * Conditional results using 'Maybe' nothingIf, nothingIfNull, -- * Bit masks combineBitMasks, containsBitMask, extractBitMasks, -- * Conversion between C and Haskell types cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum ) where import Foreign import Foreign.C import Monad (liftM) -- Composite marshalling functions -- ------------------------------- -- Strings with explicit length -- withCStringLenIntConv :: Num n => String -> ((CString, n) -> IO a) -> IO a withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, fromIntegral n) peekCStringLenIntConv :: Integral n => (CString, n) -> IO String peekCStringLenIntConv (s, n) = peekCStringLen (s, fromIntegral n) -- Marshalling of numerals -- withIntConv :: (Storable b, Integral a, Integral b) => a -> (Ptr b -> IO c) -> IO c withIntConv = with . fromIntegral withFloatConv :: (Storable b, RealFloat a, RealFloat b) => a -> (Ptr b -> IO c) -> IO c withFloatConv = with . realToFrac peekIntConv :: (Storable a, Integral a, Integral b) => Ptr a -> IO b peekIntConv = liftM fromIntegral . peek peekFloatConv :: (Storable a, RealFloat a, RealFloat b) => Ptr a -> IO b peekFloatConv = liftM realToFrac . peek -- Everything else below is deprecated. -- These functions are not used by code generated by c2hs. {-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED peekBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED withEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED peekEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED nothingIf "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED nothingIfNull "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED combineBitMasks "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED containsBitMask "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED extractBitMasks "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cIntConv "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cFloatConv "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cFromBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cToBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cToEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} {-# DEPRECATED cFromEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} -- Passing Booleans by reference -- withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b withBool = with . fromBool peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool peekBool = liftM toBool . peek -- Passing enums by reference -- withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c withEnum = with . cFromEnum peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a peekEnum = liftM cToEnum . peek -- Storing of 'Maybe' values -- ------------------------- --TODO: kill off this orphan instance! instance Storable a => Storable (Maybe a) where sizeOf _ = sizeOf (undefined :: Ptr ()) alignment _ = alignment (undefined :: Ptr ()) peek p = do ptr <- peek (castPtr p) if ptr == nullPtr then return Nothing else liftM Just $ peek ptr poke p v = do ptr <- case v of Nothing -> return nullPtr Just v' -> new v' poke (castPtr p) ptr -- Conditional results using 'Maybe' -- --------------------------------- -- Wrap the result into a 'Maybe' type. -- -- * the predicate determines when the result is considered to be non-existing, -- ie, it is represented by `Nothing' -- -- * the second argument allows to map a result wrapped into `Just' to some -- other domain -- nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b nothingIf p f x = if p x then Nothing else Just $ f x -- |Instance for special casing null pointers. -- nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b nothingIfNull = nothingIf (== nullPtr) -- Support for bit masks -- --------------------- -- Given a list of enumeration values that represent bit masks, combine these -- masks using bitwise disjunction. -- combineBitMasks :: (Enum a, Bits b) => [a] -> b combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum) -- Tests whether the given bit mask is contained in the given bit pattern -- (i.e., all bits set in the mask are also set in the pattern). -- containsBitMask :: (Bits a, Enum b) => a -> b -> Bool bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm in bm' .&. bits == bm' -- |Given a bit pattern, yield all bit masks that it contains. -- -- * This does *not* attempt to compute a minimal set of bit masks that when -- combined yield the bit pattern, instead all contained bit masks are -- produced. -- extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b] extractBitMasks bits = [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm] -- Conversion routines -- ------------------- -- |Integral conversion -- cIntConv :: (Integral a, Integral b) => a -> b cIntConv = fromIntegral -- |Floating conversion -- cFloatConv :: (RealFloat a, RealFloat b) => a -> b cFloatConv = realToFrac -- |Obtain C value from Haskell 'Bool'. -- cFromBool :: Num a => Bool -> a cFromBool = fromBool -- |Obtain Haskell 'Bool' from C value. -- cToBool :: Num a => a -> Bool cToBool = toBool -- |Convert a C enumeration to Haskell. -- cToEnum :: (Integral i, Enum e) => i -> e cToEnum = toEnum . fromIntegral -- |Convert a Haskell enumeration to C. -- cFromEnum :: (Enum e, Integral i) => e -> i cFromEnum = fromIntegral . fromEnum c2hs-0.16.4/INSTALL0000644000000000000000000000365612044310770011670 0ustar0000000000000000 C->Haskell Installation Instructions -*-text-*- ------------------------------------ Prerequisites ~~~~~~~~~~~~~ You need GHC, the Haskell compiler. Currently, this has to be GHC 6.8 upwards, which you can get from http://haskell.org/ghc Simple install procedure ~~~~~~~~~~~~~~~~~~~~~~~~ % tar -xzf .tar.gz # unpack the sources % cd # change to the toplevel directory % runghc Setup.hs configure # configure the build system % runghc Setup.hs build # build everything [ Become root if necessary ] % runghc Setup.hs install # install c2hs The Nitty-Gritty ~~~~~~~~~~~~~~~~ The './Setup.hs configure' command understands the following options: * --prefix=PREFIX install architecture-independent files in PREFIX [ Defaults to /usr/local ] * --with-compiler=HC use Haskell compiler HC This needs to be the full path to the compiler executable. * --with-happy=HAPPY ditto for parser generator Happy * --with-alex=ALEX ditto for lexer generator Alex * --user allow the use of packages from user database * --global only allow packages from the global database Documentation ~~~~~~~~~~~~~ Documentation can be formatted with $ make -C doc Currently there is no support for installing the documentation. That step has to be done manually. The generated html pages for the user guide live in: docs/user_guide/* The man page is: docs/man1/c2hs.1 Supported Systems and Porting ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Tested with GHC version 6.8.2 and 6.10.1. In principle it should work with any 6.x version since 6.4.2 however the current releases of the language-c package only work with ghc-6.8 and later. The actual c2hs sources might also compile with nhc98, but Cabal doesn't fully support nhc98 yet. c2hs-0.16.4/AUTHORS0000644000000000000000000000205112044310770011673 0ustar0000000000000000Manuel M T Chakravarty Duncan Coutts with contributions from (alphabetical order) Bertram Felgenhauer Benedikt Huber John Lato Ian Lynagh AndrĂ© Pang Jens-Ulrik Petersen Armin Sander Sean Seefried Udo Stenzel Axel Simon Michael Weber Thanks for comments and suggestions to Roman Leshchinskiy Jan Kort Seth Kurtzberg Simon Marlow Matthias Neubauer Sven Panne Simon L. Peyton Jones Volker Wysk c2hs-0.16.4/COPYING0000644000000000000000000004362612044310770011673 0ustar0000000000000000This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. c2hs-0.16.4/tests/0000755000000000000000000000000012044310770011767 5ustar0000000000000000c2hs-0.16.4/tests/system/0000755000000000000000000000000012044310770013313 5ustar0000000000000000c2hs-0.16.4/tests/system/Calls.chs0000644000000000000000000000156512044310770015057 0ustar0000000000000000-- -*-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 {} -> id `Int'#} {#fun pure bar as barFun {`Int'} -> `Float'#} {#fun baz as bazFun {`Int', `Float'} -> `()'#} {#fun pure MyString as myStringFun {} -> `String'#} {#fun printString as printStringFun {`String'} -> `()'#} {#fun foobar { `String'& , alloca- `Int' peekIntConv*, `Float' } -> `Int'#} c2hs-0.16.4/tests/system/cpp.h0000644000000000000000000000002112044310770014237 0ustar0000000000000000/* dummy file */ c2hs-0.16.4/tests/system/pointer.c0000644000000000000000000000074712044310770015147 0ustar0000000000000000#include #include #include "pointer.h" string concat (string str1, string str2) { printf ("concat doesn't do anything"); return str1; } Point *make_point (int x, int y) { Point *pnt; pnt = (Point *) malloc (sizeof (Point)); pnt->x = x; pnt->x = y; return pnt; } Point *trans_point (Point *pnt, int x, int y) { Point *newPnt; newPnt = (Point *) malloc (sizeof (Point)); newPnt->x = pnt->x + x; newPnt->y = pnt->y + y; return newPnt; } c2hs-0.16.4/tests/system/sizeof.h0000644000000000000000000000167312044310770014772 0ustar0000000000000000#include #define BFSZ(ty,bits) bits size_t size_of_s1(); size_t size_of_s2(); size_t size_of_s3(); size_t size_of_s4(); size_t align_of_s1(); size_t align_of_s2(); size_t align_of_s3(); typedef struct s1 { int x; char y; void* z; } S1; typedef struct s2 { int* x[5]; int (*y)[7]; int (*f1)(void); int (*f2)[11]; } S2; typedef struct s3 { int a:7; } S3; typedef struct s4 { struct { int a : BFSZ(int,13); int b : BFSZ(int,13); int b_1: BFSZ(int,13); int b_2: BFSZ(int,13); int b_3: BFSZ(int,13); } f0; /* NOT SUPPORTED: c2hs does not allow char/short etc. as bitfield types struct { signed char c:BFSZ(signed char,4); unsigned char d; short e:BFSZ(short,7); short f:BFSZ(short,7); short f_1:BFSZ(short,7); long long g; long long h:BFSZ(long long, 15); */ } S4; c2hs-0.16.4/tests/system/pointer.h0000644000000000000000000000075112044310770015147 0ustar0000000000000000#ifndef _POINTER_H #define _POINTER_H typedef char *string; string concat (string str1, string str2); struct _Point { int x, y; }; struct _ColourPoint { int x, y; unsigned int colour; }; typedef struct _Point Point; typedef struct _ColourPoint ColourPoint; typedef struct _Point *PointPtr; Point *make_point (int x, int y); Point *trans_point (Point *pnt, int x, int y); typedef void (*FunPtrFun) (void *data); typedef char **stringPtr; #endif /* !_POINTER_H */ c2hs-0.16.4/tests/system/simple.h0000644000000000000000000000001512044310770014751 0ustar0000000000000000void foo (); c2hs-0.16.4/tests/system/structs.c0000644000000000000000000000127112044310770015167 0ustar0000000000000000#include #include "structs.h" point make_point (int x, int y) { point pnt; pnt = (point) malloc (sizeof (*pnt)); pnt->x = x; pnt->y = y; return pnt; } weird make_weird (void) { weird w; w = (weird) malloc (sizeof (*w)); w->b = ' '; w->x = -1; w->nested.y = 4; w->nested.z = 2; w->nested.pnt = make_point (100, 200); return w; } mychar *getSpacePtr (void) { static char c = ' '; return &c; } struct bit_struct my_bit_struct; struct bit_struct *get_bit_struct() { my_bit_struct.c1 = '\0'; my_bit_struct.bit = 1; my_bit_struct.very_small_int = -1; my_bit_struct.c2 = '\0'; return &my_bit_struct; } c2hs-0.16.4/tests/system/sizeof.c0000644000000000000000000000071512044310770014761 0ustar0000000000000000#include "sizeof.h" size_t size_of_s1() { return sizeof(struct s1); } size_t size_of_s2() { return sizeof(struct s2); } size_t size_of_s3() { return sizeof(struct s3); } size_t size_of_s4() { return sizeof(struct s4); } size_t align_of_s1() { return __alignof__(struct s1); } size_t align_of_s2() { return __alignof__(struct s2); } size_t align_of_s3() { return __alignof__(struct s3); } size_t align_of_s4() { return __alignof__(struct s4); } c2hs-0.16.4/tests/system/structs.expect0000644000000000000000000000003012044310770016225 0ustar000000000000000042 & -1 & 2 & 200 & ' ' c2hs-0.16.4/tests/system/Cpp.chs0000644000000000000000000000054712044310770014542 0ustar0000000000000000-- -*-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 c2hs-0.16.4/tests/system/calls.h0000644000000000000000000000054412044310770014565 0ustar0000000000000000#ifndef _CALLS_H #define _CALLS_H int foo (); float bar (int); void baz (int x, float y); char *MyString (void); typedef char *tString; void printString (tString str); void printString2 (tString); int foobar (tString chars, int nchars, int *items, float x); /* type of function `MyString' */ typedef char *(*MyStringType) (int); #endif /* !_CALLS_H */ c2hs-0.16.4/tests/system/Sizeof.chs0000644000000000000000000000363312044310770015256 0ustar0000000000000000module 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 c2hs-0.16.4/tests/system/enums.c0000644000000000000000000000021412044310770014603 0ustar0000000000000000#include #include "enums.h" enum colour colourOfSide (side aside) { /* not executed, but needed for linking */ abort (); } c2hs-0.16.4/tests/system/Pointer.chs0000644000000000000000000000267712044310770015446 0ustar0000000000000000-- -*-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." c2hs-0.16.4/tests/system/Enums.chs0000644000000000000000000000144112044310770015101 0ustar0000000000000000-- -*-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 c2hs-0.16.4/tests/system/Marsh.chs0000644000000000000000000000075112044310770015067 0ustar0000000000000000-- To build, do -*-haskell-*- -- {-% gcc -c marsh.c-} -- % ../c2hs marsh.h Marsh.chs -- % ghc -fglasgow-exts '-#include' -o marsh\ -- -i../lib -L../lib Marsh.hs {-marsh.o-} -lc2hs import 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" c2hs-0.16.4/tests/system/simple.c0000644000000000000000000000011112044310770014741 0ustar0000000000000000#include void foo () { printf ("I am the mighty foo!\n"); } c2hs-0.16.4/tests/system/Makefile0000644000000000000000000000604612044310770014761 0ustar0000000000000000# Note that file.o and File.o are the same file on case-insensitive systems # Therefore we shouldn't use one for C and one for HS HC=ghc HCFLAGS= -fffi C2HS = ../../dist/build/c2hs/c2hs # C2HSFLAGS = -d trace -d genbind -d ctrav -d chs PRGMS = simple calls enums pointer structs marsh cpp default: tests # builds C2HS.o: ../../C2HS.hs cp -p ../../C2HS.hs . $(HC) -c C2HS.hs simple: C2HS.o Simple.chs simple.h simple.c $(C2HS) $(C2HSFLAGS) simple.h Simple.chs $(HC) -c -o Simple_hs.o Simple.hs $(HCFLAGS) $(CC) -c simple.c $(HC) -o simple simple.o Simple_hs.o C2HS.o calls: C2HS.o Calls.chs calls.h $(C2HS) $(C2HSFLAGS) calls.h Calls.chs $(HC) -c -o Calls.o Calls.hs -#include\"calls.h\" $(HCFLAGS) || \ echo "!!! Building calls failed ! known bug #?" enums: C2HS.o Enums.chs enums.h $(C2HS) $(C2HSFLAGS) enums.h Enums.chs $(CC) -o enums_c.o -c enums.c $(HC) -o enums enums_c.o Enums.hs -#include\"enums.h\" $(HCFLAGS) C2HS.o pointer: C2HS.o Pointer.chs pointer.h pointer.c $(C2HS) $(C2HSFLAGS) pointer.h Pointer.chs $(CC) -o pointer_c.o -c pointer.c $(HC) -o pointer pointer_c.o Pointer.hs -#include\"pointer.h\"\ $(HCFLAGS) C2HS.o sizeof: C2HS.o Sizeof.chs sizeof.h sizeof.c $(C2HS) $(C2HSFLAGS) sizeof.h Sizeof.chs $(HC) -c -o Sizeof.o Sizeof.hs -#include\"sizeof.h\" $(HCFLAGS) $(CC) -o sizeof_c.o -c sizeof.c $(HC) -o sizeof sizeof_c.o Sizeof.o $(HCFLAGS) C2HS.o structs: C2HS.o Structs.chs structs.h structs.c $(C2HS) $(C2HSFLAGS) structs.h Structs.chs $(HC) -c -o Structs.o Structs.hs -#include\"structs.h\" $(HCFLAGS) $(CC) -o structs_c.o -c structs.c $(HC) -o structs structs_c.o Structs.o $(HCFLAGS) C2HS.o marsh: C2HS.o Marsh.chs marsh.h $(C2HS) $(C2HSFLAGS) marsh.h Marsh.chs $(HC) -o marsh Marsh.hs -#include\"marsh.h\" $(HCFLAGS) C2HS.o cpp: C2HS.o Cpp.chs cpp.h $(C2HS) $(C2HSFLAGS) Cpp.chs $(HC) -c -o Cpp.o Cpp.hs -#include\"Cpp.h\" $(HCFLAGS) C2HS.o # runs .PHONY: tests simple.run calls.build enums.run pointer.run structs.run\ marsh.run cpp.build tests: simple.run enums.run pointer.run structs.run marsh.run\ cpp.build buggy buggy: calls.build sizeof.run simple.run: simple @echo "---=== Output of \`simple'": @./simple @echo "---=== End of Output" calls.build: calls @echo "---=== Binding for \`calls'": @cat Calls.hs @echo "---=== End of Binding" enums.run: enums @echo "---=== Output for \`enums'": @./enums @echo "---=== End of Output" pointer.run: pointer @echo "---=== Output for \`pointer'": @./pointer @echo "---=== End of Output" sizeof.run: sizeof @echo "---=== Output for \`sizeof'": @./sizeof || \ echo "!!! sizeof FAILED: Maybe related to bug #10" @echo "---=== End of Output" structs.run: structs @echo "---=== Output for \`structs'": @./structs > structs.out @cat structs.out @diff structs.out structs.expect @echo "---=== End of Output (diff ok)" marsh.run: marsh @echo "---=== Output for \`marsh'": @./marsh @echo "---=== End of Output" cpp.build: cpp @echo "---=== Binding for \`cpp'": @cat Cpp.hs @echo "---=== End of Binding" # misc clean: -rm -f *.o *.hi *.hs *.out $(PRGMS) c2hs-0.16.4/tests/system/Simple.chs0000644000000000000000000000006612044310770015245 0ustar0000000000000000module Main where main :: IO () main = {#call foo#} c2hs-0.16.4/tests/system/structs.h0000644000000000000000000000222312044310770015172 0ustar0000000000000000#ifndef __STRUCTS_H__ #define __STRUCTS_H__ typedef char bool, mychar; typedef struct _point *point; int _point(void); struct _point { int x, y; }; int _point(void); typedef struct { struct _point pnt; int col; } *cpoint; typedef struct { bool b; int x; struct { int y, z; point pnt; } nested; } *weird; typedef struct ambiguousName { int x; } ambiguousName; /* same name for struct tag and type */ typedef struct ambiguousName someOtherName; point make_point (int x, int y); weird make_weird (void); mychar *getSpacePtr (void); /* bitfield functionality */ struct bit_struct { char c1; unsigned int bit : 1; signed int very_small_int : 3; char c2; }; struct bit_struct *get_bit_struct(); #ifdef __GNUC__ /* this is to check c2hs's resistance to GNU extensions */ struct _MyStructAlign {long int x;}; struct _MyStruct { int bar; } __attribute__ ((aligned (__alignof (struct _MyStructAlign)))) ; #endif /* __GNUC__ */ /* to test nested struct/unions (regression test) */ typedef struct { int type; int typ1; } FT; typedef union { int type; FT typ1; } SDL_Event; #endif /* __STRUCTS_H__ */ c2hs-0.16.4/tests/system/Structs.chs0000644000000000000000000000410012044310770015454 0ustar0000000000000000-- To build, do -*-haskell-*- -- % gcc -c structs.c -- % ../c2hs structs.h Structs.chs -- % ghc -fglasgow-exts '-#include' -o structs\ -- -i../lib -L../lib Structs.hs structs.o -lc2hs import 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 () c2hs-0.16.4/tests/system/marsh.h0000644000000000000000000000011212044310770014570 0ustar0000000000000000#ifndef __MARSH_H__ #define __MARSH_H__ int x; #endif /* __MARSH_H__ */ c2hs-0.16.4/tests/system/enums.h0000644000000000000000000000116612044310770014617 0ustar0000000000000000#ifndef _ENUMS_H #define _ENUMS_H #define STOP -1 enum colour { red, green, blue }; enum weird { NUL, EINS = red + 1, /* refers to other enum */ FIVE = 5, SIX, MINUS_ONE = STOP }; typedef enum { TOP, BOTTOM, RIGHT, LEFT } side; typedef side other_side; enum colour colourOfSide (side aside); enum enum_net_type { NET_TYPE_TCPIP, NET_TYPE_SOCKET, NET_TYPE_NAMEDPIPE }; typedef struct st_net { enum enum_net_type nettype; int rest; } NET; enum enums_enums { ENUMS_ONE = 1, ENUMS_TWO = 2, ENUMS_THREE = 3 }; /* A #define enum */ #define THIS 1 #define THAT 2 #endif /* !_ENUMS_H */ c2hs-0.16.4/src/0000755000000000000000000000000012044310770011414 5ustar0000000000000000c2hs-0.16.4/src/Main.hs0000644000000000000000000005174612044310770012651 0ustar0000000000000000-- C->Haskell Compiler: main module -- -- Copyright (c) [1999..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- Description --------------------------------------------------------------- -- -- Language: Haskell 98 -- -- This is the main module of the compiler. It sets the version, processes -- the command line arguments, and controls the compilation process. -- -- Usage: -- ------ -- -- c2hs [ option... ] [header-file] binding-file -- -- The compiler is supposed to emit a Haskell program that expands all hooks -- in the given binding file. -- -- File name suffix: -- ----------------- -- -- Note: These also depend on suffixes defined in the compiler proper. -- -- .h C header file -- .i pre-processeed C header file -- .hs Haskell file -- .chs Haskell file with C->Haskell hooks (binding file) -- .chi C->Haskell interface file -- -- Options: -- -------- -- -- -C CPPOPTS -- --cppopts=CPPOPTS -- Pass the additional options CPPOPTS to the C preprocessor. -- -- Repeated occurences accumulate. -- -- -c CPP -- --cpp=CPP -- Use the executable CPP to invoke CPP. -- -- In the case of repeated occurences, the last takes effect. -- -- -d TYPE -- --dump=TYPE -- Dump intermediate representation: -- -- + if TYPE is `trace', trace the compiler phases (to stderr) -- + if TYPE is `genbind', trace binding generation (to stderr) -- + if TYPE is `ctrav', trace C declaration traversal (to stderr) -- + if TYPE is `chs', dump the binding file (insert `.dump' into the -- file name to avoid overwriting the original file) -- -- -h, -? -- --help -- Dump brief usage information to stderr. -- -- -i DIRS -- --include=DIRS -- Search the colon separated list of directories DIRS when searching -- for .chi files. -- -- -k -- --keep -- Keep the intermediate file that contains the pre-processed C header -- (it carries the suffix `.i'). -- -- -l -- --copy-library -- Copies the library module `C2HS' into the same directory where the -- generated code from the binding file is placed. -- -- -o FILE -- --output=FILE -- Place output in file FILE. -- -- If `-o' is not specified, the default is to put the output for -- `source.chs' in `source.hs' in the same directory that contains the -- binding file. If specified, the emitted C header file is put into -- the same directory as the output file. The same holds for -- C->Haskell interface file. All generated files also share the -- basename. -- -- -p PLATFORM -- --platform=PLATFORM -- Generate output for the given PLATFORM. By default we generate -- output for the platform that c2hs executes on. -- -- -t PATH -- --output-dir=PATH -- Place generated files in the directory PATH. -- -- If this option as well as the `-o' option is given, the basename of -- the file specified with `-o' is put in the directory specified with -- `-t'. -- -- -v, -- --version -- Print (on standard output) the version and copyright -- information of the compiler (before doing anything else). -- --- TODO ---------------------------------------------------------------------- -- module Main (main) where -- standard libraries import Data.List (intersperse, partition) import Control.Monad (when, unless) import Data.Version (showVersion) import System.Console.GetOpt (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) import qualified System.FilePath as FilePath (takeExtension, dropExtension, takeBaseName) import System.FilePath ((<.>), ()) import System.IO (stderr, openFile, IOMode(..)) import System.IO.Error (ioeGetErrorString, ioeGetFileName) import System.Process (runProcess, waitForProcess) -- c2hs modules import C2HS.State (CST, runC2HS, fatal, fatalsHandledBy, SwitchBoard(..), Traces(..), setTraces, traceSet, setSwitch, getSwitch, putTraceStr) import qualified System.CIO as CIO import C2HS.C (hsuffix, isuffix, loadAttrC) import C2HS.CHS (loadCHS, dumpCHS, hssuffix, chssuffix, dumpCHI) import C2HS.Gen.Header (genHeader) import C2HS.Gen.Bind (expandHooks) import C2HS.Version (versnum, version, copyright, disclaimer) import C2HS.Config (cppopts, libfname, PlatformSpec(..), defaultPlatformSpec, platformSpecDB) import qualified C2HS.Config as CConf import Paths_c2hs (getDataDir) -- | wrapper running the compiler -- main :: IO () main = runC2HS compile -- option handling -- =============== -- | header is output in case of help, before the descriptions of the options; -- errTrailer is output after an error message -- header :: String header = version ++ "\n" ++ copyright ++ "\n" ++ disclaimer ++ "\n\nUsage: c2hs [ option... ] [header-file] binding-file\n" trailer, errTrailer :: String trailer = "\n\ \The header file must be a C header file matching the given \ \binding file.\n\ \The dump TYPE can be\n\ \ trace -- trace compiler phases\n\ \ genbind -- trace binding generation\n\ \ ctrav -- trace C declaration traversal\n\ \ chs -- dump the binding file (adds `.dump' to the name)\n" errTrailer = "Try the option `--help' on its own for more information.\n" -- | supported option types -- data Flag = CPPOpts String -- ^ additional options for C preprocessor | CPP String -- ^ program name of C preprocessor | Dump DumpType -- ^ dump internal information | Help -- ^ print brief usage information | Keep -- ^ keep the .i file | Library -- ^ copy library module @C2HS@ | Include String -- ^ list of directories to search .chi files | Output String -- ^ file where the generated file should go | Platform String -- ^ target platform to generate code for | OutDir String -- ^ directory where generates files should go | Version -- ^ print version information on stdout | NumericVersion -- ^ print numeric version on stdout | Error String -- ^ error occured during processing of options deriving Eq data DumpType = Trace -- ^ compiler trace | GenBind -- ^ trace "C2HS.Gen.Bind" | CTrav -- ^ trace "C2HS.C.CTrav" | CHS -- ^ dump binding file deriving Eq -- | option description suitable for "Distribution.GetOpt" -- options :: [OptDescr Flag] options = [ Option ['C'] ["cppopts"] (ReqArg CPPOpts "CPPOPTS") "pass CPPOPTS to the C preprocessor", Option ['c'] ["cpp"] (ReqArg CPP "CPP") "use executable CPP to invoke C preprocessor", Option ['d'] ["dump"] (ReqArg dumpArg "TYPE") "dump internal information (for debugging)", Option ['h', '?'] ["help"] (NoArg Help) "brief help (the present message)", Option ['i'] ["include"] (ReqArg Include "INCLUDE") "include paths for .chi files", Option ['k'] ["keep"] (NoArg Keep) "keep pre-processed C header", Option ['l'] ["copy-library"] (NoArg Library) "copy `C2HS' library module in", Option ['o'] ["output"] (ReqArg Output "FILE") "output result to FILE (should end in .hs)", Option ['p'] ["platform"] (ReqArg Platform "PLATFORM") "platform to use for cross compilation", Option ['t'] ["output-dir"] (ReqArg OutDir "PATH") "place generated files in PATH", Option ['v'] ["version"] (NoArg Version) "show version information", Option [] ["numeric-version"] (NoArg NumericVersion) "show version number"] -- | convert argument of 'Dump' option -- dumpArg :: String -> Flag dumpArg "trace" = Dump Trace dumpArg "genbind" = Dump GenBind dumpArg "ctrav" = Dump CTrav dumpArg "chs" = Dump CHS dumpArg _ = Error "Illegal dump type." -- | main process (set up base configuration, analyse command line, and execute -- compilation process) -- -- * Exceptions are caught and reported -- compile :: CST s () compile = do setup cmdLine <- CIO.getArgs case getOpt RequireOrder options cmdLine of (opts, [] , []) | noCompOpts opts -> doExecute opts Nothing (opts, args, []) -> case parseArgs args of justargs@(Just _) -> doExecute opts justargs Nothing -> raiseErrs [wrongNoOfArgsErr] (_ , _ , errs) -> raiseErrs errs where -- These options can be used without specifying a binding module. Then, -- the corresponding action is executed without any compilation to take -- place. (There can be --data and --output-dir (-t) options in addition -- to the action.) -- aloneOptions = [Help, Version, NumericVersion, Library] -- noCompOpts opts = let nonDataOpts = filter nonDataOrDir opts in (not . null) nonDataOpts && all (`elem` aloneOptions) nonDataOpts where nonDataOrDir (OutDir _) = False nonDataOrDir _ = True -- parseArgs :: [FilePath] -> Maybe (FilePath, [FilePath]) parseArgs = parseArgs' [] Nothing where parseArgs' hs (Just chs) [] = Just (chs, reverse hs) parseArgs' hs Nothing (file:files) | FilePath.takeExtension file == '.':chssuffix = parseArgs' hs (Just file) files parseArgs' hs chs (file:files) | FilePath.takeExtension file == '.':hsuffix = parseArgs' (file:hs) chs files parseArgs' _ _ _ = Nothing -- doExecute opts args = do execute opts args `fatalsHandledBy` failureHandler CIO.exitWith CIO.ExitSuccess -- wrongNoOfArgsErr = "There must be exactly one binding file (suffix .chs),\n\ \and optionally one or more header files (suffix .h).\n" -- -- exception handler -- failureHandler err = do let msg = ioeGetErrorString err fnMsg = case ioeGetFileName err of Nothing -> "" Just s -> " (file: `" ++ s ++ "')" CIO.hPutStrLn stderr (msg ++ fnMsg) CIO.exitWith $ CIO.ExitFailure 1 -- | set up base configuration -- setup :: CST s () setup = do setCPP CConf.cpp addCPPOpts cppopts -- | output error message -- raiseErrs :: [String] -> CST s a raiseErrs errs = do CIO.hPutStr stderr (concat errs) CIO.hPutStr stderr errTrailer CIO.exitWith $ CIO.ExitFailure 1 -- Process tasks -- ------------- -- | execute the compilation task -- -- * if 'Help' is present, emit the help message and ignore the rest -- * if 'Version' is present, do it first (and only once) -- * actual compilation is only invoked if we have one or two extra arguments -- (otherwise, it is just skipped) -- execute :: [Flag] -> Maybe (FilePath, [FilePath]) -> CST s () execute opts args | Help `elem` opts = help | otherwise = do let (vs,opts') = partition (\opt -> opt == Version || opt == NumericVersion) opts mapM_ processOpt (atMostOne vs ++ opts') case args of Just (bndFile, headerFiles) -> do let bndFileWithoutSuffix = FilePath.dropExtension bndFile computeOutputName bndFileWithoutSuffix process headerFiles bndFileWithoutSuffix `fatalsHandledBy` die Nothing -> computeOutputName "." -- we need the output name for library copying copyLibrary `fatalsHandledBy` die where atMostOne = (foldl (\_ x -> [x]) []) -- die ioerr = do name <- CIO.getProgName CIO.putStr $ name ++ ": " ++ ioeGetErrorString ioerr ++ "\n" CIO.exitWith $ CIO.ExitFailure 1 -- | emit help message -- help :: CST s () help = do CIO.putStr (usageInfo header options) CIO.putStr trailer CIO.putStr $ "PLATFORM can be " ++ hosts ++ "\n" CIO.putStr $ " (default is " ++ identPS defaultPlatformSpec ++ ")\n" where hosts = (concat . intersperse ", " . map identPS) platformSpecDB -- | process an option -- -- * 'Help' cannot occur -- processOpt :: Flag -> CST s () processOpt (CPPOpts cppopt ) = addCPPOpts [cppopt] processOpt (CPP cpp ) = setCPP cpp processOpt (Dump dt ) = setDump dt processOpt (Keep ) = setKeep processOpt (Library ) = setLibrary processOpt (Include dirs ) = setInclude dirs processOpt (Output fname ) = setOutput fname processOpt (Platform fname ) = setPlatform fname processOpt (OutDir fname ) = setOutDir fname processOpt Version = do CIO.putStrLn version platform <- getSwitch platformSB CIO.putStr " build platform is " CIO.print platform processOpt NumericVersion = CIO.putStrLn (showVersion versnum) processOpt (Error msg ) = abort msg -- | emit error message and raise an error -- abort :: String -> CST s () abort msg = do CIO.hPutStrLn stderr msg CIO.hPutStr stderr errTrailer fatal "Error in command line options" -- | Compute the base name for all generated files (Haskell, C header, and .chi -- file) -- -- * The result is available from the 'outputSB' switch -- computeOutputName :: FilePath -> CST s () computeOutputName bndFileNoSuffix = setSwitch $ \sb@SwitchBoard{ outputSB = output } -> sb { outputSB = if null output then bndFileNoSuffix else output } -- | Copy the C2HS library if requested -- copyLibrary :: CST s () copyLibrary = do outdir <- getSwitch outDirSB library <- getSwitch librarySB datadir <- CIO.liftIO getDataDir let libFullName = datadir libfname libDestName = outdir libfname when library $ CIO.readFile libFullName >>= CIO.writeFile libDestName -- set switches -- ------------ -- | set the options for the C proprocessor -- addCPPOpts :: [String] -> CST s () addCPPOpts opts = setSwitch $ \sb -> sb {cppOptsSB = cppOptsSB sb ++ opts} -- | set the program name of the C proprocessor -- setCPP :: FilePath -> CST s () setCPP fname = setSwitch $ \sb -> sb {cppSB = fname} -- set the given dump option -- setDump :: DumpType -> CST s () setDump Trace = setTraces $ \ts -> ts {tracePhasesSW = True} setDump GenBind = setTraces $ \ts -> ts {traceGenBindSW = True} setDump CTrav = setTraces $ \ts -> ts {traceCTravSW = True} setDump CHS = setTraces $ \ts -> ts {dumpCHSSW = True} -- | set flag to keep the pre-processed header file -- setKeep :: CST s () setKeep = setSwitch $ \sb -> sb {keepSB = True} -- | set flag to copy library module in -- setLibrary :: CST s () setLibrary = setSwitch $ \sb -> sb {librarySB = True} -- | set the search directories for .chi files -- -- * Several -i flags are accumulated. Later paths have higher priority. -- -- * The current directory is always searched last because it is the -- standard value in the compiler state. -- setInclude :: String -> CST s () setInclude str = 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] -- | set the output file name -- setOutput :: FilePath -> CST s () setOutput fname = do when (FilePath.takeExtension fname /= '.':hssuffix) $ raiseErrs ["Output file should end in .hs!\n"] setSwitch $ \sb -> sb {outputSB = FilePath.dropExtension fname} -- | set platform -- setPlatform :: String -> CST s () setPlatform platform = case lookup platform platformAL of Nothing -> raiseErrs ["Unknown platform `" ++ platform ++ "'\n"] Just p -> setSwitch $ \sb -> sb {platformSB = p} where platformAL = [(identPS p, p) | p <- platformSpecDB] -- | set the output directory -- setOutDir :: FilePath -> CST s () setOutDir fname = setSwitch $ \sb -> sb {outDirSB = fname} -- | set the name of the generated header file -- setHeader :: FilePath -> CST s () setHeader fname = setSwitch $ \sb -> sb {headerSB = fname} -- compilation process -- ------------------- -- | read the binding module, construct a header, run it through CPP, read it, -- and finally generate the Haskell target -- -- * the header file name (first argument) may be empty; otherwise, it already -- contains the right suffix -- -- * the binding file name has been stripped of the .chs suffix -- process :: [FilePath] -> FilePath -> CST s () process headerFiles bndFile = do -- load the Haskell binding module -- (chsMod , warnmsgs) <- loadCHS bndFile CIO.putStr warnmsgs traceCHSDump chsMod -- -- extract CPP and inline-C embedded in the .chs file (all CPP and -- inline-C fragments are removed from the .chs tree and conditionals are -- replaced by structured conditionals) -- (header', strippedCHSMod, headerwarnmsgs) <- genHeader chsMod CIO.putStr headerwarnmsgs -- -- create new header file, make it #include `headerFile', and emit -- CPP and inline-C of .chs file into the new header -- outFName <- getSwitch outputSB outDir <- getSwitch outDirSB let newHeader = outFName <.> chssuffix <.> hsuffix newHeaderFile = outDir newHeader preprocFile = FilePath.takeBaseName outFName <.> isuffix CIO.writeFile newHeaderFile $ concat $ [ "#include \"" ++ headerFile ++ "\"\n" | headerFile <- headerFiles ] ++ header' -- -- Check if we can get away without having to keep a separate .chs.h file -- case headerFiles of [headerFile] | null header -> setHeader headerFile -- the generated .hs file will directly -- refer to this header rather than going -- through a one-line .chs.h file. _ -> setHeader newHeader -- -- run C preprocessor over the header -- cpp <- getSwitch cppSB cppOpts <- getSwitch cppOptsSB let args = cppOpts ++ [newHeaderFile] tracePreproc (unwords (cpp:args)) exitCode <- CIO.liftIO $ do preprocHnd <- openFile preprocFile WriteMode cppproc <- runProcess cpp args Nothing Nothing Nothing (Just preprocHnd) Nothing waitForProcess cppproc case exitCode of CIO.ExitFailure _ -> fatal "Error during preprocessing custom header file" _ -> return () -- -- load and analyse the C header file -- (cheader, preprocMsgs) <- loadAttrC preprocFile CIO.putStr preprocMsgs -- -- remove the pre-processed header and if we no longer need it, remove the -- custom header file too. -- keep <- getSwitch keepSB unless keep $ do CIO.removeFile preprocFile case headerFiles of [_headerFile] | null header -> CIO.removeFile newHeaderFile _ -> return () -- keep it since we'll need it to compile the .hs file -- -- expand binding hooks into plain Haskell -- (hsMod, chi, hooksMsgs) <- expandHooks cheader strippedCHSMod CIO.putStr hooksMsgs -- -- output the result -- dumpCHS (outDir outFName) hsMod True dumpCHI (outDir outFName) chi -- different suffix will be appended where tracePreproc cmd = putTraceStr tracePhasesSW $ "Invoking cpp as `" ++ cmd ++ "'...\n" traceCHSDump mod' = do flag <- traceSet dumpCHSSW when flag $ (do CIO.putStr ("...dumping CHS to `" ++ chsName ++ "'...\n") dumpCHS chsName mod' False) chsName = FilePath.takeBaseName bndFile <.> "dump" c2hs-0.16.4/src/C2HS/0000755000000000000000000000000012044310770012113 5ustar0000000000000000c2hs-0.16.4/src/C2HS/Switches.hs0000644000000000000000000001041212044310770014236 0ustar0000000000000000-- C -> Haskell Compiler: management of switches -- -- Author : Manuel M T Chakravarty -- Created: 6 March 99 -- -- Copyright (c) [1999..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module manages C2HS's compiler switches. It exports the data types -- used to store the switches and operations on them. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Overview over the switches: -- -- * The cpp options specify the options passed to the C preprocessor. -- -- * The cpp filename gives the name of the executable of the C preprocessor. -- -- * The `keep' flag says whether the intermediate file produced by the C -- pre-processor should be retained or not. -- -- * `platformSB' specifies the implementation-dependent parameters of the -- targeted C compiler (as far as they are relevant to c2hs); this includes -- especially the conventions for the memory layout of bitfields -- -- * Traces specify which trace information should be output by the compiler. -- Currently the following trace information is supported: -- -- - information about phase activation and phase completion -- -- * After processing the compiler options, `outputSB' contains the base name -- for the generated Haskell, C header, and .chi files. However, during -- processing compiler options, `outputSB' contains arguments to the -- `--output' option and `outDirSB' contains arguments to the -- `--output-dir' option. -- --- TODO ---------------------------------------------------------------------- -- module C2HS.Switches ( SwitchBoard(..), Traces(..), initialSwitchBoard ) where import C2HS.Config (PlatformSpec, defaultPlatformSpec) -- the switch board contains all toolkit switches -- ---------------------------------------------- -- | all switches of the toolkit -- data SwitchBoard = SwitchBoard { cppOptsSB :: [String], -- cpp options cppSB :: FilePath, -- cpp executable keepSB :: Bool, -- keep intermediate file librarySB :: Bool, -- copy library in tracesSB :: Traces, -- trace flags outputSB :: FilePath, -- basename of generated files outDirSB :: FilePath, -- dir where generated files go platformSB:: PlatformSpec, -- target platform spec. headerSB :: FilePath, -- generated header file chiPathSB :: [FilePath] -- .chi file directories } -- | switch states on startup -- initialSwitchBoard :: SwitchBoard initialSwitchBoard = SwitchBoard { cppOptsSB = [], cppSB = "cpp", keepSB = False, librarySB = False, tracesSB = initialTraces, outputSB = "", outDirSB = "", platformSB = defaultPlatformSpec, headerSB = "", chiPathSB = ["."] } -- traces -- ------ -- | different kinds of traces possible -- data Traces = Traces { tracePhasesSW :: Bool, traceGenBindSW :: Bool, traceCTravSW :: Bool, dumpCHSSW :: Bool } -- | trace setting on startup -- -- * all traces are initially off -- initialTraces :: Traces initialTraces = Traces { tracePhasesSW = False, traceGenBindSW = False, traceCTravSW = False, dumpCHSSW = False } c2hs-0.16.4/src/C2HS/Config.hs0000644000000000000000000001267712044310770013671 0ustar0000000000000000-- -*-haskell-*- -- ** @configure_input@ ** -- =========================================================================== -- C -> Haskell Compiler: configuration -- -- Author : Manuel M T Chakravarty -- Created: 27 September 99 -- -- Copyright (c) [1999..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- Configuration options; largely set by `configure'. -- --- TODO ---------------------------------------------------------------------- -- module C2HS.Config ( -- -- programs and paths -- cpp, cppopts, libfname, hpaths, -- -- parameters of the targeted C compiler -- PlatformSpec(..), defaultPlatformSpec, platformSpecDB ) where import Foreign (toBool) import Foreign.C (CInt(..)) import System.Info (arch, os) -- program settings -- ---------------- -- | C preprocessor executable -- cpp :: FilePath cpp = case os of "darwin" -> "gcc" _ -> "cpp" -- | C preprocessor options -- -- * `-x c' forces CPP to regard the input as C code; this option seems to be -- understood at least on Linux, FreeBSD, and Solaris and seems to make a -- difference over the default language setting on FreeBSD -- -- * @-P@ would suppress @#line@ directives -- cppopts :: [String] cppopts = case (os,cpp) of -- why is gcc different between all these platforms? ("openbsd","cpp") -> ["-xc"] (_,"cpp") -> ["-x", "c"] (_,"gcc") -> ["-E", "-x", "c"] _ -> [] -- | C2HS Library file name -- libfname :: FilePath libfname = "C2HS.hs" -- | Standard system search paths for header files -- hpaths :: [FilePath] hpaths = [".", "/usr/include", "/usr/local/include"] -- parameters of the targeted C compiler -- ------------------------------------- -- | Parameters that characterise implementation-dependent features of the -- targeted C compiler -- data PlatformSpec = PlatformSpec { identPS :: String, -- platform identifier bitfieldDirectionPS :: Int, -- to fill bitfields bitfieldPaddingPS :: Bool, -- padding or split? bitfieldIntSignedPS :: Bool, -- `int' signed bitf.? bitfieldAlignmentPS :: Int -- alignment constraint } instance Show PlatformSpec where show (PlatformSpec ident dir pad intSig align) = show ident ++ " <" ++ show dir ++ ", " ++ show pad ++ ", " ++ show intSig ++ ", " ++ show align ++ ">" -- | Platform specification for the C compiler used to compile c2hs (which is -- the default target). -- defaultPlatformSpec :: PlatformSpec defaultPlatformSpec = PlatformSpec { identPS = arch ++ "-" ++ os, bitfieldDirectionPS = bitfieldDirection, bitfieldPaddingPS = bitfieldPadding, bitfieldIntSignedPS = bitfieldIntSigned, bitfieldAlignmentPS = bitfieldAlignment } -- | The set of platform specification that may be choosen for cross compiling -- bindings. -- platformSpecDB :: [PlatformSpec] platformSpecDB = [ PlatformSpec { identPS = "x86_64-linux", bitfieldDirectionPS = 1, bitfieldPaddingPS = True, bitfieldIntSignedPS = True, bitfieldAlignmentPS = 1 }, PlatformSpec { identPS = "i686-linux", bitfieldDirectionPS = 1, bitfieldPaddingPS = True, bitfieldIntSignedPS = True, bitfieldAlignmentPS = 1 }, PlatformSpec { identPS = "m68k-palmos", bitfieldDirectionPS = -1, bitfieldPaddingPS = True, bitfieldIntSignedPS = True, bitfieldAlignmentPS = 1 } ] -- | indicates in which direction the C compiler fills bitfields -- -- * the value is 1 or -1, depending on whether the direction is growing -- towards the MSB -- bitfieldDirection :: Int bitfieldDirection = fromIntegral bitfield_direction foreign import ccall "config.h" bitfield_direction :: CInt -- | indicates whether a bitfield that does not fit into a partially filled -- storage unit in its entirety introduce padding or split over two storage -- units -- -- * 'True' means that such a bitfield introduces padding (instead of being -- split) -- bitfieldPadding :: Bool bitfieldPadding = toBool bitfield_padding foreign import ccall "config.h" bitfield_padding :: CInt -- | indicates whether a bitfield of type `int' is signed in the targeted C -- compiler -- bitfieldIntSigned :: Bool bitfieldIntSigned = toBool bitfield_int_signed foreign import ccall "config.h" bitfield_int_signed :: CInt -- | the alignment constraint for a bitfield -- -- * this makes the assumption that the alignment of a bitfield is independent -- of the bitfield's size -- bitfieldAlignment :: Int bitfieldAlignment = fromIntegral bitfield_alignment foreign import ccall "config.h" bitfield_alignment :: CInt c2hs-0.16.4/src/C2HS/State.hs0000644000000000000000000000613312044310770013532 0ustar0000000000000000-- C -> Haskell Compiler: C2HS's state -- -- Author : Manuel M. T. Chakravarty -- Created: 6 March 1999 -- -- Copyright (c) 1999 Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module instantiates the Compiler Toolkit's extra state with C2HS's -- uncommon state information that should be stored in the Toolkit's base -- state. -- -- This modules re-exports everything provided by `State', and thus, should be -- used as the single reference to state related functionality within C2HS. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- State components: -- -- - compiler switches -- --- TODO ---------------------------------------------------------------------- -- module C2HS.State (-- re-exports all of `State' -- module Control.State, -- -- instantiation of `PreCST' with C2HS's extra state -- CST, runC2HS, -- -- switches -- SwitchBoard(..), Traces(..), setTraces, traceSet, putTraceStr, setSwitch, getSwitch) where import Control.Monad (when) import System.IO (stderr) import Control.State import qualified System.CIO as CIO import C2HS.Switches (SwitchBoard(..), Traces(..), initialSwitchBoard) -- instantiation of the extra state -- -------------------------------- -- | the extra state consists of the `SwitchBoard' -- type CST s a = PreCST SwitchBoard s a -- | execution of c2hs starts with the initial `SwitchBoard' -- runC2HS :: CST () a -> IO a runC2HS = run initialSwitchBoard -- switch management -- ----------------- -- | set traces according to the given transformation function -- setTraces :: (Traces -> Traces) -> CST s () setTraces t = updExtra (\es -> es {tracesSB = t (tracesSB es)}) -- | inquire the status a trace using the given inquiry function -- traceSet :: (Traces -> Bool) -> CST s Bool traceSet t = readExtra (t . tracesSB) -- | output the given string to `stderr' when the trace determined by the inquiry -- function is activated -- putTraceStr :: (Traces -> Bool) -> String -> CST s () putTraceStr t msg = do set <- traceSet t when set $ CIO.hPutStr stderr msg -- | set a switch value -- setSwitch :: (SwitchBoard -> SwitchBoard) -> CST s () setSwitch = updExtra -- | get a switch values -- getSwitch :: (SwitchBoard -> a) -> CST s a getSwitch = readExtra c2hs-0.16.4/src/C2HS/C.hs0000644000000000000000000001262412044310770012636 0ustar0000000000000000-- C->Haskell Compiler: interface to C processing routines -- -- Author : Manuel M. T. Chakravarty -- Created: 12 August 99 -- -- Copyright (c) 1999 Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This modules provides access to the C processing routines for the rest of -- the compiler. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- --- TODO ---------------------------------------------------------------------- -- -- module C2HS.C (-- interface to KL for all non-KL modules -- -- stuff from `Common' (reexported) -- Pos(posOf), -- -- structure tree -- module Language.C.Syntax, -- -- attributed structure tree with operations (reexported from -- `CAttrs') -- AttrC, CObj(..), CTag(..), CDef(..), lookupDefObjC, lookupDefTagC, getDefOfIdentC, -- -- support for C structure tree traversals -- module C2HS.C.Trav, -- loadAttrC, -- locally defined -- -- misc. reexported stuff -- Ident, NodeInfo, Attr(..), -- -- misc. own stuff -- csuffix, hsuffix, isuffix) where import Language.C.Data import Language.C.Syntax import Language.C.Parser import Data.Attributes (Attr(..)) import C2HS.State (CST, fatal, errorsPresent, showErrors, raiseError, getNameSupply, setNameSupply, Traces(..), putTraceStr) import System.CIO as CIO (liftIO) import C2HS.C.Attrs (AttrC, CObj(..), CTag(..), CDef(..), lookupDefObjC, lookupDefTagC, getDefOfIdentC) import C2HS.C.Names (nameAnalysis) import C2HS.C.Trav -- | suffix for files containing C -- csuffix, hsuffix, isuffix :: String csuffix = "c" hsuffix = "h" isuffix = "i" -- | parse a header file, raise an error if parsing failed parseHeader :: InputStream -> Position -> CST s CTranslUnit parseHeader is pos = do ns <- getNameSupply case execParser translUnitP is pos builtinTypeNames ns of Left (ParseError (msgs,pos')) -> raiseError pos' msgs >> return (CTranslUnit [] internalNode) Right (ct,ns') -> setNameSupply ns' >> return ct -- | given a file name (with suffix), parse that file as a C header and do the -- static analysis (collect defined names) -- -- * currently, lexical and syntactical errors are reported immediately and -- abort the program; others are reported as part of the fatal error message; -- warnings are returned together with the read unit -- loadAttrC :: String -> CST s (AttrC, String) loadAttrC fname = do -- read file -- traceInfoRead fname contents <- liftIO (readInputStream fname) -- parse -- traceInfoParse header <- parseHeader contents (initPos fname) -- name analysis -- traceInfoNA headerWithAttrs <- nameAnalysis header -- check for errors and finalize -- errs <- errorsPresent if errs then do traceInfoErr errmsgs <- showErrors fatal ("C header contains \ \errors:\n\n" ++ errmsgs) -- fatal error else do traceInfoOK warnmsgs <- showErrors return (headerWithAttrs, warnmsgs) where traceInfoRead fname' = putTraceStr tracePhasesSW ("Attempting to read file `" ++ fname' ++ "'...\n") traceInfoParse = putTraceStr tracePhasesSW ("...parsing `" ++ fname ++ "'...\n") traceInfoNA = putTraceStr tracePhasesSW ("...name analysis of `" ++ fname ++ "'...\n") traceInfoErr = putTraceStr tracePhasesSW ("...error(s) detected in `" ++ fname ++ "'.\n") traceInfoOK = putTraceStr tracePhasesSW ("...successfully loaded `" ++ fname ++ "'.\n") c2hs-0.16.4/src/C2HS/config.c0000644000000000000000000000613512044310770013531 0ustar0000000000000000/* C -> Haskell Compiler: configuration query routines * * Author : Manuel M T Chakravarty * Created: 12 November 1 * * Copyright (c) [2001..2002] Manuel M T Chakravarty * * This file is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This file is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * DESCRIPTION --------------------------------------------------------------- * * Runtime configuration query functions * * TODO ---------------------------------------------------------------------- */ #include "config.h" /* compute the direction in which bitfields are growing * ==================================================== */ union bitfield_direction_union { unsigned int allbits; struct { unsigned int first_bit : 1; unsigned int second_bit : 1; } twobits; }; int bitfield_direction () { union bitfield_direction_union v; /* if setting the second bit in a bitfield makes the storeage unit contain * the value `2', the direction of bitfields must be increasing towards the * MSB */ v.allbits = 0; v.twobits.second_bit = 1; return (2 == v.allbits ? 1 : -1); } /* use padding for overspilling bitfields? * ======================================= */ union bitfield_padding_union { struct { unsigned int allbits1; unsigned int allbits2; } allbits; struct { unsigned int first_bit : 1; int full_unit : sizeof (int) * 8; } somebits; }; int bitfield_padding () { union bitfield_padding_union v; /* test whether more than one bit of `full_unit' spills over into `allbits2' */ v.allbits.allbits1 = 0; v.allbits.allbits2 = 0; v.somebits.full_unit = -1; return v.allbits.allbits2 == -1; } /* is an `int' bitfield signed? * ============================ */ union bitfield_int_signed_union { struct { unsigned int first_bit : 1; unsigned int second_bit : 1; } two_single_bits; struct { int two_bits : 2; } two_bits; }; int bitfield_int_signed () { union bitfield_int_signed_union v; /* check whether a two bit field with both bits set, gives us a negative * number; then, `int' bitfields must be signed */ v.two_single_bits.first_bit = 1; v.two_single_bits.second_bit = 1; return v.two_bits.two_bits == -1; } /* alignment constraint for bitfields * ================================== */ struct bitfield_alignment_struct { char start; unsigned int bit : 1; char end; }; int bitfield_alignment () { struct bitfield_alignment_struct v; return ((int) (&v.end - &v.start)) - 1; } c2hs-0.16.4/src/C2HS/Version.hs0000644000000000000000000000153112044310770014074 0ustar0000000000000000module C2HS.Version (versnum, version, copyright, disclaimer) -- -*-haskell-*- where import qualified Paths_c2hs (version) import Data.Version (Version, showVersion) name, versnick, date, version, copyright, disclaimer :: String versnum :: Version name = "C->Haskell Compiler" versnum = Paths_c2hs.version versnick = "Crystal Seed" date = "24 Jan 2009" version = name ++ ", version " ++ showVersion versnum ++ " " ++ versnick ++ ", " ++ date copyright = "Copyright (c) 1999-2007 Manuel M T Chakravarty\n" ++ " 2005-2008 Duncan Coutts\n" ++ " 2008 Benedikt Huber" disclaimer = "This software is distributed under the \ \terms of the GNU Public Licence.\n\ \NO WARRANTY WHATSOEVER IS PROVIDED. \ \See the details in the documentation." c2hs-0.16.4/src/C2HS/config.h0000644000000000000000000000247212044310770013536 0ustar0000000000000000/* C -> Haskell Compiler: configuration query header * * Author : Manuel M T Chakravarty * Created: 12 November 1 * * Copyright (c) 2001 Manuel M T Chakravarty * * This file is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This file is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * DESCRIPTION --------------------------------------------------------------- * * Interface to the runtime configuration query functions. * * TODO ---------------------------------------------------------------------- */ #ifndef C2HS_CONFIG #define C2HS_CONFIG /* routines querying C compiler properties */ int bitfield_direction (); /* direction in which bitfields are growing */ int bitfield_padding (); /* use padding for overspilling bitfields? */ int bitfield_int_signed (); /* is an `int' bitfield signed? */ int bitfield_alignment (); /* alignment constraint for bitfields */ #endif /* C2HS_CONFIG*/ c2hs-0.16.4/src/C2HS/CHS.hs0000644000000000000000000014626512044310770013102 0ustar0000000000000000-- C->Haskell Compiler: CHS file abstraction -- -- Author : Manuel M T Chakravarty -- Created: 16 August 99 -- -- Copyright (c) [1999..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- Main file for reading CHS files. -- -- Import hooks & .chi files -- ------------------------- -- -- Reading of `.chi' files is interleaved with parsing. More precisely, -- whenever the parser comes across an import hook, it immediately reads the -- `.chi' file and inserts its contents into the abstract representation of -- the hook. The parser checks the version of the `.chi' file, but does not -- otherwise attempt to interpret its contents. This is only done during -- generation of the binding module. The first line of a .chi file has the -- form -- -- C->Haskell Interface Version -- -- where is the three component version number `Version.version'. -- C->Haskell will only accept files whose version number match its own in -- the first two components (ie, major and minor version). In other words, -- it must be guaranteed that the format of .chi files is not altered between -- versions that differ only in their patchlevel. All remaining lines of the -- file are version dependent and contain a dump of state information that -- the binding file generator needs to rescue across modules. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- The following binding hooks are recognised: -- -- hook -> `{#' inner `#}' -- inner -> `import' ['qualified'] ident -- | `context' ctxt -- | `type' ident -- | `sizeof' ident -- | `enum' idalias trans [`with' prefix] [deriving] -- | `call' [`pure'] [`unsafe'] idalias -- | `fun' [`pure'] [`unsafe'] idalias parms -- | `get' apath -- | `set' apath -- | `pointer' ['*'] idalias ptrkind ['nocode'] -- | `class' [ident `=>'] ident ident -- ctxt -> [`lib' `=' string] [prefix] -- idalias -> ident [`as' (ident | `^')] -- prefix -> `prefix' `=' string -- deriving -> `deriving' `(' ident_1 `,' ... `,' ident_n `)' -- parms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm -- parm -> [ident_or_quot_1 [`*' | `-']] verbhs [`&'] [ident_or_quot_2 [`*'] [`-']] -- ident_or_quot -> ident | quoths -- apath -> ident -- | `*' apath -- | apath `.' ident -- | apath `->' ident -- trans -> `{' alias_1 `,' ... `,' alias_n `}' -- alias -> `underscoreToCase' | `upcaseFirstLetter' -- | `downcaseFirstLetter' -- | ident `as' ident -- ptrkind -> [`foreign' | `stable'] ['newtype' | '->' ident] -- -- If `underscoreToCase', `upcaseFirstLetter', or `downcaseFirstLetter' -- occurs in a translation table, it must be the first entry, or if two of -- them occur the first two entries. -- -- Remark: Optional Haskell names are normalised during structure tree -- construction, ie, associations that associated a name with itself -- are removed. (They don't carry semantic content, and make some -- tests more complicated.) -- --- TODO ---------------------------------------------------------------------- -- module C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSChangeCase(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..), loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI, chisuffix, showCHSParm, apathToIdent) where -- standard libraries import Data.Char (isSpace, toUpper, toLower) import Data.List (intersperse) import Control.Monad (when) import System.FilePath ((<.>), ()) -- Language.C import Language.C.Data.Ident import Language.C.Data.Position import Data.Errors (interr) -- C->Haskell import C2HS.State (CST, getSwitch, chiPathSB, catchExc, throwExc, raiseError, fatal, errorsPresent, showErrors, Traces(..), putTraceStr) import qualified System.CIO as CIO import C2HS.Version (version) -- friends import C2HS.CHS.Lexer (CHSToken(..), lexCHS, keywordToIdent) -- CHS abstract syntax -- ------------------- -- | representation of a CHS module -- data CHSModule = CHSModule [CHSFrag] -- | a CHS code fragament -- -- * 'CHSVerb' fragments are present throughout the compilation and finally -- they are the only type of fragment (describing the generated Haskell -- code) -- -- * 'CHSHook' are binding hooks, which are being replaced by Haskell code by -- 'GenBind.expandHooks' -- -- * 'CHSCPP' and 'CHSC' are fragements of C code that are being removed when -- generating the custom C header in 'GenHeader.genHeader' -- -- * 'CHSCond' are strutured conditionals that are being generated by -- 'GenHeader.genHeader' from conditional CPP directives ('CHSCPP') -- data CHSFrag = CHSVerb String -- Haskell code Position | CHSHook CHSHook -- binding hook | CHSCPP String -- pre-processor directive Position | CHSLine Position -- line pragma | CHSC String -- C code Position | CHSCond [(Ident, -- C variable repr. condition [CHSFrag])] -- then/elif branches (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 (_, frag:_):_ -> posOf frag _ -> nopos -- | a CHS binding hook -- data CHSHook = CHSImport Bool -- qualified? Ident -- module name String -- content of .chi file Position | CHSContext (Maybe String) -- library name (Maybe String) -- prefix Position | CHSType Ident -- C type Position | CHSSizeof Ident -- C type Position | CHSAlignof Ident -- C type Position | CHSEnum Ident -- C enumeration type (Maybe Ident) -- Haskell name CHSTrans -- translation table (Maybe String) -- local prefix [Ident] -- instance requests from user Position | CHSEnumDefine Ident -- Haskell name CHSTrans -- translation table [Ident] -- instance requests from user Position | CHSCall Bool -- is a pure function? Bool -- is unsafe? CHSAPath -- C function (Maybe Ident) -- Haskell name Position | CHSFun Bool -- is a pure function? Bool -- is unsafe? CHSAPath -- C function (Maybe Ident) -- Haskell name (Maybe String) -- type context [CHSParm] -- argument marshalling CHSParm -- result marshalling Position | CHSField CHSAccess -- access type CHSAPath -- access path Position | CHSPointer Bool -- explicit '*' in hook Ident -- C pointer name (Maybe Ident) -- Haskell name CHSPtrType -- Ptr, ForeignPtr or StablePtr Bool -- create new type? (Maybe Ident) -- Haskell type pointed to Bool -- emit type decl? Position | CHSClass (Maybe Ident) -- superclass Ident -- class name Ident -- name of pointer type Position instance Pos CHSHook where posOf (CHSImport _ _ _ pos) = pos posOf (CHSContext _ _ pos) = pos posOf (CHSType _ pos) = pos posOf (CHSSizeof _ pos) = pos posOf (CHSAlignof _ pos) = pos posOf (CHSEnum _ _ _ _ _ pos) = pos posOf (CHSEnumDefine _ _ _ pos) = pos posOf (CHSCall _ _ _ _ pos) = pos posOf (CHSFun _ _ _ _ _ _ _ pos) = pos posOf (CHSField _ _ pos) = pos posOf (CHSPointer _ _ _ _ _ _ _ pos) = pos posOf (CHSClass _ _ _ pos) = pos -- | two hooks are equal if they have the same Haskell name and reference the -- same C object -- instance Eq CHSHook where (CHSImport qual1 ide1 _ _) == (CHSImport qual2 ide2 _ _) = qual1 == qual2 && ide1 == ide2 (CHSContext olib1 opref1 _ ) == (CHSContext olib2 opref2 _ ) = olib1 == olib2 && opref1 == opref2 (CHSType ide1 _) == (CHSType ide2 _) = ide1 == ide2 (CHSSizeof ide1 _) == (CHSSizeof ide2 _) = ide1 == ide2 (CHSAlignof ide1 _) == (CHSAlignof ide2 _) = ide1 == ide2 (CHSEnum ide1 oalias1 _ _ _ _) == (CHSEnum ide2 oalias2 _ _ _ _) = oalias1 == oalias2 && ide1 == ide2 (CHSEnumDefine ide1 _ _ _) == (CHSEnumDefine ide2 _ _ _) = ide1 == ide2 (CHSCall _ _ ide1 oalias1 _) == (CHSCall _ _ ide2 oalias2 _) = oalias1 == oalias2 && ide1 == ide2 (CHSFun _ _ ide1 oalias1 _ _ _ _) == (CHSFun _ _ ide2 oalias2 _ _ _ _) = oalias1 == oalias2 && ide1 == ide2 (CHSField acc1 path1 _) == (CHSField acc2 path2 _) = acc1 == acc2 && path1 == path2 (CHSPointer _ ide1 oalias1 _ _ _ _ _) == (CHSPointer _ ide2 oalias2 _ _ _ _ _) = ide1 == ide2 && oalias1 == oalias2 (CHSClass _ ide1 _ _) == (CHSClass _ ide2 _ _) = ide1 == ide2 _ == _ = False -- | translation table -- data CHSTrans = CHSTrans Bool -- underscore to case? CHSChangeCase -- upcase or downcase? [(Ident, Ident)] -- alias list data CHSChangeCase = CHSSameCase | CHSUpCase | CHSDownCase deriving Eq -- | marshaller consists of a function name or verbatim Haskell code -- and flag indicating whether it has to be executed in the IO monad -- type CHSMarsh = Maybe (Either Ident String, CHSArg) -- | marshalling descriptor for function hooks -- data CHSParm = CHSParm CHSMarsh -- "in" marshaller String -- Haskell type Bool -- C repr: two values? CHSMarsh -- "out" marshaller Position -- | kinds of arguments in function hooks -- data CHSArg = CHSValArg -- plain value argument | CHSIOArg -- reference argument | CHSVoidArg -- no argument | CHSIOVoidArg -- drops argument, but in monad deriving (Eq) -- | structure member access types -- data CHSAccess = CHSSet -- set structure field | CHSGet -- get structure field deriving (Eq) -- | structure access path -- data CHSAPath = CHSRoot Ident -- root of access path | CHSDeref CHSAPath Position -- dereferencing | CHSRef CHSAPath Ident -- member referencing deriving (Eq,Show) instance Pos CHSAPath where posOf (CHSRoot ide) = posOf ide posOf (CHSDeref _ pos) = pos posOf (CHSRef _ ide) = posOf ide -- | pointer options -- data CHSPtrType = CHSPtr -- standard Ptr from Haskell | CHSForeignPtr -- a pointer with a finalizer | CHSStablePtr -- a pointer into Haskell land deriving (Eq) instance Show CHSPtrType where show CHSPtr = "Ptr" show CHSForeignPtr = "ForeignPtr" show CHSStablePtr = "StablePtr" instance Read CHSPtrType where readsPrec _ ( 'P':'t':'r':rest) = [(CHSPtr, rest)] readsPrec _ ('F':'o':'r':'e':'i':'g':'n':'P':'t':'r':rest) = [(CHSForeignPtr, rest)] readsPrec _ ('S':'t':'a':'b':'l':'e' :'P':'t':'r':rest) = [(CHSStablePtr, rest)] readsPrec p (c:cs) | isSpace c = readsPrec p cs readsPrec _ _ = [] -- load and dump a CHS file -- ------------------------ hssuffix, chssuffix :: String hssuffix = "hs" chssuffix = "chs" -- | load a CHS module -- -- * the file suffix is automagically appended -- -- * in case of a syntactical or lexical error, a fatal error is raised; -- warnings are returned together with the module -- loadCHS :: FilePath -> CST s (CHSModule, String) loadCHS fname = do let fullname = fname <.> chssuffix -- read file -- traceInfoRead fullname contents <- CIO.readFile fullname -- parse -- traceInfoParse mod' <- parseCHSModule (initPos fullname) contents -- check for errors and finalize -- errs <- errorsPresent if errs then do traceInfoErr errmsgs <- showErrors fatal ("CHS module contains \ \errors:\n\n" ++ errmsgs) -- fatal error else do traceInfoOK warnmsgs <- showErrors return (mod', warnmsgs) where traceInfoRead fname' = putTraceStr tracePhasesSW ("Attempting to read file `" ++ fname' ++ "'...\n") traceInfoParse = putTraceStr tracePhasesSW ("...parsing `" ++ fname ++ "'...\n") traceInfoErr = putTraceStr tracePhasesSW ("...error(s) detected in `" ++ fname ++ "'.\n") traceInfoOK = putTraceStr tracePhasesSW ("...successfully loaded `" ++ fname ++ "'.\n") -- | given a file name (no suffix) and a CHS module, the module is printed -- into that file -- -- * the module can be flagged as being pure Haskell -- -- * the correct suffix will automagically be appended -- dumpCHS :: String -> CHSModule -> Bool -> CST s () dumpCHS fname mod' pureHaskell = do let (suffix, kind) = if pureHaskell then (hssuffix , "(Haskell)") else (chssuffix, "(C->HS binding)") CIO.writeFile (fname <.> suffix) (contents version kind) where contents version' kind = "-- GENERATED by " ++ version' ++ " " ++ kind ++ "\n\ \-- Edit the ORIGNAL .chs file instead!\n\n" ++ showCHSModule mod' pureHaskell -- | to keep track of the current state of the line emission automaton -- data LineState = Emit -- emit LINE pragma if next frag is Haskell | Wait -- emit LINE pragma after the next '\n' | NoLine -- no pragma needed deriving (Eq) -- | convert a CHS module into a string -- -- * if the second argument is 'True', all fragments must contain Haskell code -- showCHSModule :: CHSModule -> Bool -> String showCHSModule (CHSModule fragments) pureHaskell = showFrags pureHaskell Emit fragments [] where -- the second argument indicates whether the next fragment (if it is -- Haskell code) should be preceded by a LINE pragma; in particular -- generated fragments and those following them need to be prefixed with a -- LINE pragma -- showFrags :: Bool -> LineState -> [CHSFrag] -> ShowS showFrags _ _ [] = id showFrags pureHs state (CHSVerb s pos : frags) = let (fname,line) = (posFile pos, posRow pos) generated = isBuiltinPos pos emitNow = state == Emit || (state == Wait && not (null s) && head s == '\n') nextState = if generated then Wait else NoLine in (if emitNow then showString ("\n{-# LINE " ++ show (line `max` 0) ++ " " ++ show fname ++ " #-}") else id) . showString s . showFrags pureHs nextState frags showFrags False _ (CHSHook hook : frags) = showString "{#" . showCHSHook hook . showString "#}" . showFrags False Wait frags showFrags False _ (CHSCPP s _ : frags) = showChar '#' . showString s -- . showChar '\n' . showFrags False Emit frags showFrags pureHs _ (CHSLine _s : frags) = showFrags pureHs Emit frags showFrags False _ (CHSC s _ : frags) = showString "\n#c" . showString s . showString "\n#endc" . showFrags False Emit frags showFrags False _ (CHSCond _ _ : _ ) = interr "showCHSFrag: Cannot print `CHSCond'!" showFrags True _ _ = interr "showCHSFrag: Illegal hook, cpp directive, or inline C code!" showCHSHook :: CHSHook -> ShowS showCHSHook (CHSImport isQual ide _ _) = showString "import " . (if isQual then showString "qualified " else id) . showCHSIdent ide showCHSHook (CHSContext olib oprefix _) = showString "context " . (case olib of Nothing -> showString "" Just lib -> showString "lib = " . showString lib . showString " ") . showPrefix oprefix False showCHSHook (CHSType ide _) = showString "type " . showCHSIdent ide showCHSHook (CHSSizeof ide _) = showString "sizeof " . showCHSIdent ide showCHSHook (CHSAlignof ide _) = showString "alignof " . showCHSIdent ide showCHSHook (CHSEnum ide oalias trans oprefix derive _) = showString "enum " . showIdAlias ide oalias . showCHSTrans trans . showPrefix oprefix True . if null derive then id else showString $ "deriving (" ++ concat (intersperse ", " (map identToString derive)) ++ ") " showCHSHook (CHSEnumDefine ide trans derive _) = showString "enum define " . showCHSIdent ide . showCHSTrans trans . if null derive then id else showString $ "deriving (" ++ concat (intersperse ", " (map identToString derive)) ++ ") " showCHSHook (CHSCall isPure isUns ide oalias _) = showString "call " . (if isPure then showString "pure " else id) . (if isUns then showString "unsafe " else id) . showApAlias ide oalias showCHSHook (CHSFun isPure isUns ide oalias octxt parms parm _) = showString "fun " . (if isPure then showString "pure " else id) . (if isUns then showString "unsafe " else id) . showApAlias ide oalias . (case octxt of Nothing -> showChar ' ' Just ctxtStr -> showString ctxtStr . showString " => ") . showString "{" . foldr (.) id (intersperse (showString ", ") (map showCHSParm parms)) . showString "} -> " . showCHSParm parm showCHSHook (CHSField acc path _) = (case acc of CHSGet -> showString "get " CHSSet -> showString "set ") . showCHSAPath path showCHSHook (CHSPointer star ide oalias ptrType isNewtype oRefType emit _) = showString "pointer " . (if star then showString "*" else showString "") . showIdAlias ide oalias . (case ptrType of CHSForeignPtr -> showString " foreign" CHSStablePtr -> showString " stable" _ -> showString "") . (case (isNewtype, oRefType) of (True , _ ) -> showString " newtype" (False, Just ide') -> showString " -> " . showCHSIdent ide' (False, Nothing ) -> showString "") . (case emit of True -> showString "" False -> showString " nocode") showCHSHook (CHSClass oclassIde classIde typeIde _) = showString "class " . (case oclassIde of Nothing -> showString "" Just classIde' -> showCHSIdent classIde' . showString " => ") . showCHSIdent classIde . showString " " . showCHSIdent typeIde showPrefix :: Maybe String -> Bool -> ShowS showPrefix Nothing _ = showString "" showPrefix (Just prefix) withWith = maybeWith . showString "prefix = " . showString prefix . showString " " where maybeWith = if withWith then showString "with " else id showIdAlias :: Ident -> Maybe Ident -> ShowS showIdAlias ide oalias = showCHSIdent ide . (case oalias of Nothing -> id Just ide' -> showString " as " . showCHSIdent ide') showApAlias :: CHSAPath -> Maybe Ident -> ShowS showApAlias apath oalias = showCHSAPath apath . (case oalias of Nothing -> id Just ide -> showString " as " . showCHSIdent ide) showCHSParm :: CHSParm -> ShowS showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh _) = showOMarsh oimMarsh . showChar ' ' . showHsVerb hsTyStr . (if twoCVals then showChar '&' else id) . showChar ' ' . showOMarsh oomMarsh where showOMarsh Nothing = id showOMarsh (Just (body, argKind)) = showMarshBody body . (case argKind of CHSValArg -> id CHSIOArg -> showString "*" CHSVoidArg -> showString "-" CHSIOVoidArg -> showString "*-") -- showMarshBody (Left ide) = showCHSIdent ide showMarshBody (Right str) = showChar '|' . showString str . showChar '|' -- showHsVerb str = showChar '`' . showString str . showChar '\'' showCHSTrans :: CHSTrans -> ShowS showCHSTrans (CHSTrans _2Case chgCase assocs) = showString "{" . (if _2Case then showString ("underscoreToCase" ++ maybeComma) else id) . showCHSChangeCase chgCase . foldr (.) id (intersperse (showString ", ") (map showAssoc assocs)) . showString "}" where maybeComma = if null assocs then "" else ", " -- showAssoc (ide1, ide2) = showCHSIdent ide1 . showString " as " . showCHSIdent ide2 showCHSChangeCase :: CHSChangeCase -> ShowS showCHSChangeCase CHSSameCase = id showCHSChangeCase CHSUpCase = showString "upcaseFirstLetter" showCHSChangeCase CHSDownCase = showString "downcaseFirstLetter" showCHSAPath :: CHSAPath -> ShowS showCHSAPath (CHSRoot ide) = showCHSIdent ide showCHSAPath (CHSDeref path _) = showString "* " . showCHSAPath path showCHSAPath (CHSRef (CHSDeref path _) ide) = showCHSAPath path . showString "->" . showCHSIdent ide showCHSAPath (CHSRef path ide) = showCHSAPath path . showString "." . showCHSIdent ide showCHSIdent :: Ident -> ShowS showCHSIdent = showString . identToString -- load and dump a CHI file -- ------------------------ chisuffix :: String chisuffix = "chi" versionPrefix :: String versionPrefix = "C->Haskell Interface Version " -- | load a CHI file -- -- * the file suffix is automagically appended -- -- * any error raises a syntax exception (see below) -- -- * the version of the .chi file is checked against the version of the current -- executable; they must match in the major and minor version -- loadCHI :: FilePath -> CST s String loadCHI fname = do -- search for .chi files -- paths <- getSwitch chiPathSB let fullnames = [path fname <.> chisuffix | path <- paths] fullname <- findFirst fullnames (fatal $ fname <.> chisuffix ++ " not found in:\n"++ unlines paths) -- read file -- traceInfoRead fullname contents <- CIO.readFile fullname -- parse -- traceInfoVersion let ls = lines contents when (null ls) $ errorCHICorrupt fname let versline:chi = ls prefixLen = length versionPrefix when (length versline < prefixLen || take prefixLen versline /= versionPrefix) $ errorCHICorrupt fname let versline' = drop prefixLen versline (major, minor) <- case majorMinor versline' of Nothing -> errorCHICorrupt fname Just majMin -> return majMin let Just (myMajor, myMinor) = majorMinor version when (major /= myMajor || minor /= myMinor) $ errorCHIVersion fname (major ++ "." ++ minor) (myMajor ++ "." ++ myMinor) -- finalize -- traceInfoOK return $ concat chi where traceInfoRead fname' = putTraceStr tracePhasesSW ("Attempting to read file `" ++ fname' ++ "'...\n") traceInfoVersion = putTraceStr tracePhasesSW ("...checking version `" ++ fname ++ "'...\n") traceInfoOK = putTraceStr tracePhasesSW ("...successfully loaded `" ++ fname ++ "'.\n") findFirst [] err = err findFirst (p:aths) err = do e <- CIO.doesFileExist p if e then return p else findFirst aths err -- | given a file name (no suffix) and a CHI file, the information is printed -- into that file -- -- * the correct suffix will automagically be appended -- dumpCHI :: String -> String -> CST s () dumpCHI fname contents = do CIO.writeFile (fname <.> chisuffix) $ versionPrefix ++ version ++ "\n" ++ contents -- | extract major and minor number from a version string -- majorMinor :: String -> Maybe (String, String) majorMinor vers = let (major, rest) = break (== '.') vers (minor, _ ) = break (== '.') . tail $ rest in if null rest then Nothing else Just (major, minor) -- parsing a CHS token stream -- -------------------------- syntaxExc :: String syntaxExc = "syntax" -- | alternative action in case of a syntax exception -- ifError :: CST s a -> CST s a -> CST s a ifError action handler = action `catchExc` (syntaxExc, const handler) -- | raise syntax error exception -- raiseSyntaxError :: CST s a raiseSyntaxError = throwExc syntaxExc "syntax error" -- | parse a complete module -- -- * errors are entered into the compiler state -- parseCHSModule :: Position -> String -> CST s CHSModule parseCHSModule pos cs = do toks <- lexCHS cs pos frags <- parseFrags toks return (CHSModule frags) -- | parsing of code fragments -- -- * in case of an error, all tokens that are neither Haskell nor control -- tokens are skipped; afterwards parsing continues -- -- * when encountering inline-C code we scan forward over all inline-C and -- control tokens to avoid turning the control tokens within a sequence of -- inline-C into Haskell fragments -- parseFrags :: [CHSToken] -> CST s [CHSFrag] parseFrags tokens = do parseFrags0 tokens `ifError` contFrags tokens where parseFrags0 :: [CHSToken] -> CST s [CHSFrag] parseFrags0 [] = return [] parseFrags0 (CHSTokHaskell pos s:toks) = do frags <- parseFrags toks return $ CHSVerb s pos : frags parseFrags0 (CHSTokCtrl pos c:toks) = do frags <- parseFrags toks return $ CHSVerb [c] pos : frags parseFrags0 (CHSTokCPP pos s:toks) = do frags <- parseFrags toks return $ CHSCPP s pos : frags parseFrags0 (CHSTokLine pos :toks) = do frags <- parseFrags toks return $ CHSLine pos : frags parseFrags0 (CHSTokC pos s:toks) = parseC pos s toks parseFrags0 (CHSTokImport pos :toks) = parseImport pos toks parseFrags0 (CHSTokContext pos :toks) = parseContext pos toks parseFrags0 (CHSTokType pos :toks) = parseType pos toks parseFrags0 (CHSTokSizeof pos :toks) = parseSizeof pos toks parseFrags0 (CHSTokAlignof pos :toks) = parseAlignof pos toks parseFrags0 (CHSTokEnum pos :toks) = parseEnum pos toks parseFrags0 (CHSTokCall pos :toks) = parseCall pos toks parseFrags0 (CHSTokFun pos :toks) = parseFun pos toks parseFrags0 (CHSTokGet pos :toks) = parseField pos CHSGet toks parseFrags0 (CHSTokSet pos :toks) = parseField pos CHSSet toks parseFrags0 (CHSTokClass pos :toks) = parseClass pos toks parseFrags0 (CHSTokPointer pos :toks) = parsePointer pos toks parseFrags0 toks = syntaxError toks -- -- skip to next Haskell or control token -- contFrags [] = return [] contFrags toks@(CHSTokHaskell _ _:_ ) = parseFrags toks contFrags toks@(CHSTokCtrl _ _:_ ) = parseFrags toks contFrags (_ :toks) = contFrags toks parseC :: Position -> String -> [CHSToken] -> CST s [CHSFrag] parseC pos s toks = do frags <- collectCtrlAndC toks return $ CHSC s pos : frags where collectCtrlAndC (CHSTokCtrl pos' c :toks') = do frags <- collectCtrlAndC toks' return $ CHSC [c] pos' : frags collectCtrlAndC (CHSTokC pos' s':toks') = do frags <- collectCtrlAndC toks' return $ CHSC s' pos' : frags collectCtrlAndC toks' = parseFrags toks' parseImport :: Position -> [CHSToken] -> CST s [CHSFrag] parseImport pos toks = do (qual, modid, toks') <- case toks of CHSTokIdent _ ide :toks' -> let (ide', toks'') = rebuildModuleId ide toks' in return (False, ide', toks'') CHSTokQualif _: CHSTokIdent _ ide:toks' -> let (ide', toks'') = rebuildModuleId ide toks' in return (True , ide', toks'') _ -> syntaxError toks chi <- loadCHI . moduleNameToFileName . identToString $ modid toks'2 <- parseEndHook toks' frags <- parseFrags toks'2 return $ CHSHook (CHSImport qual modid chi pos) : frags -- | Qualified module names do not get lexed as a single token so we need to -- reconstruct it from a sequence of identifer and dot tokens. -- rebuildModuleId :: Ident -> [CHSToken] -> (Ident, [CHSToken]) rebuildModuleId ide (CHSTokDot _ : CHSTokIdent _ ide' : toks) = let catIdent ide'3 ide'4 = internalIdentAt (posOf ide'3) --FIXME: unpleasant hack (identToString ide'3 ++ '.' : identToString ide'4) in rebuildModuleId (catIdent ide ide') toks rebuildModuleId ide toks = (ide, toks) moduleNameToFileName :: String -> FilePath moduleNameToFileName = map dotToSlash where dotToSlash '.' = '/' dotToSlash c = c parseContext :: Position -> [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 parseType :: Position -> [CHSToken] -> CST s [CHSFrag] parseType pos (CHSTokIdent _ ide:toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSType ide pos) : frags parseType _ toks = syntaxError toks parseSizeof :: Position -> [CHSToken] -> CST s [CHSFrag] parseSizeof pos (CHSTokIdent _ ide:toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSSizeof ide pos) : frags parseSizeof _ toks = syntaxError toks parseAlignof :: Position -> [CHSToken] -> CST s [CHSFrag] parseAlignof pos (CHSTokIdent _ ide:toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSAlignof ide pos) : frags parseAlignof _ toks = syntaxError toks parseEnum :: Position -> [CHSToken] -> CST s [CHSFrag] -- {#enum define hsid {alias_1,...,alias_n} [deriving (clid_1,...,clid_n)] #} parseEnum pos (CHSTokIdent _ def: CHSTokIdent _ hsid: toks) | identToString def == "define" = do (trans , toks') <- parseTrans toks (derive, toks'') <- parseDerive toks' toks''' <- parseEndHook toks'' frags <- parseFrags toks''' return $ CHSHook (CHSEnumDefine hsid trans derive pos) : frags -- {#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 where norm Nothing = Nothing norm (Just ide') | ide == ide' = Nothing | otherwise = Just ide' parseEnum _ toks = syntaxError toks parseCall :: Position -> [CHSToken] -> CST s [CHSFrag] parseCall pos toks = do (isPure , toks' ) <- parseIsPure toks (isUnsafe, toks'' ) <- parseIsUnsafe toks' (apath , toks''' ) <- parsePath toks'' (oalias , toks'''') <- parseOptAs (apathToIdent apath) False toks''' toks''''' <- parseEndHook toks'''' frags <- parseFrags toks''''' return $ CHSHook (CHSCall isPure isUnsafe apath oalias pos) : frags parseFun :: Position -> [CHSToken] -> CST s [CHSFrag] parseFun pos toks = do (isPure , toks' ) <- parseIsPure toks (isUnsafe, toks'2) <- parseIsUnsafe toks' (apath , toks'3) <- parsePath toks'2 (oalias , toks'4) <- parseOptAs (apathToIdent apath) False toks'3 (octxt , toks'5) <- parseOptContext toks'4 (parms , toks'6) <- parseParms toks'5 (parm , toks'7) <- parseParm toks'6 toks'8 <- parseEndHook toks'7 frags <- parseFrags toks'8 return $ CHSHook (CHSFun isPure isUnsafe apath oalias octxt parms parm pos) : frags where parseOptContext (CHSTokHSVerb _ ctxt:CHSTokDArrow _:toks') = return (Just ctxt, toks') parseOptContext toks' = return (Nothing , toks') -- parseParms (CHSTokLBrace _:CHSTokRBrace _:CHSTokArrow _:toks') = return ([], toks') parseParms (CHSTokLBrace _ :toks') = parseParms' (CHSTokComma nopos:toks') parseParms toks' = syntaxError toks' -- parseParms' (CHSTokRBrace _:CHSTokArrow _:toks') = return ([], toks') parseParms' (CHSTokComma _ :toks') = do (parm , toks'2 ) <- parseParm toks' (parms, toks'3) <- parseParms' toks'2 return (parm:parms, toks'3) parseParms' (CHSTokRBrace _ :toks') = syntaxError toks' -- gives better error messages parseParms' toks' = syntaxError toks' parseIsPure :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsPure (CHSTokPure _:toks) = return (True , toks) parseIsPure (CHSTokFun _:toks) = return (True , toks) -- backwards compat. parseIsPure toks = return (False, toks) -- FIXME: eventually, remove `fun'; it's currently deprecated parseIsUnsafe :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsUnsafe (CHSTokUnsafe _:toks) = return (True , toks) parseIsUnsafe toks = return (False, toks) apathToIdent :: CHSAPath -> Ident apathToIdent (CHSRoot ide) = let lowerFirst (c:cs) = toLower c : cs in internalIdentAt (posOf ide) (lowerFirst $ identToString ide) apathToIdent (CHSDeref apath _) = let ide = apathToIdent apath in internalIdentAt (posOf ide) (identToString ide ++ "_") apathToIdent (CHSRef apath ide') = let ide = apathToIdent apath upperFirst (c:cs) = toLower c : cs sel = upperFirst $ identToString ide' in internalIdentAt (posOf ide) (identToString ide ++ sel) parseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken]) parseParm toks = do (oimMarsh, toks' ) <- parseOptMarsh toks (hsTyStr, twoCVals, pos, toks'2) <- case toks' of (CHSTokHSVerb pos hsTyStr:CHSTokAmp _:toks'2) -> return (hsTyStr, True , pos, toks'2) (CHSTokHSVerb pos hsTyStr :toks'2) -> return (hsTyStr, False, pos, toks'2) _toks -> syntaxError toks' (oomMarsh, toks'3) <- parseOptMarsh toks'2 return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh pos, toks'3) where parseOptMarsh :: [CHSToken] -> CST s (CHSMarsh, [CHSToken]) parseOptMarsh (CHSTokIdent _ ide:toks') = do (marshType, toks'2) <- parseOptMarshType toks' return (Just (Left ide, marshType), toks'2) parseOptMarsh (CHSTokHSQuot _ str:toks') = do (marshType, toks'2) <- parseOptMarshType toks' return (Just (Right str, marshType), toks'2) parseOptMarsh toks' = return (Nothing, toks') parseOptMarshType (CHSTokStar _ :CHSTokMinus _:toks') = return (CHSIOVoidArg , toks') parseOptMarshType (CHSTokStar _ :toks') = return (CHSIOArg , toks') parseOptMarshType (CHSTokMinus _:toks') = return (CHSVoidArg, toks') parseOptMarshType toks' = return (CHSValArg, toks') parseField :: Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag] parseField pos access toks = do (path, toks') <- parsePath toks toks'' <- parseEndHook toks' frags <- parseFrags toks'' return $ CHSHook (CHSField access path pos) : frags parsePointer :: Position -> [CHSToken] -> CST s [CHSFrag] parsePointer pos toks = do (isStar, ide, toks') <- case toks of CHSTokStar _:CHSTokIdent _ ide:toks' -> return (True , ide, toks') CHSTokIdent _ ide :toks' -> return (False, ide, toks') _ -> syntaxError toks (oalias , toks'2) <- parseOptAs ide True toks' (ptrType, toks'3) <- parsePtrType toks'2 let (isNewtype, oRefType, toks'4) = case toks'3 of CHSTokNewtype _ :toks'' -> (True , Nothing , toks'' ) CHSTokArrow _:CHSTokIdent _ ide':toks'' -> (False, Just ide', toks'' ) _ -> (False, Nothing , toks'3) let (emit, toks'5) = case toks'4 of CHSTokNocode _ :toks'' -> (False, toks'' ) _ -> (True , toks'4 ) toks'6 <- parseEndHook toks'5 frags <- parseFrags toks'6 return $ CHSHook (CHSPointer isStar ide (norm ide oalias) ptrType isNewtype oRefType emit pos) : frags where parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken]) parsePtrType (CHSTokForeign _:toks') = return (CHSForeignPtr, toks') parsePtrType (CHSTokStable _ :toks') = return (CHSStablePtr, toks') parsePtrType toks' = return (CHSPtr, toks') norm _ Nothing = Nothing norm ide (Just ide') | ide == ide' = Nothing | otherwise = Just ide' parseClass :: Position -> [CHSToken] -> CST s [CHSFrag] parseClass pos (CHSTokIdent _ sclassIde: CHSTokDArrow _ : CHSTokIdent _ classIde : CHSTokIdent _ typeIde : toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSClass (Just sclassIde) classIde typeIde pos) : frags parseClass pos (CHSTokIdent _ classIde : CHSTokIdent _ typeIde : toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSClass Nothing classIde typeIde pos) : frags parseClass _ toks = syntaxError toks parseOptLib :: [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptLib (CHSTokLib _ : CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks) parseOptLib (CHSTokLib _:toks ) = syntaxError toks parseOptLib toks = return (Nothing, toks) parseOptPrefix :: Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptPrefix False (CHSTokPrefix _ : CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks) parseOptPrefix True (CHSTokWith _ : CHSTokPrefix _ : CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks) parseOptPrefix _ (CHSTokWith _:toks) = syntaxError toks parseOptPrefix _ (CHSTokPrefix _:toks) = syntaxError toks parseOptPrefix _ toks = return (Nothing, toks) -- first argument is the identifier that is to be used when `^' is given and -- the second indicates whether the first character has to be upper case -- parseOptAs :: Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken]) parseOptAs _ _ (CHSTokAs _:CHSTokIdent _ ide:toks) = return (Just ide, toks) parseOptAs ide upper (CHSTokAs _:CHSTokHat pos :toks) = return (Just $ underscoreToCase ide upper pos, toks) parseOptAs _ _ (CHSTokAs _ :toks) = syntaxError toks parseOptAs _ _ toks = return (Nothing, toks) -- | convert C style identifier to Haskell style identifier -- underscoreToCase :: Ident -> Bool -> Position -> Ident underscoreToCase ide upper pos = let lexeme = identToString ide ps = filter (not . null) . parts $ lexeme in internalIdentAt pos . adjustHead . concat . map adjustCase $ ps where parts s = let (l, s') = break (== '_') s in l : case s' of [] -> [] (_:s'') -> parts s'' -- adjustCase "" = "" adjustCase (c:cs) = toUpper c : cs -- adjustHead "" = "" adjustHead (c:cs) = if upper then toUpper c : cs else toLower c:cs -- | this is disambiguated and left factored -- parsePath :: [CHSToken] -> CST s (CHSAPath, [CHSToken]) parsePath (CHSTokLParen _pos: toks) = do (inner_path, toks_rest) <- parsePath toks toks_rest' <- case toks_rest of (CHSTokRParen _pos' : ts) -> return ts _ -> syntaxError toks_rest (pathWithHole, toks') <- parsePath' toks_rest' return (pathWithHole inner_path, toks') parsePath (CHSTokStar pos:toks) = do (path, toks') <- parsePath toks return (CHSDeref path pos, toks') parsePath (tok:toks) = case keywordToIdent tok of (CHSTokIdent _ ide) -> do (pathWithHole, toks') <- parsePath' toks return (pathWithHole (CHSRoot ide), toks') _ -> syntaxError (tok:toks) parsePath toks = syntaxError toks -- | @s->m@ is represented by @(*s).m@ in the tree -- parsePath' :: [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken]) parsePath' tokens@(CHSTokDot _:desig:toks) = do ide <- case keywordToIdent desig of CHSTokIdent _ i -> return i; _ -> syntaxError tokens (pathWithHole, toks') <- parsePath' toks return (pathWithHole . (\hole -> CHSRef hole ide), toks') parsePath' tokens@(CHSTokArrow pos:desig:toks) = do ide <- case keywordToIdent desig of CHSTokIdent _ i -> return i; _ -> syntaxError tokens (pathWithHole, toks') <- parsePath' toks return (pathWithHole . (\hole -> CHSRef (CHSDeref hole pos) ide), toks') parsePath' toks = return (id,toks) parseTrans :: [CHSToken] -> CST s (CHSTrans, [CHSToken]) parseTrans (CHSTokLBrace _:toks) = do (_2Case, chgCase, toks' ) <- parse_2CaseAndChange toks case toks' of (CHSTokRBrace _:toks'2) -> return (CHSTrans _2Case chgCase [], toks'2) _ -> do -- if there was no `underscoreToCase', we add a comma token to meet -- the invariant of `parseTranss' -- (transs, toks'2) <- if (_2Case || chgCase /= CHSSameCase) then parseTranss toks' else parseTranss (CHSTokComma nopos:toks') return (CHSTrans _2Case chgCase transs, toks'2) where parse_2CaseAndChange (CHSTok_2Case _:CHSTokComma _:CHSTokUpper _:toks') = return (True, CHSUpCase, toks') parse_2CaseAndChange (CHSTok_2Case _:CHSTokComma _:CHSTokDown _ :toks') = return (True, CHSDownCase, toks') parse_2CaseAndChange (CHSTok_2Case _ :toks') = return (True, CHSSameCase, toks') parse_2CaseAndChange (CHSTokUpper _:CHSTokComma _:CHSTok_2Case _:toks') = return (True, CHSUpCase, toks') parse_2CaseAndChange (CHSTokUpper _ :toks') = return (False, CHSUpCase, toks') parse_2CaseAndChange (CHSTokDown _:CHSTokComma _:CHSTok_2Case _:toks') = return (True, CHSDownCase, toks') parse_2CaseAndChange (CHSTokDown _ :toks') = return (False, CHSDownCase, toks') parse_2CaseAndChange toks' = return (False, CHSSameCase, toks') -- parseTranss (CHSTokRBrace _:toks') = return ([], toks') parseTranss (CHSTokComma _:toks') = do (assoc, toks'2 ) <- parseAssoc toks' (trans, toks'3) <- parseTranss toks'2 return (assoc:trans, toks'3) parseTranss toks' = syntaxError toks' -- parseAssoc (CHSTokIdent _ ide1:CHSTokAs _:CHSTokIdent _ ide2:toks') = return ((ide1, ide2), toks') parseAssoc (CHSTokIdent _ _ :CHSTokAs _:toks' ) = syntaxError toks' parseAssoc (CHSTokIdent _ _ :toks' ) = syntaxError toks' parseAssoc toks' = syntaxError toks' parseTrans toks = syntaxError toks parseDerive :: [CHSToken] -> CST s ([Ident], [CHSToken]) parseDerive (CHSTokDerive _ :CHSTokLParen _:CHSTokRParen _:toks) = return ([], toks) parseDerive (CHSTokDerive _ :CHSTokLParen _:toks) = parseCommaIdent (CHSTokComma nopos:toks) where parseCommaIdent :: [CHSToken] -> CST s ([Ident], [CHSToken]) parseCommaIdent (CHSTokComma _:CHSTokIdent _ ide:toks') = do (ids, tok') <- parseCommaIdent toks' return (ide:ids, tok') parseCommaIdent (CHSTokRParen _ :toks') = return ([], toks') parseDerive toks = return ([],toks) parseEndHook :: [CHSToken] -> CST s ([CHSToken]) parseEndHook (CHSTokEndHook _:toks) = return toks parseEndHook toks = syntaxError toks syntaxError :: [CHSToken] -> CST s a syntaxError [] = errorEOF syntaxError (tok:_) = errorIllegal tok errorIllegal :: CHSToken -> CST s a errorIllegal tok = do raiseError (posOf tok) ["Syntax error!", "The phrase `" ++ show tok ++ "' is not allowed \ \here."] raiseSyntaxError errorEOF :: CST s a errorEOF = do raiseError nopos ["Premature end of file!", "The .chs file ends in the middle of a binding hook."] raiseSyntaxError errorCHICorrupt :: String -> CST s a errorCHICorrupt ide = do raiseError nopos ["Corrupt .chi file!", "The file `" ++ ide ++ ".chi' is corrupt."] raiseSyntaxError errorCHIVersion :: String -> String -> String -> CST s a errorCHIVersion ide chiVersion myVersion = do raiseError nopos ["Wrong version of .chi file!", "The file `" ++ ide ++ ".chi' is version " ++ chiVersion ++ ", but mine is " ++ myVersion ++ "."] raiseSyntaxError c2hs-0.16.4/src/C2HS/C/0000755000000000000000000000000012044310770012275 5ustar0000000000000000c2hs-0.16.4/src/C2HS/C/Names.hs0000644000000000000000000001773712044310770013713 0ustar0000000000000000-- C->Haskell Compiler: C name analysis -- -- Author : Manuel M. T. Chakravarty -- Created: 16 October 99 -- -- Copyright (c) 1999 Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- Name analysis of C header files. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * Member names are not looked up, because this requires type information -- about the expressions before the `.' or `->'. -- --- TODO ---------------------------------------------------------------------- -- -- * `defObjOrErr': currently, repeated declarations are completely ignored; -- eventually, the consistency of the declarations should be checked -- module C2HS.C.Names (nameAnalysis) where import Language.C.Data.Ident import Language.C.Data.Position import Language.C.Syntax import C2HS.State (CST) import C2HS.C.Attrs (AttrC, emptyAttrC, CObj(..), CTag(..), CDef(..)) import C2HS.C.Trav (CT, runCT, enterObjs, leaveObjs, ifCTExc, raiseErrorCTExc, defObj, findTypeObj, findValueObj, defTag, refersToDef, isTypedef) import C2HS.C.Builtin -- monad and wrapper -- ----------------- -- | local instance of the C traversal monad -- type NA a = CT () a -- | name analysis of C header files -- nameAnalysis :: CTranslUnit -> CST s AttrC nameAnalysis headder = do (ac', _) <- runCT (naCTranslUnit headder) emptyAttrC () return ac' -- name analyis traversal -- ---------------------- -- | traverse a complete header file -- -- * in case of an error, back off the current declaration -- naCTranslUnit :: CTranslUnit -> NA () naCTranslUnit (CTranslUnit decls _) = do -- establish definitions for builtins -- mapM_ (uncurry defObjOrErr) builtinTypeNames -- -- analyse the header -- mapM_ (\decl -> naCExtDecl decl `ifCTExc` return ()) decls -- | Processing of toplevel declarations -- -- * We turn function definitions into prototypes, as we are not interested in -- function bodies. -- naCExtDecl :: CExtDecl -> NA () naCExtDecl (CDeclExt decl ) = naCDecl decl naCExtDecl (CFDefExt (CFunDef specs declr _ _ at)) = naCDecl $ CDecl specs [(Just declr, Nothing, Nothing)] at naCExtDecl _ = return () naCDecl :: CDecl -> NA () naCDecl decl@(CDecl specs decls _) = do mapM_ naCDeclSpec specs mapM_ naTriple decls where naTriple (odeclr, oinit, oexpr) = do let obj = if isTypedef decl then TypeCO decl else ObjCO decl mapMaybeM_ (naCDeclr obj) odeclr mapMaybeM_ naCInit oinit mapMaybeM_ naCExpr oexpr naCDeclSpec :: CDeclSpec -> NA () naCDeclSpec (CTypeSpec tspec) = naCTypeSpec tspec naCDeclSpec _ = return () naCTypeSpec :: CTypeSpec -> NA () naCTypeSpec (CSUType su _) = naCStructUnion (StructUnionCT su) su naCTypeSpec (CEnumType enum _) = naCEnum (EnumCT enum) enum naCTypeSpec (CTypeDef ide _) = do (obj, _) <- findTypeObj ide False ide `refersToDef` ObjCD obj naCTypeSpec _ = return () naCStructUnion :: CTag -> CStructUnion -> NA () naCStructUnion tag (CStruct _ oide decls _ _) = do mapMaybeM_ (`defTagOrErr` tag) oide enterObjs -- enter local struct range for objects mapM_ naCDecl (maybe [] id decls) leaveObjs -- leave range naCEnum :: CTag -> CEnum -> NA () naCEnum tag enum@(CEnum oide enumrs _ _) = do mapMaybeM_ (`defTagOrErr` tag) oide mapM_ naEnumr (maybe [] id enumrs) where naEnumr (ide, oexpr) = do ide `defObjOrErr` EnumCO ide enum mapMaybeM_ naCExpr oexpr -- Name analysis of a declarator -- The derivations are analysed in order, only THEN -- the object itself is entered into the symboltable naCDeclr :: CObj -> CDeclr -> NA () naCDeclr obj (CDeclr oide derived _ _ _) = do mapM_ (naCDerivedDeclr obj) derived mapMaybeM_ (`defObjOrErr` obj) oide naCDerivedDeclr :: CObj -> CDerivedDeclr -> NA () naCDerivedDeclr _obj (CFunDeclr (Right (params,_)) _ _) = do enterObjs mapM_ naCDecl params leaveObjs naCDerivedDeclr _obj (CArrDeclr _ (CArrSize _ expr) _) = naCExpr expr naCDerivedDeclr _obj _ = return () naCInit :: CInit -> NA () naCInit (CInitExpr expr _) = naCExpr expr naCInit (CInitList inits _) = mapM_ (naCInit . snd) inits naCExpr :: CExpr -> NA () naCExpr (CComma exprs _) = mapM_ naCExpr exprs naCExpr (CAssign _ expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2 naCExpr (CCond expr1 expr2 expr3 _) = naCExpr expr1 >> mapMaybeM_ naCExpr expr2 >> naCExpr expr3 naCExpr (CBinary _ expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2 naCExpr (CCast decl expr _) = naCDecl decl >> naCExpr expr naCExpr (CUnary _ expr _) = naCExpr expr naCExpr (CSizeofExpr expr _) = naCExpr expr naCExpr (CSizeofType decl _) = naCDecl decl naCExpr (CAlignofExpr expr _) = naCExpr expr naCExpr (CAlignofType decl _) = naCDecl decl naCExpr (CIndex expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2 naCExpr (CCall expr exprs _) = naCExpr expr >> mapM_ naCExpr exprs naCExpr (CMember expr _ide _ _) = naCExpr expr naCExpr (CVar ide _) = do (obj, _) <- findValueObj ide False ide `refersToDef` ObjCD obj naCExpr (CConst _ ) = return () naCExpr (CCompoundLit _ inits _) = mapM_ (naCInit . snd) inits naCExpr (CComplexImag expr _) = naCExpr expr naCExpr (CComplexReal expr _) = naCExpr expr naCExpr (CLabAddrExpr _lab _) = error "Names.hs: adress of label expression analysis isn't supported" naCExpr (CBuiltinExpr _ ) = error "Names.hs: builtin expression analysis isn't supported" naCExpr (CStatExpr _ _) = error "Names.hs: analysis of GNU statement - expression isn't supported" -- auxilliary functions -- -------------------- -- | raise an error and exception if the identifier is defined twice defTagOrErr :: Ident -> CTag -> NA () ide `defTagOrErr` tag = do otag <- ide `defTag` tag case otag of Nothing -> return () Just tag' -> declaredTwiceErr ide (posOf tag') -- | associate an object with a referring identifier -- -- * currently, repeated declarations are completely ignored; eventually, the -- consistency of the declarations should be checked -- defObjOrErr :: Ident -> CObj -> NA () ide `defObjOrErr` obj = ide `defObj` obj >> return () -- | maps some monad operation into a 'Maybe', discarding the result -- mapMaybeM_ :: Monad m => (a -> m b) -> Maybe a -> m () mapMaybeM_ _ Nothing = return () mapMaybeM_ m (Just a) = m a >> return () -- error messages -- -------------- declaredTwiceErr :: Ident -> Position -> NA a declaredTwiceErr ide otherPos = raiseErrorCTExc (posOf ide) ["Identifier declared twice!", "The identifier `" ++ identToString ide ++ "' was already declared at " ++ show otherPos ++ "."] c2hs-0.16.4/src/C2HS/C/Trav.hs0000644000000000000000000007723312044310770013561 0ustar0000000000000000-- C->Haskell Compiler: traversals of C structure tree -- -- Author : Manuel M. T. Chakravarty -- Created: 16 October 99 -- -- Copyright (c) [1999..2001] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This modules provides for traversals of C structure trees. The C -- traversal monad supports traversals that need convenient access to the -- attributes of an attributed C structure tree. The monads state can still -- be extended. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Handling of redefined tag values -- -------------------------------- -- -- Structures allow both -- -- struct s {...} ...; -- struct s ...; -- -- and -- -- struct s ...; /* this is called a forward reference */ -- struct s {...} ...; -- -- In contrast enumerations only allow (in ANSI C) -- -- enum e {...} ...; -- enum e ...; -- -- The function `defTag' handles both types and establishes an object -- association from the tag identifier in the empty declaration (ie, the one -- without `{...}') to the actually definition of the structure of -- enumeration. This implies that when looking for the details of a -- structure or enumeration, possibly a chain of references on tag -- identifiers has to be chased. Note that the object association attribute -- is _not_defined_ when the `{...}' part is present in a declaration. -- --- TODO ---------------------------------------------------------------------- -- -- * `extractStruct' doesn't account for forward declarations that have no -- full declaration yet; if `extractStruct' is called on such a declaration, -- we have a user error, but currently an internal error is raised -- module C2HS.C.Trav (CT, readCT, transCT, runCT, throwCTExc, ifCTExc, raiseErrorCTExc, enter, enterObjs, leave, leaveObjs, defObj, findObj, findObjShadow, defTag, findTag, findTagShadow, applyPrefixToNameSpaces, getDefOf, refersToDef, refersToNewDef, getDeclOf, findTypeObjMaybe, findTypeObj, findValueObj, findFunObj, -- -- C structure tree query functions -- isTypedef, simplifyDecl, declrFromDecl, declrNamed, declaredDeclr, declaredName, structMembers, expandDecl, structName, enumName, tagName, isPtrDeclr, dropPtrDeclr, isPtrDecl, isFunDeclr, structFromDecl, funResultAndArgs, chaseDecl, findAndChaseDecl, checkForAlias, checkForOneCUName, checkForOneAliasName, lookupEnum, lookupStructUnion, lookupDeclOrTag) where import Data.List (find) import Control.Monad (liftM) import Control.Exception (assert) import Language.C.Data import Language.C.Data.Ident (dumpIdent) import Language.C.Syntax import Data.Attributes import Data.Errors import C2HS.State (CST, readCST, transCST, runCST, raiseError, catchExc, throwExc, Traces(..), putTraceStr) import C2HS.C.Attrs (AttrC(..), enterNewRangeC, enterNewObjRangeC, leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC, lookupDefObjCShadow, addDefTagC, lookupDefTagC, lookupDefTagCShadow, applyPrefix, getDefOfIdentC, setDefOfIdentC, updDefOfIdentC, CObj(..), CTag(..), CDef(..)) -- the C traversal monad -- --------------------- -- | C traversal monad -- type CState s = (AttrC, s) type CT s a = CST (CState s) a -- | read attributed struture tree -- readAttrCCT :: (AttrC -> a) -> CT s a readAttrCCT reader = readCST $ \(ac, _) -> reader ac -- | transform attributed structure tree -- transAttrCCT :: (AttrC -> (AttrC, a)) -> CT s a transAttrCCT trans = transCST $ \(ac, s) -> let (ac', r) = trans ac in ((ac', s), r) -- | access to the user-defined state -- -- | read user-defined state -- readCT :: (s -> a) -> CT s a readCT reader = readCST $ \(_, s) -> reader s -- | transform user-defined state -- transCT :: (s -> (s, a)) -> CT s a transCT trans = transCST $ \(ac, s) -> let (s', r) = trans s in ((ac, s'), r) -- usage of a traversal monad -- -- | execute a traversal monad -- -- * given a traversal monad, an attribute structure tree, and a user -- state, the transformed structure tree and monads result are returned -- runCT :: CT s a -> AttrC -> s -> CST t (AttrC, a) runCT m ac s = runCST m' (ac, s) where m' = do r <- m (ac', _) <- readCST id return (ac', r) -- exception handling -- ------------------ -- | exception identifier -- ctExc :: String ctExc = "ctExc" -- | throw an exception -- throwCTExc :: CT s a throwCTExc = throwExc ctExc "Error during traversal of a C structure tree" -- | catch a `ctExc' -- ifCTExc :: CT s a -> CT s a -> CT s a ifCTExc m handler = m `catchExc` (ctExc, const handler) -- | raise an error followed by throwing a CT exception -- raiseErrorCTExc :: Position -> [String] -> CT s a raiseErrorCTExc pos errs = raiseError pos errs >> throwCTExc -- attribute manipulation -- ---------------------- -- name spaces -- -- | enter a new local range -- enter :: CT s () enter = transAttrCCT $ \ac -> (enterNewRangeC ac, ()) -- | enter a new local range, only for objects -- enterObjs :: CT s () enterObjs = transAttrCCT $ \ac -> (enterNewObjRangeC ac, ()) -- | leave the current local range -- leave :: CT s () leave = transAttrCCT $ \ac -> (leaveRangeC ac, ()) -- | leave the current local range, only for objects -- leaveObjs :: CT s () leaveObjs = transAttrCCT $ \ac -> (leaveObjRangeC ac, ()) -- | enter an object definition into the object name space -- -- * if a definition of the same name was already present, it is returned -- defObj :: Ident -> CObj -> CT s (Maybe CObj) defObj ide obj = do traceCTrav $ "Defining object "++show ide++"...\n" transAttrCCT $ \ac -> addDefObjC ac ide obj -- | find a definition in the object name space -- findObj :: Ident -> CT s (Maybe CObj) findObj ide = readAttrCCT $ \ac -> lookupDefObjC ac ide -- | find a definition in the object name space; if nothing found, try -- whether there is a shadow identifier that matches -- findObjShadow :: Ident -> CT s (Maybe (CObj, Ident)) findObjShadow ide = readAttrCCT $ \ac -> lookupDefObjCShadow ac ide -- | enter a tag definition into the tag name space -- -- * empty definitions of structures get overwritten with complete ones and a -- forward reference is added to their tag identifier; furthermore, both -- structures and enums may be referenced using an empty definition when -- there was a full definition earlier and in this case there is also an -- object association added; otherwise, if a definition of the same name was -- already present, it is returned (see DOCU section) -- -- * it is checked that the first occurence of an enumeration tag is -- accompanied by a full definition of the enumeration -- defTag :: Ident -> CTag -> CT s (Maybe CTag) defTag ide tag = do traceCTrav $ "Defining tag "++show ide++"...\n" otag <- transAttrCCT $ \ac -> addDefTagC ac ide tag case otag of Nothing -> do assertIfEnumThenFull tag return Nothing -- no collision Just prevTag -> case isRefinedOrUse prevTag tag of Nothing -> return otag Just (fullTag, foreIde) -> do transAttrCCT $ \ac -> addDefTagC ac ide fullTag foreIde `refersToDef` TagCD fullTag return Nothing -- transparent for env where -- compute whether we have the case of a non-conflicting redefined tag -- definition, and if so, return the full definition and the foreward -- definition's tag identifier -- -- * the first argument contains the _previous_ definition -- -- * in the case of a structure, a foreward definition after a full -- definition is allowed, so we have to handle this case; enumerations -- don't allow foreward definitions -- -- * there may also be multiple foreward definition; if we have two of -- them here, one is arbitrarily selected to take the role of the full -- definition -- isRefinedOrUse (StructUnionCT (CStruct _ (Just ide') Nothing _ _)) tag'@(StructUnionCT (CStruct _ (Just _ ) _ _ _)) = Just (tag', ide') isRefinedOrUse tag'@(StructUnionCT (CStruct _ (Just _ ) _ _ _)) (StructUnionCT (CStruct _ (Just ide') Nothing _ _)) = Just (tag', ide') isRefinedOrUse tag'@(EnumCT (CEnum (Just _ ) _ _ _)) (EnumCT (CEnum (Just ide') Nothing _ _)) = Just (tag', ide') isRefinedOrUse _ _ = Nothing -- | find an definition in the tag name space -- findTag :: Ident -> CT s (Maybe CTag) findTag ide = readAttrCCT $ \ac -> lookupDefTagC ac ide -- | find an definition in the tag name space; if nothing found, try -- whether there is a shadow identifier that matches -- findTagShadow :: Ident -> CT s (Maybe (CTag, Ident)) findTagShadow ide = readAttrCCT $ \ac -> lookupDefTagCShadow ac ide -- | enrich the object and tag name space with identifiers obtained by dropping -- the given prefix from the identifiers already in the name space -- -- * if a new identifier would collides with an existing one, the new one is -- discarded, ie, all associations that existed before the transformation -- started are still in effect after the transformation -- applyPrefixToNameSpaces :: String -> CT s () applyPrefixToNameSpaces prefix = transAttrCCT $ \ac -> (applyPrefix ac prefix, ()) -- definition attribute -- -- | get the definition of an identifier -- -- * the attribute must be defined, ie, a definition must be associated with -- the given identifier -- getDefOf :: Ident -> CT s CDef getDefOf ide = do def <- readAttrCCT $ \ac -> getDefOfIdentC ac ide assert (not . isUndef $ def) $ return def -- | set the definition of an identifier -- refersToDef :: Ident -> CDef -> CT s () refersToDef ide def = do traceCTrav $ "linking identifier: "++ dumpIdent ide ++ " --> " ++ show def transAttrCCT $ \akl -> (setDefOfIdentC akl ide def, ()) -- | update the definition of an identifier -- refersToNewDef :: Ident -> CDef -> CT s () refersToNewDef ide def = transAttrCCT $ \akl -> (updDefOfIdentC akl ide def, ()) -- | get the declarator of an identifier -- getDeclOf :: Ident -> CT s CDecl getDeclOf ide = do traceEnter def <- getDefOf ide case def of UndefCD -> interr "CTrav.getDeclOf: Undefined!" DontCareCD -> interr "CTrav.getDeclOf: Don't care!" TagCD _ -> interr "CTrav.getDeclOf: Illegal tag!" ObjCD obj -> case obj of TypeCO decl -> traceTypeCO >> return decl ObjCO decl -> traceObjCO >> return decl EnumCO _ _ -> illegalEnum BuiltinCO -> illegalBuiltin where illegalEnum = interr "CTrav.getDeclOf: Illegal enum!" illegalBuiltin = interr "CTrav.getDeclOf: Attempted to get declarator of \ \builtin entity!" -- if the latter ever becomes necessary, we have to -- change the representation of builtins and give them -- some dummy declarator traceEnter = traceCTrav $ "Entering `getDeclOf' for `" ++ identToString ide ++ "'...\n" traceTypeCO = traceCTrav $ "...found a type object.\n" traceObjCO = traceCTrav $ "...found a vanilla object.\n" -- convenience functions -- -- | find a type object in the object name space; returns 'Nothing' if the -- identifier is not defined -- -- * if the second argument is 'True', use 'findObjShadow' -- findTypeObjMaybe :: Ident -> Bool -> CT s (Maybe (CObj, Ident)) findTypeObjMaybe ide useShadows = do oobj <- if useShadows then findObjShadow ide else liftM (fmap (\obj -> (obj, ide))) $ findObj ide case oobj of Just obj@(TypeCO _ , _) -> return $ Just obj Just obj@(BuiltinCO, _) -> return $ Just obj Just _ -> typedefExpectedErr ide Nothing -> return $ Nothing -- | find a type object in the object name space; raises an error and exception -- if the identifier is not defined -- -- * if the second argument is 'True', use 'findObjShadow' -- findTypeObj :: Ident -> Bool -> CT s (CObj, Ident) findTypeObj ide useShadows = do oobj <- findTypeObjMaybe ide useShadows case oobj of Nothing -> unknownObjErr ide Just obj -> return obj -- | find an object, function, or enumerator in the object name space; raises an -- error and exception if the identifier is not defined -- -- * if the second argument is 'True', use 'findObjShadow' -- findValueObj :: Ident -> Bool -> CT s (CObj, Ident) findValueObj ide useShadows = do oobj <- if useShadows then findObjShadow ide else liftM (fmap (\obj -> (obj, ide))) $ findObj ide case oobj of Just obj@(ObjCO _ , _) -> return obj Just obj@(EnumCO _ _, _) -> return obj Just _ -> unexpectedTypedefErr (posOf ide) Nothing -> unknownObjErr ide -- | find a function in the object name space; raises an error and exception if -- the identifier is not defined -- -- * if the second argument is 'True', use 'findObjShadow' -- findFunObj :: Ident -> Bool -> CT s (CObj, Ident) findFunObj ide useShadows = do (obj, ide') <- findValueObj ide useShadows case obj of EnumCO _ _ -> funExpectedErr (posOf ide) ObjCO decl -> do let declr = ide' `declrFromDecl` decl assertFunDeclr (posOf ide) declr return (obj, ide') -- C structure tree query routines -- ------------------------------- -- | test if this is a type definition specification -- isTypedef :: CDecl -> Bool isTypedef (CDecl specs _ _) = not . null $ [() | CStorageSpec (CTypedef _) <- specs] -- | discard all declarators but the one declaring the given identifier -- -- * the declaration must contain the identifier -- simplifyDecl :: Ident -> CDecl -> CDecl ide `simplifyDecl` (CDecl specs declrs at) = case find (`declrPlusNamed` ide) declrs of Nothing -> err Just declr -> CDecl specs [declr] at where (Just declr, _, _) `declrPlusNamed` ide' = declr `declrNamed` ide' _ `declrPlusNamed` _ = False -- err = interr $ "CTrav.simplifyDecl: Wrong C object!\n\ \ Looking for `" ++ identToString ide ++ "' in decl \ \at " ++ show (posOf at) -- | extract the declarator that declares the given identifier -- -- * the declaration must contain the identifier -- declrFromDecl :: Ident -> CDecl -> CDeclr ide `declrFromDecl` decl = let CDecl _ [(Just declr, _, _)] _ = ide `simplifyDecl` decl in declr -- | tests whether the given declarator has the given name -- declrNamed :: CDeclr -> Ident -> Bool declr `declrNamed` ide = declrName declr == Just ide -- | get the declarator of a declaration that has at most one declarator -- declaredDeclr :: CDecl -> Maybe CDeclr declaredDeclr (CDecl _ [] _) = Nothing declaredDeclr (CDecl _ [(odeclr, _, _)] _) = odeclr declaredDeclr decl = interr $ "CTrav.declaredDeclr: Too many declarators!\n\ \ Declaration at " ++ show (posOf decl) -- | get the name declared by a declaration that has exactly one declarator -- declaredName :: CDecl -> Maybe Ident declaredName decl = declaredDeclr decl >>= declrName -- | obtains the member definitions and the tag of a struct -- -- * member definitions are expanded -- structMembers :: CStructUnion -> ([CDecl], CStructTag) structMembers (CStruct tag _ members _ _) = (concat . map expandDecl $ maybe [] id members, tag) -- | expand declarators declaring more than one identifier into multiple -- declarators, eg, `int x, y;' becomes `int x; int y;' -- expandDecl :: CDecl -> [CDecl] expandDecl (CDecl specs decls at) = map (\decl -> CDecl specs [decl] at) decls -- | get a struct's name -- structName :: CStructUnion -> Maybe Ident structName (CStruct _ oide _ _ _) = oide -- | get an enum's name -- enumName :: CEnum -> Maybe Ident enumName (CEnum oide _ _ _) = oide -- | get a tag's name -- -- * fail if the tag is anonymous -- tagName :: CTag -> Ident tagName tag = case tag of StructUnionCT struct -> maybe err id $ structName struct EnumCT enum -> maybe err id $ enumName enum where err = interr "CTrav.tagName: Anonymous tag definition" -- | checks whether the given declarator defines an object that is a pointer to -- some other type -- -- * as far as parameter passing is concerned, arrays are also pointer -- isPtrDeclr :: CDeclr -> Bool isPtrDeclr (CDeclr _ (CPtrDeclr _ _:_) _ _ _) = True isPtrDeclr (CDeclr _ (CArrDeclr _ _ _:_) _ _ _) = True isPtrDeclr _ = False -- | drops the first pointer level from the given declarator -- -- * the declarator must declare a pointer object -- -- * arrays are considered to be pointers -- -- FIXME: this implementation isn't nice, because we retain the 'CVarDeclr' -- unchanged; as the declarator is changed, we should maybe make this -- into an anonymous declarator and also change its attributes -- dropPtrDeclr :: CDeclr -> CDeclr dropPtrDeclr (CDeclr ide (outermost:derived) asm ats node) = case outermost of (CPtrDeclr _ _) -> CDeclr ide derived asm ats node (CArrDeclr _ _ _) -> CDeclr ide derived asm ats node _ -> interr "CTrav.dropPtrDeclr: No pointer!" -- | checks whether the given declaration defines a pointer object -- -- * there may only be a single declarator in the declaration -- isPtrDecl :: CDecl -> Bool isPtrDecl (CDecl _ [] _) = False isPtrDecl (CDecl _ [(Just declr, _, _)] _) = isPtrDeclr declr isPtrDecl _ = interr "CTrav.isPtrDecl: There was more than one declarator!" -- | checks whether the given declarator defines a function object -- isFunDeclr :: CDeclr -> Bool isFunDeclr (CDeclr _ (CFunDeclr _ _ _:_) _ _ _) = True isFunDeclr _ = False -- | extract the structure from the type specifiers of a declaration -- structFromDecl :: Position -> CDecl -> CT s CStructUnion structFromDecl pos (CDecl specs _ _) = case head [ts | CTypeSpec ts <- specs] of CSUType su _ -> extractStruct pos (StructUnionCT su) _ -> structExpectedErr pos -- | extracts the arguments from a function declaration (must be a unique -- declarator) and constructs a declaration for the result of the function -- -- * the boolean result indicates whether the function is variadic -- -- * returns an abstract declarator funResultAndArgs :: CDecl -> ([CDecl], CDecl, Bool) funResultAndArgs cdecl@(CDecl specs [(Just declr, _, _)] _) = let (args, declr', variadic) = funArgs declr result = CDecl specs [(Just declr', Nothing, Nothing)] (newAttrsOnlyPos (posOf cdecl)) in (args, result, variadic) where funArgs (CDeclr _ide derived _asm _ats node) = case derived of (CFunDeclr (Right (args,variadic)) _ats' _dnode : derived') -> (args, CDeclr Nothing derived' Nothing [] node, variadic) (CFunDeclr (Left _) _ _ : _) -> interr "CTrav.funResultAndArgs: Old style function definition" _ -> interr "CTrav.funResultAndArgs: Illegal declarator!" -- name chasing -- -- | find the declarator identified by the given identifier; if the declarator -- is itself only a 'typedef'ed name, the operation recursively searches for -- the declarator associated with that name (this is called ``typedef -- chasing'') -- -- * if `ind = True', we have to hop over one indirection -- -- * remove all declarators except the one we just looked up -- chaseDecl :: Ident -> Bool -> CT s CDecl -- -- * cycles are no issue, as they cannot occur in a correct C header (we would -- have spotted the problem during name analysis) -- chaseDecl ide ind = do traceEnter cdecl <- getDeclOf ide let sdecl = ide `simplifyDecl` cdecl case extractAlias sdecl ind of Just (ide', ind') -> chaseDecl ide' ind' Nothing -> return sdecl where traceEnter = traceCTrav $ "Entering `chaseDecl' for `" ++ identToString ide ++ "' " ++ (if ind then "" else "not ") ++ "following indirections...\n" -- | find type object in object name space and then chase it -- -- * see also 'chaseDecl' -- -- * also create an object association from the given identifier to the object -- that it _directly_ represents -- -- * if the third argument is 'True', use 'findObjShadow' -- findAndChaseDecl :: Ident -> Bool -> Bool -> CT s CDecl findAndChaseDecl ide ind useShadows = do (obj, ide') <- findTypeObj ide useShadows -- is there an object def? ide `refersToNewDef` ObjCD obj ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing chaseDecl ide' ind -- | given a declaration (which must have exactly one declarator), if the -- declarator is an alias, chase it to the actual declaration -- checkForAlias :: CDecl -> CT s (Maybe CDecl) checkForAlias decl = case extractAlias decl False of Nothing -> return Nothing Just (ide', _) -> liftM Just $ chaseDecl ide' False -- | given a declaration (which must have exactly one declarator), if the -- declarator is an alias, yield the alias name; *no* chasing -- checkForOneAliasName :: CDecl -> Maybe Ident checkForOneAliasName decl = fmap fst $ extractAlias decl False -- | given a declaration, find the name of the struct/union type checkForOneCUName :: CDecl -> Maybe Ident checkForOneCUName decl@(CDecl specs _ _) = case [ts | CTypeSpec ts <- specs] of [CSUType (CStruct _ n _ _ _) _] -> case declaredDeclr decl of Nothing -> n Just (CDeclr _ [] _ _ _) -> n -- no type derivations _ -> Nothing _ -> Nothing -- smart lookup -- -- | for the given identifier, either find an enumeration in the tag name space -- or a type definition referring to an enumeration in the object name space; -- raises an error and exception if the identifier is not defined -- -- * if the second argument is 'True', use 'findTagShadow' -- lookupEnum :: Ident -> Bool -> CT s CEnum lookupEnum ide useShadows = do otag <- if useShadows then liftM (fmap fst) $ findTagShadow ide else findTag ide case otag of Just (StructUnionCT _ ) -> enumExpectedErr ide -- wrong tag definition Just (EnumCT enum) -> return enum -- enum tag definition Nothing -> do -- no tag definition (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 -- -- * if the third argument is `True', use `findTagShadow' -- -- * when finding a forward definition of a tag, follow it to the real -- definition -- lookupStructUnion :: Ident -> Bool -> Bool -> CT s CStructUnion lookupStructUnion ide 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 structFromDecl (posOf ide) decl -- | for the given identifier, check for the existance of both a type definition -- or a struct, union, or enum definition -- -- * if a typedef and a tag exists, the typedef takes precedence -- -- * typedefs are chased -- -- * if the second argument is `True', look for shadows, too -- lookupDeclOrTag :: Ident -> Bool -> CT s (Either CDecl CTag) lookupDeclOrTag ide useShadows = do oobj <- findTypeObjMaybe ide useShadows case oobj of Just (_, ide') -> liftM Left $ findAndChaseDecl ide' False False -- already did check shadows Nothing -> do otag <- if useShadows then liftM (fmap fst) $ findTagShadow ide else findTag ide case otag of Nothing -> unknownObjErr ide Just tag -> return $ Right tag -- auxiliary routines (internal) -- -- | if the given declaration (which may have at most one declarator) is a -- `typedef' alias, yield the referenced name -- -- * a `typedef' alias has one of the following forms -- -- at x, ...; -- at *x, ...; -- -- where `at' is the alias type, which has been defined by a `typedef', and -- are arbitrary specifiers and qualifiers. Note that `x' may be a -- variable, a type name (if `typedef' is in ), or be entirely -- omitted. -- -- * if `ind = True', the alias may be via an indirection -- -- * if `ind = True' and the alias is _not_ over an indirection, yield `True'; -- otherwise `False' (ie, the ability to hop over an indirection is consumed) -- -- * this may be an anonymous declaration, ie, the name in `CVarDeclr' may be -- omitted or there may be no declarator at all -- extractAlias :: CDecl -> Bool -> Maybe (Ident, Bool) extractAlias decl@(CDecl specs _ _) ind = case [ts | CTypeSpec ts <- specs] of [CTypeDef ide' _] -> -- type spec is aliased ident case declaredDeclr decl of Nothing -> Just (ide', ind) Just (CDeclr _ [] _ _ _) -> Just (ide', ind) -- no type derivations Just (CDeclr _ [CPtrDeclr _ _] _ _ _) -- one pointer indirection | ind -> Just (ide', False) | otherwise -> Nothing _ -> Nothing _ -> Nothing -- | if the given tag is a forward declaration of a structure, follow the -- reference to the full declaration -- -- * the recursive call is not dangerous as there can't be any cycles -- extractStruct :: Position -> CTag -> CT s CStructUnion extractStruct pos (EnumCT _ ) = structExpectedErr pos extractStruct pos (StructUnionCT su) = case su of CStruct _ (Just ide') Nothing _ _ -> do -- found forward definition def <- getDefOf ide' case def of TagCD tag -> extractStruct pos tag bad_obj -> err ide' bad_obj _ -> return su where err ide bad_obj = do interr $ "CTrav.extractStruct: Illegal reference! Expected " ++ dumpIdent ide ++ " to link to TagCD but refers to "++ (show bad_obj) ++ "\n" -- | yield the name declared by a declarator if any -- declrName :: CDeclr -> Maybe Ident declrName (CDeclr oide _ _ _ _) = oide -- | raise an error if the given declarator does not declare a C function or if -- the function is supposed to return an array (the latter is illegal in C) -- assertFunDeclr :: Position -> CDeclr -> CT s () assertFunDeclr pos (CDeclr _ (CFunDeclr _ _ _:retderiv) _ _ _) = case retderiv of (CArrDeclr _ _ _:_) -> illegalFunResultErr pos _ -> return () -- ok, we have a function which doesn't return an array assertFunDeclr pos _ = funExpectedErr pos -- | 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 () traceCTrav = putTraceStr traceCTravSW -- error messages -- -------------- unknownObjErr :: Ident -> CT s a unknownObjErr ide = raiseErrorCTExc (posOf ide) ["Unknown identifier!", "Cannot find a definition for `" ++ identToString ide ++ "' in the \ \header file."] typedefExpectedErr :: Ident -> CT s a typedefExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected type definition!", "The identifier `" ++ identToString ide ++ "' needs to be a C type name."] unexpectedTypedefErr :: Position -> CT s a unexpectedTypedefErr pos = raiseErrorCTExc pos ["Unexpected type name!", "An object, function, or enum constant is required here."] illegalFunResultErr :: Position -> CT s a illegalFunResultErr pos = raiseErrorCTExc pos ["Function cannot return an array!", "ANSI C does not allow functions to return an array."] funExpectedErr :: Position -> CT s a funExpectedErr pos = raiseErrorCTExc pos ["Function expected!", "A function is needed here, but this declarator does not declare", "a function."] enumExpectedErr :: Ident -> CT s a enumExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected enum!", "Expected `" ++ identToString ide ++ "' to denote an enum; instead found", "a struct, union, or object."] structExpectedErr :: Position -> CT s a structExpectedErr pos = raiseErrorCTExc pos ["Expected a struct!", "Expected a structure or union; instead found an enum or basic type."] enumForwardErr :: Position -> CT s a enumForwardErr pos = raiseErrorCTExc pos ["Forward definition of enumeration!", "ANSI C does not permit foreward definitions of enumerations!"] c2hs-0.16.4/src/C2HS/C/Info.hs0000644000000000000000000001716312044310770013534 0ustar0000000000000000{-# LANGUAGE CPP #-} -- C->Haskell Compiler: information about the C implementation -- -- Author : Manuel M T Chakravarty -- Created: 5 February 01 -- -- Copyright (c) [2001..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provide some information about the specific implementation of -- C that we are dealing with. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Bit fields -- ~~~~~~~~~~ -- Bit fields in C can be signed and unsigned. According to K&R A8.3, they -- can only be formed from `int', `signed int', and `unsigned int', where for -- `int' it is implementation dependent whether the field is signed or -- unsigned. Moreover, the following parameters are implementation -- dependent: -- -- * the direction of packing bits into storage units, -- * the size of storage units, and -- * whether when a field that doesn't fit a partially filled storage unit -- is split across units or the partially filled unit is padded. -- -- Generally, unnamed fields (those without an identifier) with a width of 0 -- are guaranteed to forces the above padding. Note that in `CPrimType' we -- only represent 0 width fields *if* they imply padding. In other words, -- whenever they are unnamed, they are represented by a `CPrimType', and if -- they are named, they are represented by a `CPrimType' only if that -- targeted C compiler chooses to let them introduce padding. If a field -- does not have any effect, it is dropped during the conversion of a C type -- into a `CPrimType'-based representation. -- -- In the code, we assume that the alignment of a bitfield (as determined by -- `bitfieldAlignment') is independent of the size of the bitfield. -- --- TODO ---------------------------------------------------------------------- -- module C2HS.C.Info ( CPrimType(..), size, alignment, getPlatform ) where import Foreign (Ptr, FunPtr) import qualified Foreign.Storable as Storable (Storable(sizeOf, alignment)) import Foreign.C import C2HS.Config (PlatformSpec(..)) import C2HS.State (getSwitch) import C2HS.Switches (platformSB) import C2HS.Gen.Monad (GB) import Data.Errors -- calibration of C's primitive types -- ---------------------------------- -- | C's primitive types -- -- * 'CFunPtrPT' doesn't occur in Haskell representations of C types, but we -- need to know their size, which may be different from 'CPtrPT' -- data CPrimType = CPtrPT -- void * | CFunPtrPT -- void *() | CCharPT -- char | CUCharPT -- unsigned char | CSCharPT -- signed char | CIntPT -- int | CShortPT -- short int | CLongPT -- long int | CLLongPT -- long long int | CUIntPT -- unsigned int | CUShortPT -- unsigned short int | CULongPT -- unsigned long int | CULLongPT -- unsigned long long int | CFloatPT -- float | CDoublePT -- double | CLDoublePT -- long double | CSFieldPT Int -- signed bit field | CUFieldPT Int -- unsigned bit field deriving (Eq) -- | size of primitive type of C -- -- * negative size implies that it is a bit, not an octet size -- size :: CPrimType -> Int size CPtrPT = Storable.sizeOf (undefined :: Ptr ()) size CFunPtrPT = Storable.sizeOf (undefined :: FunPtr ()) size CCharPT = 1 size CUCharPT = 1 size CSCharPT = 1 size CIntPT = Storable.sizeOf (undefined :: CInt) size CShortPT = Storable.sizeOf (undefined :: CShort) size CLongPT = Storable.sizeOf (undefined :: CLong) size CLLongPT = Storable.sizeOf (undefined :: CLLong) size CUIntPT = Storable.sizeOf (undefined :: CUInt) size CUShortPT = Storable.sizeOf (undefined :: CUShort) size CULongPT = Storable.sizeOf (undefined :: CULong) size CULLongPT = Storable.sizeOf (undefined :: CLLong) size CFloatPT = Storable.sizeOf (undefined :: CFloat) size CDoublePT = Storable.sizeOf (undefined :: CDouble) #if MIN_VERSION_base(4,2,0) size CLDoublePT = 0 --marks it as an unsupported type, see 'specType' #else size CLDoublePT = Storable.sizeOf (undefined :: CLDouble) #endif size (CSFieldPT bs) = -bs size (CUFieldPT bs) = -bs -- | alignment of C's primitive types -- -- * more precisely, the padding put before the type's member starts when the -- preceding component is a char -- alignment :: CPrimType -> GB Int alignment CPtrPT = return $ Storable.alignment (undefined :: Ptr ()) alignment CFunPtrPT = return $ Storable.alignment (undefined :: FunPtr ()) alignment CCharPT = return $ 1 alignment CUCharPT = return $ 1 alignment CSCharPT = return $ 1 alignment CIntPT = return $ Storable.alignment (undefined :: CInt) alignment CShortPT = return $ Storable.alignment (undefined :: CShort) alignment CLongPT = return $ Storable.alignment (undefined :: CLong) alignment CLLongPT = return $ Storable.alignment (undefined :: CLLong) alignment CUIntPT = return $ Storable.alignment (undefined :: CUInt) alignment CUShortPT = return $ Storable.alignment (undefined :: CUShort) alignment CULongPT = return $ Storable.alignment (undefined :: CULong) alignment CULLongPT = return $ Storable.alignment (undefined :: CULLong) alignment CFloatPT = return $ Storable.alignment (undefined :: CFloat) alignment CDoublePT = return $ Storable.alignment (undefined :: CDouble) #if MIN_VERSION_base(4,2,0) alignment CLDoublePT = interr "Info.alignment: CLDouble not supported" #else alignment CLDoublePT = return $ Storable.alignment (undefined :: CLDouble) #endif alignment (CSFieldPT bs) = fieldAlignment bs alignment (CUFieldPT bs) = fieldAlignment bs -- | alignment constraint for a C bitfield -- -- * gets the bitfield size (in bits) as an argument -- -- * alignments constraints smaller or equal to zero are reserved for bitfield -- alignments -- -- * bitfields of size 0 always trigger padding; thus, they get the maximal -- size -- -- * if bitfields whose size exceeds the space that is still available in a -- partially filled storage unit trigger padding, the size of a storage unit -- is provided as the alignment constraint; otherwise, it is 0 (meaning it -- definitely starts at the current position) -- -- * here, alignment constraint /= 0 are somewhat subtle; they mean that is -- the given number of bits doesn't fit in what's left in the current -- storage unit, alignment to the start of the next storage unit has to be -- triggered -- fieldAlignment :: Int -> GB Int fieldAlignment 0 = return $ - (size CIntPT - 1) fieldAlignment bs = do PlatformSpec {bitfieldPaddingPS = bitfieldPadding} <- getPlatform return $ if bitfieldPadding then - bs else 0 -- | obtain platform from switchboard -- getPlatform :: GB PlatformSpec getPlatform = getSwitch platformSB c2hs-0.16.4/src/C2HS/C/Attrs.hs0000644000000000000000000003365212044310770013737 0ustar0000000000000000-- C->Haskell Compiler: C attribute definitions and manipulation routines -- -- Author : Manuel M. T. Chakravarty -- Created: 12 August 99 -- -- Copyright (c) [1999..2001] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides the attributed version of the C structure tree. -- -- * C has several name spaces of which two are represented in this module: -- - `CObj' in `defObjsAC': The name space of objects, functions, typedef -- names, and enum constants. -- - `CTag' in `defTagsAC': The name space of tags of structures, unions, -- and enumerations. -- -- * The final state of the names spaces are preserved in the attributed -- structure tree. This allows further fast lookups for globally defined -- identifiers after the name anaysis is over. -- -- * In addition to the name spaces, the attribute structure tree contains -- a ident-definition table, which for attribute handles of identifiers -- refers to the identifiers definition. These are only used in usage -- occurences, except for one exception: The tag identifiers in forward -- definitions of structures or enums get a reference to the corresponding -- full definition - see `CTrav' for full details. -- -- * We maintain a shadow definition table, it can be populated with aliases -- to other objects and maps identifiers to identifiers. It is populated by -- using the `applyPrefix' function. When looksup performed via the shadow -- variant of a lookup function, shadow aliases are also considered, but -- they are used only if no normal entry for the identifiers is present. -- -- * Only ranges delimited by a block open a new range for tags (see -- `enterNewObjRangeC' and `leaveObjRangeC'). -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- --- TODO ---------------------------------------------------------------------- -- module C2HS.C.Attrs (-- attributed C -- AttrC(..), emptyAttrC, enterNewRangeC, enterNewObjRangeC, leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC, lookupDefObjCShadow, addDefTagC, lookupDefTagC, lookupDefTagCShadow, applyPrefix, getDefOfIdentC, setDefOfIdentC, updDefOfIdentC, freezeDefOfIdentsAttrC, softenDefOfIdentsAttrC, -- -- C objects -- CObj(..), CTag(..), CDef(..)) where import Data.Char (toUpper) import Data.Maybe (mapMaybe) import Language.C.Data.Node import Language.C.Data.Ident import Language.C.Data.Position import Language.C.Syntax import Language.C.Pretty import Text.PrettyPrint.HughesPJ import Data.Errors (interr) import Data.Attributes (Attr(..), AttrTable, getAttr, setAttr, updAttr, newAttrTable, freezeAttrTable, softenAttrTable) import Data.NameSpaces (NameSpace, nameSpace, enterNewRange, leaveRange, defLocal, defGlobal, find, nameSpaceToList) -- attributed C structure tree -- --------------------------- -- | attributes relevant to the outside world gathjered from a C unit -- data AttrC = AttrC { defObjsAC :: CObjNS, -- defined objects defTagsAC :: CTagNS, -- defined tags shadowsAC :: CShadowNS, -- shadow definitions (prefix) defsAC :: CDefTable -- ident-def associations } deriving (Show) -- | empty headder attribute set -- emptyAttrC :: AttrC emptyAttrC = AttrC { defObjsAC = cObjNS, defTagsAC = cTagNS, shadowsAC = cShadowNS, defsAC = cDefTable } -- the name space operations -- -- | enter a new range -- enterNewRangeC :: AttrC -> AttrC enterNewRangeC ac = ac { defObjsAC = enterNewRange . defObjsAC $ ac, defTagsAC = enterNewRange . defTagsAC $ ac } -- | enter a new range, only for objects -- enterNewObjRangeC :: AttrC -> AttrC enterNewObjRangeC ac = ac { defObjsAC = enterNewRange . defObjsAC $ ac } -- | leave the current range -- leaveRangeC :: AttrC -> AttrC leaveRangeC ac = ac { defObjsAC = fst . leaveRange . defObjsAC $ ac, defTagsAC = fst . leaveRange . defTagsAC $ ac } -- | leave the current range, only for objects -- leaveObjRangeC :: AttrC -> AttrC leaveObjRangeC ac = ac { defObjsAC = fst . leaveRange . defObjsAC $ ac } -- | add another definitions to the object name space -- -- * if a definition of the same name was already present, it is returned -- addDefObjC :: AttrC -> Ident -> CObj -> (AttrC, Maybe CObj) addDefObjC ac ide obj = let om = defObjsAC ac (ac', obj') = defLocal om ide obj in (ac {defObjsAC = ac'}, obj') -- | lookup an identifier in the object name space -- lookupDefObjC :: AttrC -> Ident -> Maybe CObj lookupDefObjC ac ide = find (defObjsAC ac) ide -- | lookup an identifier in the object name space; if nothing found, try -- whether there is a shadow identifier that matches -- -- * the returned identifier is the _real_ identifier of the object -- lookupDefObjCShadow :: AttrC -> Ident -> Maybe (CObj, Ident) lookupDefObjCShadow ac ide = case lookupDefObjC ac ide of Just obj -> Just (obj, ide) Nothing -> case find (shadowsAC ac) ide of Nothing -> Nothing Just ide' -> case lookupDefObjC ac ide' of Just obj -> Just (obj, ide') Nothing -> Nothing -- | add another definition to the tag name space -- -- * if a definition of the same name was already present, it is returned -- addDefTagC :: AttrC -> Ident -> CTag -> (AttrC, Maybe CTag) addDefTagC ac ide obj = let tm = defTagsAC ac (ac', obj') = defLocal tm ide obj in (ac {defTagsAC = ac'}, obj') -- | lookup an identifier in the tag name space -- lookupDefTagC :: AttrC -> Ident -> Maybe CTag lookupDefTagC ac ide = find (defTagsAC ac) ide -- | lookup an identifier in the tag name space; if nothing found, try -- whether there is a shadow identifier that matches -- -- * the returned identifier is the _real_ identifier of the tag -- lookupDefTagCShadow :: AttrC -> Ident -> Maybe (CTag, Ident) lookupDefTagCShadow ac ide = case lookupDefTagC ac ide of Just tag -> Just (tag, ide) Nothing -> case find (shadowsAC ac) ide of Nothing -> Nothing Just ide' -> case lookupDefTagC ac ide' of Just tag -> Just (tag, ide') Nothing -> Nothing -- | enrich the shadow name space with identifiers obtained by dropping -- the given prefix from the identifiers already in the object or tag name -- space -- -- * in case of a collisions, a random entry is selected -- -- * case is not relevant in the prefix and underscores between the prefix and -- the stem of an identifier are also dropped -- applyPrefix :: AttrC -> String -> AttrC applyPrefix ac prefix = let shadows = shadowsAC ac names = map fst (nameSpaceToList (defObjsAC ac)) ++ map fst (nameSpaceToList (defTagsAC ac)) newShadows = mapMaybe (strip prefix) names in ac {shadowsAC = foldl define shadows newShadows} where strip prefx ide = case eat prefx (identToString ide) of Nothing -> Nothing Just "" -> Nothing Just newName -> Just (internalIdentAt (posOf ide) newName, ide) -- eat [] ('_':cs) = eat [] cs eat [] cs = Just cs eat (p:prefx) (c:cs) | toUpper p == toUpper c = eat prefx cs | otherwise = Nothing eat _ _ = Nothing -- define ns (ide, def) = fst (defGlobal ns ide def) -- the attribute table operations on the attributes -- -- | get the definition associated with the given identifier -- getDefOfIdentC :: AttrC -> Ident -> CDef getDefOfIdentC ac = getAttr (defsAC ac) . nodeInfo setDefOfIdentC :: AttrC -> Ident -> CDef -> AttrC setDefOfIdentC ac ide def = let tot' = setAttr (defsAC ac) (nodeInfo ide) def in ac {defsAC = tot'} updDefOfIdentC :: AttrC -> Ident -> CDef -> AttrC updDefOfIdentC ac ide def = let tot' = updAttr (defsAC ac) (nodeInfo ide) def in ac {defsAC = tot'} freezeDefOfIdentsAttrC :: AttrC -> AttrC freezeDefOfIdentsAttrC ac = ac {defsAC = freezeAttrTable (defsAC ac)} softenDefOfIdentsAttrC :: AttrC -> AttrC softenDefOfIdentsAttrC ac = ac {defsAC = softenAttrTable (defsAC ac)} pshow :: (Pretty a) => a -> String pshow = renderStyle (Style OneLineMode 80 1.5) . pretty -- C objects including operations -- ------------------------------ -- | C objects data definition -- data CObj = TypeCO CDecl -- typedef declaration | ObjCO CDecl -- object or function declaration | EnumCO Ident CEnum -- enumerator | BuiltinCO -- builtin object instance Show CObj where show (TypeCO decl) = "TypeCO { " ++ pshow decl ++ " }" show (ObjCO decl) = "ObjCO { "++ pshow decl ++ " }" show (EnumCO ide enum) = "EnumCO "++ show ide ++ " { " ++ pshow enum ++ " }" show BuiltinCO = "BuiltinCO" -- two C objects are equal iff they are defined by the same structure -- tree node (i.e., the two nodes referenced have the same attribute -- identifier) -- instance Eq CObj where (TypeCO decl1 ) == (TypeCO decl2 ) = decl1 `eqByName` decl2 (ObjCO decl1 ) == (ObjCO decl2 ) = decl1 `eqByName` decl2 (EnumCO ide1 enum1) == (EnumCO ide2 enum2) = ide1 == ide2 && enum1 `eqByName` enum2 _ == _ = False instance Pos CObj where posOf (TypeCO def ) = posOf def posOf (ObjCO def ) = posOf def posOf (EnumCO ide _) = posOf ide posOf (BuiltinCO ) = builtinPos -- C tagged objects including operations -- ------------------------------------- -- | C tagged objects data definition -- data CTag = StructUnionCT CStructUnion -- toplevel struct-union declaration | EnumCT CEnum -- toplevel enum declaration instance Show CTag where show (StructUnionCT su) = "StructUnionCT {" ++ pshow su ++ "}" show (EnumCT e) = "EnumCT {"++ pshow e ++ "}" -- | two C tag objects are equal iff they are defined by the same structure -- tree node (i.e., the two nodes referenced have the same attribute -- identifier) -- instance Eq CTag where (StructUnionCT struct1) == (StructUnionCT struct2) = struct1 `eqByName` struct2 (EnumCT enum1 ) == (EnumCT enum2 ) = enum1 `eqByName` enum2 _ == _ = False instance Pos CTag where posOf (StructUnionCT def) = posOf def posOf (EnumCT def) = posOf def -- C general definition -- -------------------- -- | C general definition -- data CDef = UndefCD -- undefined object | DontCareCD -- don't care object | ObjCD CObj -- C object | TagCD CTag -- C tag instance Show CDef where show UndefCD = "UndefCD" show DontCareCD = "DontCareCD" show (ObjCD cobj) = "ObjCD { " ++ show cobj ++ "}" show (TagCD ctag) = "TagCD { " ++ show ctag ++ "}" -- two C definitions are equal iff they are defined by the same structure -- tree node (i.e., the two nodes referenced have the same attribute -- identifier), but don't care objects are equal to everything and undefined -- objects may not be compared -- instance Eq CDef where (ObjCD obj1) == (ObjCD obj2) = obj1 == obj2 (TagCD tag1) == (TagCD tag2) = tag1 == tag2 DontCareCD == _ = True _ == DontCareCD = True UndefCD == _ = interr "CAttrs: Attempt to compare an undefined C definition!" _ == UndefCD = interr "CAttrs: Attempt to compare an undefined C definition!" _ == _ = False instance Attr CDef where undef = UndefCD dontCare = DontCareCD isUndef UndefCD = True isUndef _ = False isDontCare DontCareCD = True isDontCare _ = False instance Pos CDef where posOf UndefCD = nopos posOf DontCareCD = nopos posOf (ObjCD obj) = posOf obj posOf (TagCD tag) = posOf tag -- object tables (internal use only) -- --------------------------------- -- | the object name spavce -- type CObjNS = NameSpace CObj -- | creating a new object name space -- cObjNS :: CObjNS cObjNS = nameSpace -- the tag name space -- type CTagNS = NameSpace CTag -- creating a new tag name space -- cTagNS :: CTagNS cTagNS = nameSpace -- | the shadow name space -- type CShadowNS = NameSpace Ident -- | creating a shadow name space -- cShadowNS :: CShadowNS cShadowNS = nameSpace -- | the general definition table -- type CDefTable = AttrTable CDef -- | creating a new definition table -- cDefTable :: CDefTable cDefTable = newAttrTable "C General Definition Table for Idents" c2hs-0.16.4/src/C2HS/C/Builtin.hs0000644000000000000000000000263612044310770014246 0ustar0000000000000000-- C->Haskell Compiler: C builtin information -- -- Author : Manuel M. T. Chakravarty -- Created: 12 February 01 -- -- Copyright (c) 2001 Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides information about builtin entities. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Currently, only builtin type names are supported. The only builtin type -- name is `__builtin_va_list', which is a builtin of GNU C. -- --- TODO ---------------------------------------------------------------------- -- module C2HS.C.Builtin ( builtinTypeNames ) where import Language.C.Data.Ident (Ident, builtinIdent) import C2HS.C.Attrs (CObj(BuiltinCO)) -- | predefined type names -- builtinTypeNames :: [(Ident, CObj)] builtinTypeNames = [(builtinIdent "__builtin_va_list", BuiltinCO)] c2hs-0.16.4/src/C2HS/CHS/0000755000000000000000000000000012044310770012530 5ustar0000000000000000c2hs-0.16.4/src/C2HS/CHS/Lexer.hs0000644000000000000000000010415412044310770014150 0ustar0000000000000000-- C->Haskell Compiler: Lexer for CHS Files -- -- Author : Manuel M T Chakravarty -- Created: 13 August 99 -- -- Copyright (c) [1999..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- Lexer for CHS files; the tokens are only partially recognised. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * CHS files are assumed to be Haskell 98 files that include C2HS binding -- hooks. -- -- * Haskell code is not tokenised, but binding hooks (delimited by `{#'and -- `#}') are analysed. Therefore the lexer operates in two states -- (realised as two lexer coupled by meta actions) depending on whether -- Haskell code or a binding hook is currently read. The lexer reading -- Haskell code is called `base lexer'; the other one, `binding-hook -- lexer'. In addition, there is a inline-c lexer, which, as the -- binding-hook lexer, can be triggered from the base lexer. -- -- * Base lexer: -- -- haskell -> (inline \\ special)* -- | special \\ `"' -- | comment -- | nested -- | hstring -- | '{#' -- | cpp -- special -> `(' | `{' | `-' | `"' -- ctrl -> `\n' | `\f' | `\r' | `\t' | `\v' -- -- inline -> any \\ ctrl -- any -> '\0'..'\255' -- -- Within the base lexer control codes appear as separate tokens in the -- token list. -- -- NOTE: It is important that `{' is an extra lexeme and not added as an -- optional component at the end of the first alternative for -- `haskell'. Otherwise, the principle of the longest match will -- divide `foo {#' into the tokens `foo {' and `#' instead of `foo ' -- and `{#'. -- -- One line comments are handled by -- -- comment -> `--' (any \\ `\n')* `\n' -- -- and nested comments by -- -- nested -> `{-' any* `-}' -- -- where `any*' may contain _balanced_ occurrences of `{-' and `-}'. -- -- hstring -> `"' inhstr* `"' -- inhstr -> ` '..`\127' \\ `"' -- | `\"' -- -- Pre-precessor directives as well as the switch to inline-C code are -- formed as follows: -- -- cpp -> `\n#' (inline | `\t')* `\n' -- | `\n#c' (' ' | '\t')* `\n' -- -- We allow whitespace between the `#' and the actual directive, but in `#c' -- and `#endc' the directive must immediately follow the `#'. This might -- be regarded as a not entirely orthogonal design, but simplifies matters -- especially for `#endc'. -- -- * On encountering the lexeme `{#', a meta action in the base lexer -- transfers control to the following binding-hook lexer: -- -- ident -> letter (letter | digit | `\'')* -- reservedid -> `as' | `call' | `class' | `context' | `deriving' -- | `enum' | `foreign' | `fun' | `get' | `lib' -- | `downcaseFirstLetter' -- | `newtype' | `nocode' | `pointer' | `prefix' | `pure' -- | `set' | `sizeof' | `stable' | `type' -- | `underscoreToCase' | `upcaseFirstLetter' | `unsafe' | -- | `with' -- reservedsym -> `{#' | `#}' | `{' | `}' | `,' | `.' | `->' | `=' -- | `=>' | '-' | `*' | `&' | `^' -- string -> `"' instr* `"' -- verbhs -> `\`' inhsverb* `\'' -- quoths -> `\'' inhsverb* `\'' -- instr -> ` '..`\127' \\ `"' -- inhsverb -> ` '..`\127' \\ `\'' -- comment -> `--' (any \\ `\n')* `\n' -- -- Control characters, white space, and comments are discarded in the -- binding-hook lexer. Nested comments are not allowed in a binding hook. -- Identifiers can be enclosed in single quotes to avoid collision with -- C->Haskell keywords, and in this case quoted part could also be followed by -- what is assumed to be a valid Haskell code, which would be transferred in the -- output file verbatim. -- -- * In the binding-hook lexer, the lexeme `#}' transfers control back to the -- base lexer. An occurence of the lexeme `{#' inside the binding-hook -- lexer triggers an error. The symbol `{#' is not explcitly represented -- in the resulting token stream. However, the occurrence of a token -- representing one of the reserved identifiers `call', `context', `enum', -- and `field' marks the start of a binding hook. Strictly speaking, `#}' -- need also not occur in the token stream, as the next `haskell' token -- marks a hook's end. It is, however, useful for producing accurate error -- messages (in case an hook is closed to early) to have a token -- representing `#}'. -- -- * The rule `ident' describes Haskell identifiers, but without -- distinguishing between variable and constructor identifers (ie, those -- starting with a lowercase and those starting with an uppercase letter). -- However, we use it also to scan C identifiers; although, strictly -- speaking, it is too general for them. In the case of C identifiers, -- this should not have any impact on the range of descriptions accepted by -- the tool, as illegal identifier will never occur in a C header file that -- is accepted by the C lexer. In the case of Haskell identifiers, a -- confusion between variable and constructor identifiers will be noted by -- the Haskell compiler translating the code generated by c2hs. Moreover, -- identifiers that are inside quoted parts (see above) may not contain apostrophes. -- -- * Any line starting with the character `#' is regarded to be a C -- preprocessor directive. With the exception of `#c' and `#endc', which -- delimit a set of lines containing inline C code. Hence, in the base -- lexer, the lexeme `#c' triggers a meta action transferring control to the -- following inline-C lexer: -- -- c -> inline* \\ `\n#endc' -- -- We do neither treat C strings nor C comments specially. Hence, if the -- string "\n#endc" occurs in a comment, we will mistakenly regard it as -- the end of the inline C code. Note that the problem cannot happen with -- strings, as C does not permit strings that extend over multiple lines. -- At the moment, it just seems not to be worth the effort required to -- treat this situation more accurately. -- -- The inline-C lexer also doesn't handle pre-processor directives -- specially. Hence, structural pre-processor directives (namely, -- conditionals) may occur within inline-C code only properly nested. -- -- Shortcomings -- ~~~~~~~~~~~~ -- Some lexemes that include single and double quote characters are not lexed -- correctly. See the implementation comment at `haskell' for details. -- -- --- TODO ---------------------------------------------------------------------- -- -- * In `haskell', the case of a single `"' (without a matching second one) -- is caught by an eplicit error raising rule. This shouldn't be -- necessary, but for some strange reason, the lexer otherwise hangs when a -- single `"' appears in the input. -- -- * Comments in the "gap" of a string are not yet supported. -- module C2HS.CHS.Lexer (CHSToken(..), lexCHS, keywordToIdent) where import Data.List ((\\)) import Data.Char (isDigit) import Language.C.Data.Ident import Language.C.Data.Name import Language.C.Data.Position import Data.Errors (ErrorLevel(..), makeError) import Text.Lexers (Regexp, Lexer, Action, epsilon, char, (+>), lexaction, lexactionErr, lexmeta, (>|<), (>||<), ctrlLexer, star, plus, alt, string, execLexer) import Control.State (getNameSupply, setNameSupply) import C2HS.State (CST, raise, raiseError) -- token definition -- ---------------- -- | possible tokens -- data CHSToken = CHSTokArrow Position -- `->' | CHSTokDArrow Position -- `=>' | CHSTokDot Position -- `.' | CHSTokComma Position -- `,' | CHSTokEqual Position -- `=' | CHSTokMinus Position -- `-' | CHSTokStar Position -- `*' | CHSTokAmp Position -- `&' | CHSTokHat Position -- `^' | CHSTokLBrace Position -- `{' | CHSTokRBrace Position -- `}' | CHSTokLParen Position -- `(' | CHSTokRParen Position -- `)' | CHSTokEndHook Position -- `#}' | CHSTokAs Position -- `as' | CHSTokCall Position -- `call' | CHSTokClass Position -- `class' | CHSTokContext Position -- `context' | CHSTokDerive Position -- `deriving' | CHSTokDown Position -- `downcaseFirstLetter' | CHSTokEnum Position -- `enum' | CHSTokForeign Position -- `foreign' | CHSTokFun Position -- `fun' | CHSTokGet Position -- `get' | CHSTokImport Position -- `import' | CHSTokLib Position -- `lib' | CHSTokNewtype Position -- `newtype' | CHSTokNocode Position -- `nocode' | CHSTokPointer Position -- `pointer' | CHSTokPrefix Position -- `prefix' | CHSTokPure Position -- `pure' | CHSTokQualif Position -- `qualified' | CHSTokSet Position -- `set' | CHSTokSizeof Position -- `sizeof' | CHSTokAlignof Position -- `alignof' | CHSTokStable Position -- `stable' | CHSTokType Position -- `type' | CHSTok_2Case Position -- `underscoreToCase' | CHSTokUnsafe Position -- `unsafe' | CHSTokUpper Position -- `upcaseFirstLetter' | CHSTokWith Position -- `with' | CHSTokString Position String -- string | CHSTokHSVerb Position String -- verbatim Haskell (`...') | CHSTokHSQuot Position String -- quoted Haskell ('...') | CHSTokIdent Position Ident -- identifier | CHSTokHaskell Position String -- verbatim Haskell code | CHSTokCPP Position String -- pre-processor directive | CHSTokLine Position -- line pragma | CHSTokC Position String -- verbatim C code | CHSTokCtrl Position Char -- control code instance Pos CHSToken where posOf (CHSTokArrow pos ) = pos posOf (CHSTokDArrow pos ) = pos posOf (CHSTokDot pos ) = pos posOf (CHSTokComma pos ) = pos posOf (CHSTokEqual pos ) = pos posOf (CHSTokMinus pos ) = pos posOf (CHSTokStar pos ) = pos posOf (CHSTokAmp pos ) = pos posOf (CHSTokHat pos ) = pos posOf (CHSTokLBrace pos ) = pos posOf (CHSTokRBrace pos ) = pos posOf (CHSTokLParen pos ) = pos posOf (CHSTokRParen pos ) = pos posOf (CHSTokEndHook pos ) = pos posOf (CHSTokAs pos ) = pos posOf (CHSTokCall pos ) = pos posOf (CHSTokClass pos ) = pos posOf (CHSTokContext pos ) = pos posOf (CHSTokDerive pos ) = pos posOf (CHSTokDown pos ) = pos posOf (CHSTokEnum pos ) = pos posOf (CHSTokForeign pos ) = pos posOf (CHSTokFun pos ) = pos posOf (CHSTokGet pos ) = pos posOf (CHSTokImport pos ) = pos posOf (CHSTokLib pos ) = pos posOf (CHSTokNewtype pos ) = pos posOf (CHSTokNocode pos ) = pos posOf (CHSTokPointer pos ) = pos posOf (CHSTokPrefix pos ) = pos posOf (CHSTokPure pos ) = pos posOf (CHSTokQualif pos ) = pos posOf (CHSTokSet pos ) = pos posOf (CHSTokSizeof pos ) = pos posOf (CHSTokAlignof pos ) = pos posOf (CHSTokStable pos ) = pos posOf (CHSTokType pos ) = pos posOf (CHSTok_2Case pos ) = pos posOf (CHSTokUnsafe pos ) = pos posOf (CHSTokUpper pos ) = pos posOf (CHSTokWith pos ) = pos posOf (CHSTokString pos _) = pos posOf (CHSTokHSVerb pos _) = pos posOf (CHSTokHSQuot pos _) = pos posOf (CHSTokIdent pos _) = pos posOf (CHSTokHaskell pos _) = pos posOf (CHSTokCPP pos _) = pos posOf (CHSTokLine pos ) = pos posOf (CHSTokC pos _) = pos posOf (CHSTokCtrl pos _) = pos instance Eq CHSToken where (CHSTokArrow _ ) == (CHSTokArrow _ ) = True (CHSTokDArrow _ ) == (CHSTokDArrow _ ) = True (CHSTokDot _ ) == (CHSTokDot _ ) = True (CHSTokComma _ ) == (CHSTokComma _ ) = True (CHSTokEqual _ ) == (CHSTokEqual _ ) = True (CHSTokMinus _ ) == (CHSTokMinus _ ) = True (CHSTokStar _ ) == (CHSTokStar _ ) = True (CHSTokAmp _ ) == (CHSTokAmp _ ) = True (CHSTokHat _ ) == (CHSTokHat _ ) = True (CHSTokLBrace _ ) == (CHSTokLBrace _ ) = True (CHSTokRBrace _ ) == (CHSTokRBrace _ ) = True (CHSTokLParen _ ) == (CHSTokLParen _ ) = True (CHSTokRParen _ ) == (CHSTokRParen _ ) = True (CHSTokEndHook _ ) == (CHSTokEndHook _ ) = True (CHSTokAs _ ) == (CHSTokAs _ ) = True (CHSTokCall _ ) == (CHSTokCall _ ) = True (CHSTokClass _ ) == (CHSTokClass _ ) = True (CHSTokContext _ ) == (CHSTokContext _ ) = True (CHSTokDerive _ ) == (CHSTokDerive _ ) = True (CHSTokDown _ ) == (CHSTokDown _ ) = True (CHSTokEnum _ ) == (CHSTokEnum _ ) = True (CHSTokForeign _ ) == (CHSTokForeign _ ) = True (CHSTokFun _ ) == (CHSTokFun _ ) = True (CHSTokGet _ ) == (CHSTokGet _ ) = True (CHSTokImport _ ) == (CHSTokImport _ ) = True (CHSTokLib _ ) == (CHSTokLib _ ) = True (CHSTokNewtype _ ) == (CHSTokNewtype _ ) = True (CHSTokNocode _ ) == (CHSTokNocode _ ) = True (CHSTokPointer _ ) == (CHSTokPointer _ ) = True (CHSTokPrefix _ ) == (CHSTokPrefix _ ) = True (CHSTokPure _ ) == (CHSTokPure _ ) = True (CHSTokQualif _ ) == (CHSTokQualif _ ) = True (CHSTokSet _ ) == (CHSTokSet _ ) = True (CHSTokSizeof _ ) == (CHSTokSizeof _ ) = True (CHSTokAlignof _ ) == (CHSTokAlignof _ ) = True (CHSTokStable _ ) == (CHSTokStable _ ) = True (CHSTokType _ ) == (CHSTokType _ ) = True (CHSTok_2Case _ ) == (CHSTok_2Case _ ) = True (CHSTokUnsafe _ ) == (CHSTokUnsafe _ ) = True (CHSTokUpper _ ) == (CHSTokUpper _ ) = True (CHSTokWith _ ) == (CHSTokWith _ ) = True (CHSTokString _ _) == (CHSTokString _ _) = True (CHSTokHSVerb _ _) == (CHSTokHSVerb _ _) = True (CHSTokHSQuot _ _) == (CHSTokHSQuot _ _) = True (CHSTokIdent _ _) == (CHSTokIdent _ _) = True (CHSTokHaskell _ _) == (CHSTokHaskell _ _) = True (CHSTokCPP _ _) == (CHSTokCPP _ _) = True (CHSTokLine _ ) == (CHSTokLine _ ) = True (CHSTokC _ _) == (CHSTokC _ _) = True (CHSTokCtrl _ _) == (CHSTokCtrl _ _) = True _ == _ = False instance Show CHSToken where showsPrec _ (CHSTokArrow _ ) = showString "->" showsPrec _ (CHSTokDArrow _ ) = showString "=>" showsPrec _ (CHSTokDot _ ) = showString "." showsPrec _ (CHSTokComma _ ) = showString "," showsPrec _ (CHSTokEqual _ ) = showString "=" showsPrec _ (CHSTokMinus _ ) = showString "-" showsPrec _ (CHSTokStar _ ) = showString "*" showsPrec _ (CHSTokAmp _ ) = showString "&" showsPrec _ (CHSTokHat _ ) = showString "^" showsPrec _ (CHSTokLBrace _ ) = showString "{" showsPrec _ (CHSTokRBrace _ ) = showString "}" showsPrec _ (CHSTokLParen _ ) = showString "(" showsPrec _ (CHSTokRParen _ ) = showString ")" showsPrec _ (CHSTokEndHook _ ) = showString "#}" showsPrec _ (CHSTokAs _ ) = showString "as" showsPrec _ (CHSTokCall _ ) = showString "call" showsPrec _ (CHSTokClass _ ) = showString "class" showsPrec _ (CHSTokContext _ ) = showString "context" showsPrec _ (CHSTokDerive _ ) = showString "deriving" showsPrec _ (CHSTokDown _ ) = showString "downcaseFirstLetter" showsPrec _ (CHSTokEnum _ ) = showString "enum" showsPrec _ (CHSTokForeign _ ) = showString "foreign" showsPrec _ (CHSTokFun _ ) = showString "fun" showsPrec _ (CHSTokGet _ ) = showString "get" showsPrec _ (CHSTokImport _ ) = showString "import" showsPrec _ (CHSTokLib _ ) = showString "lib" showsPrec _ (CHSTokNewtype _ ) = showString "newtype" showsPrec _ (CHSTokNocode _ ) = showString "nocode" showsPrec _ (CHSTokPointer _ ) = showString "pointer" showsPrec _ (CHSTokPrefix _ ) = showString "prefix" showsPrec _ (CHSTokPure _ ) = showString "pure" showsPrec _ (CHSTokQualif _ ) = showString "qualified" showsPrec _ (CHSTokSet _ ) = showString "set" showsPrec _ (CHSTokSizeof _ ) = showString "sizeof" showsPrec _ (CHSTokAlignof _ ) = showString "alignof" showsPrec _ (CHSTokStable _ ) = showString "stable" showsPrec _ (CHSTokType _ ) = showString "type" showsPrec _ (CHSTok_2Case _ ) = showString "underscoreToCase" showsPrec _ (CHSTokUnsafe _ ) = showString "unsafe" showsPrec _ (CHSTokUpper _ ) = showString "upcaseFirstLetter" showsPrec _ (CHSTokWith _ ) = showString "with" showsPrec _ (CHSTokString _ s) = showString ("\"" ++ s ++ "\"") showsPrec _ (CHSTokHSVerb _ s) = showString ("`" ++ s ++ "'") showsPrec _ (CHSTokHSQuot _ s) = showString ("'" ++ s ++ "'") showsPrec _ (CHSTokIdent _ i) = (showString . identToString) i showsPrec _ (CHSTokHaskell _ s) = showString s showsPrec _ (CHSTokCPP _ s) = showString s showsPrec _ (CHSTokLine _ ) = id --TODO show line num? showsPrec _ (CHSTokC _ s) = showString s showsPrec _ (CHSTokCtrl _ c) = showChar c -- lexer state -- ----------- -- | state threaded through the lexer -- data CHSLexerState = CHSLS { nestLvl :: Int, -- nesting depth of nested comments inHook :: Bool, -- within a binding hook? namesup :: [Name] -- supply of unique names } -- | initial state -- initialState :: [Name] -> CST s CHSLexerState initialState nameSupply = do return CHSLS { nestLvl = 0, inHook = False, namesup = nameSupply } -- | raise an error if the given state is not a final state -- assertFinalState :: Position -> CHSLexerState -> CST s () assertFinalState pos CHSLS {nestLvl = nestLvl', inHook = inHook'} | nestLvl' > 0 = raiseError pos ["Unexpected end of file!", "Unclosed nested comment."] | inHook' = raiseError pos ["Unexpected end of file!", "Unclosed binding hook."] | otherwise = return () -- | lexer and action type used throughout this specification -- type CHSLexer = Lexer CHSLexerState CHSToken type CHSAction = Action CHSToken type CHSRegexp = Regexp CHSLexerState CHSToken -- | for actions that need a new unique name -- infixl 3 `lexactionName` lexactionName :: CHSRegexp -> (String -> Position -> Name -> CHSToken) -> CHSLexer re `lexactionName` action = re `lexmeta` action' where action' str pos state = let name:ns = namesup state in (Just $ Right (action str pos name), incPos pos (length str), state {namesup = ns}, Nothing) -- lexical specification -- --------------------- -- | the lexical definition of the tokens (the base lexer) -- chslexer :: CHSLexer chslexer = haskell -- Haskell code >||< nested -- nested comments >||< ctrl -- control code (that has to be preserved) >||< hook -- start of a binding hook >||< cpp -- a pre-processor directive (or `#c') -- | stream of Haskell code (terminated by a control character or binding hook) -- haskell :: CHSLexer -- -- NB: We need to make sure that '"' is not regarded as the beginning of a -- string; however, we cannot really lex character literals properly -- without lexing identifiers (as the latter may containing single quotes -- as part of their lexeme). Thus, we special case '"'. This is still a -- kludge, as a program fragment, such as -- -- foo'"'strange string" -- -- will not be handled correctly. -- haskell = ( anyButSpecial`star` epsilon >|< specialButQuotes >|< char '"' +> inhstr`star` char '"' >|< string "'\"'" -- special case of " >|< string "--" +> anyButNL`star` epsilon -- comment ) `lexaction` copyVerbatim >||< char '"' -- this is a bad kludge `lexactionErr` \_ pos -> (Left $ makeError LevelError pos ["Lexical error!", "Unclosed string."]) where anyButSpecial = alt (inlineSet \\ specialSet) specialButQuotes = alt (specialSet \\ ['"']) anyButNL = alt (anySet \\ ['\n']) inhstr = instr >|< char '\\' >|< string "\\\"" >|< gap gap = char '\\' +> alt (' ':ctrlSet)`plus` char '\\' -- | action copying the input verbatim to `CHSTokHaskell' tokens -- copyVerbatim :: CHSAction copyVerbatim cs pos = Just $ CHSTokHaskell pos cs -- | nested comments -- nested :: CHSLexer nested = string "{-" {- for Haskell emacs mode :-( -} `lexmeta` enterComment >||< string "-}" `lexmeta` leaveComment where enterComment cs pos s = (copyVerbatim' cs pos, -- collect the lexeme incPos pos 2, -- advance current position s {nestLvl = nestLvl s + 1}, -- increase nesting level Just $ inNestedComment) -- continue in comment lexer -- leaveComment cs pos s = case nestLvl s of 0 -> (commentCloseErr pos, -- 0: -} outside comment => err incPos pos 2, -- advance current position s, Nothing) 1 -> (copyVerbatim' cs pos, -- collect the lexeme incPos pos 2, -- advance current position s {nestLvl = nestLvl s - 1}, -- decrease nesting level Just chslexer) -- 1: continue with root lexer _ -> (copyVerbatim' cs pos, -- collect the lexeme incPos pos 2, -- advance current position s {nestLvl = nestLvl s - 1}, -- decrease nesting level Nothing) -- _: cont with comment lexer -- copyVerbatim' cs pos = Just $ Right (CHSTokHaskell pos cs) -- commentCloseErr pos = Just $ Left (makeError LevelError pos ["Lexical error!", "`-}' not preceded by a matching `{-'."]) {- for Haskell emacs mode :-( -} -- | lexer processing the inner of a comment -- inNestedComment :: CHSLexer inNestedComment = commentInterior -- inside a comment >||< nested -- nested comments >||< ctrl -- control code (preserved) -- | standard characters in a nested comment -- commentInterior :: CHSLexer commentInterior = ( anyButSpecial`star` epsilon >|< special ) `lexaction` copyVerbatim where anyButSpecial = alt (inlineSet \\ commentSpecialSet) special = alt commentSpecialSet -- | control code in the base lexer (is turned into a token) -- -- * this covers exactly the same set of characters as contained in `ctrlSet' -- and `Lexers.ctrlLexer' and advances positions also like the `ctrlLexer' -- ctrl :: CHSLexer ctrl = char '\n' `lexmeta` newline >||< char '\r' `lexmeta` newline >||< char '\v' `lexmeta` newline >||< char '\f' `lexmeta` formfeed >||< char '\t' `lexmeta` tab where newline [c] pos = ctrlResult pos c (retPos pos) formfeed [c] pos = ctrlResult pos c (incPos pos 1) tab [c] pos = ctrlResult pos c (incPos pos 8) ctrlResult pos c pos' s = (Just $ Right (CHSTokCtrl pos c), pos', s, Nothing) -- | start of a binding hook (ie, enter the binding hook lexer) -- hook :: CHSLexer hook = string "{#" `lexmeta` \_ pos s -> (Nothing, incPos pos 2, s, Just bhLexer) -- | pre-processor directives and `#c' -- -- * we lex `#c' as a directive and special case it in the action -- -- * we lex C line number pragmas and special case it in the action -- cpp :: CHSLexer cpp = directive where directive = string "\n#" +> alt ('\t':inlineSet)`star` epsilon `lexmeta` \(_:_:dir) pos s -> -- strip off the "\n#" case dir of ['c'] -> -- #c (Nothing, retPos pos, s, Just cLexer) -- a #c may be followed by whitespace 'c':sp:_ | sp `elem` " \t" -> -- #c (Nothing, retPos pos, 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) adjustPosByCLinePragma :: String -> Position -> Position adjustPosByCLinePragma str pos = adjustPos fname' row' pos where fname = posFile pos str' = dropWhite str (rowStr, str'') = span isDigit str' row' = read rowStr str''' = dropWhite str'' fnameStr = takeWhile (/= '"') . drop 1 $ str''' fname' | null str''' || head str''' /= '"' = fname -- try and get more sharing of file name strings | fnameStr == fname = fname | otherwise = fnameStr -- dropWhite = dropWhile (\c -> c == ' ' || c == '\t') -- | the binding hook lexer -- bhLexer :: CHSLexer bhLexer = identOrKW >||< symbol >||< strlit >||< hsverb >||< hsquot >||< whitespace >||< endOfHook >||< string "--" +> anyButNL`star` char '\n' -- comment `lexmeta` \_ pos s -> (Nothing, retPos pos, s, Nothing) where anyButNL = alt (anySet \\ ['\n']) endOfHook = string "#}" `lexmeta` \_ pos s -> (Just $ Right (CHSTokEndHook pos), incPos pos 2, s, Just chslexer) -- | the inline-C lexer -- cLexer :: CHSLexer cLexer = inlineC -- inline C code >||< ctrl -- control code (preserved) >||< string "\n#endc" -- end of inline C code... `lexmeta` -- ...preserve '\n' as control token \_ pos s -> (Just $ Right (CHSTokCtrl pos '\n'), retPos pos, s, Just chslexer) where inlineC = alt inlineSet `lexaction` copyVerbatimC -- copyVerbatimC :: CHSAction copyVerbatimC cs pos = Just $ CHSTokC pos cs -- | whitespace -- -- * horizontal and vertical tabs, newlines, and form feeds are filter out by -- `Lexers.ctrlLexer' -- whitespace :: CHSLexer whitespace = (char ' ' `lexaction` \_ _ -> Nothing) >||< ctrlLexer -- | identifiers and keywords -- identOrKW :: CHSLexer -- -- the strictness annotations seem to help a bit -- identOrKW = -- identifier or keyword (letter +> (letter >|< digit >|< char '\'')`star` epsilon `lexactionName` \cs pos name -> (idkwtok $!pos) cs name) where idkwtok pos "as" _ = CHSTokAs pos idkwtok pos "call" _ = CHSTokCall pos idkwtok pos "class" _ = CHSTokClass pos idkwtok pos "context" _ = CHSTokContext pos idkwtok pos "deriving" _ = CHSTokDerive pos idkwtok pos "downcaseFirstLetter" _ = CHSTokDown pos idkwtok pos "enum" _ = CHSTokEnum pos idkwtok pos "foreign" _ = CHSTokForeign pos idkwtok pos "fun" _ = CHSTokFun pos idkwtok pos "get" _ = CHSTokGet pos idkwtok pos "import" _ = CHSTokImport pos idkwtok pos "lib" _ = CHSTokLib pos idkwtok pos "newtype" _ = CHSTokNewtype pos idkwtok pos "nocode" _ = CHSTokNocode pos idkwtok pos "pointer" _ = CHSTokPointer pos idkwtok pos "prefix" _ = CHSTokPrefix pos idkwtok pos "pure" _ = CHSTokPure pos idkwtok pos "qualified" _ = CHSTokQualif pos idkwtok pos "set" _ = CHSTokSet pos idkwtok pos "sizeof" _ = CHSTokSizeof pos idkwtok pos "alignof" _ = CHSTokAlignof pos idkwtok pos "stable" _ = CHSTokStable pos idkwtok pos "type" _ = CHSTokType pos idkwtok pos "underscoreToCase" _ = CHSTok_2Case pos idkwtok pos "unsafe" _ = CHSTokUnsafe pos idkwtok pos "upcaseFirstLetter"_ = CHSTokUpper pos idkwtok pos "with" _ = CHSTokWith pos idkwtok pos cs name = mkid pos cs name -- mkid pos cs name = CHSTokIdent pos (mkIdent pos cs name) keywordToIdent :: CHSToken -> CHSToken keywordToIdent tok = case tok of CHSTokAs pos -> mkid pos "as" CHSTokCall pos -> mkid pos "call" CHSTokClass pos -> mkid pos "class" CHSTokContext pos -> mkid pos "context" CHSTokDerive pos -> mkid pos "deriving" CHSTokDown pos -> mkid pos "downcaseFirstLetter" CHSTokEnum pos -> mkid pos "enum" CHSTokForeign pos -> mkid pos "foreign" CHSTokFun pos -> mkid pos "fun" CHSTokGet pos -> mkid pos "get" CHSTokImport pos -> mkid pos "import" CHSTokLib pos -> mkid pos "lib" CHSTokNewtype pos -> mkid pos "newtype" CHSTokNocode pos -> mkid pos "nocode" CHSTokPointer pos -> mkid pos "pointer" CHSTokPrefix pos -> mkid pos "prefix" CHSTokPure pos -> mkid pos "pure" CHSTokQualif pos -> mkid pos "qualified" CHSTokSet pos -> mkid pos "set" CHSTokSizeof pos -> mkid pos "sizeof" CHSTokAlignof pos -> mkid pos "alignof" CHSTokStable pos -> mkid pos "stable" CHSTokType pos -> mkid pos "type" CHSTok_2Case pos -> mkid pos "underscoreToCase" CHSTokUnsafe pos -> mkid pos "unsafe" CHSTokUpper pos -> mkid pos "upcaseFirstLetter" CHSTokWith pos -> mkid pos "with" _ -> tok where mkid pos str = CHSTokIdent pos (internalIdent str) -- | reserved symbols -- symbol :: CHSLexer symbol = sym "->" CHSTokArrow >||< sym "=>" CHSTokDArrow >||< sym "." CHSTokDot >||< sym "," CHSTokComma >||< sym "=" CHSTokEqual >||< sym "-" CHSTokMinus >||< sym "*" CHSTokStar >||< sym "&" CHSTokAmp >||< sym "^" CHSTokHat >||< sym "{" CHSTokLBrace >||< sym "}" CHSTokRBrace >||< sym "(" CHSTokLParen >||< sym ")" CHSTokRParen where sym cs con = string cs `lexaction` \_ pos -> Just (con pos) -- | string -- strlit :: CHSLexer strlit = char '"' +> (instr >|< char '\\')`star` char '"' `lexaction` \cs pos -> Just (CHSTokString pos (init . tail $ cs)) -- | verbatim code -- hsverb :: CHSLexer hsverb = char '`' +> inhsverb`star` char '\'' `lexaction` \cs pos -> Just (CHSTokHSVerb pos (init . tail $ cs)) -- | quoted code -- hsquot :: CHSLexer hsquot = char '\'' +> inhsverb`star` char '\'' `lexaction` \cs pos -> Just (CHSTokHSQuot pos (init . tail $ cs)) -- | regular expressions -- letter, digit, instr, inhsverb :: Regexp s t letter = alt ['a'..'z'] >|< alt ['A'..'Z'] >|< char '_' digit = alt ['0'..'9'] instr = alt ([' '..'\255'] \\ "\"\\") inhsverb = alt ([' '..'\127'] \\ "'") -- | character sets -- anySet, inlineSet, specialSet, commentSpecialSet, ctrlSet :: [Char] anySet = ['\0'..'\255'] inlineSet = anySet \\ ctrlSet specialSet = ['{', '-', '"', '\''] commentSpecialSet = ['{', '-'] ctrlSet = ['\n', '\f', '\r', '\t', '\v'] -- main lexing routine -- ------------------- -- | generate a token sequence out of a string denoting a CHS file -- -- * the given position is attributed to the first character in the string -- -- * errors are entered into the compiler state -- -- * on a successfull parse, the name supply is updated lexCHS :: String -> Position -> CST s [CHSToken] lexCHS cs pos = do nameSupply <- getNameSupply state <- initialState nameSupply let (ts, lstate, errs) = execLexer chslexer (cs, pos, state) (_, pos', state') = lstate mapM_ raise errs assertFinalState pos' state' setNameSupply $ namesup state' return ts c2hs-0.16.4/src/C2HS/Gen/0000755000000000000000000000000012044310770012624 5ustar0000000000000000c2hs-0.16.4/src/C2HS/Gen/Bind.hs0000644000000000000000000027766112044310770014057 0ustar0000000000000000-- C->Haskell Compiler: binding generator -- -- Copyright (c) [1999..2003] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- Description --------------------------------------------------------------- -- -- Language: Haskell 98 -- -- Module implementing the expansion of the binding hooks. -- -- * If there is an error in one binding hook, it is skipped and the next one -- is processed (to collect as many errors as possible). However, if at -- least one error occured, the expansion of binding hooks ends in a fatal -- exception. -- -- * `CST' exceptions are used to back off a binding hook as soon as an error -- is encountered while it is processed. -- -- Mapping of C types to Haskell FFI types: -- ---------------------------------------- -- -- The following defines the mapping for basic types. If the type specifer -- is missing, it is taken to be `int'. In the following, elements enclosed -- in square brackets are optional. -- -- void -> () -- char -> CChar -- unsigned char -> CUChar -- signed char -> CShort -- signed -> CInt -- [signed] int -> CInt -- [signed] short [int] -> CSInt -- [signed] long [int] -> CLong -- [signed] long long [int] -> CLLong -- unsigned [int] -> CUInt -- unsigned short [int] -> CUShort -- unsigned long [int] -> CULong -- unsigned long long [int] -> CULLong -- float -> CFloat -- double -> CDouble -- long double -> CLDouble -- enum ... -> CInt -- struct ... -> ** error ** -- union ... -> ** error ** -- -- Plain structures or unions (ie, if not the base type of a pointer type) -- are not supported at the moment (the underlying FFI does not support them -- directly). Named types (ie, in C type names defined using `typedef') are -- traced back to their original definitions. Pointer types are mapped -- to `Ptr a' or `FunPtr a' depending on whether they point to a functional. -- Values obtained from bit fields are represented by `CInt' or `CUInt' -- depending on whether they are signed. -- -- We obtain the size and alignment constraints for all primitive types of C -- from `CInfo', which obtains it from the Haskell 98 FFI. In the alignment -- computations involving bit fields, we assume that the alignment -- constraints for bitfields (wrt to non-bitfield members) is always the same -- as for `int' irrespective of the size of the bitfield. This seems to be -- implicitly guaranteed by K&R A8.3, but it is not entirely clear. -- -- Identifier lookup: -- ------------------ -- -- We allow to identify enumerations and structures by the names of `typedef' -- types aliased to them. -- -- * enumerations: It is first checked whether there is a tag with the given -- identifier; if such a tag does not exist, the definition of a typedef -- with the same name is taken if it exists. -- * structs/unions: like enumerations -- -- We generally use `shadow' lookups. When an identifier cannot be found, -- we check whether - according to the prefix set by the context hook - -- another identifier casts a shadow that matches. If so, that identifier is -- taken instead of the original one. -- --- ToDo ---------------------------------------------------------------------- -- -- * A function prototype that uses a defined type on its left hand side may -- declare a function, while that is not obvious from the declaration -- itself (without also considering the `typedef'). Calls to such -- functions are currently rejected, which is a BUG. -- -- * context hook must preceded all but the import hooks -- -- * The use of `++' in the recursive definition of the routines generating -- `Enum' instances is not particularly efficient. -- -- * Some operands are missing in `applyBin' - unfortunately, Haskell does -- not have standard bit operations. Some constructs are also missing -- from `evalConstCExpr'. Haskell 98 FFI standardises `Bits'; use that. -- module C2HS.Gen.Bind (expandHooks) where import Prelude hiding (exp) -- standard libraries import Data.Char (toLower) import Data.List (deleteBy, intersperse, find) import Data.Maybe (isNothing, fromJust, fromMaybe) import Data.Bits ((.|.), (.&.)) import Control.Monad (when, unless, liftM, mapAndUnzipM) -- Language.C / compiler toolkit import Language.C.Data.Position import Language.C.Data.Ident import Language.C.Pretty import Text.PrettyPrint.HughesPJ (render) import Data.Errors import Data.Attributes (newAttrsOnlyPos) -- C->Haskell import C2HS.Config (PlatformSpec(..)) import C2HS.State (CST, errorsPresent, showErrors, fatal, SwitchBoard(..), Traces(..), putTraceStr, getSwitch) import C2HS.C (AttrC, CObj(..), CTag(..), CDecl(..), CDeclSpec(..), CTypeSpec(..), CStructUnion(..), CStructTag(..), CEnum(..), CDeclr(..), CAttr(..), CDerivedDeclr(..),CArrSize(..), CExpr(..), CBinaryOp(..), CUnaryOp(..), CConst (..), CInteger(..),cInteger,getCInteger,getCCharAsInt, runCT, ifCTExc, raiseErrorCTExc, findValueObj, findFunObj, findTag, applyPrefixToNameSpaces, simplifyDecl, declrNamed, structMembers, structName, tagName, declaredName , structFromDecl, funResultAndArgs, chaseDecl, findAndChaseDecl, checkForAlias, checkForOneAliasName, checkForOneCUName, lookupEnum, lookupStructUnion, lookupDeclOrTag, isPtrDeclr, dropPtrDeclr, isPtrDecl, getDeclOf, isFunDeclr, refersToNewDef, partitionDeclSpecs, CDef(..)) -- friends import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..), showCHSParm, apathToIdent) 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, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, queryClass, queryPointer, mergeMaps, dumpMaps) -- default marshallers -- ------------------- -- FIXME: -- - we might have a dynamically extended table in the monad if needed (we -- could marshall enums this way and also save the 'id' marshallers for -- pointers defined via (newtype) pointer hooks) -- - the checks for the Haskell types are quite kludgy -- | determine the default "in" marshaller for the given Haskell and C types -- lookupDftMarshIn :: String -> [ExtType] -> GB CHSMarsh lookupDftMarshIn "Bool" [PrimET pt] | isIntegralCPrimType pt = return $ Just (Left cFromBoolIde, CHSValArg) lookupDftMarshIn hsTy [PrimET pt] | isIntegralHsType hsTy &&isIntegralCPrimType pt = return $ Just (Left cIntConvIde, CHSValArg) lookupDftMarshIn hsTy [PrimET pt] | isFloatHsType hsTy &&isFloatCPrimType pt = return $ Just (Left cFloatConvIde, CHSValArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT)] = return $ Just (Left withCStringIde, CHSIOArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt] | isIntegralCPrimType pt = return $ Just (Left withCStringLenIde, CHSIOArg) lookupDftMarshIn hsTy [PtrET ty] | showExtType ty == hsTy = return $ Just (Left withIde, CHSIOArg) lookupDftMarshIn hsTy [PtrET (PrimET pt)] | isIntegralHsType hsTy && isIntegralCPrimType pt = return $ Just (Left withIntConvIde, CHSIOArg) lookupDftMarshIn hsTy [PtrET (PrimET pt)] | isFloatHsType hsTy && isFloatCPrimType pt = return $ Just (Left withFloatConvIde, CHSIOArg) lookupDftMarshIn "Bool" [PtrET (PrimET pt)] | isIntegralCPrimType pt = return $ Just (Left withFromBoolIde, CHSIOArg) -- 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 lookupDftMarshOut "()" _ = return $ Just (Left voidIde, CHSVoidArg) lookupDftMarshOut "Bool" [PrimET pt] | isIntegralCPrimType pt = return $ Just (Left cToBoolIde, CHSValArg) lookupDftMarshOut hsTy [PrimET pt] | isIntegralHsType hsTy &&isIntegralCPrimType pt = return $ Just (Left cIntConvIde, CHSValArg) lookupDftMarshOut hsTy [PrimET pt] | isFloatHsType hsTy &&isFloatCPrimType pt = return $ Just (Left cFloatConvIde, CHSValArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT)] = return $ Just (Left peekCStringIde, CHSIOArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT), PrimET pt] | isIntegralCPrimType pt = return $ Just (Left peekCStringLenIde, CHSIOArg) lookupDftMarshOut hsTy [PtrET ty] | showExtType ty == hsTy = return $ Just (Left peekIde, CHSIOArg) -- FIXME: add combination, such as "peek" plus "cIntConv" etc -- FIXME: handle array-list conversion lookupDftMarshOut _ _ = return Nothing -- | check for integral Haskell types -- isIntegralHsType :: String -> Bool isIntegralHsType "Int" = True isIntegralHsType "Int8" = True isIntegralHsType "Int16" = True isIntegralHsType "Int32" = True isIntegralHsType "Int64" = True isIntegralHsType "Word8" = True isIntegralHsType "Word16" = True isIntegralHsType "Word32" = True isIntegralHsType "Word64" = True isIntegralHsType _ = False -- | check for floating Haskell types -- isFloatHsType :: String -> Bool isFloatHsType "Float" = True isFloatHsType "Double" = True isFloatHsType _ = False isVariadic :: ExtType -> Bool isVariadic (FunET s t) = any isVariadic [s,t] isVariadic (IOET t) = isVariadic t isVariadic (PtrET t) = isVariadic t isVariadic (VarFunET _) = True isVariadic _ = False -- | check for integral C types -- -- * For marshalling purposes C char's are integral types (see also types -- classes for which the FFI guarantees instances for 'CChar', 'CSChar', and -- 'CUChar') -- isIntegralCPrimType :: CPrimType -> Bool isIntegralCPrimType = (`elem` [CCharPT, CSCharPT, CIntPT, CShortPT, CLongPT, CLLongPT, CUIntPT, CUCharPT, CUShortPT, CULongPT, CULLongPT]) -- | check for floating C types -- isFloatCPrimType :: CPrimType -> Bool isFloatCPrimType = (`elem` [CFloatPT, CDoublePT, CLDoublePT]) -- | standard conversions -- voidIde, cFromBoolIde, cToBoolIde, cIntConvIde, cFloatConvIde, withIde, withCStringIde, withCStringLenIde, withIntConvIde, withFloatConvIde, withFromBoolIde, peekIde, peekCStringIde, peekCStringLenIde :: 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 --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 -- -------------------------- -- | given a C header file and a binding file, expand all hooks in the binding -- file using the C header information -- -- * together with the module, returns the contents of the .chi file -- -- * if any error (not warnings) is encountered, a fatal error is raised. -- -- * also returns all warning messages encountered (last component of result) -- expandHooks :: AttrC -> CHSModule -> CST s (CHSModule, String, String) expandHooks ac mod' = do (_, res) <- runCT (expandModule mod') ac initialGBState return res expandModule :: CHSModule -> GB (CHSModule, String, String) expandModule (CHSModule frags) = do -- expand hooks -- traceInfoExpand frags' <- expandFrags frags delayedFrags <- getDelayedCode -- get .chi dump -- chi <- dumpMaps -- check for errors and finalise -- errs <- errorsPresent if errs then do traceInfoErr errmsgs <- showErrors fatal ("Errors during expansion of binding hooks:\n\n" -- fatal error ++ errmsgs) else do traceInfoOK warnmsgs <- showErrors return (CHSModule (frags' ++ delayedFrags), chi, warnmsgs) where traceInfoExpand = putTraceStr tracePhasesSW ("...expanding binding hooks...\n") traceInfoErr = putTraceStr tracePhasesSW ("...error(s) detected.\n") traceInfoOK = putTraceStr tracePhasesSW ("...successfully completed.\n") expandFrags :: [CHSFrag] -> GB [CHSFrag] expandFrags = liftM concat . mapM expandFrag expandFrag :: CHSFrag -> GB [CHSFrag] expandFrag verb@(CHSVerb _ _ ) = return [verb] expandFrag line@(CHSLine _ ) = return [line] expandFrag (CHSHook h ) = do code <- expandHook h return [CHSVerb code builtinPos] `ifCTExc` return [CHSVerb "** ERROR **" builtinPos] expandFrag (CHSCPP s _ ) = interr $ "GenBind.expandFrag: Left over CHSCPP!\n---\n" ++ s ++ "\n---" expandFrag (CHSC s _ ) = interr $ "GenBind.expandFrag: Left over CHSC!\n---\n" ++ s ++ "\n---" expandFrag (CHSCond alts dft) = do traceInfoCond select alts where select [] = do traceInfoDft dft expandFrags (maybe [] id dft) select ((ide, frags):alts') = do oobj <- findTag ide traceInfoVal ide oobj if isNothing oobj then select alts' else -- found right alternative expandFrags frags -- traceInfoCond = traceGenBind "** CPP conditional:\n" traceInfoVal ide oobj = traceGenBind $ identToString ide ++ " is " ++ (if isNothing oobj then "not " else "") ++ "defined.\n" traceInfoDft dft' = if isNothing dft' then return () else traceGenBind "Choosing else branch.\n" expandHook :: CHSHook -> GB String expandHook (CHSImport qual ide chi _) = do mergeMaps chi return $ "import " ++ (if qual then "qualified " else "") ++ identToString ide expandHook (CHSContext olib oprefix _) = do setContext olib oprefix -- enter context information mapMaybeM_ applyPrefixToNameSpaces oprefix -- use the prefix on name spaces return "" expandHook (CHSType ide pos) = do traceInfoType decl <- findAndChaseDecl ide False True -- no indirection, but shadows ty <- extractSimpleType False pos decl traceInfoDump (render $ pretty decl) ty when (isVariadic ty) (variadicErr pos (posOf decl)) return $ "(" ++ showExtType ty ++ ")" where traceInfoType = traceGenBind "** Type hook:\n" traceInfoDump decl ty = traceGenBind $ "Declaration\n" ++ show decl ++ "\ntranslates to\n" ++ showExtType ty ++ "\n" expandHook (CHSAlignof ide _) = do traceInfoAlignof decl <- findAndChaseDecl ide False True -- no indirection, but shadows (_, align) <- sizeAlignOf decl traceInfoDump (render $ pretty decl) align return $ show align where traceInfoAlignof = traceGenBind "** alignment hook:\n" traceInfoDump decl align = traceGenBind $ "Alignment of declaration\n" ++ show decl ++ "\nis " ++ show align ++ "\n" expandHook (CHSSizeof ide _) = do traceInfoSizeof decl <- findAndChaseDecl ide False True -- no indirection, but shadows (size, _) <- sizeAlignOf decl traceInfoDump (render $ pretty decl) size return $ show (padBits size) where traceInfoSizeof = traceGenBind "** Sizeof hook:\n" traceInfoDump decl size = traceGenBind $ "Size of declaration\n" ++ show decl ++ "\nis " ++ 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 _) = do -- get the corresponding C declaration -- enum <- lookupEnum cide True -- smart lookup incl error handling -- -- convert the translation table and generate data type definition code -- gprefix <- getPrefix let prefix = case oprefix of Nothing -> gprefix Just pref -> pref let trans = transTabToTransFun prefix chsTrans hide = identToString . fromMaybe cide $ oalias enumDef enum hide trans (map identToString derive) expandHook hook@(CHSCall isPure isUns (CHSRoot ide) oalias pos) = do traceEnter -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used -- afterwards instead of the original one -- (ObjCO cdecl, ide') <- findFunObj ide True let ideLexeme = identToString ide' -- orignl name might have been a shadow hsLexeme = ideLexeme `maybe` identToString $ oalias cdecl' = ide' `simplifyDecl` cdecl callImport hook isPure isUns ideLexeme hsLexeme cdecl' pos return hsLexeme where traceEnter = traceGenBind $ "** Call hook for `" ++ identToString ide ++ "':\n" expandHook hook@(CHSCall isPure isUns apath oalias pos) = do traceEnter (decl, offsets) <- accessPath apath ptrTy <- extractSimpleType False pos decl ty <- case ptrTy of PtrET f@(FunET _ _) -> return f _ -> funPtrExpectedErr pos traceValueType ty set_get <- setGet pos CHSGet offsets ptrTy -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used -- afterwards instead of the original one -- -- (ObjCO cdecl, ide) <- findFunObj ide True let ideLexeme = identToString $ apathToIdent apath hsLexeme = ideLexeme `maybe` identToString $ oalias -- cdecl' = ide `simplifyDecl` cdecl args = concat [ " x" ++ show n | n <- [1..numArgs ty] ] callImportDyn hook isPure isUns ideLexeme hsLexeme ty pos return $ "(\\o" ++ args ++ " -> " ++ set_get ++ " o >>= \\f -> " ++ hsLexeme ++ " f" ++ args ++ ")" where traceEnter = traceGenBind $ "** Indirect call hook for `" ++ identToString (apathToIdent apath) ++ "':\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n" expandHook (CHSFun isPure isUns (CHSRoot ide) oalias ctxt parms parm pos) = do traceEnter -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used -- afterwards instead of the original one -- (ObjCO cdecl, cide) <- findFunObj ide True let ideLexeme = identToString ide -- orignal name might have been a shadow hsLexeme = ideLexeme `maybe` identToString $ oalias fiLexeme = hsLexeme ++ "'_" -- Urgh - probably unqiue... fiIde = internalIdent fiLexeme cdecl' = cide `simplifyDecl` cdecl callHook = CHSCall isPure isUns (CHSRoot cide) (Just fiIde) pos callImport callHook isPure isUns (identToString cide) fiLexeme cdecl' pos extTy <- extractFunType pos cdecl' True funDef isPure hsLexeme fiLexeme extTy ctxt parms parm Nothing pos where traceEnter = traceGenBind $ "** Fun hook for `" ++ identToString ide ++ "':\n" expandHook (CHSFun isPure isUns apath oalias ctxt parms parm pos) = do traceEnter (decl, offsets) <- accessPath apath ptrTy <- extractSimpleType False pos decl ty <- case ptrTy of PtrET f@(FunET _ _) -> return f _ -> funPtrExpectedErr pos traceValueType ty -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used -- afterwards instead of the original one -- -- (ObjCO cdecl, cide) <- findFunObj ide True let ideLexeme = identToString $ apathToIdent apath hsLexeme = ideLexeme `maybe` identToString $ oalias fiLexeme = hsLexeme ++ "'_" -- Urgh - probably unqiue... fiIde = internalIdent fiLexeme -- cdecl' = cide `simplifyDecl` cdecl -- args = concat [ " x" ++ show n | n <- [1..numArgs ty] ] callHook = CHSCall isPure isUns apath (Just fiIde) pos callImportDyn callHook isPure isUns ideLexeme fiLexeme ty pos set_get <- setGet pos CHSGet offsets ptrTy funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) ctxt parms parm (Just set_get) pos where -- remove IO from the result type of a function ExtType. necessary -- due to an unexpected interaction with the way funDef works purify (FunET a b) = FunET a (purify b) purify (IOET b) = b purify a = a traceEnter = traceGenBind $ "** Fun hook for `" ++ identToString (apathToIdent apath) ++ "':\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n" expandHook (CHSField access path pos) = do traceInfoField (decl, offsets) <- accessPath path traceDepth offsets ty <- extractSimpleType False pos decl traceValueType ty setGet pos access offsets ty where accessString = case access of CHSGet -> "Get" CHSSet -> "Set" traceInfoField = traceGenBind $ "** " ++ accessString ++ " hook:\n" traceDepth offsets = traceGenBind $ "Depth of access path: " ++ show (length offsets) ++ "\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n" expandHook (CHSPointer isStar cName oalias ptrKind isNewtype oRefType emit pos) = do traceInfoPointer let hsIde = fromMaybe cName oalias hsName = identToString hsIde hsIde `objIs` Pointer ptrKind isNewtype -- register Haskell object -- -- we check for a typedef declaration or tag (struct, union, or enum) -- declOrTag <- lookupDeclOrTag cName True case declOrTag of Left cdecl -> do -- found a typedef declaration cNameFull <- case declaredName cdecl of Just ide -> return ide Nothing -> interr "GenBind.expandHook: Where is the name?" cNameFull `refersToNewDef` ObjCD (TypeCO cdecl) -- assoc needed for chasing traceInfoCName "declaration" cNameFull unless (isStar || isPtrDecl cdecl) $ ptrExpectedErr (posOf cName) (hsType, isFun) <- case oRefType of Nothing -> do cDecl <- chaseDecl cNameFull (not isStar) et <- extractPtrType cDecl traceInfoPtrType et let et' = adjustPtr isStar et when (isVariadic et') (variadicErr pos (posOf cDecl)) return (showExtType et', isFunExtType et') Just hsType -> return (identToString hsType, False) -- FIXME: it is not possible to determine whether `hsType' -- is a function; we would need to extend the syntax to -- allow `... -> fun HSTYPE' to explicitly mark function -- types if this ever becomes important traceInfoHsType hsName hsType pointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun emit Right tag -> do -- found a tag definition let cNameFull = tagName tag traceInfoCName "tag definition" cNameFull unless isStar $ -- tags need an explicit `*' ptrExpectedErr (posOf cName) let hsType = case oRefType of Nothing -> "()" Just hsType' -> identToString hsType' traceInfoHsType hsName hsType pointerDef isStar cNameFull hsName ptrKind isNewtype hsType False emit where -- remove a pointer level if the first argument is `False' -- adjustPtr True et = et adjustPtr False (PtrET et) = et adjustPtr False (DefinedET _ _) = interr "GenBind.adjustPtr: Can't adjust defined type" adjustPtr _ _ = interr "GenBind.adjustPtr: Where is the Ptr?" -- traceInfoPointer = traceGenBind "** Pointer hook:\n" traceInfoPtrType et = traceGenBind $ "extracted ptr type is `" ++ showExtType et ++ "'\n" traceInfoHsType name ty = traceGenBind $ "associated with Haskell entity `" ++ name ++ "'\nhaving type " ++ ty ++ "\n" traceInfoCName kind ide = traceGenBind $ "found C " ++ kind ++ " for `" ++ identToString ide ++ "'\n" expandHook (CHSClass oclassIde classIde typeIde pos) = do traceInfoClass classIde `objIs` Class oclassIde typeIde -- register Haskell object superClasses <- collectClasses oclassIde Pointer ptrType isNewtype <- queryPointer typeIde when (ptrType == CHSStablePtr) $ illegalStablePtrErr pos classDef pos (identToString classIde) (identToString typeIde) ptrType isNewtype superClasses where -- compile a list of all super classes (the direct super class first) -- collectClasses :: Maybe Ident -> GB [(String, String, HsObject)] collectClasses Nothing = return [] collectClasses (Just ide) = do Class oclassIde' typeIde' <- queryClass ide ptr <- queryPointer typeIde' classes <- collectClasses oclassIde' return $ (identToString ide, identToString typeIde, ptr) : classes -- traceInfoClass = traceGenBind $ "** Class hook:\n" -- | produce code for an enumeration -- -- * an extra instance declaration is required when any of the enumeration -- constants is explicitly assigned a value in its definition -- -- * the translation function strips prefixes where possible (different -- enumerators maye have different prefixes) -- enumDef :: CEnum -> String -> TransFun -> [String] -> GB String enumDef (CEnum _ (Just list) _ _) hident trans userDerive = do (list', enumAuto) <- evalTagVals list let enumVals = [(trans ide, cexpr) | (ide, cexpr) <- 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 return $ defHead ++ defBody ++ inst where evalTagVals [] = return ([], True) evalTagVals ((ide, Nothing ):list') = do (list'', derived) <- evalTagVals list' return ((ide, Nothing):list'', derived) evalTagVals ((ide, Just exp):list') = do (list'', _derived) <- evalTagVals list' val <- evalConstCExpr exp case val of IntResult val' -> return ((ide, Just $ CConst (CIntConst (cInteger val') at1)):list'', False) FloatResult _ -> illegalConstExprErr (posOf exp) "a float result" where at1 = newAttrsOnlyPos nopos makeDerives [] = "" makeDerives dList = "deriving (" ++ concat (intersperse "," dList) ++")" -- | Haskell code for the head of an enumeration definition -- enumHead :: String -> String enumHead ident = "data " ++ ident ++ " = " -- | Haskell code for the body of an enumeration definition -- enumBody :: Int -> [(String, Maybe CExpr)] -> String enumBody _ [] = "" enumBody indent ((ide, _):list) = ide ++ "\n" ++ replicate indent ' ' ++ (if null list then "" else "| " ++ enumBody indent list) -- | Num instance for C Integers -- We should preserve type flags and repr if possible instance Num CInteger where fromInteger = cInteger (+) a b = cInteger (getCInteger a + getCInteger b) (*) a b = cInteger (getCInteger a * getCInteger b) abs a = cInteger (abs $ getCInteger a) signum a = cInteger (signum $ getCInteger a) -- | Haskell code for an instance declaration for 'Enum' -- -- * the expression of all explicitly specified tag values already have to be -- in normal form, ie, to be an int constant -- -- * enumerations start at 0 and whenever an explicit value is specified, -- following tags are assigned values continuing from the explicitly -- specified one -- enumInst :: String -> [(String, Maybe CExpr)] -> String enumInst ident list = "instance Enum " ++ ident ++ " where\n" ++ fromDef list 0 ++ "\n" ++ toDef list 0 where fromDef [] _ = "" fromDef ((ide, exp):list') n = " fromEnum " ++ ide ++ " = " ++ show' (getCInteger val) ++ "\n" ++ fromDef list' (val + 1) where val = case exp of Nothing -> n Just (CConst (CIntConst m _)) -> m Just _ -> interr "GenBind.enumInst: Integer constant expected!" -- show' x = if x < 0 then "(" ++ show x ++ ")" else show x -- toDef [] _ = " toEnum unmatched = error (\"" ++ ident ++ ".toEnum: Cannot match \" ++ show unmatched)\n" toDef ((ide, exp):list') n = " toEnum " ++ show' val ++ " = " ++ ide ++ "\n" ++ toDef list' (val + 1) where val = case exp of Nothing -> n Just (CConst (CIntConst m _)) -> m Just _ -> interr "GenBind.enumInst: Integer constant expected!" -- show' x = if x < 0 then "(" ++ show x ++ ")" else show x -- | generate a foreign import declaration that is put into the delayed code -- -- * the C declaration is a simplified declaration of the function that we -- want to import into Haskell land -- callImport :: CHSHook -> Bool -> Bool -> String -> String -> CDecl -> Position -> GB () callImport hook isPure isUns ideLexeme hsLexeme cdecl pos = do -- compute the external type from the declaration, and delay the foreign -- export declaration -- extType <- extractFunType pos cdecl isPure header <- getSwitch headerSB when (isVariadic extType) (variadicErr pos (posOf cdecl)) delayCode hook (foreignImport (extractCallingConvention cdecl) header ideLexeme hsLexeme isUns extType) traceFunType extType where traceFunType et = traceGenBind $ "Imported function type: " ++ showExtType et ++ "\n" callImportDyn :: CHSHook -> Bool -> Bool -> String -> String -> ExtType -> Position -> GB () callImportDyn hook _isPure isUns ideLexeme hsLexeme ty pos = do -- compute the external type from the declaration, and delay the foreign -- export declaration -- when (isVariadic ty) (variadicErr pos pos) -- FIXME? (posOf cdecl)) delayCode hook (foreignImportDyn ideLexeme hsLexeme isUns ty) traceFunType ty where traceFunType et = traceGenBind $ "Imported function type: " ++ showExtType et ++ "\n" -- | Haskell code for the foreign import declaration needed by a call hook -- foreignImport :: CallingConvention -> String -> String -> String -> Bool -> ExtType -> String foreignImport cconv header ident hsIdent isUnsafe ty = "foreign import " ++ showCallingConvention cconv ++ " " ++ safety ++ " " ++ show entity ++ "\n " ++ hsIdent ++ " :: " ++ showExtType ty ++ "\n" where safety = if isUnsafe then "unsafe" else "safe" entity | null header = ident | otherwise = header ++ " " ++ ident -- | Haskell code for the foreign import dynamic declaration needed by a call hook -- foreignImportDyn :: String -> String -> Bool -> ExtType -> String foreignImportDyn _ident hsIdent isUnsafe ty = "foreign import ccall " ++ safety ++ " \"dynamic\"\n " ++ hsIdent ++ " :: FunPtr( " ++ showExtType ty ++ " ) -> " ++ showExtType ty ++ "\n" where safety = if isUnsafe then "unsafe" else "safe" -- | produce a Haskell function definition for a fun hook -- -- * FIXME: There's an ugly special case in here: to support dynamic fun hooks -- I had to add a special second marshaller for the first argument, -- which, if present, is inserted just before the function call. This -- is probably not the most elegant solution, it's just the only one I -- can up with at the moment. If present, this special marshaller is -- an io action (like 'peek' and unlike 'with'). -- US funDef :: Bool -- pure function? -> String -- name of the new Haskell function -> String -- Haskell name of the foreign imported C function -> ExtType -- simplified declaration of the C function -> Maybe String -- type context of the new Haskell function -> [CHSParm] -- parameter marshalling description -> CHSParm -- result marshalling description -> Maybe String -- optional additional marshaller for first arg -> Position -- source location of the hook -> GB String -- Haskell code in text form funDef isPure hsLexeme fiLexeme extTy octxt parms parm marsh2 pos = do (parms', parm', isImpure) <- addDftMarshaller pos parms parm extTy traceMarsh parms' parm' isImpure let sig = hsLexeme ++ " :: " ++ funTy parms' parm' ++ "\n" marshs = [marshArg i parm'' | (i, parm'') <- zip [1..] parms'] funArgs = [funArg | (funArg, _, _, _, _) <- marshs, funArg /= ""] marshIns = [marshIn | (_, marshIn, _, _, _) <- marshs] callArgs = [callArg | (_, _, cs, _, _) <- marshs, callArg <- cs] marshOuts = [marshOut | (_, _, _, marshOut, _) <- marshs, marshOut /= ""] retArgs = [retArg | (_, _, _, _, retArg) <- marshs, retArg /= ""] funHead = hsLexeme ++ join funArgs ++ " =\n" ++ if isPure && isImpure then " unsafePerformIO $\n" else "" call = if isPure then " let {res = " ++ fiLexeme ++ joinCallArgs ++ "} in\n" else " " ++ fiLexeme ++ joinCallArgs ++ " >>= \\res ->\n" joinCallArgs = case marsh2 of Nothing -> join callArgs Just _ -> join ("b1'" : drop 1 callArgs) mkMarsh2 = case marsh2 of Nothing -> "" Just m -> " " ++ m ++ " " ++ join (take 1 callArgs) ++ " >>= \\b1' ->\n" marshRes = case parm' of CHSParm _ _ _twoCVal (Just (_ , CHSVoidArg )) _ -> "" CHSParm _ _ _twoCVal (Just (omBody, CHSIOVoidArg)) _ -> " " ++ marshBody omBody ++ " res >> \n" CHSParm _ _ _twoCVal (Just (omBody, CHSIOArg )) _ -> " " ++ marshBody omBody ++ " res >>= \\res' ->\n" CHSParm _ _ _twoCVal (Just (omBody, CHSValArg )) _ -> " let {res' = " ++ marshBody omBody ++ " res} in\n" CHSParm _ _ _ Nothing _ -> interr "GenBind.funDef: marshRes: no default?" marshBody (Left ide) = identToString ide marshBody (Right str) = str retArgs' = case parm' of CHSParm _ _ _ (Just (_, CHSVoidArg)) _ -> retArgs CHSParm _ _ _ (Just (_, CHSIOVoidArg)) _ -> retArgs _ -> "res'":retArgs ret = "(" ++ concat (intersperse ", " retArgs') ++ ")" funBody = joinLines marshIns ++ mkMarsh2 ++ call ++ joinLines marshOuts ++ marshRes ++ " " ++ (if isImpure || not isPure then "return " else "") ++ ret return $ sig ++ funHead ++ funBody where join = concatMap (' ':) joinLines = concatMap (\s -> " " ++ s ++ "\n") -- -- construct the function type -- -- * specified types appear in the argument and result only if their "in" -- and "out" marshaller, respectively, is not the `void' marshaller -- funTy parms' parm' = let ctxt = case octxt of Nothing -> "" Just ctxtStr -> ctxtStr ++ " => " argTys = [ty | CHSParm im ty _ _ _ <- parms' , notVoid im] resTys = [ty | CHSParm _ ty _ om _ <- parm':parms', notVoid om] resTup = let (lp, rp) = if isPure && length resTys == 1 then ("", "") else ("(", ")") io = if isPure then "" else "IO " in io ++ lp ++ concat (intersperse ", " resTys) ++ rp in ctxt ++ concat (intersperse " -> " (argTys ++ [resTup])) where notVoid Nothing = interr "GenBind.funDef: \ \No default marshaller?" notVoid (Just (_, kind)) = kind /= CHSVoidArg && kind /= CHSIOVoidArg -- -- for an argument marshaller, generate all "in" and "out" marshalling -- code fragments -- marshArg i (CHSParm (Just (imBody, imArgKind)) _ twoCVal (Just (omBody, omArgKind)) _ ) = let a = "a" ++ show (i :: Int) imStr = marshBody imBody imApp = imStr ++ " " ++ a funArg = if imArgKind == CHSVoidArg then "" else a inBndr = if twoCVal then "(" ++ a ++ "'1, " ++ a ++ "'2)" else a ++ "'" marshIn = case imArgKind of CHSVoidArg -> imStr ++ " $ \\" ++ inBndr ++ " -> " CHSIOArg -> imApp ++ " $ \\" ++ inBndr ++ " -> " CHSValArg -> "let {" ++ inBndr ++ " = " ++ imApp ++ "} in " callArgs = if twoCVal then [a ++ "'1 ", a ++ "'2"] else [a ++ "'"] omApp = marshBody omBody ++ " " ++ join callArgs outBndr = a ++ "''" marshOut = case omArgKind of CHSVoidArg -> "" CHSIOVoidArg -> omApp ++ ">>" CHSIOArg -> omApp ++ ">>= \\" ++ outBndr ++ " -> " CHSValArg -> "let {" ++ outBndr ++ " = " ++ omApp ++ "} in " retArg = if omArgKind == CHSVoidArg || omArgKind == CHSIOVoidArg then "" else outBndr marshBody (Left ide) = identToString ide marshBody (Right str) = str in (funArg, marshIn, callArgs, marshOut, retArg) marshArg _ _ = interr "GenBind.funDef: Missing default?" -- traceMarsh parms' parm' isImpure = traceGenBind $ "Marshalling specification including defaults: \n" ++ showParms (parms' ++ [parm']) "" ++ " The marshalling is " ++ if isImpure then "impure.\n" else "pure.\n" where showParms [] = id showParms (parm'':parms'') = showString " " . showCHSParm parm'' . showChar '\n' . showParms parms'' -- | add default marshallers for "in" and "out" marshalling -- addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> ExtType -> GB ([CHSParm], CHSParm, Bool) addDftMarshaller pos parms parm extTy = do let (resTy, argTys) = splitFunTy extTy (parm' , isImpure1) <- checkResMarsh parm resTy (parms', isImpure2) <- addDft parms argTys return (parms', parm', isImpure1 || isImpure2) where -- the result marshalling may not use an "in" marshaller and can only have -- one C value -- -- * a default marshaller maybe used for "out" marshalling -- checkResMarsh (CHSParm (Just _) _ _ _ pos') _ = resMarshIllegalInErr pos' checkResMarsh (CHSParm _ _ True _ pos') _ = resMarshIllegalTwoCValErr pos' checkResMarsh (CHSParm _ ty _ omMarsh pos') cTy = do (imMarsh', _ ) <- addDftVoid Nothing (omMarsh', isImpure) <- addDftOut pos' omMarsh ty [cTy] return (CHSParm imMarsh' ty False omMarsh' pos', isImpure) -- splitFunTy (FunET UnitET ty ) = splitFunTy ty splitFunTy (FunET ty1 ty2) = let (resTy, argTys) = splitFunTy ty2 in (resTy, ty1:argTys) splitFunTy resTy = (resTy, []) -- -- match Haskell with C arguments (and results) -- addDft ((CHSParm imMarsh hsTy False omMarsh p):parms'') (cTy :cTys) = do (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy] (omMarsh', isImpureOut) <- addDftVoid omMarsh (parms' , isImpure ) <- addDft parms'' cTys return (CHSParm imMarsh' hsTy False omMarsh' p : parms', isImpure || isImpureIn || isImpureOut) addDft ((CHSParm imMarsh hsTy True omMarsh p):parms'') (cTy1:cTy2:cTys) = do (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy1, cTy2] (omMarsh', isImpureOut) <- addDftVoid omMarsh (parms' , isImpure ) <- addDft parms'' cTys return (CHSParm imMarsh' hsTy True omMarsh' p : parms', isImpure || isImpureIn || isImpureOut) addDft [] [] = return ([], False) addDft ((CHSParm _ _ _ _ pos'):_) [] = marshArgMismatchErr pos' "This parameter is in excess of the C arguments." addDft [] (_:_) = marshArgMismatchErr pos "Parameter marshallers are missing." -- addDftIn _ imMarsh@(Just (_, kind)) _ _ = return (imMarsh, kind == CHSIOArg) addDftIn pos' _imMarsh@Nothing hsTy cTys = do marsh <- lookupDftMarshIn hsTy cTys when (isNothing marsh) $ noDftMarshErr pos' "\"in\"" hsTy cTys return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg}) -- addDftOut _ omMarsh@(Just (_, kind)) _ _ = return (omMarsh, kind == CHSIOArg) addDftOut pos' _omMarsh@Nothing hsTy cTys = do marsh <- lookupDftMarshOut hsTy cTys when (isNothing marsh) $ noDftMarshErr pos' "\"out\"" hsTy cTys return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg}) -- -- add void marshaller if no explict one is given -- addDftVoid marsh@(Just (_, kind)) = return (marsh, kind == CHSIOArg) addDftVoid Nothing = do return (Just (Left (internalIdent "void"), CHSVoidArg), False) -- | compute from an access path, the declarator finally accessed and the index -- path required for the access -- -- * each element in the index path specifies dereferencing an address and the -- offset to be added to the address before dereferencing -- -- * the returned declaration is already normalised (ie, alias have been -- expanded) -- -- * it may appear as if `t.m' and `t->m' should have different access paths, -- as the latter specifies one more dereferencing; this is certainly true in -- C, but it doesn't apply here, as `t.m' is merely provided for the -- convenience of the interface writer - it is strictly speaking an -- impossible access paths, as in Haskell we always have a pointer to a -- structure, we can never have the structure as a value itself -- accessPath :: CHSAPath -> GB (CDecl, [BitSize]) accessPath (CHSRoot ide) = -- t do decl <- findAndChaseDecl ide False True return (ide `simplifyDecl` decl, [BitSize 0 0]) accessPath (CHSDeref (CHSRoot ide) _) = -- *t do decl <- findAndChaseDecl ide True True return (ide `simplifyDecl` decl, [BitSize 0 0]) accessPath (CHSRef (CHSRoot ide1) ide2) = -- t.m do su <- lookupStructUnion ide1 False True (offset, decl') <- refStruct su ide2 adecl <- replaceByAlias decl' return (adecl, [offset]) accessPath (CHSRef (CHSDeref (CHSRoot ide1) _) ide2) = -- t->m do su <- lookupStructUnion ide1 True True (offset, decl') <- refStruct su ide2 adecl <- replaceByAlias decl' return (adecl, [offset]) accessPath (CHSRef path ide) = -- a.m do (decl, offset:offsets) <- accessPath path assertPrimDeclr ide decl su <- structFromDecl (posOf ide) decl (addOffset, decl') <- refStruct su ide adecl <- replaceByAlias decl' return (adecl, offset `addBitSize` addOffset : offsets) where assertPrimDeclr ide' (CDecl _ [declr] _) = case declr of (Just (CDeclr _ [] _ _ _), _, _) -> return () _ -> structExpectedErr ide' accessPath (CHSDeref path _pos) = -- *a do (decl, offsets) <- accessPath path decl' <- derefOrErr decl adecl <- replaceByAlias decl' return (adecl, BitSize 0 0 : offsets) where derefOrErr (CDecl specs [(Just declr, oinit, oexpr)] at) = do declr' <- derefDeclr declr return $ CDecl specs [(Just declr', oinit, oexpr)] at derefDeclr (CDeclr oid (CPtrDeclr _ _: derived') asm ats n) = return $ CDeclr oid derived' asm ats n derefDeclr (CDeclr _oid _unexp_deriv _ _ n) = ptrExpectedErr (posOf n) -- | replaces a decleration by its alias if any -- -- * the alias inherits any field size specification that the original -- declaration may have -- -- * declaration must have exactly one declarator -- replaceByAlias :: CDecl -> GB CDecl replaceByAlias cdecl@(CDecl _ [(_, _, size)] _at) = do ocdecl <- checkForAlias cdecl case ocdecl of Nothing -> return cdecl Just (CDecl specs [(declr, init', _)] at) -> -- form of an alias return $ CDecl specs [(declr, init', size)] at -- | given a structure declaration and member name, compute the offset of the -- member in the structure and the declaration of the referenced member -- refStruct :: CStructUnion -> Ident -> GB (BitSize, CDecl) refStruct su ide = do -- get the list of fields and check for our selector -- let (fields, tag) = structMembers su (pre, post) = span (not . flip declNamed ide) fields when (null post) $ unknownFieldErr (posOf su) ide -- -- get sizes of preceding fields and the result type (`pre' are all -- declarators preceding `ide' and the first declarator in `post' defines -- `ide') -- let decl = head post offset <- case tag of CStructTag -> offsetInStruct pre decl tag CUnionTag -> return $ BitSize 0 0 return (offset, decl) -- | does the given declarator define the given name? -- declNamed :: CDecl -> Ident -> Bool (CDecl _ [(Nothing , _, _)] _) `declNamed` _ = False (CDecl _ [(Just declr, _, _)] _) `declNamed` ide = declr `declrNamed` ide (CDecl _ [] _) `declNamed` _ = interr "GenBind.declNamed: Abstract declarator in structure!" _ `declNamed` _ = interr "GenBind.declNamed: More than one declarator!" -- | Haskell code for writing to or reading from a struct -- setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> GB String setGet pos access offsets ty = do let pre = case access of CHSSet -> "(\\ptr val -> do {" CHSGet -> "(\\ptr -> do {" body <- setGetBody (reverse offsets) return $ pre ++ body ++ "})" where setGetBody [BitSize offset bitOffset] = do let tyTag = showExtType ty bf <- checkType ty case bf of Nothing -> return $ case access of -- not a bitfield CHSGet -> peekOp offset tyTag CHSSet -> pokeOp offset tyTag "val" --FIXME: must take `bitfieldDirection' into account Just (_, bs) -> return $ case access of -- a bitfield CHSGet -> "val <- " ++ peekOp offset tyTag ++ extractBitfield CHSSet -> "org <- " ++ peekOp offset tyTag ++ insertBitfield ++ pokeOp offset tyTag "val'" where -- we have to be careful here to ensure proper sign extension; -- in particular, shifting right followed by anding a mask is -- *not* sufficient; instead, we exploit in the following that -- `shiftR' performs sign extension -- extractBitfield = "; return $ (val `shiftL` (" ++ bitsPerField ++ " - " ++ show (bs + bitOffset) ++ ")) `shiftR` (" ++ bitsPerField ++ " - " ++ show bs ++ ")" bitsPerField = show $ CInfo.size CIntPT * 8 -- insertBitfield = "; let {val' = (org .&. " ++ middleMask ++ ") .|. (val `shiftL` " ++ show bitOffset ++ ")}; " middleMask = "fromIntegral (((maxBound::CUInt) `shiftL` " ++ show bs ++ ") `rotateL` " ++ show bitOffset ++ ")" setGetBody (BitSize offset 0 : offsetsrem) = do code <- setGetBody offsetsrem return $ "ptr <- peekByteOff ptr " ++ show offset ++ "; " ++ code setGetBody (BitSize _ _ : _ ) = derefBitfieldErr pos -- -- check that the type can be marshalled and compute extra operations for -- bitfields -- checkType (VarFunET _ ) = variadicErr pos pos checkType (IOET _ ) = interr "GenBind.setGet: Illegal \ \type!" checkType (UnitET ) = voidFieldErr pos checkType (DefinedET _ _ ) = return Nothing-- can't check further checkType (PrimET (CUFieldPT bs)) = return $ Just (False, bs) checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs) checkType _ = return Nothing -- peekOp off tyTag = "peekByteOff ptr " ++ show off ++ " ::IO " ++ tyTag pokeOp off tyTag var = "pokeByteOff ptr " ++ show off ++ " (" ++ var ++ "::" ++ tyTag ++ ")" -- | generate the type definition for a pointer hook and enter the required type -- mapping into the 'ptrmap' -- pointerDef :: Bool -- explicit `*' in pointer hook -> Ident -- full C name -> String -- Haskell name -> CHSPtrType -- kind of the pointer -> Bool -- explicit newtype tag -> String -- Haskell type expression of pointer argument -> Bool -- do we have a pointer to a function? -> Bool -- shall we emit code? -> GB String pointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun emit = do let ptrArg = if isNewtype then hsName -- abstract type else hsType -- concrete type ptrCon = case ptrKind of CHSPtr | isFun -> "FunPtr" _ -> show ptrKind ptrType = ptrCon ++ " (" ++ ptrArg ++ ")" thePtr = (isStar, cNameFull) case ptrKind of CHSForeignPtr -> thePtr `ptrMapsTo` ("Ptr (" ++ ptrArg ++ ")", "Ptr (" ++ ptrArg ++ ")") _ -> thePtr `ptrMapsTo` (hsName, hsName) return $ case (emit, isNewtype) of (False, _) -> "" -- suppress code generation (True , True) -> "newtype " ++ hsName ++ " = " ++ hsName ++ " (" ++ ptrType ++ ")" ++ withForeignFun (True , False) -> "type " ++ hsName ++ " = " ++ ptrType where -- if we have a foreign pointer wrapped into a newtype, provide a -- safe unwrapping function automatically -- withForeignFun | ptrKind == CHSForeignPtr = "\n" ++ "with" ++ hsName ++ " (" ++ hsName ++ " fptr) = withForeignPtr fptr" | otherwise = "" -- | generate the class and instance definitions for a class hook -- -- * the pointer type must not be a stable pointer -- -- * the first super class (if present) must be the direct superclass -- -- * all Haskell objects in the superclass list must be pointer objects -- classDef :: Position -- for error messages -> String -- class name -> String -- pointer type name -> CHSPtrType -- type of the pointer -> Bool -- is a newtype? -> [(String, String, HsObject)] -- superclasses -> GB String classDef pos className typeName ptrType isNewtype superClasses = do let toMethodName = case typeName of "" -> interr "GenBind.classDef: \ \Illegal identifier!" c:cs -> toLower c : cs fromMethodName = "from" ++ typeName classDefContext = case superClasses of [] -> "" (superName, _, _):_ -> superName ++ " p => " classDefStr = "class " ++ classDefContext ++ className ++ " p where\n" ++ " " ++ toMethodName ++ " :: p -> " ++ typeName ++ "\n" ++ " " ++ fromMethodName ++ " :: " ++ typeName ++ " -> p\n" instDef = "instance " ++ className ++ " " ++ typeName ++ " where\n" ++ " " ++ toMethodName ++ " = id\n" ++ " " ++ fromMethodName ++ " = id\n" instDefs <- castInstDefs superClasses return $ classDefStr ++ instDefs ++ instDef where castInstDefs [] = return "" castInstDefs ((superName, ptrName, Pointer ptrType' isNewtype'):classes) = do unless (ptrType == ptrType') $ pointerTypeMismatchErr pos className superName let toMethodName = case ptrName of "" -> interr "GenBind.classDef: \ \Illegal identifier - 2!" c:cs -> toLower c : cs fromMethodName = "from" ++ ptrName castFun = "cast" ++ show ptrType typeConstr = if isNewtype then typeName ++ " " else "" superConstr = if isNewtype' then ptrName ++ " " else "" instDef = "instance " ++ superName ++ " " ++ typeName ++ " where\n" ++ " " ++ toMethodName ++ " (" ++ typeConstr ++ "p) = " ++ superConstr ++ "(" ++ castFun ++ " p)\n" ++ " " ++ fromMethodName ++ " (" ++ superConstr ++ "p) = " ++ typeConstr ++ "(" ++ castFun ++ " p)\n" instDefs <- castInstDefs classes return $ instDef ++ instDefs -- C code computations -- ------------------- -- | the result of a constant expression -- data ConstResult = IntResult Integer | FloatResult Float -- | types that may occur in foreign declarations, ie, Haskell land types -- -- * we reprsent C functions with no arguments (ie, the ANSI C `void' -- argument) by `FunET UnitET res' rather than just `res' internally, -- although the latter representation is finally emitted into the binding -- file; this is because we need to know which types are functions (in -- particular, to distinguish between `Ptr a' and `FunPtr a') -- -- * aliased types (`DefinedET') are represented by a string plus their C -- declaration; the latter is for functions interpreting the following -- structure; an aliased type is always a pointer type that is contained in -- the pointer map (and got there either from a .chi or from a pointer hook -- in the same module) -- -- * the representation for pointers does not distinguish between normal, -- function, foreign, and stable pointers; function pointers are identified -- by their argument and foreign and stable pointers are only used -- indirectly, by referring to type names introduced by a `pointer' hook -- data ExtType = FunET ExtType ExtType -- function | IOET ExtType -- operation with side effect | PtrET ExtType -- typed pointer | DefinedET CDecl String -- aliased type | PrimET CPrimType -- basic C type | UnitET -- void | VarFunET ExtType -- variadic function instance Eq ExtType where (FunET t1 t2) == (FunET t1' t2') = t1 == t1' && t2 == t2' (IOET t ) == (IOET t' ) = t == t' (PtrET t ) == (PtrET t' ) = t == t' (DefinedET _ s ) == (DefinedET _ s' ) = s == s' (PrimET t ) == (PrimET t' ) = t == t' (VarFunET t ) == (VarFunET t' ) = t == t' UnitET == UnitET = True -- | composite C type -- data CompType = ExtType ExtType -- external type | SUType CStructUnion -- structure or union -- | check whether an external type denotes a function type -- isFunExtType :: ExtType -> Bool isFunExtType (FunET _ _) = True isFunExtType (VarFunET _ ) = True isFunExtType (IOET _ ) = True isFunExtType _ = False numArgs :: ExtType -> Int numArgs (FunET _ f) = 1 + numArgs f numArgs _ = 0 -- | pretty print an external type -- -- * a previous version of this function attempted to not print unnecessary -- brackets; this however doesn't work consistently due to `DefinedET'; so, -- we give up on the idea (preferring simplicity) -- showExtType :: ExtType -> String showExtType (FunET UnitET res) = showExtType res showExtType (FunET arg res) = "(" ++ showExtType arg ++ " -> " ++ showExtType res ++ ")" showExtType (VarFunET res) = "( ... -> " ++ showExtType res ++ ")" showExtType (IOET t) = "(IO " ++ showExtType t ++ ")" showExtType (PtrET t) = let ptrCon = if isFunExtType t then "FunPtr" else "Ptr" in "(" ++ ptrCon ++ " " ++ showExtType t ++ ")" showExtType (DefinedET _ str) = "(" ++ str ++ ")" showExtType (PrimET CPtrPT) = "(Ptr ())" showExtType (PrimET CFunPtrPT) = "(FunPtr ())" showExtType (PrimET CCharPT) = "CChar" showExtType (PrimET CUCharPT) = "CUChar" showExtType (PrimET CSCharPT) = "CSChar" showExtType (PrimET CIntPT) = "CInt" showExtType (PrimET CShortPT) = "CShort" showExtType (PrimET CLongPT) = "CLong" showExtType (PrimET CLLongPT) = "CLLong" showExtType (PrimET CUIntPT) = "CUInt" showExtType (PrimET CUShortPT) = "CUShort" showExtType (PrimET CULongPT) = "CULong" showExtType (PrimET CULLongPT) = "CULLong" showExtType (PrimET CFloatPT) = "CFloat" showExtType (PrimET CDoublePT) = "CDouble" showExtType (PrimET CLDoublePT) = "CLDouble" showExtType (PrimET (CSFieldPT bs)) = "CInt{-:" ++ show bs ++ "-}" showExtType (PrimET (CUFieldPT bs)) = "CUInt{-:" ++ show bs ++ "-}" showExtType UnitET = "()" -- | compute the type of the C function declared by the given C object -- -- * the identifier specifies in which of the declarators we are interested -- -- * if the third argument is 'True', the function result should not be -- wrapped into an 'IO' type -- -- * the caller has to guarantee that the object does indeed refer to a -- function -- extractFunType :: Position -> CDecl -> Bool -> GB ExtType extractFunType pos cdecl isPure = do -- remove all declarators except that of the function we are processing; -- then, extract the functions arguments and result type (also check that -- the function is not variadic); finally, compute the external type for -- the result -- let (args, resultDecl, variadic) = funResultAndArgs cdecl preResultType <- extractSimpleType True pos resultDecl -- -- we can now add the 'IO' monad if this is no pure function -- let protoResultType = if isPure then preResultType else IOET preResultType let resultType = if variadic then VarFunET protoResultType else protoResultType -- -- compute function arguments and create a function type (a function -- prototype with `void' as its single argument declares a nullary -- function) -- argTypes <- mapM (extractSimpleType False pos) args return $ foldr FunET resultType argTypes -- | compute a non-struct/union type from the given declaration -- -- * the declaration may have at most one declarator -- extractSimpleType :: Bool -> Position -> CDecl -> GB ExtType extractSimpleType isResult pos cdecl = do traceEnter ct <- extractCompType isResult True cdecl case ct of ExtType et -> return et SUType _ -> illegalStructUnionErr (posOf cdecl) pos where traceEnter = traceGenBind $ "Entering `extractSimpleType' (" ++ (if isResult then "" else "not ") ++ "for a result)...\n" -- | compute a Haskell type for a type referenced in a C pointer type -- -- * the declaration may have at most one declarator -- -- * unknown struct/union types are mapped to '()' -- -- * do *not* take aliases into account -- -- * NB: this is by definition not a result type -- extractPtrType :: CDecl -> GB ExtType extractPtrType cdecl = do ct <- extractCompType False False cdecl case ct of ExtType et -> return et SUType _ -> return UnitET -- | compute a Haskell type from the given C declaration, where C functions are -- represented by function pointers -- -- * the declaration may have at most one declarator -- -- * typedef'ed types are chased -- -- * the first argument specifies whether the type specifies the result of a -- function (this is only applicable to direct results and not to type -- parameters for pointers that are a result) -- -- * takes the pointer map into account -- -- * IMPORTANT NOTE: `sizeAlignOf' relies on `DefinedET' only being produced -- for pointer types; if this ever changes, we need to -- handle `DefinedET's differently. The problem is that -- entries in the pointer map currently prevent -- `extractCompType' from looking further "into" the -- definition of that pointer. -- extractCompType :: Bool -> Bool -> CDecl -> GB CompType extractCompType isResult usePtrAliases cdecl@(CDecl specs' declrs ats) = if length declrs > 1 then interr "GenBind.extractCompType: Too many declarators!" else case declrs of [(Just declr, _, size)] | isPtrDeclr declr -> ptrType declr | isFunDeclr declr -> funType | otherwise -> aliasOrSpecType size [] -> aliasOrSpecType Nothing where -- handle explicit pointer types -- ptrType declr = do tracePtrType let declrs' = dropPtrDeclr declr -- remove indirection cdecl' = CDecl specs' [(Just declrs', Nothing, Nothing)] ats oalias = checkForOneAliasName cdecl' -- is only an alias remaining? osu = checkForOneCUName cdecl' oname = if oalias == Nothing then osu else oalias oHsRepr <- case oname of Nothing -> return $ Nothing Just ide -> queryPtr (True, ide) case oHsRepr of Just repr | usePtrAliases -> ptrAlias repr -- got an alias _ -> do -- no alias => recurs ct <- extractCompType False usePtrAliases cdecl' returnX $ case ct of ExtType et -> PtrET et SUType _ -> PtrET UnitET -- -- handle explicit function types -- -- FIXME: we currently regard any functions as being impure (ie, being IO -- functions); is this ever going to be a problem? -- funType = do traceFunType et <- extractFunType (posOf cdecl) cdecl False returnX et -- -- handle all types, which are not obviously pointers or functions -- aliasOrSpecType :: Maybe CExpr -> GB CompType aliasOrSpecType size = do traceAliasOrSpecType size case checkForOneAliasName cdecl of Nothing -> specType (posOf cdecl) specs' size Just ide -> do -- this is a typedef alias traceAlias ide oHsRepr <- queryPtr (False, ide) -- check for pointer hook alias case oHsRepr of Just repr | usePtrAliases -> ptrAlias repr -- found a pointer hook alias _ -> do -- skip current alias (only one) cdecl' <- getDeclOf ide let CDecl specs [(declr, init', _)] at = ide `simplifyDecl` cdecl' sdecl = CDecl specs [(declr, init', size)] at -- propagate `size' down (slightly kludgy) extractCompType isResult usePtrAliases sdecl -- -- compute the result for a pointer alias -- ptrAlias (repr1, repr2) = returnX $ DefinedET cdecl (if isResult then repr2 else repr1) -- -- wrap an `ExtType' into a `CompType' -- returnX retval = return $ ExtType retval -- tracePtrType = traceGenBind $ "extractCompType: explicit pointer type\n" traceFunType = traceGenBind $ "extractCompType: explicit function type\n" traceAliasOrSpecType Nothing = traceGenBind $ "extractCompType: checking for alias\n" traceAliasOrSpecType (Just _) = traceGenBind $ "extractCompType: checking for alias of bitfield\n" traceAlias ide = traceGenBind $ "extractCompType: found an alias called `" ++ identToString ide ++ "'\n" -- | C to Haskell type mapping described in the DOCU section -- typeMap :: [([CTypeSpec], ExtType)] typeMap = [([void] , UnitET ), ([char] , PrimET CCharPT ), ([unsigned, char] , PrimET CUCharPT ), ([signed, char] , PrimET CSCharPT ), ([signed] , PrimET CIntPT ), ([int] , PrimET CIntPT ), ([signed, int] , PrimET CIntPT ), ([short] , PrimET CShortPT ), ([short, int] , PrimET CShortPT ), ([signed, short] , PrimET CShortPT ), ([signed, short, int] , PrimET CShortPT ), ([long] , PrimET CLongPT ), ([long, int] , PrimET CLongPT ), ([signed, long] , PrimET CLongPT ), ([signed, long, int] , PrimET CLongPT ), ([long, long] , PrimET CLLongPT ), ([long, long, int] , PrimET CLLongPT ), ([signed, long, long] , PrimET CLLongPT ), ([signed, long, long, int] , PrimET CLLongPT ), ([unsigned] , PrimET CUIntPT ), ([unsigned, int] , PrimET CUIntPT ), ([unsigned, short] , PrimET CUShortPT ), ([unsigned, short, int] , PrimET CUShortPT ), ([unsigned, long] , PrimET CULongPT ), ([unsigned, long, int] , PrimET CULongPT ), ([unsigned, long, long] , PrimET CULLongPT ), ([unsigned, long, long, int] , PrimET CULLongPT ), ([float] , PrimET CFloatPT ), ([double] , PrimET CDoublePT ), ([long, double] , PrimET CLDoublePT), ([enum] , PrimET CIntPT )] where void = CVoidType undefined char = CCharType undefined short = CShortType undefined int = CIntType undefined long = CLongType undefined float = CFloatType undefined double = CDoubleType undefined signed = CSignedType undefined unsigned = CUnsigType undefined enum = CEnumType undefined undefined -- | compute the complex (external) type determined by a list of type specifiers -- -- * may not be called for a specifier that defines a typedef alias -- specType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB CompType specType cpos specs'' osize = let tspecs = [ts | CTypeSpec ts <- specs''] in case lookupTSpec tspecs typeMap of Just et | isUnsupportedType et -> unsupportedTypeSpecErr cpos | isNothing osize -> return $ ExtType et -- not a bitfield | otherwise -> bitfieldSpec tspecs et osize -- bitfield Nothing -> case tspecs of [CSUType cu _] -> return $ SUType cu -- struct or union [CEnumType _ _] -> return $ ExtType (PrimET CIntPT) -- enum [CTypeDef _ _] -> interr "GenBind.specType: Illegal typedef alias!" _ -> illegalTypeSpecErr cpos where lookupTSpec = lookupBy matches -- -- can't be a bitfield (yet) isUnsupportedType (PrimET et) = CInfo.size et == 0 isUnsupportedType _ = False -- -- check whether two type specifier lists denote the same type; handles -- types like `long long' correctly, as `deleteBy' removes only the first -- occurrence of the given element -- matches :: [CTypeSpec] -> [CTypeSpec] -> Bool [] `matches` [] = True [] `matches` (_:_) = False (spec:specs) `matches` specs' | any (eqSpec spec) specs' = specs `matches` deleteBy eqSpec spec specs' | otherwise = False -- eqSpec (CVoidType _) (CVoidType _) = True eqSpec (CCharType _) (CCharType _) = True eqSpec (CShortType _) (CShortType _) = True eqSpec (CIntType _) (CIntType _) = True eqSpec (CLongType _) (CLongType _) = True eqSpec (CFloatType _) (CFloatType _) = True eqSpec (CDoubleType _) (CDoubleType _) = True eqSpec (CSignedType _) (CSignedType _) = True eqSpec (CUnsigType _) (CUnsigType _) = True eqSpec (CSUType _ _) (CSUType _ _) = True eqSpec (CEnumType _ _) (CEnumType _ _) = True eqSpec (CTypeDef _ _) (CTypeDef _ _) = True eqSpec _ _ = False -- bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType bitfieldSpec tspecs et (Just sizeExpr) = -- never called with 'Nothing' do PlatformSpec {bitfieldIntSignedPS = bitfieldIntSigned} <- getPlatform let pos = posOf sizeExpr sizeResult <- evalConstCExpr sizeExpr case sizeResult of FloatResult _ -> illegalConstExprErr pos "a float result" IntResult size' -> do let size = fromInteger size' case et of PrimET CUIntPT -> returnCT $ CUFieldPT size PrimET CIntPT | [signed] `matches` tspecs || [signed, int] `matches` tspecs -> returnCT $ CSFieldPT size | [int] `matches` tspecs -> returnCT $ if bitfieldIntSigned then CSFieldPT size else CUFieldPT size _ -> illegalFieldSizeErr pos where returnCT = return . ExtType . PrimET -- int = CIntType undefined signed = CSignedType undefined -- handle calling convention -- ------------------------- data CallingConvention = StdCallConv | CCallConv deriving (Eq) -- | determine the calling convention for the provided decl extractCallingConvention :: CDecl -> CallingConvention extractCallingConvention cdecl | hasStdCallAttr cdecl = StdCallConv | otherwise = CCallConv where isStdCallAttr (CAttr x _ _) = identToString x == "stdcall" || identToString x == "__stdcall__" hasStdCallAttr = any isStdCallAttr . funAttrs funAttrs (CDecl specs declrs _) = let (_,attrs',_,_,_) = partitionDeclSpecs specs in attrs' ++ funEndAttrs declrs -- attrs after the function name, e.g. void foo() __attribute__((...)); funEndAttrs [(Just ((CDeclr _ (CFunDeclr _ _ _ : _) _ attrs _)), _, _)] = attrs funEndAttrs _ = [] -- | generate the necessary parameter for "foreign import" for the -- provided calling convention showCallingConvention :: CallingConvention -> String showCallingConvention StdCallConv = "stdcall" showCallingConvention CCallConv = "ccall" -- offset and size computations -- ---------------------------- -- | precise size representation -- -- * this is a pair of a number of octets and a number of bits -- -- * if the number of bits is nonzero, the octet component is aligned by the -- alignment constraint for 'CIntPT' (important for accessing bitfields with -- more than 8 bits) -- data BitSize = BitSize Int Int deriving (Eq, Show) -- | ordering relation compares in terms of required storage units -- instance Ord BitSize where bs1@(BitSize o1 b1) < bs2@(BitSize o2 b2) = padBits bs1 < padBits bs2 || (o1 == o2 && b1 < b2) bs1 <= bs2 = bs1 < bs2 || bs1 == bs2 -- the <= instance is needed for Ord's compare functions, which is used in -- the defaults for all other members -- | add two bit size values -- addBitSize :: BitSize -> BitSize -> BitSize addBitSize (BitSize o1 b1) (BitSize o2 b2) = BitSize (o1 + o2 + overflow) rest where bitsPerBitfield = CInfo.size CIntPT * 8 (overflow, rest) = (b1 + b2) `divMod` bitsPerBitfield -- | multiply a bit size by a constant (gives size of an array) -- -- * not sure if this makes sense if the number of bits is non-zero. -- scaleBitSize :: Int -> BitSize -> BitSize scaleBitSize n (BitSize o1 b1) = BitSize (n * o1 + overflow) rest where bitsPerBitfield = CInfo.size CIntPT * 8 (overflow, rest) = (n * b1) `divMod` bitsPerBitfield -- | pad any storage unit that is partially used by a bitfield -- padBits :: BitSize -> Int padBits (BitSize o 0) = o padBits (BitSize o _) = o + CInfo.size CIntPT -- | compute the offset of the declarator in the second argument when it is -- preceded by the declarators in the first argument -- offsetInStruct :: [CDecl] -> CDecl -> CStructTag -> GB BitSize offsetInStruct [] _ _ = return $ BitSize 0 0 offsetInStruct decls decl tag = do PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform (offset, _) <- sizeAlignOfStruct decls tag (_, align) <- sizeAlignOf decl return $ alignOffset offset align bitfieldAlignment -- | compute the size and alignment (no padding at the end) of a set of -- declarators from a struct -- sizeAlignOfStruct :: [CDecl] -> CStructTag -> GB (BitSize, Int) sizeAlignOfStruct [] _ = return (BitSize 0 0, 1) sizeAlignOfStruct decls CStructTag = do PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform (offset, preAlign) <- sizeAlignOfStruct (init decls) CStructTag (size, align) <- sizeAlignOf (last decls) let sizeOfStruct = alignOffset offset align bitfieldAlignment `addBitSize` size align' = if align > 0 then align else bitfieldAlignment alignOfStruct = preAlign `max` align' return (sizeOfStruct, alignOfStruct) sizeAlignOfStruct decls CUnionTag = do PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform (sizes, aligns) <- mapAndUnzipM sizeAlignOf decls let aligns' = [if align > 0 then align else bitfieldAlignment | align <- aligns] return (maximum sizes, maximum aligns') -- | compute the size and alignment of the declarators forming a struct -- including any end-of-struct padding that is needed to make the struct ``tile -- in an array'' (K&R A7.4.8) -- sizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int) sizeAlignOfStructPad decls tag = do PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform (size, align) <- sizeAlignOfStruct decls tag return (alignOffset size align bitfieldAlignment, align) -- | compute the size and alignment constraint of a given C declaration -- sizeAlignOf :: CDecl -> GB (BitSize, Int) sizeAlignOfSingle :: CDecl -> GB (BitSize, Int) -- -- * we make use of the assertion that 'extractCompType' can only return a -- 'DefinedET' when the declaration is a pointer declaration -- * for arrays, alignment is the same as for the base type and the size -- is the size of the base type multiplied by the number of elements. -- FIXME: I'm not sure whether anything of this is guaranteed by ISO C -- and I have no idea what happens when an array-of-bitfield is -- declared. At this time I don't care. -- U.S. 05/2006 -- sizeAlignOf (CDecl dclspec [(Just (CDeclr oide (CArrDeclr _ (CArrSize _ lexpr) _ : derived') _asm _ats n), init', expr)] attr) = do (bitsize, align) <- sizeAlignOf (CDecl dclspec [(Just (CDeclr oide derived' Nothing [] n), init', expr)] attr) IntResult len <- evalConstCExpr lexpr return (fromIntegral len `scaleBitSize` bitsize, align) sizeAlignOf (CDecl _ [(Just (CDeclr _ (CArrDeclr _ (CNoArrSize _) _ : _) _ _ _), _init, _expr)] _) = interr "GenBind.sizeAlignOf: array of undeclared size." sizeAlignOf cdecl = sizeAlignOfSingle cdecl sizeAlignOfSingle cdecl = do ct <- extractCompType False False cdecl case ct of ExtType (FunET _ _ ) -> do align <- alignment CFunPtrPT return (bitSize CFunPtrPT, align) ExtType (VarFunET _ ) -> do align <- alignment CFunPtrPT return (bitSize CFunPtrPT, align) ExtType (IOET _ ) -> interr "GenBind.sizeof: Illegal IO type!" ExtType (PtrET t ) | isFunExtType t -> do align <- alignment CFunPtrPT return (bitSize CFunPtrPT, align) | otherwise -> do align <- alignment CPtrPT return (bitSize CPtrPT, align) ExtType (DefinedET _ _ ) -> interr "GenBind.sizeAlignOf: Should never get a defined type" {- OLD: do align <- alignment CPtrPT return (bitSize CPtrPT, align) -- FIXME: The defined type could be a function pointer!!! -} ExtType (PrimET pt ) -> do align <- alignment pt return (bitSize pt, align) ExtType UnitET -> voidFieldErr (posOf cdecl) SUType su -> do let (fields, tag) = structMembers su fields' <- let ide = structName su in if (not . null $ fields) || isNothing ide then return fields else do -- get the real... tag' <- findTag (fromJust ide) -- ...definition case tag' of Just (StructUnionCT su') -> return (fst . structMembers $ su') _ -> return fields sizeAlignOfStructPad fields' tag where bitSize et | sz < 0 = BitSize 0 (-sz) -- size is in bits | otherwise = BitSize sz 0 where sz = CInfo.size et -- | apply the given alignment constraint at the given offset -- -- * if the alignment constraint is negative or zero, it is the alignment -- constraint for a bitfield -- -- * the third argument gives the platform-specific bitfield alignment -- alignOffset :: BitSize -> Int -> Int -> BitSize alignOffset offset@(BitSize octetOffset bitOffset) align bitfieldAlignment | align > 0 && bitOffset /= 0 = -- close bitfield first alignOffset (BitSize (octetOffset + (bitOffset + 7) `div` 8) 0) align bitfieldAlignment | align > 0 && bitOffset == 0 = -- no bitfields involved BitSize (((octetOffset - 1) `div` align + 1) * align) 0 | bitOffset == 0 -- start a bitfield || overflowingBitfield = -- .. or overflowing bitfield alignOffset offset bitfieldAlignment bitfieldAlignment | otherwise = -- stays in current bitfield offset where bitsPerBitfield = CInfo.size CIntPT * 8 overflowingBitfield = bitOffset - align >= bitsPerBitfield -- note, `align' is negative -- constant folding -- ---------------- -- | evaluate a constant expression -- -- FIXME: this is a bit too simplistic, as the range of expression allowed as -- constant expression varies depending on the context in which the -- constant expression occurs -- evalConstCExpr :: CExpr -> GB ConstResult evalConstCExpr (CComma _ at) = illegalConstExprErr (posOf at) "a comma expression" evalConstCExpr (CAssign _ _ _ at) = illegalConstExprErr (posOf at) "an assignment" evalConstCExpr (CCond b (Just t) e _) = do bv <- evalConstCExpr b case bv of IntResult bvi -> if bvi /= 0 then evalConstCExpr t else evalConstCExpr e FloatResult _ -> illegalConstExprErr (posOf b) "a float result" evalConstCExpr (CBinary op lhs rhs at) = do lhsVal <- evalConstCExpr lhs rhsVal <- evalConstCExpr rhs let (lhsVal', rhsVal') = usualArithConv lhsVal rhsVal applyBin (posOf at) op lhsVal' rhsVal' evalConstCExpr (CCast _ _ _) = todo "GenBind.evalConstCExpr: Casts are not implemented yet." evalConstCExpr (CUnary op arg at) = do argVal <- evalConstCExpr arg applyUnary (posOf at) op argVal evalConstCExpr (CSizeofExpr _ _) = todo "GenBind.evalConstCExpr: sizeof not implemented yet." evalConstCExpr (CSizeofType decl _) = do (size, _) <- sizeAlignOf decl return $ IntResult (fromIntegral . padBits $ size) evalConstCExpr (CAlignofExpr _ _) = todo "GenBind.evalConstCExpr: alignof (GNU C extension) not implemented yet." evalConstCExpr (CAlignofType decl _) = do (_, align) <- sizeAlignOf decl return $ IntResult (fromIntegral align) evalConstCExpr (CIndex _ _ at) = illegalConstExprErr (posOf at) "array indexing" evalConstCExpr (CCall _ _ at) = illegalConstExprErr (posOf at) "function call" evalConstCExpr (CMember _ _ _ at) = illegalConstExprErr (posOf at) "a . or -> operator" evalConstCExpr (CVar ide''' at) = do (cobj, _) <- findValueObj ide''' False case cobj of EnumCO ide'' (CEnum _ (Just enumrs) _ _) -> liftM IntResult $ enumTagValue ide'' enumrs 0 _ -> todo $ "GenBind.evalConstCExpr: variable names not implemented yet " ++ show (posOf at) where -- FIXME: this is not very nice; instead, CTrav should have some support -- for determining enum tag values (but then, constant folding needs -- to be moved to CTrav, too) -- -- Compute the tag value for `ide' defined in the given enumerator list -- enumTagValue _ [] _ = interr "GenBind.enumTagValue: enumerator not in declaration" enumTagValue ide ((ide', oexpr):enumrs) val = do val' <- case oexpr of Nothing -> return val Just exp -> do val' <- evalConstCExpr exp case val' of IntResult val'' -> return val'' FloatResult _ -> illegalConstExprErr (posOf exp) "a float result" if ide == ide' then -- found the right enumerator return val' else -- continue down the enumerator list enumTagValue ide enumrs (val' + 1) evalConstCExpr (CConst c) = evalCConst c evalCConst :: CConst -> GB ConstResult evalCConst (CIntConst i _ ) = return $ IntResult (getCInteger i) evalCConst (CCharConst c _ ) = return $ IntResult (getCCharAsInt c) evalCConst (CFloatConst _ _ ) = todo "GenBind.evalCConst: Float conversion from literal misses." evalCConst (CStrConst _ at) = illegalConstExprErr (posOf at) "a string constant" usualArithConv :: ConstResult -> ConstResult -> (ConstResult, ConstResult) usualArithConv lhs@(FloatResult _) rhs = (lhs, toFloat rhs) usualArithConv lhs rhs@(FloatResult _) = (toFloat lhs, rhs) usualArithConv lhs rhs = (lhs, rhs) toFloat :: ConstResult -> ConstResult toFloat x@(FloatResult _) = x toFloat (IntResult i) = FloatResult . fromIntegral $ i applyBin :: Position -> CBinaryOp -> ConstResult -> ConstResult -> GB ConstResult applyBin _ CMulOp (IntResult x) (IntResult y) = return $ IntResult (x * y) applyBin _ CMulOp (FloatResult x) (FloatResult y) = return $ FloatResult (x * y) applyBin _ CDivOp (IntResult x) (IntResult y) = return $ IntResult (x `div` y) applyBin _ CDivOp (FloatResult x) (FloatResult y) = return $ FloatResult (x / y) applyBin _ CRmdOp (IntResult x) (IntResult y) = return$ IntResult (x `mod` y) applyBin cpos CRmdOp (FloatResult _) (FloatResult _) = illegalConstExprErr cpos "a % operator applied to a float" applyBin _ CAddOp (IntResult x) (IntResult y) = return $ IntResult (x + y) applyBin _ CAddOp (FloatResult x) (FloatResult y) = return $ FloatResult (x + y) applyBin _ CSubOp (IntResult x) (IntResult y) = return $ IntResult (x - y) applyBin _ CSubOp (FloatResult x) (FloatResult y) = return $ FloatResult (x - y) applyBin _ CShlOp (IntResult x) (IntResult y) = return $ IntResult (x * 2^y) applyBin cpos CShlOp (FloatResult _) (FloatResult _) = illegalConstExprErr cpos "a << operator applied to a float" applyBin _ CShrOp (IntResult x) (IntResult y) = return $ IntResult (x `div` 2^y) applyBin cpos CShrOp (FloatResult _) (FloatResult _) = illegalConstExprErr cpos "a >> operator applied to a float" applyBin _ COrOp (IntResult x) (IntResult y) = return $ IntResult (x .|. y) applyBin _ CAndOp (IntResult x) (IntResult y) = return $ IntResult (x .&. y) applyBin _ _ (IntResult _) (IntResult _) = todo "GenBind.applyBin: Not yet implemented operator in constant expression." applyBin _ _ (FloatResult _) (FloatResult _) = todo "GenBind.applyBin: Not yet implemented operator in constant expression." applyBin _ _ _ _ = interr "GenBind.applyBinOp: Illegal combination!" applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult applyUnary cpos CPreIncOp _ = illegalConstExprErr cpos "a ++ operator" applyUnary cpos CPreDecOp _ = illegalConstExprErr cpos "a -- operator" applyUnary cpos CPostIncOp _ = illegalConstExprErr cpos "a ++ operator" applyUnary cpos CPostDecOp _ = illegalConstExprErr cpos "a -- operator" applyUnary cpos CAdrOp _ = illegalConstExprErr cpos "a & operator" applyUnary cpos CIndOp _ = illegalConstExprErr cpos "a * operator" applyUnary _ CPlusOp arg = return arg applyUnary _ CMinOp (IntResult x) = return (IntResult (-x)) applyUnary _ CMinOp (FloatResult x) = return (FloatResult (-x)) applyUnary _ CCompOp _ = todo "GenBind.applyUnary: ~ not yet implemented." applyUnary _ CNegOp (IntResult x) = let r = toInteger . fromEnum $ (x == 0) in return (IntResult r) applyUnary cpos CNegOp (FloatResult _) = illegalConstExprErr cpos "! applied to a float" -- auxilliary functions -- -------------------- -- | print trace message -- traceGenBind :: String -> GB () traceGenBind = putTraceStr traceGenBindSW -- | generic lookup -- lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b lookupBy eq x = fmap snd . find (eq x . fst) -- | 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 -- -------------- unknownFieldErr :: Position -> Ident -> GB a unknownFieldErr cpos ide = raiseErrorCTExc (posOf ide) ["Unknown member name!", "The structure has no member called `" ++ identToString ide ++ "'. The structure is defined at", show cpos ++ "."] illegalStructUnionErr :: Position -> Position -> GB a illegalStructUnionErr cpos pos = raiseErrorCTExc pos ["Illegal structure or union type!", "There is not automatic support for marshaling of structures and", "unions; the offending type is declared at " ++ show cpos ++ "."] illegalTypeSpecErr :: Position -> GB a illegalTypeSpecErr cpos = raiseErrorCTExc cpos ["Illegal type!", "The type specifiers of this declaration do not form a legal ANSI C(89) \ \type." ] unsupportedTypeSpecErr :: Position -> GB a unsupportedTypeSpecErr cpos = raiseErrorCTExc cpos ["Unsupported type!", "The type specifier of this declaration is not supported by your \ \combination of C compiler and Haskell compiler." ] variadicErr :: Position -> Position -> GB a variadicErr pos cpos = raiseErrorCTExc pos ["Variadic function!", "Calling variadic functions is not supported by the FFI; the function", "is defined at " ++ show cpos ++ "."] illegalConstExprErr :: Position -> String -> GB a illegalConstExprErr cpos hint = raiseErrorCTExc cpos ["Illegal constant expression!", "Encountered " ++ hint ++ " in a constant expression,", "which ANSI C89 does not permit."] voidFieldErr :: Position -> GB a voidFieldErr cpos = raiseErrorCTExc cpos ["Void field in struct!", "Attempt to access a structure field of type void."] structExpectedErr :: Ident -> GB a structExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected a structure or union!", "Attempt to access member `" ++ identToString ide ++ "' in something not", "a structure or union."] ptrExpectedErr :: Position -> GB a ptrExpectedErr pos = raiseErrorCTExc pos ["Expected a pointer object!", "Attempt to dereference a non-pointer object or to use it in a `pointer' \ \hook."] funPtrExpectedErr :: Position -> GB a funPtrExpectedErr pos = raiseErrorCTExc pos ["Expected a pointer-to-function object!", "Attempt to use a non-pointer object in a `call' or `fun' hook."] illegalStablePtrErr :: Position -> GB a illegalStablePtrErr pos = raiseErrorCTExc pos ["Illegal use of a stable pointer!", "Class hooks cannot be used for stable pointers."] pointerTypeMismatchErr :: Position -> String -> String -> GB a pointerTypeMismatchErr pos className superName = raiseErrorCTExc pos ["Pointer type mismatch!", "The pointer of the class hook for `" ++ className ++ "' is of a different kind", "than that of the class hook for `" ++ superName ++ "'; this is illegal", "as the latter is defined to be an (indirect) superclass of the former."] illegalFieldSizeErr :: Position -> GB a illegalFieldSizeErr cpos = raiseErrorCTExc cpos ["Illegal field size!", "Only signed and unsigned `int' types may have a size annotation."] derefBitfieldErr :: Position -> GB a derefBitfieldErr pos = raiseErrorCTExc pos ["Illegal dereferencing of a bit field!", "Bit fields cannot be dereferenced."] resMarshIllegalInErr :: Position -> GB a resMarshIllegalInErr pos = raiseErrorCTExc pos ["Malformed result marshalling!", "An \"in\" marshaller is not allowed for the function result type.", "Note that \"out\" marshallers are specified *after* the type, like:", " {# fun ... -> `MyType' mkMyType #} "] resMarshIllegalTwoCValErr :: Position -> GB a resMarshIllegalTwoCValErr pos = raiseErrorCTExc pos ["Malformed result marshalling!", "Two C values (i.e., the `&' symbol) are not allowed for the result."] marshArgMismatchErr :: Position -> String -> GB a marshArgMismatchErr pos reason = raiseErrorCTExc pos ["Function arity mismatch!", reason] noDftMarshErr :: Position -> String -> String -> [ExtType] -> GB a noDftMarshErr pos inOut hsTy cTys = raiseErrorCTExc pos ["Missing " ++ inOut ++ " marshaller!", "There is no default marshaller for this combination of Haskell and \ \C type:", "Haskell type: " ++ hsTy, "C type : " ++ concat (intersperse " " (map showExtType cTys))] c2hs-0.16.4/src/C2HS/Gen/Header.hs0000644000000000000000000002752712044310770014365 0ustar0000000000000000-- C->Haskell Compiler: custom header generator -- -- Author : Manuel M T Chakravarty -- Created: 5 February 2003 -- -- Copyright (c) 2004 Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module implements the generation of a custom header from a binding -- module. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Computing CPP Conditionals -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- We obtain information about which branches of CPP conditions are taken -- during pre-processing of the custom header file by introducing new -- struct declarations. Specifically, after each #if[[n]def] or #elif, -- we place a declaration of the form -- -- struct C2HS_COND_SENTRY; -- -- We can, then, determine which branch of a conditional has been taken by -- checking whether the struct corresponding to that conditional has been -- declared. -- --- TODO ---------------------------------------------------------------------- -- -- * Ideally, `ghFrag[s]' should be tail recursive module C2HS.Gen.Header ( genHeader ) where -- standard libraries import Control.Monad (when,liftM) -- Language.C / Compiler Toolkit import Language.C.Data import Language.C.Pretty import Language.C.Syntax import Data.Errors (interr) import Data.DLists (DList) import qualified Data.DLists as DL -- C->Haskell import C2HS.State (CST, runCST, transCST, raiseError, catchExc, throwExc, errorsPresent, showErrors, fatal) -- friends import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSChangeCase(..), CHSTrans(..)) -- | The header generation monad -- type GH a = CST [Name] a -- | Generate a custom C header from a CHS binding module. -- -- * All CPP directives and inline-C fragments are moved into the custom header -- -- * The CPP and inline-C fragments are removed from the .chs tree and -- conditionals are replaced by structured conditionals -- genHeader :: CHSModule -> CST s ([String], CHSModule, String) genHeader mod' = do (header, mod'') <- runCST (ghModule mod') newNameSupply `ifGHExc` return ([], CHSModule []) -- check for errors and finalise -- errs <- errorsPresent if errs then do errmsgs <- showErrors fatal ("Errors during generation of C header:\n\n" -- fatal error ++ errmsgs) else do warnmsgs <- showErrors return (header, mod'', warnmsgs) -- | Obtain a new base name that may be used, in C, to encode the result of a -- preprocessor conditional. -- newName :: CST [Name] String newName = transCST $ \supply -> (tail supply, "C2HS_COND_SENTRY_" ++ (show.nameId) (head supply)) -- | Various forms of processed fragments -- data FragElem = Frag CHSFrag | Elif String Position | Else Position | Endif Position | EOF instance Pos FragElem where posOf (Frag frag ) = posOf frag posOf (Elif _ pos) = pos posOf (Else pos) = pos posOf (Endif pos) = pos posOf EOF = nopos -- | check for end of file -- isEOF :: FragElem -> Bool isEOF EOF = True isEOF _ = False -- | Generate the C header for an entire .chs module. -- -- * This works more or less like a recursive decent parser for a statement -- sequence that may contain conditionals, where 'ghFrag' implements most of -- the state transition system of the associated automaton -- ghModule :: CHSModule -> GH ([String], CHSModule) ghModule (CHSModule frags) = do (header, frags', last', _rest) <- ghFrags frags when (not . isEOF $ last') $ notOpenCondErr (posOf last') return (DL.close header, CHSModule frags') -- | Collect header and fragments up to eof or a CPP directive that is part of a -- conditional -- -- * We collect the header (ie, CPP directives and inline-C) using a -- difference list to avoid worst case O(n^2) complexity due to -- concatenation of lines that go into the header. -- ghFrags :: [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag]) ghFrags [] = return (DL.zero, [], EOF, []) ghFrags frags = do (header, frag, rest) <- ghFrag frags case frag of Frag aFrag -> do (header2, frags', frag', rest') <- ghFrags rest -- FIXME: Not tail rec return (header `DL.join` header2, aFrag:frags', frag', rest') _ -> return (header, [], frag, rest) -- | Process a single fragment *structure*; i.e., if the first fragment -- introduces a conditional, process the whole conditional; otherwise, process -- the first fragment -- ghFrag :: [CHSFrag] -> GH (DList String, -- partial header file FragElem, -- processed fragment [CHSFrag]) -- not yet processed fragments ghFrag [] = return (DL.zero, EOF, []) ghFrag (frag@(CHSVerb _ _ ) : frags) = return (DL.zero, Frag frag, frags) -- generate an enum __c2hs__enum__'id { __c2hs_enr__'id = DEF1, ... } and then process an -- ordinary enum directive ghFrag (_frag@(CHSHook (CHSEnumDefine hsident trans instances pos)) : frags) = do ide <- newEnumIdent (enrs,trans') <- createEnumerators trans return (DL.open [show.pretty $ enumDef ide enrs,";\n"], Frag (enumFrag (identToString ide) trans'), frags) where newEnumIdent = liftM internalIdent $ transCST $ \supply -> (tail supply, "__c2hs_enum__" ++ show (nameId $ head supply)) newEnrIdent = liftM internalIdent $ transCST $ \supply -> (tail supply, "__c2hs_enr__" ++ show (nameId $ head supply)) createEnumerators (CHSTrans isUnderscore changeCase aliases) | isUnderscore = raiseErrorGHExc pos ["underScoreToCase is meaningless for `enum define' hooks"] | changeCase /= CHSSameCase = raiseErrorGHExc pos ["changing case is meaningless for `enum define' hooks"] | otherwise = do (enrs,transtbl') <- liftM unzip (mapM createEnumerator aliases) return (enrs,CHSTrans False CHSSameCase transtbl') createEnumerator (cid,hsid) = liftM (\enr -> ((enr,cid),(enr,hsid))) newEnrIdent enumDef ide enrs = CEnum (Just ide) (Just$ map mkEnr enrs) [] internalNode where mkEnr (name,value) = (name, Just $ CVar value internalNode) enumFrag ide trans' = CHSHook (CHSEnum (internalIdent ide) (Just hsident) trans' Nothing instances pos) ghFrag (frag@(CHSHook _ ) : frags) = return (DL.zero, Frag frag, frags) ghFrag (frag@(CHSLine _ ) : frags) = return (DL.zero, Frag frag, frags) ghFrag ( (CHSC s _ ) : frags) = do (header, frag, frags' ) <- ghFrag frags -- scan for next CHS fragment return (DL.unit s `DL.join` header, frag, frags') -- FIXME: this is not tail recursive... ghFrag ( (CHSCond _ _ ) : _ ) = interr "GenHeader.ghFrags: There can't be a structured conditional yet!" ghFrag ( (CHSCPP s pos) : frags) = let (directive, _) = break (`elem` " \t") . dropWhile (`elem` " \t") $ s in case directive of "if" -> openIf s pos frags "ifdef" -> openIf s pos frags "ifndef" -> openIf s pos frags "else" -> return (DL.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) where -- enter a new conditional (may be an #if[[n]def] or #elif) -- -- * Arguments are the lexeme of the directive `s', the position of that -- directive `pos', and the fragments following the directive `frags' -- openIf s' _pos frags' = do (headerTh, fragsTh, last', rest) <- ghFrags frags' case last' of Else _pos' -> do (headerEl, fragsEl, last'', rest') <- ghFrags rest case last'' of Else pos' -> notOpenCondErr pos' Elif _ pos' -> notOpenCondErr pos' Endif _ -> closeIf ((headerTh `DL.snoc` "#else\n") `DL.join` (headerEl `DL.snoc` "#endif\n")) (s', fragsTh) [] (Just fragsEl) rest' EOF -> notClosedCondErr pos Elif s'' pos' -> do (headerEl, condFrag, rest') <- openIf s'' pos' rest case condFrag of Frag (CHSCond alts dft) -> closeIf (headerTh `DL.join` headerEl) (s, fragsTh) alts dft rest' _ -> interr "GenHeader.ghFrag: Expected CHSCond!" Endif _ -> closeIf (headerTh `DL.snoc` "#endif\n") (s, fragsTh) [] (Just []) rest EOF -> notClosedCondErr pos -- -- turn a completed conditional into a 'CHSCond' fragment -- -- * `(s, fragsTh)' is the CPP directive `s' containing the condition under -- which `fragTh' should be executed; `alts' are alternative branches -- (with conditions); and `oelse' is an optional else-branch -- closeIf headerTail (s', fragsTh) alts oelse rest = do sentryName <- newName let sentry = internalIdent sentryName -- don't use an internal ident, as we need to test for -- equality with identifiers read from the .i file -- during binding hook expansion header = DL.open ['#':s', "\n", "struct ", sentryName, ";\n"] `DL.join` headerTail return (header, Frag (CHSCond ((sentry, fragsTh):alts) oelse), rest) -- exception handling -- ------------------ -- | exception identifier -- ghExc :: String ghExc = "ghExc" -- | throw an exception -- throwGHExc :: GH a throwGHExc = throwExc ghExc "Error during C header generation" -- | catch a 'ghExc' -- ifGHExc :: CST s a -> CST s a -> CST s a ifGHExc m handler = m `catchExc` (ghExc, const handler) -- | raise an error followed by throwing a GH exception -- raiseErrorGHExc :: Position -> [String] -> GH a raiseErrorGHExc pos errs = raiseError pos errs >> throwGHExc -- error messages -- -------------- notClosedCondErr :: Position -> GH a notClosedCondErr pos = raiseErrorGHExc pos ["Unexpected end of file!", "File ended while the conditional block starting here was not closed \ \properly."] notOpenCondErr :: Position -> GH a notOpenCondErr pos = raiseErrorGHExc pos ["Missing #if[[n]def]!", "There is a #else, #elif, or #endif without an #if, #ifdef, or #ifndef."] c2hs-0.16.4/src/C2HS/Gen/Monad.hs0000644000000000000000000004006512044310770014223 0ustar0000000000000000-- C->Haskell Compiler: monad for the binding generator -- -- Author : Manuel M T Chakravarty -- Derived: 18 February 2 (extracted from GenBind.hs) -- -- Copyright (c) [2002..2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This modules defines the monad and related utility routines for the code -- that implements the expansion of the binding hooks. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- Translation table handling for enumerators: -- ------------------------------------------- -- -- First a translation table lookup on the original identifier of the -- enumerator is done. If that doesn't match and the prefix can be removed -- from the identifier, a second lookup on the identifier without the prefix -- is performed. If this also doesn't match, the identifier without prefix -- (possible after underscoreToCase or similar translation is returned). If -- there is a match, the translation (without any further stripping of -- prefix) is returned. -- -- Pointer map -- ----------- -- -- Pointer hooks allow the use to customise the Haskell types to which C -- pointer types are mapped. The globally maintained map essentially maps C -- pointer types to Haskell pointer types. The representation of the Haskell -- types is defined by the `type' or `newtype' declaration emitted by the -- corresponding pointer hook. However, the map stores a flag that tells -- whether the C type is itself the pointer type in question or whether it is -- pointers to this C type that should be mapped as specified. The pointer -- map is dumped into and read from `.chi' files. -- -- Haskell object map -- ------------------ -- -- Some features require information about Haskell objects defined by c2hs. -- Therefore, the Haskell object map maintains the necessary information -- about these Haskell objects. The Haskell object map is dumped into and -- read from `.chi' files. -- --- TODO ---------------------------------------------------------------------- -- -- * Look up in translation tables is naive - this probably doesn't affect -- costs much, but at some point a little profiling might be beneficial. -- module C2HS.Gen.Monad ( TransFun, transTabToTransFun, HsObject(..), GB, initialGBState, setContext, getLibrary, getPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, queryObj, queryClass, queryPointer, mergeMaps, dumpMaps ) where -- standard libraries import Data.Char (toUpper, toLower, isSpace) import Data.List (find) import Data.Maybe (fromMaybe) import qualified Data.Map as Map (empty, insert, lookup, union, toList, fromList) import Data.Map (Map) -- Language.C import Language.C.Data.Position import Language.C.Data.Ident import Data.Errors -- C -> Haskell import C2HS.C (CT, readCT, transCT, raiseErrorCTExc) -- friends import C2HS.CHS (CHSFrag(..), CHSHook(..), CHSTrans(..), CHSChangeCase(..), CHSPtrType(..)) -- translation tables -- ------------------ -- | takes an identifier to a lexeme including a potential mapping by a -- translation table -- type TransFun = Ident -> String -- | translation function for the 'underscoreToCase' flag -- underscoreToCase :: String -> String underscoreToCase lexeme = let ps = filter (not . null) . parts $ lexeme in concat . map adjustCase $ ps where parts s = let (l, s') = break (== '_') s in l : case s' of [] -> [] (_:s'') -> parts s'' adjustCase (c:cs) = toUpper c : map toLower cs -- | translation function for the 'upcaseFirstLetter' flag -- upcaseFirstLetter :: String -> String upcaseFirstLetter "" = "" upcaseFirstLetter (c:cs) = toUpper c : cs -- | translation function for the 'downcaseFirstLetter' flag -- downcaseFirstLetter :: String -> String downcaseFirstLetter "" = "" downcaseFirstLetter (c:cs) = toLower c : cs -- | takes an identifier association table to a translation function -- -- * if first argument is 'True', identifiers that are not found in the -- translation table are subjected to 'underscoreToCase' and friends -- -- * the details of handling the prefix are given in the DOCU section at the -- beginning of this file -- transTabToTransFun :: String -> CHSTrans -> TransFun transTabToTransFun prefx (CHSTrans _2Case chgCase table) = \ide -> let caseTrafo = (if _2Case then underscoreToCase else id) . (case chgCase of CHSSameCase -> id CHSUpCase -> upcaseFirstLetter CHSDownCase -> downcaseFirstLetter) lexeme = identToString ide dft = caseTrafo lexeme -- default uses case trafo in case lookup ide table of -- lookup original ident Just ide' -> identToString ide' -- original ident matches Nothing -> case eat prefx lexeme of Nothing -> dft -- no match & no prefix Just eatenLexeme -> let eatenIde = internalIdentAt (posOf ide) eatenLexeme eatenDft = caseTrafo eatenLexeme in case lookup eatenIde table of -- lookup without prefix Nothing -> eatenDft -- orig ide without prefix Just ide' -> identToString ide' -- without prefix matched where -- try to eat prefix and return `Just partialLexeme' if successful -- eat [] ('_':cs) = eat [] cs eat [] cs = Just cs eat (p:prefx') (c:cs) | toUpper p == toUpper c = eat prefx' cs | otherwise = Nothing eat _ _ = Nothing -- the local monad -- --------------- -- | map that for maps C pointer types to Haskell types for pointer that have -- been registered using a pointer hook -- -- * the 'Bool' indicates whether for a C type "ctype", we map "ctype" itself -- or "*ctype" -- -- * in the co-domain, the first string is the type for function arguments and -- the second string is for function results; this distinction is necessary -- as 'ForeignPtr's cannot be returned by a foreign function; the -- restriction on function result types is only for the actual result, not -- for type arguments to parametrised pointer types, ie, it holds for @res@ -- in `Int -> IO res', but not in `Int -> Ptr res' -- type PointerMap = Map (Bool, Ident) (String, String) -- | map that maintains key information about some of the Haskell objects -- generated by c2hs -- -- NB: using records here avoids to run into a bug with deriving 'Read' in GHC -- 5.04.1 -- data HsObject = Pointer { ptrTypeHO :: CHSPtrType, -- kind of pointer isNewtypeHO :: Bool -- newtype? } | Class { superclassHO :: (Maybe Ident),-- superclass ptrHO :: Ident -- pointer } deriving (Show, Read) type HsObjectMap = Map Ident HsObject {- FIXME: What a mess... instance Show HsObject where show (Pointer ptrType isNewtype) = "Pointer " ++ show ptrType ++ show isNewtype show (Class osuper pointer ) = "Class " ++ show ptrType ++ show isNewtype -} -- super kludgy (depends on Show instance of Ident) instance Read Ident where readsPrec _ ('`':lexeme) = let (ideChars, rest) = span (/= '\'') lexeme in if null ideChars then [] else [(internalIdent ideChars, tail rest)] readsPrec p (c:cs) | isSpace c = readsPrec p cs readsPrec _ _ = [] -- | the local state consists of -- -- (1) the dynamic library specified by the context hook, -- (2) the prefix specified by the context hook, -- (3) the set of delayed code fragaments, ie, pieces of Haskell code that, -- finally, have to be appended at the CHS module together with the hook -- that created them (the latter allows avoid duplication of foreign -- export declarations), and -- (4) a map associating C pointer types with their Haskell representation -- -- access to the attributes of the C structure tree is via the 'CT' monad of -- which we use an instance here -- data GBState = GBState { lib :: String, -- dynamic library prefix :: String, -- prefix frags :: [(CHSHook, CHSFrag)], -- delayed code (with hooks) ptrmap :: PointerMap, -- pointer representation objmap :: HsObjectMap -- generated Haskell objects } type GB a = CT GBState a initialGBState :: GBState initialGBState = GBState { lib = "", prefix = "", frags = [], ptrmap = Map.empty, objmap = Map.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'}, ()) -- | get the dynamic library -- getLibrary :: GB String getLibrary = readCT lib -- | get the prefix string -- getPrefix :: GB String getPrefix = readCT prefix -- | add code to the delayed fragments (the code is made to start at a new line) -- -- * currently only code belonging to call hooks can be delayed -- -- * if code for the same call hook (ie, same C function) is delayed -- repeatedly only the first entry is stored; it is checked that the hooks -- specify the same flags (ie, produce the same delayed code) -- delayCode :: CHSHook -> String -> GB () delayCode hook str = do frags'' <- readCT frags frags' <- delay hook frags'' transCT (\state -> (state {frags = frags'}, ())) where newEntry = (hook, (CHSVerb ("\n" ++ str) (posOf hook))) -- delay hook'@(CHSCall isFun isUns ide _oalias _) frags' = case find (\(hook'', _) -> hook'' == hook') frags' of Just (CHSCall isFun' isUns' ide' _ _, _) | isFun == isFun' && isUns == isUns' && ide == ide' -> return frags' | otherwise -> err (posOf ide) (posOf ide') Nothing -> return $ frags' ++ [newEntry] delay _ _ = interr "GBMonad.delayCode: Illegal delay!" -- err = incompatibleCallHooksErr -- | get the complete list of delayed fragments -- getDelayedCode :: GB [CHSFrag] getDelayedCode = readCT (map snd . frags) -- | add an entry to the pointer map -- ptrMapsTo :: (Bool, Ident) -> (String, String) -> GB () (isStar, cName) `ptrMapsTo` hsRepr = transCT (\state -> (state { ptrmap = Map.insert (isStar, cName) hsRepr (ptrmap state) }, ())) -- | query the pointer map -- queryPtr :: (Bool, Ident) -> GB (Maybe (String, String)) queryPtr pcName = do fm <- readCT ptrmap return $ Map.lookup pcName fm -- | add an entry to the Haskell object map -- objIs :: Ident -> HsObject -> GB () hsName `objIs` obj = transCT (\state -> (state { objmap = Map.insert hsName obj (objmap state) }, ())) -- | query the Haskell object map -- queryObj :: Ident -> GB (Maybe HsObject) queryObj hsName = do fm <- readCT objmap return $ Map.lookup hsName fm -- | query the Haskell object map for a class -- -- * raise an error if the class cannot be found -- queryClass :: Ident -> GB HsObject queryClass hsName = do oobj <- queryObj hsName case oobj of Just obj@(Class _ _) -> return obj Just _ -> classExpectedErr hsName Nothing -> hsObjExpectedErr hsName -- | query the Haskell object map for a pointer -- -- * raise an error if the pointer cannot be found -- queryPointer :: Ident -> GB HsObject queryPointer hsName = do oobj <- queryObj hsName case oobj of Just obj@(Pointer _ _) -> return obj Just _ -> pointerExpectedErr hsName Nothing -> hsObjExpectedErr hsName -- | merge the pointer and Haskell object maps -- -- * currently, the read map overrides any entires for shared keys in the map -- that is already in the monad; this is so that, if multiple import hooks -- add entries for shared keys, the textually latest prevails; any local -- entries are entered after all import hooks anyway -- -- FIXME: This currently has several shortcomings: -- * It just dies in case of a corrupted .chi file -- * We should at least have the option to raise a warning if two -- entries collide in the 'objmap'. But it would be better to -- implement qualified names. -- * Do we want position information associated with the read idents? -- mergeMaps :: String -> GB () mergeMaps str = transCT (\state -> (state { ptrmap = Map.union readPtrMap (ptrmap state), objmap = Map.union readObjMap (objmap state) }, ())) where (ptrAssoc, objAssoc) = read str readPtrMap = Map.fromList [((isStar, internalIdent ide), repr) | ((isStar, ide), repr) <- ptrAssoc] readObjMap = Map.fromList [(internalIdent ide, obj) | (ide, obj) <- objAssoc] -- | convert the whole pointer and Haskell object maps into printable form -- dumpMaps :: GB String dumpMaps = do ptrFM <- readCT ptrmap objFM <- readCT objmap let dumpable = ([((isStar, identToString ide), repr) | ((isStar, ide), repr) <- Map.toList ptrFM], [(identToString ide, obj) | (ide, obj) <- Map.toList objFM]) return $ show dumpable -- error messages -- -------------- incompatibleCallHooksErr :: Position -> Position -> GB a incompatibleCallHooksErr here there = raiseErrorCTExc here ["Incompatible call hooks!", "There is a another call hook for the same C function at " ++ show there, "The flags and C function name of the two hooks should be identical,", "but they are not."] classExpectedErr :: Ident -> GB a classExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected a class name!", "Expected `" ++ identToString ide ++ "' to refer to a class introduced", "by a class hook."] pointerExpectedErr :: Ident -> GB a pointerExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected a pointer name!", "Expected `" ++ identToString ide ++ "' to be a type name introduced by", "a pointer hook."] hsObjExpectedErr :: Ident -> GB a hsObjExpectedErr ide = raiseErrorCTExc (posOf ide) ["Unknown name!", "`" ++ identToString ide ++ "' is unknown; it has *not* been defined by", "a previous hook."] c2hs-0.16.4/src/Text/0000755000000000000000000000000012044310770012340 5ustar0000000000000000c2hs-0.16.4/src/Text/Lexers.hs0000644000000000000000000004535612044310770014153 0ustar0000000000000000-- Compiler Toolkit: Self-optimizing lexers -- -- Author : Manuel M. T. Chakravarty -- Created: 2 March 99 -- -- Copyright (c) 1999 Manuel M. T. Chakravarty -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Library General Public -- License as published by the Free Software Foundation; either -- version 2 of the License, or (at your option) any later version. -- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Library General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- Self-optimizing lexer combinators. -- -- For detailed information, see ``Lazy Lexing is Fast'', Manuel -- M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of -- Fourth Fuji International Symposium on Functional and Logic Programming, -- Springer-Verlag, LNCS 1722, 1999. (See my Web page for details.) -- -- Thanks to Simon L. Peyton Jones and Roman -- Lechtchinsky for their helpful suggestions that -- improved the design of this library. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- The idea is to combine the benefits of off-line generators with -- combinators like in `Parsers.hs' (which builds on Swierstra/Duponcheel's -- technique for self-optimizing parser combinators). In essence, a state -- transition graph representing a lexer table is computed on the fly, to -- make lexing deterministic and based on cheap table lookups. -- -- Regular expression map to Haskell expressions as follows. If `x' and `y' -- are regular expressions, -- -- -> epsilon -- xy -> x +> y -- x*y -> x `star` y -- x+y -> x `plus` y -- x?y -> x `quest` y -- -- Given such a Haskelized regular expression `hre', we can use -- -- (1) hre `lexaction` \lexeme -> Nothing -- (2) hre `lexaction` \lexeme -> Just token -- (3) hre `lexmeta` \lexeme pos s -> (res, pos', s', Nothing) -- (4) hre `lexmeta` \lexeme pos s -> (res, pos', s', Just l) -- -- where `epsilon' is required at the end of `hre' if it otherwise ends on -- `star', `plus', or `quest', and then, we have -- -- (1) discards `lexeme' accepted by `hre', -- (2) turns the `lexeme' accepted by `hre' into a token, -- (3) while discarding the lexeme accepted by `hre', transforms the -- position and/or user state, and -- (4) while discarding the lexeme accepted by `hre', transforms the -- position and/or user state and returns a lexer to be used for the -- next lexeme. -- -- The component `res' in case of a meta action, can be `Nothing', `Just -- (Left err)', or `Just (Right token)' to return nothing, an error, or a -- token from a meta action, respectively. -- -- * By adding `ctrlLexer', `Positions' are properly handled in the presence -- of layout control characters. -- -- * This module makes essential use of graphical data structures (for -- representing the state transition graph) and laziness (for maintaining -- the last action in `execLexer'. -- -- NOTES: -- -- * In this implementation, the combinators `quest`, `star`, and `plus` are -- *right* associative - this was different in the ``Lazy Lexing is Fast'' -- paper. This change was made on a suggestion by Martin Norbäck -- . -- --- TODO ---------------------------------------------------------------------- -- -- * error correction is missing -- -- * in (>||<) in the last case, `(addBoundsNum bn bn')' is too simple, as -- the number of outgoing edges is not the sum of the numbers of the -- individual states when there are conflicting edges, ie, ones labeled -- with the same character; however, the number is only used to decide a -- heuristic, so it is questionable whether it is worth spending the -- additional effort of computing the accurate number -- -- * Unicode posses a problem as the character domain becomes too big for -- using arrays to represent transition tables and even sparse structures -- will posse a significant overhead when character ranges are naively -- represented. So, it might be time for finite maps again. -- -- Regarding the character ranges, there seem to be at least two -- possibilities. Doaitse explicitly uses ranges and avoids expanding -- them. The problem with this approach is that we may only have -- predicates such as `isAlphaNum' to determine whether a givne character -- belongs to some character class. From this representation it is -- difficult to efficiently compute a range. The second approach, as -- proposed by Tom Pledger (on the Haskell list) -- would be to actually use predicates directly and make the whole business -- efficient by caching predicate queries. In other words, for any given -- character after we have determined (in a given state) once what the -- following state on accepting that character is, we need not consult the -- predicates again if we memorise the successor state the first time -- around. -- -- * Ken Shan writes ``Section 4.3 of your paper -- computes the definition -- -- re1 `star` re2 = \l' -> let self = re1 self >||< re2 l' in self -- -- If we let re2 = epsilon, we get -- -- many :: Regexp s t -> Regexp s t -- many re = \l' -> let self = re1 self >||< l' in self -- -- since epsilon = id.'' This should actually be as good as the current -- definiton and it might be worthwhile to offer it as a variant. -- module Text.Lexers (Regexp, Lexer, Action, epsilon, char, (+>), lexaction, lexactionErr, lexmeta, (>|<), (>||<), ctrlChars, ctrlLexer, star, plus, quest, alt, string, LexerState, execLexer) where import Data.Maybe (fromMaybe) import Data.Array (Array, (!), assocs, accumArray) import Language.C.Data.Position import qualified Data.DLists as DL import Data.Errors (interr, ErrorLevel(..), Error, makeError) infixr 4 `quest`, `star`, `plus` infixl 3 +>, `lexaction`, `lexmeta` infixl 2 >|<, >||< -- constants -- --------- -- | we use the dense representation if a table has at least the given number of -- (non-error) elements -- denseMin :: Int denseMin = 20 -- data structures -- --------------- -- | represents the number of (non-error) elements and the bounds of a table -- type BoundsNum = (Int, Char, Char) -- | combine two bounds -- addBoundsNum :: BoundsNum -> BoundsNum -> BoundsNum addBoundsNum (n, lc, hc) (n', lc', hc') = (n + n', min lc lc', max hc hc') -- | check whether a character is in the bounds -- inBounds :: Char -> BoundsNum -> Bool inBounds c (_, lc, hc) = c >= lc && c <= hc -- | Lexical actions take a lexeme with its position and may return a token; in -- a variant, an error can be returned -- -- * if there is no token returned, the current lexeme is discarded lexing -- continues looking for a token -- type Action t = String -> Position -> Maybe t type ActionErr t = String -> Position -> Either Error t -- | Meta actions transform the lexeme, position, and a user-defined state; they -- may return a lexer, which is then used for accepting the next token (this -- is important to implement non-regular behaviour like nested comments) -- type Meta s t = String -> Position -> s -> (Maybe (Either Error t), -- err/tok? Position, -- new pos s, -- state Maybe (Lexer s t)) -- lexer? -- | tree structure used to represent the lexer table -- -- * each node in the tree corresponds to a state of the lexer; the associated -- actions are those that apply when the corresponding state is reached -- data Lexer s t = Lexer (LexAction s t) (Cont s t) -- | represent the continuation of a lexer -- data Cont s t = -- on top of the tree, where entries are dense, we use arrays -- Dense BoundsNum (Array Char (Lexer s t)) -- -- further down, where the valid entries are sparse, we -- use association lists, to save memory (the first argument -- is the length of the list) -- | Sparse BoundsNum [(Char, Lexer s t)] -- -- end of a automaton -- | Done -- deriving Show -- | lexical action -- data LexAction s t = Action (Meta s t) | NoAction -- deriving Show -- | a regular expression -- type Regexp s t = Lexer s t -> Lexer s t -- basic combinators -- ----------------- -- | Empty lexeme -- epsilon :: Regexp s t epsilon = id -- | One character regexp -- char :: Char -> Regexp s t char c = \l -> Lexer NoAction (Sparse (1, c, c) [(c, l)]) -- | Concatenation of regexps -- (+>) :: Regexp s t -> Regexp s t -> Regexp s t (+>) = (.) -- | Close a regular expression with an action that converts the lexeme into a -- token -- -- * Note: After the application of the action, the position is advanced -- according to the length of the lexeme. This implies that normal -- actions should not be used in the case where a lexeme might contain -- control characters that imply non-standard changes of the position, -- such as newlines or tabs. -- lexaction :: Regexp s t -> Action t -> Lexer s t lexaction re a = re `lexmeta` a' where a' lexeme pos s = let pos' = incPos pos (length lexeme) in pos' `seq` case a lexeme pos of Nothing -> (Nothing, pos', s, Nothing) Just t -> (Just (Right t), pos', s, Nothing) -- | Variant for actions that may returns an error -- lexactionErr :: Regexp s t -> ActionErr t -> Lexer s t lexactionErr re a = re `lexmeta` a' where a' lexeme pos s = let pos' = incPos pos (length lexeme) in pos' `seq` (Just (a lexeme pos), pos', s, Nothing) -- | Close a regular expression with a meta action -- -- * Note: Meta actions have to advance the position in dependence of the -- lexeme by themselves. -- lexmeta :: Regexp s t -> Meta s t -> Lexer s t lexmeta re a = re (Lexer (Action a) Done) -- | disjunctive combination of two regexps -- (>|<) :: Regexp s t -> Regexp s t -> Regexp s t re >|< re' = \l -> re l >||< re' l -- | disjunctive combination of two lexers -- (>||<) :: Lexer s t -> Lexer s t -> Lexer s t (Lexer a c) >||< (Lexer a' c') = Lexer (joinActions a a') (joinConts c c') -- | combine two disjunctive continuations -- joinConts :: Cont s t -> Cont s t -> Cont s t joinConts Done c' = c' joinConts c Done = c joinConts c c' = let (bn , cls ) = listify c (bn', cls') = listify c' in -- note: `addsBoundsNum' can, at this point, only -- approx. the number of *non-overlapping* cases; -- however, the bounds are correct -- aggregate (addBoundsNum bn bn') (cls ++ cls') where listify (Dense n arr) = (n, assocs arr) listify (Sparse n cls) = (n, cls) listify _ = interr "Lexers.listify: Impossible argument!" -- | combine two actions -- joinActions :: LexAction s t -> LexAction s t -> LexAction s t joinActions NoAction a' = a' joinActions a NoAction = a joinActions _ _ = interr "Lexers.>||<: Overlapping actions!" -- | Note: `n' is only an upper bound of the number of non-overlapping cases -- aggregate :: BoundsNum -> ([(Char, Lexer s t)]) -> Cont s t aggregate bn@(n, lc, hc) cls | n >= denseMin = Dense bn (accumArray (>||<) noLexer (lc, hc) cls) | otherwise = Sparse bn (accum (>||<) cls) where noLexer = Lexer NoAction Done -- | combine the elements in the association list that have the same key -- accum :: Eq a => (b -> b -> b) -> [(a, b)] -> [(a, b)] accum _ [] = [] accum f ((k, e):kes) = let (ke, kes') = gather k e kes in ke : accum f kes' where gather k' e' [] = ((k', e'), []) gather k' e' (ke'@(k'2, e'2):kes') | k' == k'2 = gather k' (f e' e'2) kes' | otherwise = let (ke'2, kes'2) = gather k' e' kes' in (ke'2, ke':kes'2) -- handling of control characters -- ------------------------------ -- | control characters recognized by `ctrlLexer' -- ctrlChars :: [Char] ctrlChars = ['\n', '\r', '\f', '\t'] -- | control lexer -- -- * implements proper `Position' management in the presence of the standard -- layout control characters -- ctrlLexer :: Lexer s t ctrlLexer = char '\n' `lexmeta` newline >||< char '\r' `lexmeta` newline >||< char '\v' `lexmeta` newline >||< char '\f' `lexmeta` formfeed >||< char '\t' `lexmeta` tab where newline _ pos s = (Nothing, retPos pos , s, Nothing) formfeed _ pos s = (Nothing, incPos pos 1, s, Nothing) tab _ pos s = (Nothing, incPos pos 8, s, Nothing) -- non-basic combinators -- --------------------- -- | x `star` y corresponds to the regular expression x*y -- star :: Regexp s t -> Regexp s t -> Regexp s t -- -- The definition used below can be obtained by equational reasoning from this -- one (which is much easier to understand): -- -- star re1 re2 = let self = (re1 +> self >|< epsilon) in self +> re2 -- -- However, in the above, `self' is of type `Regexp s t' (ie, a functional), -- whereas below it is of type `Lexer s t'. Thus, below we have a graphical -- body (finite representation of an infinite structure), which doesn't grow -- with the size of the accepted lexeme - in contrast to the definition using -- the functional recursion. -- star re1 re2 = \l -> let self = re1 self >||< re2 l in self -- | x `plus` y corresponds to the regular expression x+y -- plus :: Regexp s t -> Regexp s t -> Regexp s t plus re1 re2 = re1 +> (re1 `star` re2) -- | x `quest` y corresponds to the regular expression x?y -- quest :: Regexp s t -> Regexp s t -> Regexp s t quest re1 re2 = (re1 +> re2) >|< re2 -- | accepts a non-empty set of alternative characters -- alt :: [Char] -> Regexp s t -- -- Equiv. to `(foldr1 (>|<) . map char) cs', but much faster -- alt [] = interr "Lexers.alt: Empty character set!" alt cs = \l -> let bnds = (length cs, minimum cs, maximum cs) in Lexer NoAction (aggregate bnds [(c, l) | c <- cs]) -- | accept a character sequence -- string :: String -> Regexp s t string [] = interr "Lexers.string: Empty character set!" string cs = (foldr1 (+>) . map char) cs -- execution of a lexer -- -------------------- -- | threaded top-down during lexing (current input, current position, meta -- state) -- type LexerState s = (String, Position, s) -- | apply a lexer, yielding a token sequence and a list of errors -- -- * Currently, all errors are fatal; thus, the result is undefined in case of -- an error (this changes when error correction is added). -- -- * The final lexer state is returned. -- -- * The order of the error messages is undefined. -- execLexer :: Lexer s t -> LexerState s -> ([t], LexerState s, [Error]) -- -- * the following is moderately tuned -- execLexer _ state@([], _, _) = ([], state, []) execLexer l state = case lexOne l state of (Nothing , _ , state') -> execLexer l state' (Just res, l', state') -> let (ts, final, allErrs) = execLexer l' state' in case res of (Left err) -> (ts , final, err:allErrs) (Right t ) -> (t:ts, final, allErrs) where -- accept a single lexeme -- -- lexOne :: Lexer s t -> LexerState s t -- -> (Either Error (Maybe t), Lexer s t, LexerState s t) lexOne l0 state' = oneLexeme l0 state' DL.zero lexErr where -- the result triple of `lexOne' that signals a lexical error; -- the result state is advanced by one character for error correction -- lexErr = let (cs, pos, s) = state' err = makeError LevelError pos ["Lexical error!", "The character " ++ show (head cs) ++ " does not fit here; skipping it."] in (Just (Left err), l, (tail cs, incPos pos 1, s)) -- we take an open list of characters down, where we accumulate the -- lexeme; this function returns maybe a token, the next lexer to use -- (can be altered by a meta action), the new lexer state, and a list -- of errors -- -- we implement the "principle of the longest match" by taking a -- potential result quadruple down (in the last argument); the -- potential result quadruple is updated whenever we pass by an action -- (different from `NoAction'); initially it is an error result -- -- oneLexeme :: Lexer s t -- -> LexerState -- -> DList Char -- -> (Maybe (Either Error t), Maybe (Lexer s t), -- LexerState s t) -- -> (Maybe (Either Error t), Maybe (Lexer s t), -- LexerState s t) oneLexeme (Lexer a cont') state''@(cs, pos, s) csDL last' = let last'' = action a csDL state'' last' in case cs of [] -> last'' (c:cs') -> oneChar cont' c (cs', pos, s) csDL last'' oneChar Done _ _ _ last' = last' oneChar (Dense bn arr) c state'' csDL last' | c `inBounds` bn = cont (arr!c) c state'' csDL last' | otherwise = last' oneChar (Sparse bn cls) c state'' csDL last' | c `inBounds` bn = case lookup c cls of Nothing -> last' Just l' -> cont l' c state'' csDL last' | otherwise = last' -- continue within the current lexeme -- cont l' c state'' csDL last' = oneLexeme l' state'' (csDL `DL.snoc` c) last' -- execute the action if present and finalise the current lexeme -- action (Action f) csDL (cs, pos, s) _last = case f (DL.close csDL) pos s of (Nothing, pos', s', l') | not . null $ cs -> lexOne (fromMaybe l0 l') (cs, pos', s') (res , pos', s', l') -> (res, (fromMaybe l0 l'), (cs, pos', s')) action NoAction _csDL _state last' = last' -- no change c2hs-0.16.4/src/Control/0000755000000000000000000000000012044310770013034 5ustar0000000000000000c2hs-0.16.4/src/Control/StateBase.hs0000644000000000000000000001060412044310770015244 0ustar0000000000000000-- Compiler Toolkit: compiler state management basics -- -- Author : Manuel M. T. Chakravarty -- Created: 7 November 97 -- -- Copyright (C) [1997..1999] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides basic types and services used to realize the state -- management of the compiler. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * The monad `PreCST' is an instance of `STB' where the base state is fixed. -- However, the base state itself is parametrized by an extra state -- component that can be instantiated by the compiler that uses the toolkit -- (to store information like compiler switches) -- this is the reason for -- adding the prefix `Pre'. -- -- * The module exports the details of the `BaseState' etc as they have to be -- know by `State'. The latter ensures the necessary abstraction for -- modules that do not belong to the state management. -- -- * Due to this module, the state management modules can share internal -- information about the data types hidden to the rest of the system. -- -- * The following state components are maintained: -- -- + errorsBS (type `ErrorState') -- keeps track of raised errors -- + namesBS (type `NameSupply') -- provides unique names -- + extraBS (generic type) -- extra compiler-dependent state -- information, e.g., for compiler -- switches -- --- TODO ---------------------------------------------------------------------- -- module Control.StateBase (PreCST(..), ErrorState(..), BaseState(..), unpackCST, readCST, writeCST, transCST, liftIO) where import Control.StateTrans (STB, readGeneric, writeGeneric, transGeneric) import qualified Control.StateTrans as StateTrans (liftIO) import Data.Errors (ErrorLevel(..), Error) import Language.C.Data.Name -- state used in the whole compiler -- -------------------------------- -- | form of the error state -- -- * when no error was raised yet, the error level is the lowest possible one -- data ErrorState = ErrorState ErrorLevel -- worst error level that was raised Int -- number of errors (excl warnings) [Error] -- already raised errors -- | base state -- data BaseState e = BaseState { errorsBS :: ErrorState, supplyBS :: [Name], -- unique names extraBS :: e -- extra state } -- | the compiler state transformer -- newtype PreCST e s a = CST (STB (BaseState e) s a) instance Monad (PreCST e s) where return = yield (>>=) = (+>=) -- | unwrapper coercion function -- unpackCST :: PreCST e s a -> STB (BaseState e) s a unpackCST m = let CST m' = m in m' -- monad operations -- ---------------- -- | the monad's unit -- yield :: a -> PreCST e s a yield a = CST $ return a -- | the monad's bind -- (+>=) :: PreCST e s a -> (a -> PreCST e s b) -> PreCST e s b m +>= k = CST $ unpackCST m >>= (\a -> unpackCST (k a)) -- generic state manipulation -- -------------------------- -- | given a reader function for the state, wrap it into an CST monad -- readCST :: (s -> a) -> PreCST e s a readCST f = CST $ readGeneric f -- | given a new state, inject it into an CST monad -- writeCST :: s -> PreCST e s () writeCST s' = CST $ writeGeneric s' -- | given a transformer function for the state, wrap it into an CST monad -- transCST :: (s -> (s, a)) -> PreCST e s a transCST f = CST $ transGeneric f -- interaction with the encapsulated 'IO' monad -- -------------------------------------------- -- | lifts an 'IO' state transformer into 'CST' -- liftIO :: IO a -> PreCST e s a liftIO m = CST $ (StateTrans.liftIO m) c2hs-0.16.4/src/Control/State.hs0000644000000000000000000002447312044310770014462 0ustar0000000000000000-- Compiler Toolkit: compiler state management -- -- Author : Manuel M. T. Chakravarty -- Created: 2 November 95 -- -- Copyright (c) [1995..1999] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module forms the interface to the state base of the compiler. It is -- used by all modules that are not directly involved in implementing the -- state base. It provides a state transformer that is capable of doing I/O -- and provides facilities such as error handling and compiler switch -- management. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * The monad `PreCST' is reexported abstractly. -- -- * Errors are dumped to `stdout' to facilitate communication with other -- processes (see `Interact'). -- --- TODO ---------------------------------------------------------------------- -- module Control.State (-- the PreCST monad -- PreCST, -- reexport ABSTRACT throwExc, fatal, catchExc, fatalsHandledBy, -- reexport lifted readCST, writeCST, transCST, run, runCST, -- -- more compiler I/O -- liftIO, -- -- error management -- raise, raiseWarning, raiseError, raiseFatal, showErrors, errorsPresent, -- -- state management helpers getNameSupply, setNameSupply, -- -- extra state management -- readExtra, updExtra) where import Control.Monad (when) import Control.StateTrans (readBase, transBase, runSTB) import qualified Control.StateTrans as StateTrans (interleave, throwExc, fatal, catchExc, fatalsHandledBy) import Control.StateBase (PreCST(..), ErrorState(..), BaseState(..), unpackCST, readCST, writeCST, transCST, liftIO) import qualified System.CIO as CIO import Data.Errors (Error, makeError) import Language.C.Data.Name import Language.C.Data.Position import Language.C.Data.Error hiding (Error) -- state used in the whole compiler -- -------------------------------- -- | initialization -- -- * it gets the version information and the initial extra state as arguments -- initialBaseState :: e -> BaseState e initialBaseState es = BaseState { supplyBS = newNameSupply, errorsBS = initialErrorState, extraBS = es } -- executing state transformers -- ---------------------------- -- | initiate a complete run of the ToolKit represented by a PreCST with a void -- generic component (type '()') -- -- * fatals errors are explicitly caught and reported (instead of letting them -- through to the runtime system) -- run :: e -> PreCST e () a -> IO a run es cst = runSTB m (initialBaseState es) () where m = unpackCST ( cst `fatalsHandledBy` \err -> CIO.putStr ("Uncaught fatal error: " ++ show err) >> CIO.exitWith (CIO.ExitFailure 1) ) -- | run a PreCST in the context of another PreCST -- -- the generic state of the enclosing PreCST is preserved while the -- computation of the PreCST passed as an argument is interleaved in the -- execution of the enclosing one -- runCST :: PreCST e s a -> s -> PreCST e s' a runCST m s = CST $ StateTrans.interleave (unpackCST m) s -- exception handling -- ------------------ -- | throw an exception with the given tag and message -- throwExc :: String -> String -> PreCST e s a throwExc s1 s2 = CST $ StateTrans.throwExc s1 s2 -- | raise a fatal user-defined error -- -- * such an error my be caught and handled using 'fatalsHandeledBy' -- fatal :: String -> PreCST e s a fatal = CST . StateTrans.fatal -- | the given state transformer is executed and exceptions with the given tag -- are caught using the provided handler, which expects to get the exception -- message -- -- * the state observed by the exception handler is *modified* by the failed -- state transformer upto the point where the exception was thrown (this -- semantics is the only reasonable when it should be possible to use -- updating for maintaining the state) -- catchExc :: PreCST e s a -> (String, String -> PreCST e s a) -> PreCST e s a catchExc m (s, h) = CST $ StateTrans.catchExc (unpackCST m) (s, unpackCST . h) -- | given a state transformer that may raise fatal errors and an error handler -- for fatal errors, execute the state transformer and apply the error handler -- when a fatal error occurs -- -- * fatal errors are IO monad errors and errors raised by 'fatal' as well as -- uncaught exceptions -- -- * the base and generic state observed by the error handler is *in contrast -- to 'catch'* the state *before* the state transformer is applied -- fatalsHandledBy :: PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a fatalsHandledBy m h = CST $ StateTrans.fatalsHandledBy m' h' where m' = unpackCST m h' = unpackCST . h -- manipulating the error state -- ---------------------------- -- | the lowest level of errors is 'LevelWarn', but it is meaningless as long as -- the the list of errors is empty -- initialErrorState :: ErrorState initialErrorState = ErrorState LevelWarn 0 [] -- | raise an error -- -- * a fatal error is reported immediately; see 'raiseFatal' -- raise :: Error -> PreCST e s () raise err = case errorLevel err of LevelWarn -> raise0 err LevelError -> raise0 err LevelFatal -> raiseFatal0 "Generic fatal error." err -- | raise a warning (see 'raiseErr') -- raiseWarning :: Position -> [String] -> PreCST e s () raiseWarning pos msg = raise0 (makeError LevelWarn pos msg) -- | raise an error (see 'raiseErr') -- raiseError :: Position -> [String] -> PreCST e s () raiseError pos msg = raise0 (makeError LevelError pos msg) -- | raise a fatal compilation error -- -- * the error is together with the up-to-now accumulated errors are reported -- as part of the error message of the fatal error exception -- -- * the current thread of control is discarded and control is passed to the -- innermost handler for fatal errors -- -- * the first argument must contain a short description of the error, while -- the second and third argument are like the two arguments to 'raise' -- raiseFatal :: String -> Position -> [String] -> PreCST e s a raiseFatal short pos long = raiseFatal0 short (makeError LevelFatal pos long) -- | raise a fatal error; internal version that gets an abstract error -- raiseFatal0 :: String -> Error -> PreCST e s a raiseFatal0 short err = do raise0 err errmsgs <- showErrors fatal (short ++ "\n\n" ++ errmsgs) -- | raise an error; internal version, doesn't check whether the error is fatal -- -- * the error is entered into the compiler state and a fatal error is -- triggered if the 'errorLimit' is reached -- raise0 :: Error -> PreCST e s () raise0 err = do noOfErrs <- CST $ transBase doRaise when (noOfErrs >= errorLimit) $ do errmsgs <- showErrors fatal ("Error limit of " ++ show errorLimit ++ " errors has been reached.\n" ++ errmsgs) where errorLimit = 20 doRaise :: BaseState e -> (BaseState e, Int) doRaise bs = let lvl = errorLevel err ErrorState wlvl no errs = errorsBS bs wlvl' = max wlvl lvl no' = no + if lvl > LevelWarn then 1 else 0 errs' = err : errs in (bs {errorsBS = (ErrorState wlvl' no' errs')}, no') -- | yield a string containing the collected error messages -- -- * the error state is reset in this process -- showErrors :: PreCST e s String showErrors = CST $ do ErrorState _ _ errs <- transBase extractErrs return $ concatMap (showErrorInfo "" . errorInfo) errs --FIXME: should be using show here ^^, but Show instance -- for CError from language-c is weird where extractErrs :: BaseState e -> (BaseState e, ErrorState) extractErrs bs = (bs {errorsBS = initialErrorState}, errorsBS bs) -- | inquire if there was already an error of at least level 'LevelError' raised -- errorsPresent :: PreCST e s Bool errorsPresent = CST $ do ErrorState wlvl _ _ <- readBase errorsBS return $ wlvl >= LevelError -- helpers for manipulating state -- ---------------------------- -- | get a name supply getNameSupply :: PreCST e s [Name] getNameSupply = CST $ readBase supplyBS -- | update the name supply setNameSupply :: [Name] -> PreCST e s () setNameSupply ns = CST $ transBase $ \st -> (st { supplyBS = ns }, ()) -- manipulating the extra state -- ---------------------------- -- | apply a reader function to the extra state and yield the reader's result -- readExtra :: (e -> a) -> PreCST e s a readExtra rf = CST $ readBase (\bs -> (rf . extraBS) bs ) -- | apply an update function to the extra state -- updExtra :: (e -> e) -> PreCST e s () updExtra uf = CST $ transBase (\bs -> let es = extraBS bs in (bs {extraBS = uf es}, ()) ) c2hs-0.16.4/src/Control/StateTrans.hs0000644000000000000000000002672212044310770015471 0ustar0000000000000000-- The HiPar Toolkit: state transformer routines -- -- Author : Manuel M. T. Chakravarty -- Created: 3 March 95 -- -- Copyright (C) [1995..1999] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides basic support for the use of state transformers. -- The state transformer is build around the `IO' monad to allow the -- manipulation of external state. It encapsulated two separate states with -- the intention to use the first one for the omnipresent compiler state -- consisting of the accumulated error messages etc. and to use the second as -- a generic component that can be used in different ways by the different -- phases of the compiler. -- -- The module also supports the use of exceptions and fatal errors. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * We explicitly do not use any names for the monad types and functions -- that are used by either Haskell's `IO' monad or GHC's `ST' monad. Since -- Haskell 1.4, `STB' is an instance of the `Monad' constructor class. -- -- * To integrate the Haskell prelude `IO' monad into our `STB' monad we use -- the technique from ``Composing monads'' by Mark P. Jones and Luc -- Duponcheel (Report YALEU/DCS/RR-1004) from 1993, Section 8. -- -- * The use of GHC's inplace-update goodies within monads of kind `STB' is -- possible, bacause `IO' is based on `ST' in the GHC. -- -- * In the following, we call the two kinds of state managed by the `STB' the -- base state (the omnipresent state of the compiler) and generic state. -- -- * `STB' is a newtype, which requires careful wrapping and unwrapping of its -- values in the following definitions. -- --- TODO ---------------------------------------------------------------------- -- -- * with constructor classes, the state transformer business can be made -- more elegant (they weren't around when this module was initially written) -- -- * it would be possible to maintain the already applied changes to the base -- and generic state even in the case of a fatal error, when in `listIO' -- every IO operation is encapsulated into a handler that transforms IO -- errors into exceptions -- module Control.StateTrans (-- the monad and the generic operations -- STB, -- -- monad specific operations -- readBase, writeBase, transBase, readGeneric, writeGeneric, transGeneric, liftIO, runSTB, interleave, -- -- exception handling and fatal errors -- throwExc, fatal, catchExc, fatalsHandledBy) where import Control.Exception (catch) import Prelude hiding (catch) -- BEWARE! You enter monad country. Read any of Wadler's or -- Launchbury/Peyton-Jones' texts before entering. Otherwise, -- your mental health my be in danger. You have been warned! -- state transformer base and its monad operations -- ----------------------------------------------- -- | the generic form of a state transformer using the external state represented -- by 'IO'; 'STB' is a abbreviation for state transformer base -- -- the first state component @bs@ is provided for the omnipresent compiler -- state and the, second, @gs@ for the generic component -- -- the third component of the result distinguishes between erroneous and -- successful computations where -- -- @Left (tag, msg)@ -- stands for an exception identified by @tag@ with -- error message @msg@, and -- @Right a@ -- is a successfully delivered result -- newtype STB bs gs a = STB (bs -> gs -> IO (bs, gs, Either (String, String) a)) instance Monad (STB bs gs) where return = yield (>>=) = (+>=) -- | the monad's unit -- yield :: a -> STB bs gs a yield a = STB $ \bs gs -> return (bs, gs, Right a) -- | the monad's bind -- -- * exceptions are propagated -- (+>=) :: STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b m +>= k = let STB m' = m in STB $ \bs gs -> m' bs gs >>= \(bs', gs', res) -> case res of Left exc -> return (bs', gs', Left exc) -- prop exc Right a -> let STB k' = k a in k' bs' gs' -- cont -- generic state manipulation -- -------------------------- -- base state: -- -- | given a reader function for the base state, wrap it into an STB monad -- readBase :: (bs -> a) -> STB bs gs a readBase f = STB $ \bs gs -> return (bs, gs, Right (f bs)) -- | given a new base state, inject it into an STB monad -- writeBase :: bs -> STB bs gs () writeBase bs' = STB $ \_ gs -> return (bs', gs, Right ()) -- | given a transformer function for the base state, wrap it into an STB monad -- transBase :: (bs -> (bs, a)) -> STB bs gs a transBase f = STB $ \bs gs -> let (bs', a) = f bs in return (bs', gs, Right a) -- generic state: -- -- | given a reader function for the generic state, wrap it into an STB monad -- readGeneric :: (gs -> a) -> STB bs gs a readGeneric f = STB $ \bs gs -> return (bs, gs, Right (f gs)) -- | given a new generic state, inject it into an STB monad -- writeGeneric :: gs -> STB bs gs () writeGeneric gs' = STB $ \bs _ -> return (bs, gs', Right ()) -- | given a transformer function for the generic state, wrap it into an STB -- monad -- transGeneric :: (gs -> (gs, a)) -> STB bs gs a transGeneric f = STB $ \bs gs -> let (gs', a) = f gs in return (bs, gs', Right a) -- interaction with the encapsulated 'IO' monad -- -------------------------------------------- -- | lifts an 'IO' state transformer into 'STB' -- liftIO :: IO a -> STB bs gs a liftIO m = STB $ \bs gs -> m >>= \r -> return (bs, gs, Right r) -- | given an initial state, executes the 'STB' state transformer yielding an -- 'IO' state transformer that must be placed into the context of the external -- IO -- -- * uncaught exceptions become fatal errors -- runSTB :: STB bs gs a -> bs -> gs -> IO a runSTB m bs gs = let STB m' = m in m' bs gs >>= \(_, _, res) -> case res of Left (tag, msg) -> let err = userError ("Exception `" ++ tag ++ "': " ++ msg) in ioError err Right a -> return a -- | interleave the (complete) execution of an 'STB' with another generic state -- component into an 'STB' -- interleave :: STB bs gs' a -> gs' -> STB bs gs a interleave m gs' = STB $ let STB m' = m in \bs gs -> (m' bs gs' >>= \(bs', _, a) -> return (bs', gs, a)) -- error and exception handling -- ---------------------------- -- * we exploit the 'UserError' component of 'IOError' for fatal errors -- -- * we distinguish exceptions and user-defined fatal errors -- -- - exceptions are meant to be caught in order to recover the currently -- executed operation; they turn into fatal errors if they are not caught; -- execeptions are tagged, which allows to deal with multiple kinds of -- execeptions at the same time and to handle them differently -- - user-defined fatal errors abort the currently executed operation, but -- they may be caught at the top-level in order to terminate gracefully or -- to invoke another operation; there is no special support for different -- handling of different kinds of fatal-errors -- -- * the costs for fatal error handling are already incurred by the 'IO' monad; -- the costs for exceptions mainly is the case distinction in the definition -- of '+>=' -- -- | throw an exception with the given tag and message -- throwExc :: String -> String -> STB bs gs a throwExc tag msg = STB $ \bs gs -> return (bs, gs, Left (tag, msg)) -- | raise a fatal user-defined error -- -- * such an error my be caught and handled using 'fatalsHandeledBy' -- fatal :: String -> STB bs gs a fatal s = liftIO (ioError (userError s)) -- | the given state transformer is executed and exceptions with the given tag -- are caught using the provided handler, which expects to get the exception -- message -- -- * the base and generic state observed by the exception handler is *modified* -- by the failed state transformer upto the point where the exception was -- thrown (this semantics is the only reasonable when it should be possible -- to use updating for maintaining the state) -- catchExc :: STB bs gs a -> (String, String -> STB bs gs a) -> STB bs gs a catchExc m (tag, handler) = STB $ \bs gs -> let STB m' = m in m' bs gs >>= \state@(bs', gs', res) -> case res of Left (tag', msg) -> if (tag == tag') -- exception with... then let STB handler' = handler msg in handler' bs' gs' -- correct tag, catch else return state -- wrong tag, rethrow Right _ -> return state -- no exception -- | given a state transformer that may raise fatal errors and an error handler -- for fatal errors, execute the state transformer and apply the error handler -- when a fatal error occurs -- -- * fatal errors are IO monad errors and errors raised by 'fatal' as well as -- uncaught exceptions -- -- * the base and generic state observed by the error handler is *in contrast -- to 'catch'* the state *before* the state transformer is applied -- fatalsHandledBy :: STB bs gs a -> (IOError -> STB bs gs a) -> STB bs gs a fatalsHandledBy m handler = STB $ \bs gs -> (let STB m' = m in m' bs gs >>= \state@(_gs', _bs', res) -> case res of Left (tag, msg) -> let err = userError ("Exception `" ++ tag ++ "': " ++ msg) in ioError err Right _a -> return state ) `catch` (\err -> let STB handler' = handler err in handler' bs gs) c2hs-0.16.4/src/System/0000755000000000000000000000000012044310770012700 5ustar0000000000000000c2hs-0.16.4/src/System/CIO.hs0000644000000000000000000001163212044310770013651 0ustar0000000000000000{-# LANGUAGE CPP #-} -- Compiler Toolkit: Compiler I/O -- -- Author : Manuel M T Chakravarty -- Created: 2 November 95 -- -- Copyright (c) [1995...2005] Manuel M T Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module lifts the Haskell I/O facilities into `STB' and provides some -- useful extensions. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * the usage of the `...CIO' functions is exactly as that of the -- corresponding `...' functions from the Haskell 98 prelude and library -- -- * error handling can be found in the module `StateTrans' and `State' -- -- * Also reexports constants, such as `stderr', and data types of `IO' to -- avoid explicit imports of `IO' in the rest of the compiler. -- --- TODO ---------------------------------------------------------------------- -- module System.CIO ( -- -- file handling -- openFile, hClose, -- -- text I/O -- putChar, putStr, putStrLn, hPutStr, hPutStrLn, writeFile, readFile, print, getChar, hFlush, hPutChar, hSetBuffering, hGetBuffering, newline, -- -- `Directory' -- doesFileExist, removeFile, -- -- `System' -- IO.ExitCode(..), exitWith, getArgs, getProgName, system, -- -- lifting -- liftIO ) where import Prelude (Bool, Char, String, FilePath, (.), ($), Show, return) import qualified System.IO as IO import qualified System.Directory as IO (doesFileExist, removeFile) import qualified System.Environment as IO (getArgs, getProgName) import qualified System.Cmd as IO (system) import qualified System.Exit as IO (ExitCode(..), exitWith) import Control.StateBase (PreCST, liftIO) -- file handling -- ------------- openFile :: FilePath -> IO.IOMode -> PreCST e s IO.Handle openFile p m = liftIO $ do hnd <- IO.openFile p m #if MIN_VERSION_base(4,2,0) --FIXME: really we should be using utf8 for .chs and .hs files -- however the current .chs lexer cannot cope with chars -- that are over 255, it goes into an infinte loop. -- As an workaround, use latin1 encoding for the moment: IO.hSetEncoding hnd IO.latin1 #endif return hnd hClose :: IO.Handle -> PreCST e s () hClose h = liftIO (IO.hClose h) -- text I/O -- -------- putChar :: Char -> PreCST e s () putChar c = liftIO (IO.putChar c) putStr :: String -> PreCST e s () putStr s = liftIO (IO.putStr s) putStrLn :: String -> PreCST e s () putStrLn s = liftIO (IO.putStrLn s) hPutStr :: IO.Handle -> String -> PreCST e s () hPutStr h s = liftIO (IO.hPutStr h s) hPutStrLn :: IO.Handle -> String -> PreCST e s () hPutStrLn h s = liftIO (IO.hPutStrLn h s) writeFile :: FilePath -> String -> PreCST e s () writeFile fname contents = do --FIXME: see encoding comment with openFile above -- this isn't exception-safe hnd <- openFile fname IO.WriteMode hPutStr hnd contents hClose hnd readFile :: FilePath -> PreCST e s String readFile fname = do --FIXME: see encoding comment with openFile above hnd <- openFile fname IO.ReadMode liftIO (IO.hGetContents hnd) print :: Show a => a -> PreCST e s () print a = liftIO (IO.print a) getChar :: PreCST e s Char getChar = liftIO IO.getChar hFlush :: IO.Handle -> PreCST e s () hFlush h = liftIO (IO.hFlush h) hPutChar :: IO.Handle -> Char -> PreCST e s () hPutChar h ch = liftIO (IO.hPutChar h ch) hSetBuffering :: IO.Handle -> IO.BufferMode -> PreCST e s () hSetBuffering h m = liftIO (IO.hSetBuffering h m) hGetBuffering :: IO.Handle -> PreCST e s IO.BufferMode hGetBuffering h = liftIO (IO.hGetBuffering h) -- derived functions -- newline :: PreCST e s () newline = putChar '\n' -- `Directory' -- ----------- doesFileExist :: FilePath -> PreCST e s Bool doesFileExist = liftIO . IO.doesFileExist removeFile :: FilePath -> PreCST e s () removeFile = liftIO . IO.removeFile -- `System' -- -------- exitWith :: IO.ExitCode -> PreCST e s a exitWith = liftIO . IO.exitWith getArgs :: PreCST e s [String] getArgs = liftIO IO.getArgs getProgName :: PreCST e s String getProgName = liftIO IO.getProgName system :: String -> PreCST e s IO.ExitCode system = liftIO . IO.system c2hs-0.16.4/src/Data/0000755000000000000000000000000012044310770012265 5ustar0000000000000000c2hs-0.16.4/src/Data/NameSpaces.hs0000644000000000000000000001355012044310770014644 0ustar0000000000000000-- Compiler Toolkit: name space management -- -- Author : Manuel M. T. Chakravarty -- Created: 12 November 95 -- -- Copyright (c) [1995..1999] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module manages name spaces. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * A name space associates identifiers with their definition. -- -- * Each name space is organized in a hierarchical way using the notion of -- ranges. A name space, at any moment, always has a global range and may -- have several local ranges. Definitions in inner ranges hide definitions -- of the same identifiert in outer ranges. -- --- TODO ---------------------------------------------------------------------- -- -- * evaluate the performance gain that a hashtable would bring -- module Data.NameSpaces (NameSpace, nameSpace, defGlobal, enterNewRange, leaveRange, defLocal, find, nameSpaceToList) where import qualified Data.Map as Map (empty, insert, lookup, toList) import Data.Map (Map) import Language.C.Data.Ident import Data.Errors (interr) -- | name space -- -- * the definitions in the global ranges are stored in a finite map, because -- they tend to be a lot and are normally not updated after the global range -- is constructed -- -- * the definitions of the local ranges are stored in a single list, usually -- they are not very many and the definitions entered last are the most -- frequently accessed ones; the list structure naturally hides older -- definitions, i.e., definitions from outer ranges; adding new definitions -- is done in time proportinal to the current size of the range; removing a -- range is done in constant time (and the definitions of a range can be -- returned as a result of leaving the range); lookup is proportional to the -- number of definitions in the local ranges and the logarithm of the number -- of definitions in the global range---i.e., efficiency relies on a -- relatively low number of local definitions together with frequent lookup -- of the most recently defined local identifiers -- data NameSpace a = NameSpace (Map Ident a) -- defs in global range [[(Ident, a)]] -- stack of local ranges instance (Show a) => Show (NameSpace a) where show = show . nameSpaceToList -- | create a name space -- nameSpace :: NameSpace a nameSpace = NameSpace Map.empty [] -- | add global definition -- -- * returns the modfied name space -- -- * if the identfier is already declared, the resulting name space contains -- the new binding and the second component of the result contains the -- definition declared previosuly (which is henceforth not contained in the -- name space anymore) -- defGlobal :: NameSpace a -> Ident -> a -> (NameSpace a, Maybe a) defGlobal (NameSpace gs lss) ide def = (NameSpace (Map.insert ide def gs) lss, Map.lookup ide gs) -- | add new range -- enterNewRange :: NameSpace a -> NameSpace a enterNewRange (NameSpace gs lss) = NameSpace gs ([]:lss) -- | pop topmost range and return its definitions -- leaveRange :: NameSpace a -> (NameSpace a, [(Ident, a)]) leaveRange (NameSpace _gs []) = interr "NameSpaces.leaveRange: \ \No local range!" leaveRange (NameSpace gs (ls:lss)) = (NameSpace gs lss, ls) -- | add local definition -- -- * returns the modfied name space -- -- * if there is no local range, the definition is entered globally -- -- * if the identfier is already declared, the resulting name space contains -- the new binding and the second component of the result contains the -- definition declared previosuly (which is henceforth not contained in the -- name space anymore) -- defLocal :: NameSpace a -> Ident -> a -> (NameSpace a, Maybe a) defLocal ns@(NameSpace _ [] ) ide def = defGlobal ns ide def defLocal (NameSpace gs (ls:lss)) ide def = (NameSpace gs (((ide, def):ls):lss), lookup' ls) where lookup' [] = Nothing lookup' ((ide', def'):ls') | ide == ide' = Just def' | otherwise = lookup' ls' -- | search for a definition -- -- * the definition from the innermost range is returned, if any -- find :: NameSpace a -> Ident -> Maybe a find (NameSpace gs lss) ide = case (lookup' lss) of Nothing -> Map.lookup ide gs Just def -> Just def where lookup' [] = Nothing lookup' (ls:lss') = case (lookup'' ls) of Nothing -> lookup' lss' Just def -> Just def lookup'' [] = Nothing lookup'' ((ide', def):ls) | ide' == ide = Just def | otherwise = lookup'' ls -- | dump a name space into a list -- -- * local ranges are concatenated -- nameSpaceToList :: NameSpace a -> [(Ident, a)] nameSpaceToList (NameSpace gs lss) = Map.toList gs ++ concat lss c2hs-0.16.4/src/Data/DLists.hs0000644000000000000000000000356512044310770014034 0ustar0000000000000000-- The Compiler Toolkit: difference lists -- -- Author : Manuel M. T. Chakravarty -- Created: 24 February 95 -- -- Copyright (c) [1995..2000] Manuel M. T. Chakravarty -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Library General Public -- License as published by the Free Software Foundation; either -- version 2 of the License, or (at your option) any later version. -- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Library General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides the functional equivalent of the difference lists -- from logic programming. They provide an O(1) append. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- --- TODO ---------------------------------------------------------------------- -- module Data.DLists (DList, open, zero, unit, snoc, join, close) where -- | a difference list is a function that given a list returns the original -- contents of the difference list prepended at the given list -- type DList a = [a] -> [a] -- | open a list for use as a difference list -- open :: [a] -> DList a open = (++) -- | create a difference list containing no elements -- zero :: DList a zero = id -- | create difference list with given single element -- unit :: a -> DList a unit = (:) -- | append a single element at a difference list -- snoc :: DList a -> a -> DList a snoc dl x = \l -> dl (x:l) -- | appending difference lists -- join :: DList a -> DList a -> DList a join = (.) -- | closing a difference list into a normal list -- close :: DList a -> [a] close = ($[]) c2hs-0.16.4/src/Data/Errors.hs0000644000000000000000000000545412044310770014105 0ustar0000000000000000-- Compiler Toolkit: basic error management -- -- Author : Manuel M. T. Chakravarty -- Created: 20 February 95 -- -- Copyright (c) [1995..2000] Manuel M. T. Chakravarty -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Library General Public -- License as published by the Free Software Foundation; either -- version 2 of the License, or (at your option) any later version. -- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Library General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This modules exports some auxilliary routines for error handling. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * the single lines of error messages shouldn't be to long as file name -- and position are prepended at each line -- --- TODO ---------------------------------------------------------------------- -- module Data.Errors ( -- handling of internal error -- interr, todo, -- -- errors in the compiled program (wrapper to Language.C Error type) -- ErrorLevel(..), Error, makeError, errorLevel, showError, errorAtPos ) where import Language.C.Data.Error hiding (Error) import Language.C.Data.Position type Error = CError -- internal errors -- --------------- -- | raise a fatal internal error; message may have multiple lines -- interr :: String -> a interr msg = error ("INTERNAL COMPILER ERROR:\n" ++ indentMultilineString 2 msg ++ "\n") -- | raise a error due to a implementation restriction; message may have multiple -- lines -- todo :: String -> a todo msg = error ("Feature not yet implemented:\n" ++ indentMultilineString 2 msg ++ "\n") -- | produce an 'Error', given its level, position, and a list of lines of -- the error message that must not be empty -- makeError :: ErrorLevel -> Position -> [String] -> Error makeError lvl pos msgs = CError $ ErrorInfo lvl pos msgs errorAtPos :: Position -> [String] -> a errorAtPos pos = error --FIXME: should be using show here, but Show instance -- for CError from language-c is wierd . showErrorInfo "" . errorInfo . makeError LevelError pos -- | indent the given multiline text by the given number of spaces -- indentMultilineString :: Int -> String -> String indentMultilineString n = unlines . (map (spaces++)) . lines where spaces = take n (repeat ' ') c2hs-0.16.4/src/Data/Attributes.hs0000644000000000000000000003506612044310770014761 0ustar0000000000000000-- Compiler Toolkit: general purpose attribute management -- -- Author : Manuel M. T. Chakravarty -- Created: 14 February 95 -- -- Copyright (c) [1995..1999] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides an abstract notion of attributes (in the sense of -- compiler construction). The collection of attributes that is attached to a -- single node of the structure tree is referenced via an attributes -- identifier. This is basically a reference into so-called attribute tables, -- which manage attributes of one type and may use different representations. -- There is also a position attribute managed via the attribute identifier -- without needing a further table (it is already fixed on construction of -- the structure tree). -- -- The `Attributed' class is based on a suggestion from Roman Lechtchinsky. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * Attribute identifiers are generated during parsing and whenever new -- structure tree elements, possibly due to transformations, are generated. -- -- * New attributes can be added by simply providing a new attribute table -- indexed by the attribute identifiers. Thus, adding or discarding an -- attribute does not involve any change in the structure tree. -- -- * Consecutive sequences of names are used as attribute identifiers to -- facilitate the use of arrays for attributes that are fixed; speeds up -- read access. (See also TODO.) -- -- * Each attribute table can simultaneously provide melted (updatable) and -- frozen (non-updatable) attributes. It also allows to dynamically grow the -- table, i.e., cover a wider range of attribute identifiers. -- -- * There is a variant merely providing a position, which is used for -- internal identifiers and such. -- -- * `StdAttr' provides standard undefined and don't care variants for -- attribute values. -- --- TODO ---------------------------------------------------------------------- -- -- * When there are sparse attribute tables that we want to freeze (and they -- will occur sooner or later), then introduce a third variant of tables -- realized via hash table---depending on the type of attribute table, we -- may even allow them to be soft. -- -- NOTE: Currently, if assertions are switched on, on freezing a table, its -- density is calculate and, if it is below 33%, an internal error is -- raised (only if there are more than 1000 entries in the table). -- -- * check whether it would increase the performance significantly if we use -- a mixed finite map/array representation for soft tables (all attributes -- defined before the last `soften' could be held in the array, changing -- an attribute just means to update it in the FM; i.e., the FM entries take -- precedence over the array entries) -- module Data.Attributes (-- attribute management -- NodeInfo, newAttrsOnlyPos, newAttrs, Attributed(attrsOf), eqOfAttrsOf, posOfAttrsOf, -- -- attributes and attribute tables -- Attr(undef, isUndef, dontCare, isDontCare), AttrTable, newAttrTable, getAttr, setAttr, updAttr, copyAttr, freezeAttrTable, softenAttrTable, StdAttr(..), getStdAttr, getStdAttrDft, isDontCareStdAttr, isUndefStdAttr, setStdAttr, updStdAttr, getGenAttr, setGenAttr, updGenAttr) where import Data.Array import Control.Exception (assert) import qualified Data.IntMap as NameMap (fromList, insert, findWithDefault, empty, assocs) import Data.IntMap (IntMap) import Language.C.Data.Node import Language.C.Data.Position import Language.C.Data.Name (Name(Name, nameId)) import Data.Errors (interr) type NameMap = IntMap -- attribute management data structures and operations -- --------------------------------------------------- -- a class for convenient access to the attributes of an attributed object -- -- class Attributed a where attrsOf :: a -> NodeInfo -- equality induced by attribution -- eqOfAttrsOf :: Attributed a => a -> a -> Bool eqOfAttrsOf obj1 obj2 = (attrsOf obj1) == (attrsOf obj2) -- position induced by attribution -- posOfAttrsOf :: Attributed a => a -> Position posOfAttrsOf = posOf . attrsOf -- attribute identifier creation -- ----------------------------- -- Given only a source position, create a new attribute identifier -- newAttrsOnlyPos :: Position -> NodeInfo newAttrsOnlyPos = mkNodeInfoOnlyPos -- Given a source position and a unique name, create a new attribute -- identifier -- newAttrs :: Position -> Name -> NodeInfo newAttrs = mkNodeInfo -- attribute tables and operations on them -- --------------------------------------- -- | the type class 'Attr' determines which types may be used as attributes -- -- -- * such types have to provide values representing an undefined and a don't -- care state, together with two functions to test for these values -- -- * an attribute in an attribute table is initially set to 'undef' (before -- some value is assigned to it) -- -- * an attribute with value 'dontCare' participated in an already detected -- error, it's value may not be used for further computations in order to -- avoid error avalanches -- class Attr a where undef :: a isUndef :: a -> Bool dontCare :: a isDontCare :: a -> Bool undef = interr "Attributes: Undefined `undef' method in `Attr' class!" isUndef = interr "Attributes: Undefined `isUndef' method in `Attr' \ \class!" dontCare = interr "Attributes: Undefined `dontCare' method in `Attr' \ \class!" isDontCare = interr "Attributes: Undefined `isDontCare' method in `Attr' \ \class!" -- | attribute tables map attribute identifiers to attribute values -- -- * the attributes within a table can be soft or frozen, the former may by be -- updated, but the latter can not be changed -- -- * the attributes in a frozen table are stored in an array for fast -- lookup; consequently, the attribute identifiers must be *dense* -- -- * the table description string is used to emit better error messages (for -- internal errors) -- data Attr a => AttrTable a = -- for all attribute identifiers not contained in the -- finite map the value is 'undef' -- SoftTable (NameMap a) -- updated attr.s String -- desc of the table -- the array contains 'undef' attributes for the undefined -- attributes; for all attribute identifiers outside the -- bounds, the value is also 'undef'; -- | FrozenTable (Array Name a) -- attribute values String -- desc of the table instance (Attr a, Show a) => Show (AttrTable a) where show (SoftTable mp descr) = -- freeze is disabled "AttrTable "++ descr ++ " { " ++ (unwords . map show) (NameMap.assocs mp) ++ " }" show tbl@(FrozenTable _ _) = show (softenAttrTable tbl) nameMapToList :: NameMap a -> [(Name, a)] nameMapToList = map (\(k,v) -> (Name k, v)) . NameMap.assocs nameMapFromList :: [(Name, a)] -> NameMap a nameMapFromList = NameMap.fromList . map (\(k,v) -> (nameId k, v)) -- | create an attribute table, where all attributes are 'undef' -- -- the description string is used to identify the table in error messages -- (internal errors); a table is initially soft -- newAttrTable :: Attr a => String -> AttrTable a newAttrTable desc = SoftTable NameMap.empty desc -- | get the value of an attribute from the given attribute table -- getAttr :: Attr a => AttrTable a -> NodeInfo -> a getAttr at node = case nameOfNode node of Nothing -> onlyPosErr "getAttr" at (posOfNode node) Just aid -> case at of (SoftTable fm _) -> NameMap.findWithDefault undef (nameId aid) fm (FrozenTable arr _) -> let (lbd, ubd) = bounds arr in if (aid < lbd || aid > ubd) then undef else arr!aid -- | set the value of an, up to now, undefined attribute from the given -- attribute table -- setAttr :: Attr a => AttrTable a -> NodeInfo -> a -> AttrTable a setAttr at node av = case nameOfNode node of Nothing -> onlyPosErr "setAttr" at (posOfNode node) Just aid -> case at of (SoftTable fm desc) -> assert (isUndef (NameMap.findWithDefault undef (nameId aid) fm)) $ SoftTable (NameMap.insert (nameId aid) av fm) desc (FrozenTable _arr _) -> interr frozenErr where frozenErr = "Attributes.setAttr: Tried to write frozen attribute in\n" ++ errLoc at (posOfNode node) -- | update the value of an attribute from the given attribute table -- updAttr :: Attr a => AttrTable a -> NodeInfo -> a -> AttrTable a updAttr at node av = case nameOfNode node of Nothing -> onlyPosErr "updAttr" at (posOfNode node) Just aid -> case at of (SoftTable fm desc) -> SoftTable (NameMap.insert (nameId aid) av fm) desc (FrozenTable _arr _) -> interr $ "Attributes.updAttr: Tried to\ \ update frozen attribute in\n" ++ errLoc at (posOfNode node) -- | copy the value of an attribute to another one -- -- * undefined attributes are not copied, to avoid filling the table -- copyAttr :: Attr a => AttrTable a -> NodeInfo -> NodeInfo -> AttrTable a copyAttr at ats ats' | isUndef av = assert (isUndef (getAttr at ats')) at | otherwise = updAttr at ats' av where av = getAttr at ats -- | auxiliary functions for error messages -- onlyPosErr :: Attr a => String -> AttrTable a -> Position -> b onlyPosErr fctName at pos = interr $ "Attributes." ++ fctName ++ ": No attribute identifier in\n" ++ errLoc at pos -- errLoc :: Attr a => AttrTable a -> Position -> String errLoc at pos = " table `" ++ tableDesc at ++ "' for construct at\n\ \ position " ++ show pos ++ "!" where tableDesc (SoftTable _ desc) = desc tableDesc (FrozenTable _ desc) = desc -- | freeze a soft table; afterwards no more changes are possible until the -- table is softened again -- freezeAttrTable :: Attr a => AttrTable a -> AttrTable a freezeAttrTable (SoftTable fm desc) = let contents = nameMapToList fm keys = map fst contents lbd = minimum keys ubd = maximum keys in assert (length keys < 1000 || (length . range) (lbd, ubd) > 3 * length keys) (FrozenTable (array (lbd, ubd) contents) desc) freezeAttrTable (FrozenTable _ desc) = interr ("Attributes.freezeAttrTable: Attempt to freeze the already frozen\n\ \ table `" ++ desc ++ "'!") -- | soften a frozen table; afterwards changes are possible until the -- table is frozen again -- softenAttrTable :: Attr a => AttrTable a -> AttrTable a softenAttrTable (SoftTable _fm desc) = interr ("Attributes.softenAttrTable: Attempt to soften the already \ \softened\n table `" ++ desc ++ "'!") softenAttrTable (FrozenTable arr desc) = SoftTable (nameMapFromList . assocs $ arr) desc -- standard attributes -- ------------------- -- | standard attribute variants -- data StdAttr a = UndefStdAttr | DontCareStdAttr | JustStdAttr a instance Attr (StdAttr a) where undef = UndefStdAttr isUndef UndefStdAttr = True isUndef _ = False dontCare = DontCareStdAttr isDontCare DontCareStdAttr = True isDontCare _ = False -- | get an attribute value from a standard attribute table -- -- * if the attribute can be "don't care", this should be checked before -- calling this function (using 'isDontCareStdAttr') -- getStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> a getStdAttr atab at = getStdAttrDft atab at err where err = interr $ "Attributes.getStdAttr: Don't care in\n" ++ errLoc atab (posOf at) -- | get an attribute value from a standard attribute table, where a default is -- substituted if the table is don't care -- getStdAttrDft :: AttrTable (StdAttr a) -> NodeInfo -> a -> a getStdAttrDft atab at dft = case getAttr atab at of DontCareStdAttr -> dft JustStdAttr av -> av UndefStdAttr -> interr $ "Attributes.getStdAttrDft: Undefined in\n" ++ errLoc atab (posOf at) -- | check if the attribue value is marked as "don't care" -- isDontCareStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> Bool isDontCareStdAttr atab at = isDontCare (getAttr atab at) -- | check if the attribue value is still undefined -- -- * we also regard "don't care" attributes as undefined -- isUndefStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> Bool isUndefStdAttr atab at = isUndef (getAttr atab at) -- | set an attribute value in a standard attribute table -- setStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> a -> AttrTable (StdAttr a) setStdAttr atab at av = setAttr atab at (JustStdAttr av) -- | update an attribute value in a standard attribute table -- updStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> a -> AttrTable (StdAttr a) updStdAttr atab at av = updAttr atab at (JustStdAttr av) -- generic attribute table access -- ------------------------------ getGenAttr :: (Attr a, Attributed obj) => AttrTable a -> obj -> a getGenAttr atab at = getAttr atab (attrsOf at) setGenAttr :: (Attr a, Attributed obj) => AttrTable a -> obj -> a -> AttrTable a setGenAttr atab at av = setAttr atab (attrsOf at) av updGenAttr :: (Attr a, Attributed obj) => AttrTable a -> obj -> a -> AttrTable a updGenAttr atab at av = updAttr atab (attrsOf at) av c2hs-0.16.4/doc/0000755000000000000000000000000012044310770011372 5ustar0000000000000000c2hs-0.16.4/doc/c2hs.css0000644000000000000000000000147212044310770012747 0ustar0000000000000000div { font-family: sans-serif; color: black; background: white } h1, h2, h3, h4, h5, h6, p.title { color: #005A9C } h1 { font: 170% sans-serif } h2 { font: 140% sans-serif } h3 { font: 120% sans-serif } h4 { font: bold 100% sans-serif } h5 { font: italic 100% sans-serif } h6 { font: small-caps 100% sans-serif } pre { font-family: monospace; border-width: 1px; border-style: solid; padding: 0.3em } pre.screen { color: #006400 } pre.programlisting { color: maroon } div.example { margin: 1ex 0em; border: solid #412e25 1px; padding: 0ex 0.4em } div.example, div.example-contents { background-color: #fffcf5 } a:link { color: #0000C8 } a:hover { background: #FFFFA8 } a:active { color: #D00000 } a:visited { color: #680098 } c2hs-0.16.4/doc/Makefile0000644000000000000000000000316212044310770013034 0ustar0000000000000000# C->Haskell Compiler: documentation makefile # # Author : Manuel M T Chakravarty # Created: 30 October 1999 # # Version $Revision: 1.9 $ from $Date: 2002/07/06 09:59:40 $ # # Copyright (c) [1999..2002] Manuel M T Chakravarty # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This file is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # = DOCU ===================================================================== # # * Nothing is installed at the moment. That has to be done manually. # must be first # default: html XMLLINT=xmllint XMLLINT_OPTIONS=--nonet --noout --valid XSLTPROC=xsltproc XSLTPROC_HTML_OUTDIR=users_guide/ XSLTPROC_HTML_CSS=c2hs.css XSLTPROC_HTML_PARAMS=\ --param use.id.as.filename 1 \ --stringparam base.dir $(XSLTPROC_HTML_OUTDIR) \ --stringparam html.stylesheet $(XSLTPROC_HTML_CSS) XSLTPROC_HTML_STYLESHEET=http://docbook.sourceforge.net/release/xsl/current/html/chunk.xsl XSLTPROC_OPTIONS=--nonet $(XSLTPROC_HTML_PARAMS) $(XSLTPROC_HTML_STYLESHEET) # build targets # .PHONY: html pdf html: c2hs.xml $(XMLLINT) $(XMLLINT_OPTIONS) $< $(XSLTPROC) $(XSLTPROC_OPTIONS) $< cp $(XSLTPROC_HTML_CSS) $(XSLTPROC_HTML_OUTDIR) pdf: c2hs.xml sgml2pdf $< # auxiliary targets # .PHONY: clean clean: -rm -rf users_guide/ c2hs.pdf c2hs-0.16.4/doc/c2hs.xml0000644000000000000000000016030512044310770012760 0ustar0000000000000000 c2hs'> ]>
The Binding Generator &C2hs; Manuel Chakravarty chak@cse.unsw.edu.au November 2007 &C2hs; is an interface generator that simplifies the development of Haskell bindings to C libraries. The tool processes existing C header files that determine data layout and function signatures on the C side in conjunction with Haskell modules that specify Haskell-side type signatures and marshaling details. Hooks embedded in the Haskell code signal access to C structures and functions -- they are expanded by the interfacing tool in dependence on information from the corresponding C header file. Another noteworthy property is the lightweight nature of the approach. More background information is available in a research paper discussing &C2hs;, which is at . However, this paper does not cover the more recent advanced features such as function hooks and conditional compilation. Installation It follows a brief discussion of the installation from source. There is, however, a file INSTALL in the source distribution, which is more frequently updated and should be consulted in any case. Where is the Source? The master site of &C2hs; is at . It has all the latest information and sources. Furthermore, it explains how to get access to the &C2hs; Darcs repository and has references to pre-compiled binaries. What Else Do I Need? You need a Haskell system supported by &C2hs;. Currently, this is only the Glasgow Haskell Compiler (GHC), which you can obtain from . Furthermore, you need the Haskell package system Cabal. See the INSTALL file for details on supported versions. To build the documentation, you will also need the SGML Tools, which you find at your nearest sunsite or Linux mirror or at . On an up-to-date Linux system, the tools are probably already installed. I Got Everything, and Now? The short answer is $ tar -xzf package.tar.gz # unpack the sources $ cd package # change to the toplevel directory $ runghc Setup.hs configure # configure the build system $ runghc Setup.hs build # build everything [ Become root if necessary ] $ runghc Setup.hs install # install c2hs In the INSTALL file, there are more details. Optionally, you can build the documentation by issuing make doc and install it with make install-doc. Usage of &C2hs; Let's have a brief look at how to call the tool and how to use the generated interfaces. Usage of &c2hs; &C2hs; is implemented by the executable &c2hs;. The simplest form of usage is c2hs Lib.chs where Lib.chs is the Haskell binding module defining the Haskell interface to a C library together with the required marshalling code. If &c2hs; is invoked in this manner, the binding module must contain a cpp #include directive to determine the C-side interface of the library. Alternatively, a C header file can be specified on the command line, as in c2hs lib.h Lib.chs However, the latter option is only preserved for backwards compatibility and not recommended. If no errors occur, &c2hs; generates three files: a pure Haskell module Lib.hs, which implements the Haskell API of the library a C header file Lib.h which some Haskell systems need to compile the generated Haskell code. a &c2hs; interface file Lib.chi that is used by other binding modules that import Lib.hs using an import hook (see the section on import hooks for details). The executable &c2hs; has a couple more options: Usage: c2hs [ option... ] [header-file] binding-file -C CPPOPTS --cppopts=CPPOPTS pass CPPOPTS to the C preprocessor -c CPP --cpp=CPP use executable CPP to invoke C preprocessor -d TYPE --dump=TYPE dump internal information (for debugging) -h, -? --help brief help (the present message) -i INCLUDE --include=INCLUDE include paths for .chi files -k --keep keep pre-processed C header -l --copy-library copy `C2HS' library module in -o FILE --output=FILE output result to FILE (should end in .hs) -p PLATFORM --platform=PLATFORM platform to use for cross compilation -t PATH --output-dir=PATH place generated files in PATH -v --version show version information --numeric-version show version number The header file must be a C header file matching the given binding file. The dump TYPE can be trace -- trace compiler phases genbind -- trace binding generation ctrav -- trace C declaration traversal chs -- dump the binding file (adds `.dump' to the name) PLATFORM can be x86_64-linux, i686-linux, m68k-palmos The most useful of these is probably --cppopts= (or -C). If the C header file needs any special options (like -D or -I) to go through the C pre-processor, here is the place to pass them. A call may look like this: c2hs --cppopts='-I/some/obscure/dir' --cppopts=-DEXTRA' Lib.chs If you have more than one option that you want to pass to the pre-processor it is best to use multiple --cppopts= flags. That way there is no need to worry about quoting. Often, lib.h will not be in the current directory, but in one of the header file directories. &c2hs; leaves locating the header file to the standard C preprocessor, which usually looks in two places for the header: first, in the standard include directory of the used system, this is usually /usr/include and /usr/local/include; and second, it will look in every directory that is mentioned in a -IDIR option passed to the pre-processor via --cppopts. If the compiled binding module contains import hooks, &C2hs; needs to find the .chi (&C2hs; interface files) produced while compiling the corresponding binding modules. By default, they will be searched for in the current working directory. If they are located elsewhere, the --include=INCLUDE option has to be used to indicate the location, where INCLUDE is a colon-separated list of directories. Multiple such options are admissible. Paths specified later are searched first. Compilation of a Generated Haskell API &C2hs; comes with a marshalling library, called C2HS, which needs to be explicitly imported into Haskell binding modules. The library contains functions that users might use explicitly, but also functions that &C2hs; will generate for some classes of bindings. The library takes the form of a single Haskell module, which &c2hs; places in the same directory as the generated binding whenever it is given the --copy-library (or -l) option. Implementation of Haskell Binding Modules A discussion of binding modules, the principles behind the tool, and a discussion of related work can be found in a research paper located at . All features described in the paper, except enum define hooks are implemented in the tool, but since the publication of the paper, the tool has been extended further. The library interface essentially consists of the new Haskell FFI Marshalling Library. More details about this library are provided in the next section. The remainder of this section describes the hooks that are available in binding modules. Import Hooks {#import [qualified] modid#} Is translated into the same syntactic form in Haskell, which implies that it may be followed by an explicit import list. Moreover, it implies that the module modid is also generated by &C2hs; and instructs the tool to read the file modid.chi. If an explicit output file name is given (--output option), this name determines the basename for the .chi file of the currently translated module. Currently, only pointer hooks generate information that is stored in a .chi file and needs to be incorporated into any client module that makes use of these pointer types. It is, however, regarded as good style to use import hooks for any module generated by &C2hs;. Restriction &C2hs; does not use qualified names. This can be a problem, for example, if two pointer hooks are defined to have the same unqualified Haskell name in two different modules, which are then imported by a third module. To partially work around this problem, it is guaranteed that the declaration of the textually later import hook dominates. Context Hooks {#context [lib = lib] [prefix = prefix]#} Context hooks define a set of global configuration options. Currently, there are two parameters which are both strings lib is a dynamic library that contains symbols needed by the present binding. prefix is an identifier prefix that may be omitted in the lexemes of identifiers referring to C definitions in any binding hook. The is useful as C libraries often use a prefix, such as gtk_, as a form of poor man's name spaces. Any occurrence of underline characters between a prefix and the main part of an identifier must also be dropped. Case is not relevant in a prefix. In case of a conflict of the abbreviation with an explicitly defined identifier, the explicit definition takes preference. Both parameters are optional. An example of a context hook is the following: {#context prefix = "gtk"#} If a binding module contains a binding hook, it must be the first hook in the module. Type Hooks {#type ident#} A type hooks maps a C type to a Haskell type. As an example, consider type GInt = {#type gint#} The type must be a defined type, primitive types, such as int, are not admissible. Sizeof Hooks {#sizeof ident#} A sizeof hooks maps a C type to its size in bytes. As an example, consider gIntSize :: Int gIntSize = {#sizeof gint#} The type must be a defined type, primitive types, such as int, are not admissible. The size of primitive types can always be obtained using Storable.sizeOf. Enumeration Hooks {#enum cid [as hsid] {alias1 , ... , aliasn} [with prefix = pref] [deriving (clid1 , ... , clidn)]#} Rewrite the C enumeration called cid into a Haskell data type declaration, which is made an instance of Enum such that the ordinals match those of the enumeration values in C. This takes explicit enumeration values in the C definitions into account. If hsid is given, this is the name of the Haskell data type. The identifiers clid1 to clidn are added to the deriving clause of the Haskell type. By default, the names of the C enumeration are used for the constructors in Haskell. If alias1 is underscoreToCase, the original C names are capitalised and the use of underscores is rewritten to caps. If it is upcaseFirstLetter or downcaseFirstLetter, the first letter of the original C name changes case correspondingly. It is also possible to combine underscoreToCase with one of upcaseFirstLetter or downcaseFirstLetter. Moreover, alias1 to aliasn may be aliases of the form cid as hsid, which map individual C names to Haskell names. Instead of the global prefix introduced by a context hook, a local prefix pref can optionally be specified. As an example, consider {#enum WindowType {underscoreToCase} deriving (Eq)#} <literal>enum define</literal> hooks Many C libraries do not use enum types, but macro definitions to implement constants. c2hs provides enum define hooks generate a haskell datatype from a collection of macro definitions. {#enum define hsid {alias1 , ... , aliasn} [deriving (clid1 , ... , clidn)]#} Create a haskell datatype hsid, with nullary constructors as given by the aliases alias1 through aliasn. Each alias has to be of the form macrodef as hsid, where hsid is the name of the nullary haskell constructor, and macrodef the C macro which the haskell constructor should map to. The deriving part is handled as in ordinary enum hooks. Here's an example #define X 0 #define Y 1 {#enum define Axis {X as Axis0, Y as Axis1} deriving (Eq,Ord) #} Call Hooks {#call [pure] [unsafe] cid [as (hsid | ^)]#} A call hook rewrites to a call to the C function cid and also ensures that the appropriate foreign import declaration is generated. The tags pure and unsafe specify that the external function is purely functional and cannot re-enter the Haskell runtime, respectively. If hsid is present, it is used as the identifier for the foreign declaration, which otherwise defaults to the cid. When instead of hsid, the symbol ^ is given, the cid after conversion from C's underscore notation to a capitalised identifier is used. As an example, consider sin :: Float -> Float sin = {#call pure sin as "_sin"#} Function Hooks {#fun [pure] [unsafe] cid [as (hsid | ^)] [ctxt =>] { parm1 , ... , parmn } -> parm Function hooks are call hooks including parameter marshalling. Thus, the components of a function hook up to and including the as alias are the same as for call hooks. However, an as alias has a different meaning; it specifies the name of the generated Haskell function. The remaining components use literals enclosed in backwards and foward single quotes (` and ') to denote Haskell code fragments (or more precisely, parts of the Haskell type signature for the bound function). The first one is the phrase ctxt preceding =>, which denotes the type context. This is followed by zero or more type and marshalling specifications parm1 to parmn for the function arguments and one parm for the function result. Each such specification parm has the form [inmarsh [* | -]] hsty[&] [outmarsh [*] [-]] where hsty is a Haskell code fragment denoting a Haskell type. The optional information to the left and right of this type determines the marshalling of the corresponding Haskell value to and from C; they are called the in and out marshaller, respectively. Each marshalling specification parm corresponds to one or two arguments of the C function, in the order in which they are given. A marshalling specification in which the symbol & follows the Haskell type corresponds to two C function arguments; otherwise, it corresponds only to one argument. The parm following the left arrow -> determines the marshalling of the result of the C function and may not contain the symbol &. The *- output marshal specification is for monadic actions that must be executed but whose results are discarded. This is very useful for e.g. checking an error value and throwing an exception if needed. Both inmarsh and outmarsh are identifiers of Haskell marshalling functions. By default they are assumed to be pure functions; if they have to be executed in the IO monad, the function name needs to be followed by a star symbol *. Alternatively, the identifier may be followed by a minux sign -, in which case the Haskell type does not appear as an argument (in marshaller) or result (out marshaller) of the generated Haskell function. In other words, the argument types of the Haskell function is determined by the set of all marshalling specifications where the in marshaller is not followed by a minus sign. Conversely, the result tuple of the Haskell function is determined by the set of all marshalling specifications where the out marshaller is not followed by a minus sign. The order of function arguments and components in the result tuple is the same as the order in which the marshalling specifications are given, with the exception that the value of the result marshaller is always the first component in the result tuple if it is included at all. For a set of commonly occuring Haskell and C type combinations, default marshallers are provided by &C2hs; if no explicit marshaller is given. The out marshaller for function arguments is by default void-. The defaults for the in marshallers for function arguments are as follows: Bool and integral C type (including chars): cFromBool Integral Haskell and integral C type: cIntConv Floating Haskell and floating C type: cFloatConv String and char*: withCString* String and char* with explicit length: withCStringLen* T and T*: with* T and T* where T is an integral type: withIntConv* T and T* where T is a floating type: withFloatConv* Bool and T* where T is an integral type: withFromBool* The defaults for the out marshaller of the result are the converse of the above; i.e., instead of the with functions, the corresponding peek functions are used. Moreover, when the Haskell type is (), the default marshaller is void-. As an example, consider {#fun notebook_query_tab_label_packing as ^ `(NotebookClass nb, WidgetClass cld)' => {notebook `nb' , widget `cld' , alloca- `Bool' peekBool*, alloca- `Bool' peekBool*, alloca- `PackType' peekEnum*} -> `()'#} which results in the Haskell type signature notebookQueryTabLabelPacking :: (NotebookClass nb, WidgetClass cld) => nb -> cld -> IO (Bool, Bool, PackType) which binds the following C function: void gtk_notebook_query_tab_label_packing (GtkNotebook *notebook, GtkWidget *child, gboolean *expand, gboolean *fill, GtkPackType *pack_type); Get Hooks {#get apath#} A get hook supports accessing a member value of a C structure. The hook itself yields a function that, when given the address of a structure of the right type, performs the structure access. The member that is to be extracted is specified by the access path apath. Access paths are formed as follows (following a subset of the C expression syntax): The root of any access path is a simple identifier, which denotes either a type name or struct tag. An access path of the form *apath denotes dereferencing of the pointer yielded by accessing the access path apath. An access path of the form apath.cid specifies that the value of the struct member called cid should be accessed. Finally, an access path of the form apath->cid, as in C, specifies a combination of dereferencing and member selection. For example, we may have visualGetType :: Visual -> IO VisualType visualGetType (Visual vis) = liftM cToEnum $ {#get Visual->type#} vis Set Hooks {#set apath#} Set hooks are formed in the same way as get hooks, but yield a function that assigns a value to a member of a C structure. These functions expect a pointer to the structure as the first and the value to be assigned as the second argument. For example, we may have {#set sockaddr_in.sin_family#} addr_in (cFromEnum AF_NET) Pointer Hooks {#pointer [*] cid [as hsid] [foreign | stable] [newtype | -> hsid2] [nocode]#} A pointer hook facilitates the mapping of C to Haskell pointer types. In particular, it enables the use of ForeignPtr and StablePtr types and defines type name translations for pointers to non-basic types. In general, such a hook establishes an association between the C type cid or *cid and the Haskell type hsid, where the latter defaults to cid if not explicitly given. The identifier cid will usually be a type name, but in the case of *cid may also be a struct, union, or enum tag. If both a type name and a tag of the same name are available, the type name takes precedence. Optionally, the Haskell representation of the pointer can be by a ForeignPtr or StablePtr instead of a plain Ptr. If the newtype tag is given, the Haskell type hsid is defined as a newtype rather than a transparent type synonym. In case of a newtype, the type argument to the Haskell pointer type will be hsid, which gives a cyclic definition, but the type argument is here really only used as a unique type tag. Without newtype, the default type argument is (), but another type can be specified after the symbol ->. For example, we may have {#pointer *GtkObject as Object newtype#} This will generate a new type Object as follows: newtype Object = Object (Ptr Object) which enables exporting Object as an abstract type and facilitates type checking at call sites of imported functions using the encapsulated pointer. The latter is achieved by &C2hs; as follows. The tool remembers the association of the C type *GtkObject with the Haskell type Object, and so, it generates for the C function void gtk_unref_object (GtkObject *obj); the import declaration foreign import gtk_unref_object :: Object -> IO () This function can obviously only be applied to pointers of the right type, and thus, protects against the common mistake of confusing the order of pointer arguments in function calls. However, as the Haskell FFI does not permit to directly pass ForeignPtrs to function calls or return them, the tool will use the type Ptr HsName in this case, where HsName is the Haskell name of the type. So, if we modify the above declaration to be {#pointer *GtkObject as Object foreign newtype#} the type Ptr Object will be used instead of a plain Object in import declarations; i.e., the previous import declaration will become foreign import gtk_unref_object :: Ptr Object -> IO () To simplify the required marshalling code for such pointers, the tool automatically generates a function withObject :: Object -> (Ptr Object -> IO a) -> IO a As an example that does not represent the pointer as an abstract type, consider the C type declaration: typedef struct {int x, y;} *point; We can represent it in Haskell as data Point = Point {x :: Int, y :: Int} {#pointer point as PointPtr -> Point#} which will translate to data Point = Point {x :: Int, y :: Int} type PointPtr = Ptr Point and establish a type association between point and PointPtr. If the keyword nocode is added to the end of a pointer hook, &C2hs; will not emit a type declaration. This is useful when a &C2hs; module wants to make use of an existing type declaration in a binding not generated by &C2hs; (i.e., where there are no .chi files). Restriction The name cid cannot be a basic C type (such as int), it must be a defined name. Class Hooks {#class [hsid1 =>] hsid2 hsid3#} Class hooks facilitate the definition of a single inheritance class hierachy for external pointers including up and down cast functionality. This is meant to be used in cases where the objects referred to by the external pointers are order in such a hierachy in the external API - such structures are encountered in C libraries that provide an object-oriented interface. Each class hook rewrites to a class declaration and one or more instance declarations. All classes in a hierarchy, except the root, will have a superclass identified by hsid1. The new class is given by hsid2 and the corresponding external pointer is identified by hsid3. Both the superclass and the pointer type must already have been defined by binding hooks that precede the class hook. The pointers in a hierachy must either all be foreign pointers or all be normal pointers. Stable pointers are not allowed. Both pointer defined as newtypes and those defined by type synonyms may be used in class declarations and they may be mixed. In the case of synonyms, Haskell's usual restrictions regarding overlapping instance declarations apply. The newly defined class has two members whose names are derived from the type name hsid3. The name of first member is derived from hsid3 by converting the first character to lower case. This function casts from any superclass to the current class. The name of the second member is derived by prefixing hsid3 with the from. It casts from the current class to any superclass. A class hook generates an instance for the pointer in the newly defined class as well as in all its superclasses. As an example, consider {#pointer *GtkObject newtype#} {#class GtkObjectClass GtkObject#} {#pointer *GtkWidget newtype#} {#class GtkObjectClass => GtkWidgetClass GtkWidget#} The second class hook generates an instance for GtkWidget for both the GtkWidgetClass as well as for the GtkObjectClass. CPP Directives and Inline C Code A Haskell binding module may include arbitrary C pre-processor directives using the standard C syntax. The directives are used in two ways: Firstly, they are included in the C header file generated by &C2hs; in exactly the same order in which they appear in the binding module. Secondly, all conditional directives are honoured by &C2hs; in that all Haskell binding code in alternatives that are discarded by the C pre-processor are also discarded by &C2hs;. This latter feature is, for example, useful to maintain different bindings for multiple versions of the same C API in a single Haskell binding module. In addition to C pre-processor directives, vanilla C code can be maintained in a Haskell binding module by bracketing this C code with the pseudo directives #c and #endc. Such inline C code is emitted into the C header generated by &C2hs; at exactly the same position relative to CPP directives as it occurs in the binding module. Pre-processor directives may encompass the #include directive, which can be used instead of specifying a C header file as an argument to c2hs. In particular, this enables the simultaneous use of multiple header files without the need to provide a custom header file that binds them together. If a header file lib.h is specified as an argument to c2hs, the tool will emit the directive #include"lib.h" into the generated C header before any other CPP directive or inline C code. As an artificial example of these features consider the following code: #define VERSION 2 #if (VERSION == 1) foo :: CInt -> CInt foo = {#call pure fooC#} #else foo :: CInt -> CInt -> CInt foo = {#call pure fooC#} #endif #c int fooC (int, int); #endc One of two versions of the Haskell function foo (having different arities) is selected in dependence on the value of the CPP macro VERSION, which in this example is defined in the same file. In realistic code, VERSION would be defined in the header file supplied with the C library that is made accessible from Haskell by a binding module. The above code fragment also includes one line of inline C code that declares a C prototype for fooC. Current limitation of the implementation Inline C code can currently not contain any code blocks; i.e., only declarations as typically found in header files may be included. Grammar Rules The following grammar rules define the syntax of binding hooks: hook -> `{#' inner `#}' inner -> `import' ['qualified'] ident | `context' ctxt | `type' ident | `sizeof' ident | `enum' idalias trans [`with' prefix] [deriving] | `call' [`pure'] [`unsafe'] idalias | `fun' [`pure'] [`unsafe'] idalias parms | `get' apath | `set' apath | `pointer' ['*'] idalias ptrkind | `class' [ident `=>'] ident ident ctxt -> [`lib' `=' string] [prefix] idalias -> ident [(`as' ident | `^')] prefix -> `prefix' `=' string deriving -> `deriving' `(' ident_1 `,' ... `,' ident_n `)' parms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm parm -> [ident_1 [`*' | `-']] verbhs [`&'] [ident_2 [`*'] [`-']] apath -> ident | `*' apath | apath `.' ident | apath `->' ident trans -> `{' alias_1 `,' ... `,' alias_n `}' alias -> `underscoreToCase' | `upcaseFirstLetter' | `downcaseFirstLetter' | ident `as' ident ptrkind -> [`foreign' | `stable'] ['newtype' | '->' ident] Identifier ident follow the lexis of Haskell. They may be enclosed in single quotes to disambiguate them from C->Haskell keywords. Bug Reports and Suggestions There is a tracker for bugs and feature requests: . Alternatively if you prefer email please send your bug reports and suggestions to the C->Haskell List c2hs@haskell.org. A good bug report contains information on the used operating system and Haskell compiler as well as the version of &C2hs; that you have been using. You can obtain the version information by running c2hs --version. If possible a concise example illustrating your problem would be appreciated. Copyright &C2hs; is Copyright (C) [1999..2005] Manuel M. T. Chakravarty &C2hs; License This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Documentation License This manual is Copyright (c) [2000..2005] by Manuel M. T. Chakravarty. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.1 or any later version published by the Free Software Foundation; with no Invariant Sections, with no Front-Cover Texts, and with the no Back-Cover Texts. A copy of the license is included in the section entitled "GNU Free Documentation License". Possible Licenses of Generated Code All code included into generated bindings is under a BSD-style license that does not place any restrictions on the license of the inteface produced with &C2hs; (ie, closed proprietary licenses are possible, too). In other words, I do not care what you use &C2hs; for or to whom you are giving &C2hs; or any interfaces generated with &C2hs;, only if you modify or improve &C2hs; itself, you have to contribute your changes back to the community. Nevertheless, I will of course be particularly delighted if you choose to make your work freely available. GNU Free Documentation License The GNU Free Documentation License is available at . Release Notes Important changes (especially those affecting the semantics of the tool) are documented in the following. Version 0.15.1 "Rainy Days" New C parser that can parse all of C99 and GNU C Make c2hs integrate better with Cabal (1.2 and later) Adapted to GHC 6.8. Now requires Cabal 1.2. Lots and lots of old code removal Several bug fixes and improvements from Udo Stenzel: allowing variadic functions in structures allowing call and fun hooks for FunPtrs in C structs embedded arrays size calculated correctly Version 0.14.5 "Travelling Lightly" Added nocode directive to pointer hooks Can use structs properly in pointer hooks now (contributed by Jelmer Vernooij) upcaseFirstLetter and downcaseFirstLetter Cross-compiling with --platform flag Gcc's asm construct is supported (contributed by Duncan Coutts) Hierarchical modules syntax in import hooks supported No separately installed marshaling library anymore; as a result binary &C2hs; packages and installations are now independent of the targeted Haskell system New lexer and parser generated with Alex and Happy (contributed by Duncan Coutts) Cabal build system Version 0.13.6 "Pressing Forward" Works with GHC 6.4 and Cabal packages Strings may contain 8-bit characters (e.g., umlauts). Identifier may optionally be put in single quotes. (This is useful if they would otherwise collide with a &C2hs; keyword.) Some smaller bug fixes C chars are treated as integral types for marshalling purposes. If there is no explicit output file specified, the generated header file is put in the same directory as the binding file; otherwise, it goes in the directory where the output file is put. Moreover, the --output-dir option enables the specification of directory where all generated files are to be put. Foreign import declarations include the name of the header file generated by &C2hs; (ie, it needs neither be passed to the Haskell compiler at the command line nor in an OPTIONS pragma). We allow structs and unions with no declarations. Headers including function bodies are now parsed correctly. Duncan Coutts identified a space leak in the parser whose removal improved performance significantly. Version 0.12.1 "Springtime" Removed support for deprecated C2HS interface and for old versions of the FFI libraries Improved line pragma generation Works with GHC 6.3 Builds on Mac OS X thanks to a patch by Sean Seefried Version 0.11.5 "Powder Snow" Bug fixes Constant expression can now contain enumerators header label removed from context hooks This version of c2hs may overwrite C header files in the current directory. More precisely, if a binding module with the name Foo.chs is processed, a header file with the name Foo.h is generated and will overwrite any file of the same name in the current directory or the directory specified via the -o option. Added support for CPP directives, including special treatment of conditions, and for inline C code; specification of a header file as an argument to c2hs is now option. GHC line pragmas are emitted into generated Haskell code Swap the order of reading the binding module and the C header (i.e., we now read the binding module first) Version 0.10.17 "Altocumulus Stratiformis Perlucidus Undulatus" Worked around a bug in GHC 5.04.1 Solaris-related fix Marshalling support for bit masks represented as enumeration types Added fun hooks as aliases can use ^ convert the orignal identifier with underscore2case In call hooks, the attributes `fun' was replaced by `pure' (`fun' is will still be recognised for a while to ensure backwards compatibility, but it's use is deprecated) GHC's package system is now supported If two import hooks add a type mapping for a pointer hook with the same name, the textual later one dominates. Bug fixes Support for bitfields (they are correctly handled when computing struct offsets and they can be accessed using set and get hooks) Some more support for GNU C extensions ("alignof" and better support "__attribute__") Added class hooks Version 0.9.9 "Blue Ginger" Bug fixes Library names in foreign imports have been removed until the convention of the new FFI is implemented (they are currently silently omitted) Added sizeof hooks; sizeof of type names is now also supported in constant expressions Local prefix for enum hooks; courtesy of Armin Sander Added import hooks The documentation includes a description of binding hooks Added pointer hooks, which were derived from code for a similar feature by Axel Simon; this includes proper treatment of parametrised pointers Integrated deriving option for enum hooks, which was contributed by Axel Simon Adapted to GHC 5.0 Version 0.8.2 "Gentle Moon" Adaptation layer for legacy StablePtr interface Forgot to export FunPtr and associated functions from C2HS Forgot to export some names in C2HSDeprecated Added support for gcc's __builtin_va_list Version 0.8.1 "Gentle Moon" Library adapted to New FFI; the old interface can still be used by importing C2HSDeprecated FFI Library specification added to the documentation Version 0.7.10 "Afterthought" CygWin support; based on suggestions by Anibal Maffioletti Rodrigues de DEUS anibaldedeus@email.com IntConv instances for Int8, Word8, and Char Version 0.7.9 "Afterthought" Debugged the stripping of prefixes from enumerators; prefixes are now generally stripped, independent of whether they can be stripped from all enumerators of a given enumeration type Comma now correctly required after underscoreToCase. This breaks source compatibility with previous versions. Version 0.7.8 Provisional support for GHC 4.08 Corrected constant folding Version 0.7.7 Ignores any occurrence of #pragma. Version 0.7.6 Bug fixes and support for long long. Version 0.7.5 This is mainly a bug fix release. In particular, the space behaviour of &C2hs; has been significantly improved. IMPORTANT NOTE: From this release on, library names in lib tags in context hooks should not contain a suffix (i.e., omit .so etc).
c2hs-0.16.4/doc/man1/0000755000000000000000000000000012044310770012226 5ustar0000000000000000c2hs-0.16.4/doc/man1/c2hs.10000644000000000000000000001034512044310770013152 0ustar0000000000000000.\" Hey Emacs! This file is -*- nroff -*- source. .\" .\" Version $Revision: 1.2 $ from $Date: 2002/09/15 07:00:41 $ .\" .TH C2HS 1 "November 2007" "Version 0.15.1" C\->Haskell .SH NAME c2hs \- C->Haskell Interface Generator .SH SYNOPSIS .B c2hs .RB [ OPTIONS ]... .I header-file .I binding-file .SH DESCRIPTION This manual page briefly describes the .B c2hs command. For more details, refer to the main documentation, which is available in various other formats, including SGML and HTML; see below. .PP .SH OPTIONS The programs follow the usual GNU command line syntax, with long options starting with two dashes (`-'). A summary of options are included below. For a complete description, see the other documentation. .B c2hs accepts the following options: .TP .B \-h, \-?, \-\-help brief help .TP .B \-v, \-\-version show version information .TP .B \-\-numeric\-version show version number .TP .BI \-c \ CPP\fR, \ \-\-cpp= CPP use executable \fICPP\fR to invoke C preprocessor .TP .BR \-C \ CPPOPTS\fR, \ \-\-cppopts= CPPOPTS pass CPPOPTS to the C preprocessor .TP .BI \-o \ FILE\fR, \ \-\-output= FILE output result to \fIFILE\fR (should end in \fI.hs\fR) .TP .BI \-t \ PATH\fR, \ \-\-output\-dir= PATH place generated files in PATH .TP .B \-p \ PLATFORM, \-\-platform=PLATFORM platform to use for cross compilation .TP .B \-k, \-\-keep keep pre-processed C header .TP .B \-l, \-\-copy\-library copy `C2HS' library module to the current directory .TP .BR \-d \ TYPE\fR, \ \-\-dump= TYPE dump internal information (for debugging), where TYPE is one of: .RS .IP "\(bu \fBtrace\fR" 10 trace compiler phases .IP "\(bu \fBgenbind\fR" 10 trace binding generation .IP "\(bu \fBctrav\fR" 10 trace C declaration traversal .IP "\(bu \fBchs\fR" 10 dump the binding file (adds \fI.dump\fR to the name) .RE .PP .I header-file is the header file belonging to the marshalled library. It must end with suffix .IR .h . .I binding-file is the corresponding Haskell binding file, which must end with suffix .IR .chs . .I PLATFORM The platform name can be one of: .IR x86_64-linux . .IR i686-linux . .IR m68k-palmos . This allows for cross-compilation, assuming the rest of your toolchain supports that. The default is the current host platform. The most useful of these options is probably .B \-\-cppopts (or .BR \-C ). If the C header file needs any special options (like \-D or \-I) to go through the C pre-processor, here is the place to pass them. .SH EXAMPLES The easiest way to use the C->Haskell Interface Generator is via .I Cabal. Cabal knows about .I .chs files and will run .B c2hs automatically, passing the appropriate flags. When used directly, .Bc2hs is usually called as: .B c2hs .I lib.h Lib.chs where .I lib.h is the header file and .I Lib.chs the Haskell binding module, which define the C- and Haskell-side interface, respectively. If no errors occur, the result is a pure Haskell module .IR Lib.hs , which implements the Haskell API of the library. A more advanced call may look like this: .BR "c2hs" \ \-\-cppopts=\-I\fI/some/obscure/dir\fR \-\-cppopts=\-DEXTRA .I lib.h Lib.chs Often, .I lib.h will not be in the current directory, but in one of the header file directories. Apart from the current directory, C->Haskell looks in two places for the header: first, in the standard include directory of the used system, this is usually .IR /usr/include " and " /usr/local/include ; and second, it will look in every directory that is mentioned in a .RI \-I DIR option passed to the pre-processor via .BR \-\-cppopts . .SH CAVEATS If you have more than one option that you want to give to the pre-processor, use multiple .BR \-\-cppopts= \ flags. .SH "SEE ALSO" User guide .I /usr/share/doc/c2hs-0.15.1/html/c2hs.html Home page .I http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ .SH "BUGS" Please report bugs and feature requests in the c2hs trac .I http://hackage.haskell.org/trac/c2hs/ or to the C->Haskell mailing list .I c2hs@haskell.org .SH COPYRIGHT C->Haskell Version 0.15.1 Copyright (c) [1999..2007] Manuel M. T. Chakravarty .SH AUTHOR This manual page was mainly assembled from the original documentation. It was written by Michael Weber for the Debian GNU/Linux system (but may be used by others).