gtk2hs-buildtools-0.13.10.0/0000755000000000000000000000000007346545000013563 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/COPYING0000644000000000000000000004356507346545000014633 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 Lesser 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 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. {description} Copyright (C) {year} {fullname} 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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) year 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. {signature of Ty Coon}, 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 Lesser General Public License instead of this License. gtk2hs-buildtools-0.13.10.0/Setup.hs0000644000000000000000000000012707346545000015217 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain gtk2hs-buildtools-0.13.10.0/c2hs/base/admin/0000755000000000000000000000000007346545000016424 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/c2hs/base/admin/BaseVersion.hs0000644000000000000000000000126407346545000021203 0ustar0000000000000000module BaseVersion (version, copyright, disclaimer) where -- version number is major.minor.patchlvl; don't change the format of the -- `versnum' line as it is `grep'ed for by a Makefile -- idstr = "$Id: BaseVersion.hs,v 1.1.1.1 2004/11/13 16:42:44 duncan_coutts Exp $" name = "Compiler Toolkit" versnum = "0.26.0" date = "19 Oct 2003" version = name ++ ", version " ++ versnum ++ ", " ++ date copyright = "Copyright (c) [1995..2003] Manuel M T Chakravarty" 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." gtk2hs-buildtools-0.13.10.0/c2hs/base/admin/Config.hs0000644000000000000000000000311207346545000020162 0ustar0000000000000000-- The Compiler Toolkit: configuration switches -- -- Author : Manuel M. T. Chakravarty -- Created: 3 October 95 -- -- Version $Revision: 1.1.1.1 $ from $Date: 2004/11/13 16:42:45 $ -- -- Copyright (c) [1995...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 --------------------------------------------------------------- -- -- This modules is used to configure the toolkit. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * Must not import any other module. -- --- TODO ---------------------------------------------------------------------- -- module Config (-- limits -- errorLimit, -- -- debuging -- assertEnabled) where -- compilation aborts with a fatal error, when the given number of errors -- has been raised (warnings do not count) -- errorLimit :: Int errorLimit = 20 -- specifies whether the internal consistency checks with `assert' should be -- made -- assertEnabled :: Bool assertEnabled = True gtk2hs-buildtools-0.13.10.0/c2hs/base/errors/0000755000000000000000000000000007346545000016650 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/c2hs/base/errors/Errors.hs0000644000000000000000000001163207346545000020463 0ustar0000000000000000-- Compiler Toolkit: basic error management -- -- Author : Manuel M. T. Chakravarty -- Created: 20 February 95 -- -- Version $Revision: 1.2 $ from $Date: 2004/11/13 17:26:50 $ -- -- 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 Errors ( -- handling of internal error -- interr, todo, -- -- errors in the compiled program -- ErrorLvl(..), Error, makeError, errorLvl, showError, errorAtPos ) where import Position (Position(..), isInternalPos) -- internal errors -- --------------- -- raise a fatal internal error; message may have multiple lines (EXPORTED) -- 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 (EXPORTED) -- todo :: String -> a todo msg = error ("Feature not yet implemented:\n" ++ indentMultilineString 2 msg ++ "\n") -- errors in the compiled program -- ------------------------------ -- the higher the level of an error, the more critical it is (EXPORTED) -- data ErrorLvl = WarningErr -- does not affect compilation | ErrorErr -- cannot generate code | FatalErr -- abort immediately deriving (Eq, Ord) data Error = Error ErrorLvl Position [String] -- (EXPORTED ABSTRACTLY) -- note that the equality to on errors takes into account only the error level -- and position (not the error text) -- -- note that these comparisions are expensive (the positions contain the file -- names as strings) -- instance Eq Error where (Error lvl1 pos1 _) == (Error lvl2 pos2 _) = lvl1 == lvl2 && pos1 == pos2 instance Ord Error where (Error lvl1 pos1 _) < (Error lvl2 pos2 _) = pos1 < pos2 || (pos1 == pos2 && lvl1 < lvl2) e1 <= e2 = e1 < e2 || e1 == e2 -- produce an `Error', given its level, position, and a list of lines of -- the error message that must not be empty (EXPORTED) -- makeError :: ErrorLvl -> Position -> [String] -> Error makeError = Error -- inquire the error level (EXPORTED) -- errorLvl :: Error -> ErrorLvl errorLvl (Error lvl _ _) = lvl -- converts an error into a string using a fixed format (EXPORTED) -- -- * the list of lines of the error message must not be empty -- -- * the format is -- -- :: (column ) [] -- >>> -- -- ... -- -- -- * internal errors (identified by a special position value) are formatted as -- -- INTERNAL ERROR! -- >>> -- -- ... -- -- showError :: Error -> String showError (Error _ pos (l:ls)) | isInternalPos pos = "INTERNAL ERROR!\n" ++ " >>> " ++ l ++ "\n" ++ (indentMultilineString 2 . unlines) ls showError (Error lvl (Position fname row col) (l:ls)) = let prefix = fname ++ ":" ++ show (row::Int) ++ ": " ++ "(column " ++ show (col::Int) ++ ") [" ++ showErrorLvl lvl ++ "] " showErrorLvl WarningErr = "WARNING" showErrorLvl ErrorErr = "ERROR" showErrorLvl FatalErr = "FATAL" in prefix ++ "\n" ++ " >>> " ++ l ++ "\n" ++ (indentMultilineString 2 . unlines) ls showError (Error _ _ [] ) = interr "Errors: showError:\ \ Empty error message!" errorAtPos :: Position -> [String] -> a errorAtPos pos msg = (error . showError . makeError ErrorErr pos) msg -- 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 ' ') gtk2hs-buildtools-0.13.10.0/c2hs/base/general/0000755000000000000000000000000007346545000016751 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/c2hs/base/general/Binary.hs0000644000000000000000000006463307346545000020545 0ustar0000000000000000{-# LANGUAGE CPP, ScopedTypeVariables #-} -- -- (c) The University of Glasgow 2002 -- -- Binary I/O library, with special tweaks for GHC -- -- Based on the nhc98 Binary library, which is copyright -- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. -- Under the terms of the license for that software, we must tell you -- where you can obtain the original version of the Binary library, namely -- http://www.cs.york.ac.uk/fp/nhc98/ module Binary ( {-type-} Bin, {-class-} Binary(..), {-type-} BinHandle, openBinIO, openBinIO_, openBinMem, -- closeBin, seekBin, tellBin, castBin, writeBinMem, readBinMem, isEOFBin, -- for writing instances: putByte, getByte, putSharedString, getSharedString, -- lazy Bin I/O lazyGet, lazyPut, #if __GLASGOW_HASKELL__<610 -- GHC only: ByteArray(..), getByteArray, putByteArray, #endif getBinFileWithDict, -- :: Binary a => FilePath -> IO a putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO () ) where #if __GLASGOW_HASKELL__>=604 #include "ghcconfig.h" #else #include "config.h" #endif import FastMutInt import Map (Map) import qualified Map as Map #if __GLASGOW_HASKELL__>=602 # if __GLASGOW_HASKELL__>=707 import Data.HashTable.Class as HashTable (HashTable) import Data.HashTable.IO as HashTable (BasicHashTable, toList, new, insert, lookup) # else import Data.HashTable as HashTable # endif #endif import Data.Array.IO import Data.Array import Data.Bits import Data.Int import Data.Word import Data.IORef import Data.Char ( ord, chr ) import Data.Array.Base ( unsafeRead, unsafeWrite ) import Control.Monad ( when, liftM ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) import GHC.Real ( Ratio(..) ) import GHC.Exts # if __GLASGOW_HASKELL__>=612 import GHC.IO (IO(IO)) #else import GHC.IOBase (IO(IO)) #endif import GHC.Word ( Word8(..) ) # if __GLASGOW_HASKELL__<602 import GHC.Handle ( hSetBinaryMode ) # endif -- for debug import System.CPUTime (getCPUTime) import Numeric (showFFloat) #define SIZEOF_HSINT SIZEOF_VOID_P type BinArray = IOUArray Int Word8 --------------------------------------------------------------- -- BinHandle --------------------------------------------------------------- data BinHandle = BinMem { -- binary data stored in an unboxed array bh_usr :: UserData, -- sigh, need parameterized modules :-) off_r :: !FastMutInt, -- the current offset sz_r :: !FastMutInt, -- size of the array (cached) arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) } -- XXX: should really store a "high water mark" for dumping out -- the binary data to a file. | BinIO { -- binary data stored in a file bh_usr :: UserData, off_r :: !FastMutInt, -- the current offset (cached) hdl :: !IO.Handle -- the file handle (must be seekable) } -- cache the file ptr in BinIO; using hTell is too expensive -- to call repeatedly. If anyone else is modifying this Handle -- at the same time, we'll be screwed. getUserData :: BinHandle -> UserData getUserData bh = bh_usr bh setUserData :: BinHandle -> UserData -> BinHandle setUserData bh us = bh { bh_usr = us } --------------------------------------------------------------- -- Bin --------------------------------------------------------------- newtype Bin a = BinPtr Int deriving (Eq, Ord, Show, Bounded) castBin :: Bin a -> Bin b castBin (BinPtr i) = BinPtr i --------------------------------------------------------------- -- class Binary --------------------------------------------------------------- class Binary a where put_ :: BinHandle -> a -> IO () put :: BinHandle -> a -> IO (Bin a) get :: BinHandle -> IO a -- define one of put_, put. Use of put_ is recommended because it -- is more likely that tail-calls can kick in, and we rarely need the -- position return value. put_ bh a = do put bh a; return () put bh a = do p <- tellBin bh; put_ bh a; return p putAt :: Binary a => BinHandle -> Bin a -> a -> IO () putAt bh p x = do seekBin bh p; put bh x; return () getAt :: Binary a => BinHandle -> Bin a -> IO a getAt bh p = do seekBin bh p; get bh openBinIO_ :: IO.Handle -> IO BinHandle openBinIO_ h = openBinIO h openBinIO :: IO.Handle -> IO BinHandle openBinIO h = do r <- newFastMutInt writeFastMutInt r 0 return (BinIO noUserData r h) openBinMem :: Int -> IO BinHandle openBinMem size | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" | otherwise = do arr <- newArray_ (0,size-1) arr_r <- newIORef arr ix_r <- newFastMutInt writeFastMutInt ix_r 0 sz_r <- newFastMutInt writeFastMutInt sz_r size return (BinMem noUserData ix_r sz_r arr_r) tellBin :: BinHandle -> IO (Bin a) tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix) tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) seekBin :: BinHandle -> Bin a -> IO () seekBin (BinIO _ ix_r h) (BinPtr p) = do writeFastMutInt ix_r p hSeek h AbsoluteSeek (fromIntegral p) seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do sz <- readFastMutInt sz_r if (p >= sz) then do expandBin h p; writeFastMutInt ix_r p else writeFastMutInt ix_r p isEOFBin :: BinHandle -> IO Bool isEOFBin (BinMem _ ix_r sz_r a) = do ix <- readFastMutInt ix_r sz <- readFastMutInt sz_r return (ix >= sz) isEOFBin (BinIO _ ix_r h) = hIsEOF h writeBinMem :: BinHandle -> FilePath -> IO () writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle" writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do h <- openFile fn WriteMode hSetBinaryMode h True arr <- readIORef arr_r ix <- readFastMutInt ix_r hPutArray h arr ix hClose h readBinMem :: FilePath -> IO BinHandle -- Return a BinHandle with a totally undefined State readBinMem filename = do h <- openFile filename ReadMode hSetBinaryMode h True filesize' <- hFileSize h let filesize = fromIntegral filesize' arr <- newArray_ (0,filesize-1) count <- hGetArray h arr filesize when (count /= filesize) (error ("Binary.readBinMem: only read " ++ show count ++ " bytes")) hClose h arr_r <- newIORef arr ix_r <- newFastMutInt writeFastMutInt ix_r 0 sz_r <- newFastMutInt writeFastMutInt sz_r filesize return (BinMem noUserData ix_r sz_r arr_r) -- expand the size of the array to include a specified offset expandBin :: BinHandle -> Int -> IO () expandBin (BinMem _ ix_r sz_r arr_r) off = do sz <- readFastMutInt sz_r let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) arr <- readIORef arr_r arr' <- newArray_ (0,sz'-1) sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i | i <- [ 0 .. sz-1 ] ] writeFastMutInt sz_r sz' writeIORef arr_r arr' #ifdef DEBUG hPutStrLn stderr ("Binary: expanding to size: " ++ show sz') #endif return () expandBin (BinIO _ _ _) _ = return () -- no need to expand a file, we'll assume they expand by themselves. {-# INLINE expandBin #-} -- ----------------------------------------------------------------------------- -- Low-level reading/writing of bytes putWord8 :: BinHandle -> Word8 -> IO () putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do ix <- readFastMutInt ix_r sz <- readFastMutInt sz_r -- double the size of the array if it overflows if (ix >= sz) then do expandBin h ix putWord8 h w else do arr <- readIORef arr_r unsafeWrite arr ix w writeFastMutInt ix_r (ix+1) return () putWord8 (BinIO _ ix_r h) w = do ix <- readFastMutInt ix_r hPutChar h (chr (fromIntegral w)) -- XXX not really correct writeFastMutInt ix_r (ix+1) return () getWord8 :: BinHandle -> IO Word8 getWord8 (BinMem _ ix_r sz_r arr_r) = do ix <- readFastMutInt ix_r sz <- readFastMutInt sz_r when (ix >= sz) $ ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) arr <- readIORef arr_r w <- unsafeRead arr ix writeFastMutInt ix_r (ix+1) return w getWord8 (BinIO _ ix_r h) = do ix <- readFastMutInt ix_r c <- hGetChar h writeFastMutInt ix_r (ix+1) return $! (fromIntegral (ord c)) -- XXX not really correct putByte :: BinHandle -> Word8 -> IO () putByte bh w = put_ bh w getByte :: BinHandle -> IO Word8 getByte = getWord8 -- ----------------------------------------------------------------------------- -- Primitve Word writes instance Binary Word8 where put_ = putWord8 get = getWord8 instance Binary Word16 where put_ h w = do -- XXX too slow.. inline putWord8? putByte h (fromIntegral (w `shiftR` 8)) putByte h (fromIntegral (w .&. 0xff)) get h = do w1 <- getWord8 h w2 <- getWord8 h return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) instance Binary Word32 where put_ h w = do putByte h (fromIntegral (w `shiftR` 24)) putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) putByte h (fromIntegral (w .&. 0xff)) get h = do w1 <- getWord8 h w2 <- getWord8 h w3 <- getWord8 h w4 <- getWord8 h return $! ((fromIntegral w1 `shiftL` 24) .|. (fromIntegral w2 `shiftL` 16) .|. (fromIntegral w3 `shiftL` 8) .|. (fromIntegral w4)) instance Binary Word64 where put_ h w = do putByte h (fromIntegral (w `shiftR` 56)) putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff)) putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff)) putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff)) putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff)) putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) putByte h (fromIntegral (w .&. 0xff)) get h = do w1 <- getWord8 h w2 <- getWord8 h w3 <- getWord8 h w4 <- getWord8 h w5 <- getWord8 h w6 <- getWord8 h w7 <- getWord8 h w8 <- getWord8 h return $! ((fromIntegral w1 `shiftL` 56) .|. (fromIntegral w2 `shiftL` 48) .|. (fromIntegral w3 `shiftL` 40) .|. (fromIntegral w4 `shiftL` 32) .|. (fromIntegral w5 `shiftL` 24) .|. (fromIntegral w6 `shiftL` 16) .|. (fromIntegral w7 `shiftL` 8) .|. (fromIntegral w8)) -- ----------------------------------------------------------------------------- -- Primitve Int writes instance Binary Int8 where put_ h w = put_ h (fromIntegral w :: Word8) get h = do w <- get h; return $! (fromIntegral (w::Word8)) instance Binary Int16 where put_ h w = put_ h (fromIntegral w :: Word16) get h = do w <- get h; return $! (fromIntegral (w::Word16)) instance Binary Int32 where put_ h w = put_ h (fromIntegral w :: Word32) get h = do w <- get h; return $! (fromIntegral (w::Word32)) instance Binary Int64 where put_ h w = put_ h (fromIntegral w :: Word64) get h = do w <- get h; return $! (fromIntegral (w::Word64)) -- ----------------------------------------------------------------------------- -- Instances for standard types instance Binary () where put_ bh () = return () get _ = return () -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b) instance Binary Bool where put_ bh b = putByte bh (fromIntegral (fromEnum b)) get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) -- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b) instance Binary Char where put_ bh c = put_ bh (fromIntegral (ord c) :: Word8) get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word8))) -- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b) instance Binary Int where #if SIZEOF_HSINT == 4 put_ bh i = put_ bh (fromIntegral i :: Int32) get bh = do x <- get bh return $! (fromIntegral (x :: Int32)) #elif SIZEOF_HSINT == 8 put_ bh i = put_ bh (fromIntegral i :: Int64) get bh = do x <- get bh return $! (fromIntegral (x :: Int64)) #else #error "unsupported sizeof(HsInt)" #endif -- getF bh = getBitsF bh 32 instance Binary a => Binary [a] where put_ bh list = do put_ bh (length list) mapM_ (put_ bh) list get bh = do len <- get bh let getMany :: Int -> IO [a] getMany 0 = return [] getMany n = do x <- get bh xs <- getMany (n-1) return (x:xs) getMany len instance (Binary a, Binary b) => Binary (a,b) where put_ bh (a,b) = do put_ bh a; put_ bh b get bh = do a <- get bh b <- get bh return (a,b) instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c get bh = do a <- get bh b <- get bh c <- get bh return (a,b,c) instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d get bh = do a <- get bh b <- get bh c <- get bh d <- get bh return (a,b,c,d) instance Binary a => Binary (Maybe a) where put_ bh Nothing = putByte bh 0 put_ bh (Just a) = do putByte bh 1; put_ bh a get bh = do h <- getWord8 bh case h of 0 -> return Nothing _ -> do x <- get bh; return (Just x) instance (Binary a, Binary b) => Binary (Either a b) where put_ bh (Left a) = do putByte bh 0; put_ bh a put_ bh (Right b) = do putByte bh 1; put_ bh b get bh = do h <- getWord8 bh case h of 0 -> do a <- get bh ; return (Left a) _ -> do b <- get bh ; return (Right b) instance (Binary a, Binary i, Ix i) => Binary (Array i a) where put_ bh arr = do put_ bh (Data.Array.bounds arr) put_ bh (Data.Array.elems arr) get bh = do bounds <- get bh elems <- get bh return $ listArray bounds elems instance (Binary key, Ord key, Binary elem) => Binary (Map key elem) where -- put_ bh fm = put_ bh (Map.toList fm) -- get bh = do list <- get bh -- return (Map.fromList list) put_ bh fm = do let list = Map.toList fm put_ bh (length list) mapM_ (\(key, val) -> do put_ bh key lazyPut bh val) list get bh = do len <- get bh let getMany :: Int -> IO [(key,elem)] getMany 0 = return [] getMany n = do key <- get bh val <- lazyGet bh xs <- getMany (n-1) return ((key,val):xs) -- printElapsedTime "before get Map" list <- getMany len -- printElapsedTime "after get Map" return (Map.fromList list) #ifdef __GLASGOW_HASKELL__ #if __GLASGOW_HASKELL__<610 instance Binary Integer where put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) put_ bh (J# s# a#) = do p <- putByte bh 1; put_ bh (I# s#) let sz# = sizeofByteArray# a# -- in *bytes* put_ bh (I# sz#) -- in *bytes* putByteArray bh a# sz# get bh = do b <- getByte bh case b of 0 -> do (I# i#) <- get bh return (S# i#) _ -> do (I# s#) <- get bh sz <- get bh (BA a#) <- getByteArray bh sz return (J# s# a#) putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () putByteArray bh a s# = loop 0# where loop n# | n# ==# s# = return () | otherwise = do putByte bh (indexByteArray a n#) loop (n# +# 1#) getByteArray :: BinHandle -> Int -> IO ByteArray getByteArray bh (I# sz) = do (MBA arr) <- newByteArray sz let loop n | n ==# sz = return () | otherwise = do w <- getByte bh writeByteArray arr n w loop (n +# 1#) loop 0# freezeByteArray arr data ByteArray = BA ByteArray# data MBA = MBA (MutableByteArray# RealWorld) newByteArray :: Int# -> IO MBA newByteArray sz = IO $ \s -> case newByteArray# sz s of { (# s, arr #) -> (# s, MBA arr #) } freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray freezeByteArray arr = IO $ \s -> case unsafeFreezeByteArray# arr s of { (# s, arr #) -> (# s, BA arr #) } writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () #if __GLASGOW_HASKELL__ < 503 writeByteArray arr i w8 = IO $ \s -> case word8ToWord w8 of { W# w# -> case writeCharArray# arr i (chr# (word2Int# w#)) s of { s -> (# s , () #) }} #else writeByteArray arr i (W8# w) = IO $ \s -> case writeWord8Array# arr i w s of { s -> (# s, () #) } #endif #if __GLASGOW_HASKELL__ < 503 indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#))) #else indexByteArray a# n# = W8# (indexWord8Array# a# n#) #endif instance (Integral a, Binary a) => Binary (Ratio a) where put_ bh (a :% b) = do put_ bh a; put_ bh b get bh = do a <- get bh; b <- get bh; return (a :% b) #else instance Binary Integer where put_ h n = do put h ((fromIntegral $ signum n) :: Int8) when (n /= 0) $ do let n' = abs n nBytes = byteSize n' put h (fromIntegral nBytes :: Word64) mapM_ (putByte h) [ fromIntegral ((n' `shiftR` (b * 8)) .&. 0xff) | b <- [ nBytes-1, nBytes-2 .. 0 ] ] where byteSize n = let f b = if (1 `shiftL` (b * 8)) > n then b else f (b + 1) in f 0 get h = do sign :: Int8 <- get h if sign == 0 then return 0 else do nBytes :: Word64 <- get h n <- accumBytes nBytes 0 return $ fromIntegral sign * n where accumBytes nBytes acc | nBytes == 0 = return acc | otherwise = do b <- getByte h accumBytes (nBytes - 1) ((acc `shiftL` 8) .|. fromIntegral b) #endif #endif instance Binary (Bin a) where put_ bh (BinPtr i) = put_ bh i get bh = do i <- get bh; return (BinPtr i) -- ----------------------------------------------------------------------------- -- Lazy reading/writing lazyPut :: Binary a => BinHandle -> a -> IO () lazyPut bh a = do -- output the obj with a ptr to skip over it: pre_a <- tellBin bh put_ bh pre_a -- save a slot for the ptr put_ bh a -- dump the object q <- tellBin bh -- q = ptr to after object putAt bh pre_a q -- fill in slot before a with ptr to q seekBin bh q -- finally carry on writing at q lazyGet :: Binary a => BinHandle -> IO a lazyGet bh = do p <- get bh -- a BinPtr p_a <- tellBin bh a <- unsafeInterleaveIO (getAt bh p_a) seekBin bh p -- skip over the object for now return a -- -------------------------------------------------------------- -- Main wrappers: getBinFileWithDict, putBinFileWithDict -- -- This layer is built on top of the stuff above, -- and should not know anything about BinHandles -- -------------------------------------------------------------- initBinMemSize = (1024*1024) :: Int binaryInterfaceMagic = 0x1face :: Word32 getBinFileWithDict :: Binary a => FilePath -> IO a getBinFileWithDict file_path = do bh <- Binary.readBinMem file_path -- Read the magic number to check that this really is a GHC .hi file -- (This magic number does not change when we change -- GHC interface file format) magic <- get bh when (magic /= binaryInterfaceMagic) $ error "magic number mismatch: old/corrupt interface file?" -- Read the dictionary -- The next word in the file is a pointer to where the dictionary is -- (probably at the end of the file) dict_p <- Binary.get bh -- Get the dictionary ptr data_p <- tellBin bh -- Remember where we are now seekBin bh dict_p dict <- getDictionary bh seekBin bh data_p -- Back to where we were before -- Initialise the user-data field of bh let bh' = setUserData bh (initReadState dict) -- At last, get the thing get bh' putBinFileWithDict :: Binary a => FilePath -> a -> IO () putBinFileWithDict file_path the_thing = do -- hnd <- openBinaryFile file_path WriteMode -- bh <- openBinIO hnd bh <- openBinMem initBinMemSize put_ bh binaryInterfaceMagic -- Remember where the dictionary pointer will go dict_p_p <- tellBin bh put_ bh dict_p_p -- Placeholder for ptr to dictionary -- Make some intial state usr_state <- newWriteState -- Put the main thing, put_ (setUserData bh usr_state) the_thing -- Get the final-state j <- readIORef (ud_next usr_state) #if __GLASGOW_HASKELL__>=602 fm <- HashTable.toList (ud_map usr_state) #else fm <- liftM Map.toList $ readIORef (ud_map usr_state) #endif dict_p <- tellBin bh -- This is where the dictionary will start -- Write the dictionary pointer at the fornt of the file putAt bh dict_p_p dict_p -- Fill in the placeholder seekBin bh dict_p -- Seek back to the end of the file -- Write the dictionary itself putDictionary bh j (constructDictionary j fm) -- And send the result to the file writeBinMem bh file_path -- hClose hnd -- ----------------------------------------------------------------------------- -- UserData -- ----------------------------------------------------------------------------- data UserData = UserData { -- This field is used only when reading ud_dict :: Dictionary, -- The next two fields are only used when writing ud_next :: IORef Int, -- The next index to use #if __GLASGOW_HASKELL__>=602 # if __GLASGOW_HASKELL__>=707 ud_map :: BasicHashTable String Int -- The index of each string # else ud_map :: HashTable String Int -- The index of each string # endif #else ud_map :: IORef (Map String Int) #endif } noUserData = error "Binary.UserData: no user data" initReadState :: Dictionary -> UserData initReadState dict = UserData{ ud_dict = dict, ud_next = undef "next", ud_map = undef "map" } newWriteState :: IO UserData newWriteState = do j_r <- newIORef 0 #if __GLASGOW_HASKELL__>=602 # if __GLASGOW_HASKELL__>=707 out_r <- HashTable.new # else out_r <- HashTable.new (==) HashTable.hashString # endif #else out_r <- newIORef Map.empty #endif return (UserData { ud_dict = error "dict", ud_next = j_r, ud_map = out_r }) undef s = error ("Binary.UserData: no " ++ s) --------------------------------------------------------- -- The Dictionary --------------------------------------------------------- type Dictionary = Array Int String -- The dictionary -- Should be 0-indexed putDictionary :: BinHandle -> Int -> Dictionary -> IO () putDictionary bh sz dict = do put_ bh sz mapM_ (put_ bh) (elems dict) getDictionary :: BinHandle -> IO Dictionary getDictionary bh = do sz <- get bh elems <- sequence (take sz (repeat (get bh))) return (listArray (0,sz-1) elems) constructDictionary :: Int -> [(String,Int)] -> Dictionary constructDictionary j fm = array (0,j-1) (map (\(x,y) -> (y,x)) fm) --------------------------------------------------------- -- Reading and writing memoised Strings --------------------------------------------------------- putSharedString :: BinHandle -> String -> IO () putSharedString bh str = case getUserData bh of UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do #if __GLASGOW_HASKELL__>=602 entry <- HashTable.lookup out_r str #else fm <- readIORef out_r let entry = Map.lookup str fm #endif case entry of Just j -> put_ bh j Nothing -> do j <- readIORef j_r put_ bh j writeIORef j_r (j+1) #if __GLASGOW_HASKELL__>=602 HashTable.insert out_r str j #else modifyIORef out_r (\fm -> Map.insert str j fm) #endif getSharedString :: BinHandle -> IO String getSharedString bh = do j <- get bh return $! (ud_dict (getUserData bh) ! j) {- --------------------------------------------------------- -- Reading and writing FastStrings --------------------------------------------------------- putFS bh (FastString id l ba) = do put_ bh (I# l) putByteArray bh ba l putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s) -- Note: the length of the FastString is *not* the same as -- the size of the ByteArray: the latter is rounded up to a -- multiple of the word size. {- -- possible faster version, not quite there yet: getFS bh@BinMem{} = do (I# l) <- get bh arr <- readIORef (arr_r bh) off <- readFastMutInt (off_r bh) return $! (mkFastSubStringBA# arr off l) -} getFS bh = do (I# l) <- get bh (BA ba) <- getByteArray bh (I# l) return $! (mkFastSubStringBA# ba 0# l) instance Binary FastString where put_ bh f@(FastString id l ba) = case getUserData bh of { UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do out <- readIORef out_r let uniq = getUnique f case lookupUFM out uniq of Just (j,f) -> put_ bh j Nothing -> do j <- readIORef j_r put_ bh j writeIORef j_r (j+1) writeIORef out_r (addToUFM out uniq (j,f)) } put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s)) get bh = do j <- get bh return $! (ud_dict (getUserData bh) ! j) -} printElapsedTime :: String -> IO () printElapsedTime msg = do time <- getCPUTime hPutStr stderr $ "elapsed time: " ++ Numeric.showFFloat (Just 2) ((fromIntegral time) / 10^12) " (" ++ msg ++ ")\n" gtk2hs-buildtools-0.13.10.0/c2hs/base/general/DLists.hs0000644000000000000000000000373007346545000020512 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 DLists (DList, openDL, zeroDL, unitDL, snocDL, joinDL, closeDL) where -- a difference list is a function that given a list returns the original -- contents of the difference list prepended at the given list (EXPORTED) -- type DList a = [a] -> [a] -- open a list for use as a difference list (EXPORTED) -- openDL :: [a] -> DList a openDL = (++) -- create a difference list containing no elements (EXPORTED) -- zeroDL :: DList a zeroDL = id -- create difference list with given single element (EXPORTED) -- unitDL :: a -> DList a unitDL = (:) -- append a single element at a difference list (EXPORTED) -- snocDL :: DList a -> a -> DList a snocDL dl x = \l -> dl (x:l) -- appending difference lists (EXPORTED) -- joinDL :: DList a -> DList a -> DList a joinDL = (.) -- closing a difference list into a normal list (EXPORTED) -- closeDL :: DList a -> [a] closeDL = ($[]) gtk2hs-buildtools-0.13.10.0/c2hs/base/general/FNameOps.hs0000644000000000000000000000413307346545000020756 0ustar0000000000000000-- Compiler Toolkit: operations on file names -- -- Author : Manuel M. T. Chakravarty -- Created: 15 November 98 -- -- Version $Revision: 1.1.1.1 $ from $Date: 2004/11/13 16:42:47 $ -- -- Copyright (c) [1998..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 --------------------------------------------------------------- -- -- Typical operations needed when manipulating file names. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- --- TODO ---------------------------------------------------------------------- -- module FNameOps (basename, dirname, stripDirname, suffix, stripSuffix, addPath, splitSearchPath) where import System.FilePath -- strip directory and suffix (EXPORTED) -- -- eg, ../lib/libc.so -> libc -- basename :: FilePath -> FilePath basename = takeBaseName -- strip basename and suffix (EXPORTED) -- -- eg, ../lib/libc.so -> ../lib/ -- dirname :: FilePath -> FilePath dirname = takeDirectory -- remove dirname (EXPORTED) -- -- eg, ../lib/libc.so -> libc.so -- stripDirname :: FilePath -> FilePath stripDirname = takeFileName -- get suffix (EXPORTED) -- -- eg, ../lib/libc.so -> .so -- suffix :: FilePath -> String suffix = takeExtension -- remove suffix (EXPORTED) -- -- eg, ../lib/libc.so -> ../lib/libc -- stripSuffix :: FilePath -> FilePath stripSuffix = dropExtension -- prepend a path to a file name (EXPORTED) -- -- eg, ../lib/, libc.so -> ../lib/libc.so -- ../lib , libc.so -> ../lib/libc.so -- addPath :: FilePath -> FilePath -> FilePath addPath = () gtk2hs-buildtools-0.13.10.0/c2hs/base/general/FastMutInt.hs0000644000000000000000000000162307346545000021345 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples #-} -- -- (c) The University of Glasgow 2002 -- -- Unboxed mutable Ints module FastMutInt( FastMutInt, newFastMutInt, readFastMutInt, writeFastMutInt ) where #define SIZEOF_HSINT 4 import GHC.Exts # if __GLASGOW_HASKELL__>=612 import GHC.IO (IO(IO)) #else import GHC.IOBase (IO(IO)) #endif data FastMutInt = FastMutInt (MutableByteArray# RealWorld) newFastMutInt :: IO FastMutInt newFastMutInt = IO $ \s -> case newByteArray# size s of { (# s, arr #) -> (# s, FastMutInt arr #) } where !(I# size) = SIZEOF_HSINT readFastMutInt :: FastMutInt -> IO Int readFastMutInt (FastMutInt arr) = IO $ \s -> case readIntArray# arr 0# s of { (# s, i #) -> (# s, I# i #) } writeFastMutInt :: FastMutInt -> Int -> IO () writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> case writeIntArray# arr 0# i s of { s -> (# s, () #) } gtk2hs-buildtools-0.13.10.0/c2hs/base/general/FileOps.hs0000644000000000000000000001026507346545000020652 0ustar0000000000000000-- Compiler Toolkit: operations on file -- -- Author : Manuel M T Chakravarty -- Created: 6 November 1999 -- -- Version $Revision: 1.1.1.1 $ from $Date: 2004/11/13 16:42:49 $ -- -- 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 --------------------------------------------------------------- -- -- Typical operations needed when manipulating file names. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- --- TODO ---------------------------------------------------------------------- -- module FileOps (fileFindIn, mktemp) where import Prelude hiding (catch) -- standard libs import Data.Char (chr, ord) import System.Directory (doesFileExist) import System.IO (Handle, IOMode(..), openFile) import Control.Monad (liftM) import Control.Exception (catch, SomeException) import System.Random (newStdGen, randomRs) import FNameOps (dirname, stripDirname, addPath) -- search for the given file in the given list of directories (EXPORTED) -- -- * if the file does not exist, an exception is raised -- -- * if the given file name is absolute, it is first tried whether this file -- exists, afterwards the path component is stripped and the given -- directories are searched; otherwise, if the file name is not absolute, -- the path component is retained while searching the directories -- fileFindIn :: FilePath -> [FilePath] -> IO FilePath "" `fileFindIn` paths = fail "Empty file name" file `fileFindIn` paths = do let (paths', file') = if head file == '/' then (dirname file : paths, stripDirname file) else (paths, file) files = map (`addPath` file') paths' existsFlags <- mapM doesFileExist files let existingFiles = [file | (file, flag) <- zip files existsFlags, flag] if null existingFiles then fail (file ++ ": File does not exist") else return $ head existingFiles -- |Create a temporary file with a unique name. -- -- * A unique sequence of at least six characters and digits is added -- inbetween the two given components (the latter of which must include the -- file suffix if any is needed) -- -- * Default permissions are used, which might not be optimal, but -- unfortunately the Haskell standard libs don't support proper permission -- management. -- -- * We make 100 attempts on getting a unique filename before giving up. -- mktemp :: FilePath -> FilePath -> IO (Handle, FilePath) mktemp pre post = do rs <- liftM (randomRs (0, 61)) newStdGen -- range for lower and upper case letters plus digits createLoop 100 rs where createLoop 0 _ = fail "mktemp: failed 100 times" createLoop attempts rs = let (rs', fname) = nextName rs in do h <- openFile fname ReadWriteMode return (h, fname) `catch` handler attempts rs' -- handler :: Int -> [Int] -> SomeException -> IO (Handle,FilePath) handler attempts rs' _ = createLoop (attempts - 1) rs' sixChars :: [Int] -> ([Int], String) sixChars is = let (sixInts, is') = splitAt 6 is -- toChar i | i < 10 = chr . (ord '0' +) $ i | i < 36 = chr . (ord 'A' +) . (subtract 10) $ i | otherwise = chr . (ord 'a' +) . (subtract 36) $ i in (is', map toChar sixInts) -- nextName :: [Int] -> ([Int], String) nextName is = let (is', rndChars) = sixChars is in (is', pre ++ rndChars ++ post) gtk2hs-buildtools-0.13.10.0/c2hs/base/general/Map.hs0000644000000000000000000000215707346545000020027 0ustar0000000000000000{-# OPTIONS -cpp #-} module Map ( Map, empty, singleton, lookup, findWithDefault, insert, union, unionWith, map, fromList, toList ) where import Prelude hiding (lookup, map) #if __GLASGOW_HASKELL__ >= 603 || !__GLASGOW_HASKELL__ import Data.Map #else import Data.FiniteMap type Map k a = FiniteMap k a empty :: Map k a empty = emptyFM singleton :: k -> a -> Map k a singleton = unitFM lookup :: Ord k => k -> Map k a -> Maybe a lookup = flip lookupFM findWithDefault :: Ord k => a -> k -> Map k a -> a findWithDefault a k m = lookupWithDefaultFM m a k insert :: Ord k => k -> a -> Map k a -> Map k a insert k a m = addToFM m k a insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a insertWith c k a m = addToFM_C (flip c) m k a union :: Ord k => Map k a -> Map k a -> Map k a union = flip plusFM unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a unionWith c l r = plusFM_C (flip c) r l map :: (a -> b) -> Map k a -> Map k b map f = mapFM (\_ -> f) fromList :: Ord k => [(k,a)] -> Map k a fromList = listToFM toList :: Map k a -> [(k, a)] toList = fmToList #endif gtk2hs-buildtools-0.13.10.0/c2hs/base/general/Position.hs0000644000000000000000000000753207346545000021120 0ustar0000000000000000-- Compiler Toolkit: some basic definitions used all over the place -- -- Author : Manuel M. T. Chakravarty -- Created: 16 February 95 -- -- Version $Revision: 1.44 $ from $Date: 2000/10/05 07:51:28 $ -- -- 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 some definitions used throughout all modules of a -- compiler. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * May not import anything apart from `Config'. -- --- TODO ---------------------------------------------------------------------- -- module Position ( -- -- source text positions -- Position(Position), Pos (posOf), nopos, isNopos, dontCarePos, isDontCarePos, builtinPos, isBuiltinPos, internalPos, isInternalPos, incPos, tabPos, retPos, ) where import Binary (Binary(..), putSharedString, getSharedString) -- uniform representation of source file positions; the order of the arguments -- is important as it leads to the desired ordering of source positions -- (EXPORTED) -- data Position = Position String -- file name {-# UNPACK #-} !Int -- row {-# UNPACK #-} !Int -- column deriving (Eq, Ord) instance Show Position where show (Position fname row col) = show (fname, row, col) -- no position (for unknown position information) (EXPORTED) -- nopos :: Position nopos = Position "" (-1) (-1) isNopos :: Position -> Bool isNopos (Position _ (-1) (-1)) = True isNopos _ = False -- don't care position (to be used for invalid position information) (EXPORTED) -- dontCarePos :: Position dontCarePos = Position "" (-2) (-2) isDontCarePos :: Position -> Bool isDontCarePos (Position _ (-2) (-2)) = True isDontCarePos _ = False -- position attached to objects that are hard-coded into the toolkit (EXPORTED) -- builtinPos :: Position builtinPos = Position "" (-3) (-3) isBuiltinPos :: Position -> Bool isBuiltinPos (Position _ (-3) (-3)) = True isBuiltinPos _ = False -- position used for internal errors (EXPORTED) -- internalPos :: Position internalPos = Position "" (-4) (-4) isInternalPos :: Position -> Bool isInternalPos (Position _ (-4) (-4)) = True isInternalPos _ = False -- instances of the class `Pos' are associated with some source text position -- don't care position (to be used for invalid position information) (EXPORTED) -- class Pos a where posOf :: a -> Position -- advance column -- incPos :: Position -> Int -> Position incPos (Position fname row col) n = Position fname row (col + n) -- advance column to next tab positions (tabs are at every 8th column) -- tabPos :: Position -> Position tabPos (Position fname row col) = Position fname row (col + 8 - (col - 1) `mod` 8) -- advance to next line -- retPos :: Position -> Position retPos (Position fname row col) = Position fname (row + 1) 1 instance Binary Position where put_ bh (Position fname row col) = do putSharedString bh fname -- put_ bh fname put_ bh row put_ bh col get bh = do fname <- getSharedString bh -- aa <- get bh row <- get bh col <- get bh return (Position fname row col) gtk2hs-buildtools-0.13.10.0/c2hs/base/general/Set.hs0000644000000000000000000000062707346545000020045 0ustar0000000000000000{-# OPTIONS -cpp #-} module Set ( Set, empty, member, insert, fromList, ) where #if __GLASGOW_HASKELL__ >= 603 || !__GLASGOW_HASKELL__ import Data.Set #else import Data.Set empty :: Set a empty = emptySet member :: Ord a => a -> Set a -> Bool member = elementOf insert :: Ord a => a -> Set a -> Set a insert a s = addToSet s a fromList :: Ord a => [a] -> Set a fromList = mkSet #endif gtk2hs-buildtools-0.13.10.0/c2hs/base/general/UNames.hs0000644000000000000000000001436707346545000020510 0ustar0000000000000000-- The HiPar Toolkit: generates unique names -- -- Author : Manuel M T Chakravarty -- Created: 3 April 98 -- -- Version $Revision: 1.2 $ from $Date: 2004/11/13 17:26:50 $ -- -- Copyright (C) [1998..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 --------------------------------------------------------------- -- -- Generates unqiue names according to a method of L. Augustsson, M. Rittri -- & D. Synek ``Functional pearl: On generating unique names'', Journal of -- Functional Programming 4(1), pp 117-123, 1994. -- -- WARNING: DON'T tinker with the implementation! It uses UNSAFE low-level -- operations! -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * This module provides an ordering relation on names (e.g., for using -- `Maps'), but no assumption maybe made on the order in which names -- are generated from the name space. Furthermore, names are instances of -- `Ix' to allow to use them as indicies. -- -- * A supply should be used *at most* once to *either* split it or extract a -- stream of names. A supply used repeatedly will always generate the same -- set of names (otherwise, the whole thing wouldn't be referential -- transparent). -- -- * If you ignored the warning below, looked at the implementation, and lost -- faith, consider that laziness means call-by-need *and* sharing, and that -- sharing is realized by updating evaluated thunks. -- -- * ATTENTION: No clever CSE or unnecessary argument elimination may be -- applied to the function `names'! -- --- TODO -- module UNames (NameSupply, Name, rootSupply, splitSupply, names, saveRootNameSupply, restoreRootNameSupply, unsafeResetRootNameSupply) where import Control.Monad (when) import Data.Ix import System.IO.Unsafe (unsafePerformIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Binary (Binary(..)) -- Name supply definition (EXPORTED ABSTRACTLY) -- newtype NameSupply = NameSupply (IORef Int) -- Name (EXPORTED ABSTRACTLY) -- newtype Name = Name Int -- deriving (Show, Eq, Ord, Ix) -- FIXME: nhc98, v1.08 can't derive Ix deriving (Eq, Ord) instance Ix Name where range (Name from, Name to) = map Name (range (from, to)) index (Name from, Name to) (Name idx) = index (from, to) idx inRange (Name from, Name to) (Name idx) = inRange (from, to) idx -- we want to show the number only, to be useful for generating unqiue -- printable names -- instance Show Name where show (Name i) = show i -- *** DON'T TOUCH THE FOLLOWING *** -- and if you believe in the lambda calculus better also don't look at it -- ! here lives the daemon of unordered destructive updates ! -- The initial supply (EXPORTED) -- rootSupply :: NameSupply {-# NOINLINE rootSupply #-} rootSupply = NameSupply (unsafeNewIntRef 1) -- Split a name supply into a stream of supplies (EXPORTED) -- splitSupply :: NameSupply -> [NameSupply] splitSupply s = repeat s -- Given a name supply, yield a stream of names (EXPORTED) -- names :: NameSupply -> [Name] -- -- The recursion of `theNames' where `s' is passed as an argument is crucial, -- as it forces the creation of a new closure for `unsafeReadAndIncIntRef s' -- in each recursion step. Sharing a single closure or building a cyclic -- graph for a nullary `theNames' would always result in the same name! If -- the compiler ever gets clever enough to optimize this, we have to prevent -- it from doing so. -- names (NameSupply s) = theNames s where theNames s = Name (unsafeReadAndIncIntRef s) : theNames s -- Actions for saving and restoring the state of the whole program. (EXPORTED) -- The rules for these functions are as follows: -- you must not use the root name supply after saving it -- you must not use the root namue supply before restoring it -- Otherwise bad things will happen, your unique Ids will no longer be unique saveRootNameSupply :: IO Name saveRootNameSupply = case rootSupply of NameSupply ref -> do val <- readIORef ref writeIORef ref 0 return (Name val) restoreRootNameSupply :: Name -> IO () restoreRootNameSupply (Name val) = case rootSupply of NameSupply ref -> do prev <- readIORef ref when (prev > 1) (error "UName: root name supply used before restoring") writeIORef ref val -- Resets the root name supply -- you must not do this unless you are done with all the names unsafeResetRootNameSupply :: IO () unsafeResetRootNameSupply = case rootSupply of NameSupply ref -> writeIORef ref 1 {-! for Name derive : GhcBinary !-} {-* Generated by DrIFT : Look, but Don't Touch. *-} instance Binary Name where put_ bh (Name aa) = do put_ bh aa get bh = do aa <- get bh return (Name aa) -- UNSAFE mutable variables -- ------------------------ -- WARNING: The following does not exist, or at least, it belongs to another -- world. And if you believe into the lambda calculus, you don't -- want to know about this other world. -- -- *** DON'T TOUCH NOR USE THIS STUFF *** -- (unless you really know what you are doing!) -- UNSAFELY create a mutable integer (EXPORTED) -- unsafeNewIntRef :: Int -> IORef Int unsafeNewIntRef i = unsafePerformIO (newIORef i) -- UNSAFELY increment a mutable integer and yield its value before the -- increment (EXPORTED) -- unsafeReadAndIncIntRef :: IORef Int -> Int unsafeReadAndIncIntRef mv = unsafePerformIO $ do v <- readIORef mv when (v<1) $ error "UName: root name supply used after saving" writeIORef mv (v + 1) return v gtk2hs-buildtools-0.13.10.0/c2hs/base/state/0000755000000000000000000000000007346545000016454 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/c2hs/base/state/CIO.hs0000644000000000000000000001240407346545000017423 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -cpp #-} -- Compiler Toolkit: Compiler I/O -- -- Author : Manuel M T Chakravarty -- Created: 2 November 95 -- -- Version $Revision: 1.1.1.1 $ from $Date: 2004/11/13 16:42:47 $ -- -- Copyright (c) [1995...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 --------------------------------------------------------------- -- -- 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 CIO (-- (verbatim) re-exports -- Handle, HandlePosn, IOMode(..), BufferMode(..), SeekMode(..), stdin, stdout, stderr, isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError, isFullError, isEOFError, isIllegalOperation, isPermissionError, isUserError, ioeGetErrorString, ioeGetHandle, ioeGetFileName, -- -- file handling -- openFileCIO, hCloseCIO, -- -- text I/O -- putCharCIO, putStrCIO, hPutStrCIO, hPutStrLnCIO, writeFileCIO, readFileCIO, printCIO, getCharCIO, hFlushCIO, hPutCharCIO, hGetContentsCIO, hSetBufferingCIO, hGetBufferingCIO, newlineCIO, -- -- `Directory' -- doesFileExistCIO, removeFileCIO, -- -- `System' -- ExitCode(..), exitWithCIO, getArgsCIO, getProgNameCIO, -- -- CTK general stuff -- fileFindInCIO, mktempCIO) where import System.IO import System.IO.Error import System.Cmd import System.Directory import System.Exit import System.Environment #if __GLASGOW_HASKELL__ >= 612 import System.IO (hSetEncoding, latin1) #endif import FileOps (fileFindIn, mktemp) import StateBase (PreCST, liftIO) -- file handling -- ------------- openFileCIO :: FilePath -> IOMode -> PreCST e s Handle openFileCIO p m = liftIO $ do hnd <- openFile p m #if __GLASGOW_HASKELL__ >= 612 hSetEncoding hnd latin1 #endif return hnd hCloseCIO :: Handle -> PreCST e s () hCloseCIO h = liftIO (hClose h) -- text I/O -- -------- putCharCIO :: Char -> PreCST e s () putCharCIO c = liftIO (putChar c) putStrCIO :: String -> PreCST e s () putStrCIO s = liftIO (putStr s) hPutStrCIO :: Handle -> String -> PreCST e s () hPutStrCIO h s = liftIO (hPutStr h s) hPutStrLnCIO :: Handle -> String -> PreCST e s () hPutStrLnCIO h s = liftIO (hPutStrLn h s) writeFileCIO :: FilePath -> String -> PreCST e s () writeFileCIO fname contents = do hnd <- openFileCIO fname WriteMode hPutStrCIO hnd contents hCloseCIO hnd readFileCIO :: FilePath -> PreCST e s String readFileCIO fname = do hnd <- openFileCIO fname ReadMode liftIO (hGetContents hnd) hGetContentsCIO :: Handle -> PreCST e s String hGetContentsCIO hnd = liftIO (hGetContents hnd) printCIO :: Show a => a -> PreCST e s () printCIO a = liftIO (print a) getCharCIO :: PreCST e s Char getCharCIO = liftIO getChar hFlushCIO :: Handle -> PreCST e s () hFlushCIO h = liftIO (hFlush h) hPutCharCIO :: Handle -> Char -> PreCST e s () hPutCharCIO h ch = liftIO (hPutChar h ch) hSetBufferingCIO :: Handle -> BufferMode -> PreCST e s () hSetBufferingCIO h m = liftIO (hSetBuffering h m) hGetBufferingCIO :: Handle -> PreCST e s BufferMode hGetBufferingCIO h = liftIO (hGetBuffering h) -- derived functions -- newlineCIO :: PreCST e s () newlineCIO = putCharCIO '\n' -- `Directory' -- ----------- doesFileExistCIO :: FilePath -> PreCST e s Bool doesFileExistCIO = liftIO . doesFileExist removeFileCIO :: FilePath -> PreCST e s () removeFileCIO = liftIO . removeFile -- `System' -- -------- exitWithCIO :: ExitCode -> PreCST e s a exitWithCIO = liftIO . exitWith getArgsCIO :: PreCST e s [String] getArgsCIO = liftIO getArgs getProgNameCIO :: PreCST e s String getProgNameCIO = liftIO getProgName -- general IO routines defined in CTK -- ---------------------------------- fileFindInCIO :: FilePath -> [FilePath] -> PreCST e s FilePath fileFindInCIO file paths = liftIO $ file `fileFindIn` paths mktempCIO :: FilePath -> FilePath -> PreCST e s (Handle, FilePath) mktempCIO pre post = liftIO $ mktemp pre post gtk2hs-buildtools-0.13.10.0/c2hs/base/state/State.hs0000644000000000000000000002750707346545000020103 0ustar0000000000000000-- Compiler Toolkit: compiler state management -- -- Author : Manuel M. T. Chakravarty -- Created: 2 November 95 -- -- Version $Revision: 1.1.1.1 $ from $Date: 2004/11/13 16:42:45 $ -- -- 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 State (-- the PreCST monad -- PreCST, -- reexport ABSTRACT nop, yield, (+>=), (+>), fixCST, -- reexport throwExc, fatal, catchExc, fatalsHandledBy, -- reexport lifted readCST, writeCST, transCST, run, runCST, StateTrans.MVar, -- reexport newMV, readMV, assignMV, -- reexport lifted -- -- reexport compiler I/O -- module CIO, liftIO, -- -- identification -- getId, -- -- error management -- raise, raiseWarning, raiseError, raiseFatal, showErrors, errorsPresent, -- -- extra state management -- readExtra, updExtra, -- -- name supplies -- getNameSupply) where import Data.Ix import Control.Monad (when) import Data.List (sort) import BaseVersion (version, copyright, disclaimer) import Config (errorLimit) import Position (Position) import UNames (NameSupply, rootSupply, splitSupply) import StateTrans (STB, readBase, transBase, runSTB) import qualified StateTrans (interleave, throwExc, fatal, catchExc, fatalsHandledBy, MVar, newMV, readMV, assignMV) import StateBase (PreCST(..), ErrorState(..), BaseState(..), nop, yield, (+>=), (+>), fixCST, unpackCST, readCST, writeCST, transCST, liftIO) import CIO import Errors (ErrorLvl(..), Error, makeError, errorLvl, showError) -- state used in the whole compiler -- -------------------------------- -- initialization -- -- * it gets the version information and the initial extra state as arguments -- initialBaseState :: (String, String, String) -> e -> BaseState e initialBaseState vcd es = BaseState { idTKBS = (version, copyright, disclaimer), idBS = vcd, errorsBS = initialErrorState, suppliesBS = splitSupply rootSupply, extraBS = es } -- executing state transformers -- ---------------------------- -- initiate a complete run of the ToolKit represented by a PreCST with a void -- generic component (type `()') (EXPORTED) -- -- * fatals errors are explicitly caught and reported (instead of letting them -- through to the runtime system) -- run :: (String, String, String) -> e -> PreCST e () a -> IO a run vcd es cst = runSTB m (initialBaseState vcd es) () where m = unpackCST ( cst `fatalsHandledBy` \err -> putStrCIO ("Uncaught fatal error: " ++ show err) >> exitWithCIO (ExitFailure 1) ) -- run a PreCST in the context of another PreCST (EXPORTED) -- -- 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 (EXPORTED) -- throwExc :: String -> String -> PreCST e s a throwExc s1 s2 = CST $ StateTrans.throwExc s1 s2 -- raise a fatal user-defined error (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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 -- mutable variables -- ----------------- -- lifted mutable variable functions (EXPORTED) -- newMV :: a -> PreCST e s (StateTrans.MVar a) newMV = CST . StateTrans.newMV readMV :: StateTrans.MVar a -> PreCST e s a readMV = CST . StateTrans.readMV assignMV :: StateTrans.MVar a -> a -> PreCST e s () assignMV m a = CST $ StateTrans.assignMV m a -- read identification -- ------------------- -- read identification information (EXPORT) -- getId :: PreCST e s (String, String, String) getId = CST $ readBase (idBS) -- manipulating the error state -- ---------------------------- -- the lowest level of errors is `WarningErr', but it is meaningless as long as -- the the list of errors is empty -- initialErrorState :: ErrorState initialErrorState = ErrorState WarningErr 0 [] -- raise an error (EXPORTED) -- -- * a fatal error is reported immediately; see `raiseFatal' -- raise :: Error -> PreCST e s () raise err = case errorLvl err of WarningErr -> raise0 err ErrorErr -> raise0 err FatalErr -> raiseFatal0 "Generic fatal error." err -- raise a warning (see `raiseErr') (EXPORTED) -- raiseWarning :: Position -> [String] -> PreCST e s () raiseWarning pos msg = raise0 (makeError WarningErr pos msg) -- raise an error (see `raiseErr') (EXPORTED) -- raiseError :: Position -> [String] -> PreCST e s () raiseError pos msg = raise0 (makeError ErrorErr pos msg) -- raise a fatal compilation error (EXPORTED) -- -- * 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 FatalErr 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 doRaise :: BaseState e -> (BaseState e, Int) doRaise bs = let lvl = errorLvl err ErrorState wlvl no errs = errorsBS bs wlvl' = max wlvl lvl no' = no + if lvl > WarningErr then 1 else 0 errs' = err : errs in (bs {errorsBS = (ErrorState wlvl' no' errs')}, no') -- yield a string containing the collected error messages (EXPORTED) -- -- * the error state is reset in this process -- showErrors :: PreCST e s String showErrors = CST $ do ErrorState wlvl no errs <- transBase extractErrs return $ foldr (.) id (map showString (errsToStrs errs)) "" where extractErrs :: BaseState e -> (BaseState e, ErrorState) extractErrs bs = (bs {errorsBS = initialErrorState}, errorsBS bs) errsToStrs :: [Error] -> [String] errsToStrs errs = (map showError . sort) errs -- inquire if there was already an error of at least level `ErrorErr' raised -- (EXPORTED) -- errorsPresent :: PreCST e s Bool errorsPresent = CST $ do ErrorState wlvl no _ <- readBase errorsBS return $ wlvl >= ErrorErr -- manipulating the extra state -- ---------------------------- -- apply a reader function to the extra state and yield the reader's result -- (EXPORTED) -- readExtra :: (e -> a) -> PreCST e s a readExtra rf = CST $ readBase (\bs -> (rf . extraBS) bs ) -- apply an update function to the extra state (EXPORTED) -- updExtra :: (e -> e) -> PreCST e s () updExtra uf = CST $ transBase (\bs -> let es = extraBS bs in (bs {extraBS = uf es}, ()) ) -- name supplies -- ------------- -- Get a name supply out of the base state (EXPORTED) -- getNameSupply :: PreCST e s NameSupply getNameSupply = CST $ transBase (\bs -> let supply : supplies = suppliesBS bs in (bs {suppliesBS = supplies}, supply) ) gtk2hs-buildtools-0.13.10.0/c2hs/base/state/StateBase.hs0000644000000000000000000001267107346545000020672 0ustar0000000000000000-- Compiler Toolkit: compiler state management basics -- -- Author : Manuel M. T. Chakravarty -- Created: 7 November 97 -- -- Version $Revision: 1.1.1.1 $ -- -- 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: -- -- + idBS (triple of strings) -- version, copyright, and disclaimer -- + 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 StateBase (PreCST(..), ErrorState(..), BaseState(..), nop, yield, (+>=), (+>), fixCST, unpackCST, readCST, writeCST, transCST, liftIO) where import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap) import Control.Monad.Fail (MonadFail (..)) import Position (Position) import UNames (NameSupply) import StateTrans (STB, fixSTB, readGeneric, writeGeneric, transGeneric, readBase, transBase) import qualified StateTrans (liftIO) import Errors (ErrorLvl(..), Error) infixr 1 +>=, +> -- 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 ErrorLvl -- worst error level that was raised Int -- number of errors (excl warnings) [Error] -- already raised errors -- base state (EXPORTED) -- data BaseState e = BaseState { idTKBS :: (String, String, String), -- toolkit id idBS :: (String, String, String), -- compiler id errorsBS :: ErrorState, suppliesBS :: [NameSupply], extraBS :: e -- extra state } -- the compiler state transformer (EXPORTED) -- newtype PreCST e s a = CST (STB (BaseState e) s a) instance Functor (PreCST e s) where fmap = liftM instance Applicative (PreCST e s) where pure = return (<*>) = ap instance Monad (PreCST e s) where return = yield (>>=) = (+>=) (>>) = (+>) instance MonadFail (PreCST e s) where fail = error -- unwrapper coercion function (EXPORTED) -- 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)) -- bind dropping the result of the first state transfomer -- (+>) :: PreCST e s a -> PreCST e s b -> PreCST e s b k +> m = k +>= const m -- unit with no result -- nop :: PreCST e s () nop = yield () -- fixpoint combinator in the monad (EXPORTED) -- fixCST :: (a -> PreCST e s a) -> PreCST e s a fixCST m = CST $ fixSTB (unpackCST . m) -- generic state manipulation -- -------------------------- -- given a reader function for the state, wrap it into an CST monad (EXPORTED) -- readCST :: (s -> a) -> PreCST e s a readCST f = CST $ readGeneric f -- given a new state, inject it into an CST monad (EXPORTED) -- writeCST :: s -> PreCST e s () writeCST s' = CST $ writeGeneric s' -- given a transformer function for the state, wrap it into an CST monad -- (EXPORTED) -- 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) gtk2hs-buildtools-0.13.10.0/c2hs/base/state/StateTrans.hs0000644000000000000000000003267507346545000021115 0ustar0000000000000000-- The HiPar Toolkit: state transformer routines -- -- Author : Manuel M. T. Chakravarty -- Created: 3 March 95 -- -- Version $Revision: 1.1.1.1 $ from $Date: 2004/11/13 16:42:45 $ -- -- 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 StateTrans (-- the monad and the generic operations -- STB, fixSTB, -- -- monad specific operations -- readBase, writeBase, transBase, readGeneric, writeGeneric, transGeneric, liftIO, runSTB, interleave, -- -- exception handling and fatal errors -- throwExc, fatal, catchExc, fatalsHandledBy, -- -- mutable variables and arrays -- MVar, newMV, readMV, assignMV) where import Prelude hiding (catch) import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap) import Control.Exception (catch) import System.IO (fixIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Errors (interr) infixr 1 +>=, +> -- BEWARE! You enter monad country. Read any of Wadler's or -- Launchbury/Peyton-Jones' texts before entering. Otherwise, -- your mental health my be in danger. You have been warned! -- state transformer base and its monad operations -- ----------------------------------------------- -- the generic form of a state transformer using the external state represented -- by `IO'; `STB' is a abbreviation for state transformer base -- -- the first state component `bs' is provided for the omnipresent compiler -- state and the, second, `gs' for the generic component -- -- the third component of the result distinguishes between erroneous and -- successful computations where -- -- `Left (tag, msg)' -- stands for an exception identified by `tag' with -- error message `msg', and -- `Right a' -- is a successfully delivered result -- newtype STB bs gs a = STB (bs -> gs -> IO (bs, gs, Either (String, String) a)) instance Functor (STB bs gs) where fmap = liftM instance Applicative (STB bs gs) where pure = return (<*>) = ap instance Monad (STB bs gs) where return = yield (>>=) = (+>=) (>>) = (+>) -- the monad's unit -- yield :: a -> STB bs gs a yield a = STB $ \bs gs -> return (bs, gs, Right a) -- the monad's bind -- -- * exceptions are propagated -- (+>=) :: STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b m +>= k = let STB m' = m in STB $ \bs gs -> m' bs gs >>= \(bs', gs', res) -> case res of Left exc -> return (bs', gs', Left exc) -- prop exc Right a -> let STB k' = k a in k' bs' gs' -- cont -- bind dropping the result of the first state transfomer -- (+>) :: STB bs gs a -> STB bs gs b -> STB bs gs b k +> m = k +>= const m -- fixpoint combinator in the monad -- fixSTB :: (a -> STB bs gs a) -> STB bs gs a -- -- builds on the fixpoint combinator embedded within the IO monad; the -- future overall result wrapped into a closure with the function extracting -- the user-level result component is used to build the cycle -- fixSTB m = STB $ \bs gs -> fixIO (\future -> let STB m' = m (extractResult future) in m' bs gs) where extractResult (_, _, Right r) = r extractResult (_, _, Left _ ) = interr "StateTrans: fixSTB: \ \Tried to access result \ \of unsuccessful \ \recursive computation!" -- 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 (EXPORTED) -- 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 (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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) -- list mutable variables and arrays stuff into `STB'; all (EXPORTED) -- ------------------------------------------------------------------ type MVar a = IORef a newMV :: a -> STB bs gs (MVar a) newMV x = liftIO (newIORef x) readMV :: MVar a -> STB bs gs a readMV mv = liftIO (readIORef mv) assignMV :: MVar a -> a -> STB bs gs () assignMV mv x = liftIO (writeIORef mv x) gtk2hs-buildtools-0.13.10.0/c2hs/base/syms/0000755000000000000000000000000007346545000016327 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/c2hs/base/syms/Attributes.hs0000644000000000000000000004040307346545000021012 0ustar0000000000000000-- Compiler Toolkit: general purpose attribute management -- -- Author : Manuel M. T. Chakravarty -- Created: 14 February 95 -- -- Version $Revision: 1.4 $ from $Date: 2005/06/22 16:01:03 $ -- -- 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 Attributes (-- attribute management -- Attrs, 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 Position (Position, Pos(posOf), nopos, isNopos, dontCarePos, isDontCarePos) import Errors (interr) import UNames (NameSupply, Name, rootSupply, splitSupply, names) import Map (Map) import qualified Map as Map (fromList, toList, insert, findWithDefault, empty) import Binary (Binary(..), putByte, getByte) -- attribute management data structures and operations -- --------------------------------------------------- -- abstract data structure used in the structure tree to represent the -- attribute identifier and the position (EXPORTED) -- data Attrs = OnlyPos Position -- only pos (for internal stuff only) | Attrs Position Name -- pos and unique name -- get the position associated with an attribute identifier (EXPORTED) -- instance Pos Attrs where posOf (OnlyPos pos ) = pos posOf (Attrs pos _) = pos -- equality of attributes is used to define the equality of objects (EXPORTED) -- instance Eq Attrs where (Attrs _ id1) == (Attrs _ id2) = id1 == id2 _ == _ = interr "Attributes: Attempt to compare `OnlyPos' attributes!" -- attribute ordering is also lifted to objects (EXPORTED) -- instance Ord Attrs where (Attrs _ id1) <= (Attrs _ id2) = id1 <= id2 _ <= _ = interr "Attributes: Attempt to compare `OnlyPos' attributes!" -- a class for convenient access to the attributes of an attributed object -- (EXPORTED) -- class Attributed a where attrsOf :: a -> Attrs -- equality induced by attribution (EXPORTED) -- eqOfAttrsOf :: Attributed a => a -> a -> Bool eqOfAttrsOf obj1 obj2 = (attrsOf obj1) == (attrsOf obj2) -- position induced by attribution (EXPORTED) -- posOfAttrsOf :: Attributed a => a -> Position posOfAttrsOf = posOf . attrsOf -- attribute identifier creation -- ----------------------------- -- Given only a source position, create a new attribute identifier (EXPORTED) -- newAttrsOnlyPos :: Position -> Attrs newAttrsOnlyPos pos = OnlyPos pos -- Given a source position and a unique name, create a new attribute -- identifier (EXPORTED) -- newAttrs :: Position -> Name -> Attrs newAttrs pos name = Attrs pos name -- attribute tables and operations on them -- --------------------------------------- -- the type class `Attr' determines which types may be used as attributes -- (EXPORTED) -- -- * 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 -- (EXPORTED ABSTRACT) -- -- * 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 (Map Name 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 -- create an attribute table, where all attributes are `undef' (EXPORTED) -- -- 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 Map.empty desc -- get the value of an attribute from the given attribute table (EXPORTED) -- getAttr :: Attr a => AttrTable a -> Attrs -> a getAttr at (OnlyPos pos ) = onlyPosErr "getAttr" at pos getAttr at (Attrs _ aid) = case at of (SoftTable fm _) -> Map.findWithDefault undef 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 (EXPORTED) -- setAttr :: Attr a => AttrTable a -> Attrs -> a -> AttrTable a setAttr at (OnlyPos pos ) av = onlyPosErr "setAttr" at pos setAttr at (Attrs pos aid) av = case at of (SoftTable fm desc) -> assert (isUndef (Map.findWithDefault undef aid fm)) $ SoftTable (Map.insert aid av fm) desc (FrozenTable arr _) -> interr frozenErr where frozenErr = "Attributes.setAttr: Tried to write frozen attribute in\n" ++ errLoc at pos -- update the value of an attribute from the given attribute table (EXPORTED) -- updAttr :: Attr a => AttrTable a -> Attrs -> a -> AttrTable a updAttr at (OnlyPos pos ) av = onlyPosErr "updAttr" at pos updAttr at (Attrs pos aid) av = case at of (SoftTable fm desc) -> SoftTable (Map.insert aid av fm) desc (FrozenTable arr _) -> interr $ "Attributes.updAttr: Tried to\ \ update frozen attribute in\n" ++ errLoc at pos -- copy the value of an attribute to another one (EXPORTED) -- -- * undefined attributes are not copied, to avoid filling the table -- copyAttr :: Attr a => AttrTable a -> Attrs -> Attrs -> 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 (EXPORTED) -- freezeAttrTable :: Attr a => AttrTable a -> AttrTable a freezeAttrTable (SoftTable fm desc) = let contents = Map.toList 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 arr 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 (EXPORTED) -- 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 (Map.fromList . assocs $ arr) desc -- standard attributes -- ------------------- -- standard attribute variants (EXPORTED) -- 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 (EXPORTED) -- -- * if the attribute can be "don't care", this should be checked before -- calling this function (using `isDontCareStdAttr') -- getStdAttr :: AttrTable (StdAttr a) -> Attrs -> 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 (EXPORTED) -- getStdAttrDft :: AttrTable (StdAttr a) -> Attrs -> 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" (EXPORTED) -- isDontCareStdAttr :: AttrTable (StdAttr a) -> Attrs -> Bool isDontCareStdAttr atab at = isDontCare (getAttr atab at) -- check if the attribue value is still undefined (EXPORTED) -- -- * we also regard "don't care" attributes as undefined -- isUndefStdAttr :: AttrTable (StdAttr a) -> Attrs -> Bool isUndefStdAttr atab at = isUndef (getAttr atab at) -- set an attribute value in a standard attribute table (EXPORTED) -- setStdAttr :: AttrTable (StdAttr a) -> Attrs -> a -> AttrTable (StdAttr a) setStdAttr atab at av = setAttr atab at (JustStdAttr av) -- update an attribute value in a standard attribute table (EXPORTED) -- updStdAttr :: AttrTable (StdAttr a) -> Attrs -> a -> AttrTable (StdAttr a) updStdAttr atab at av = updAttr atab at (JustStdAttr av) -- generic attribute table access (EXPORTED) -- ------------------------------ 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 {-! for Attrs derive : GhcBinary !-} {-! for AttrTable derive : GhcBinary !-} {-* Generated by DrIFT : Look, but Don't Touch. *-} instance Binary Attrs where put_ bh (OnlyPos aa) = do putByte bh 0 put_ bh aa put_ bh (Attrs ab ac) = do putByte bh 1 put_ bh ab put_ bh ac get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (OnlyPos aa) 1 -> do ab <- get bh ac <- get bh return (Attrs ab ac) instance (Binary a, Attr a) => Binary (AttrTable a) where put_ bh (SoftTable aa ab) = do putByte bh 0 put_ bh aa put_ bh ab put_ bh (FrozenTable ac ad) = do putByte bh 1 put_ bh ac put_ bh ad get bh = do h <- getByte bh case h of 0 -> do aa <- get bh ab <- get bh return (SoftTable aa ab) 1 -> do ac <- get bh ad <- get bh return (FrozenTable ac ad) gtk2hs-buildtools-0.13.10.0/c2hs/base/syms/Idents.hs0000644000000000000000000003730207346545000020116 0ustar0000000000000000-- Compiler Toolkit: identifiers -- -- Author : Manuel M. T. Chakravarty -- Created: 14 February 95 -- -- Version $Revision: 1.2 $ from $Date: 2004/11/13 17:26:50 $ -- -- 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 identifiers. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * We speed up the equality test between identifiers by assigning an -- identification number to each of them, and providing a special equality -- that compares the lexemes only if the identification numbers are equal. -- -- * The ordering relation on identifiers is also oriented at the -- identification number and, hence, does *not* follow the alphanumerical -- ordering of the lexemes of the identifiers. Instead, it provides a fast -- ordering when identifiers are used as keys in a `Map'. -- -- * The ambiguousness resolving number of an identifier is `-1' when no such -- number is present (so, such identifiers are distinguished from -- identifiers that share the front part of the lexeme while having an -- ambiguousness resolving number). -- -- The ambiguousness resolving number of primitive identifiers (`pid' in the -- grammar contained in the KCode definition) is `-2' (this gives primitive -- identifiers a distinct name space). -- -- * Attributes may be associated to identifiers, except with `OnlyPos' -- identifiers, which have a position as their only attribute (they do not -- carry an attribute identifier, which can be used to index attribute -- tables). -- -- * Internal identifiers that are forming a completely unique name space are -- supported. But note, they do not have a proper lexeme, i.e., they are not -- suited for code generation. -- --- TODO ---------------------------------------------------------------------- -- -- * Hashing is not 8bit clean. -- module Idents (Ident, noARNum, isLegalIdent, lexemeToIdent, internalIdent, onlyPosIdent, cloneIdent, identToLexeme, isIdentSimple, isIdentPrim, stripIdentARNum, getIdentARNum, newIdentARNum, getIdentAttrs, dumpIdent) where import Data.Char import Position (Position, Pos(posOf), nopos) import UNames (Name) import Errors (interr) import Attributes (Attrs, newAttrsOnlyPos, newAttrs, Attributed(attrsOf), posOfAttrsOf) import Binary (Binary(..), putSharedString, getSharedString) -- simple identifier representation (EXPORTED) -- -- identifiers without an ambiguousness resolving number get `noARNum' as -- number -- data Ident = Ident String -- lexeme !Int -- ambiguousness resolving number !Int -- id. number to speed up equality check !Attrs -- attributes of this ident. incl. position -- the definition of the equality allows identifiers to be equal that are -- defined at different source text positions, and aims at speeding up the -- equality test, by comparing the lexemes only if the two numbers are equal -- instance Eq Ident where (Ident s k id _) == (Ident s' k' id' _) = (k == k') && (id == id') && (s == s') -- this does *not* follow the alphanumerical ordering of the lexemes -- instance Ord Ident where (Ident s k id _) < (Ident s' k' id' _) = (k < k') || ((k == k') && (id < id')) || ((k == k') && (id == id') && (s < s')) id1 <= id2 = (id1 < id2) || (id1 == id2) -- for displaying identifiers -- instance Show Ident where showsPrec _ ide = showString ("`" ++ identToLexeme ide ++ "'") -- identifiers are attributed -- instance Attributed Ident where attrsOf (Ident _ _ _ at) = at -- identifiers have a canonical position -- instance Pos Ident where posOf = posOfAttrsOf -- to speed up the equality test we compute some hash-like value for each -- identifiers lexeme and store it in the identifiers representation -- hash function from the dragon book pp437; assumes 7 bit characters and needs -- the (nearly) full range of values guaranteed for `Int' by the Haskell -- language definition; can handle 8 bit characters provided we have 29 bit -- for the `Int's without sign -- quad :: String -> Int quad (c1:c2:c3:c4:s) = ((ord c4 * bits21 + ord c3 * bits14 + ord c2 * bits7 + ord c1) `mod` bits28) + (quad s `mod` bits28) quad (c1:c2:c3:[] ) = ord c3 * bits14 + ord c2 * bits7 + ord c1 quad (c1:c2:[] ) = ord c2 * bits7 + ord c1 quad (c1:[] ) = ord c1 quad ([] ) = 0 bits7 = 2^7 bits14 = 2^14 bits21 = 2^21 bits28 = 2^28 -- used as a substitute for the ambiguousness resolving number if it is not -- present (EXPORTED) -- noARNum :: Int noARNum = -1 -- used as the ambiguousness resolving number for primitive identifiers -- primARNum :: Int primARNum = -2 -- used as the ambiguousness resolving number for internal identifiers -- internARNum :: Int internARNum = -3 -- checks whether the given lexeme is a legal identifier (EXPORTED) -- isLegalIdent :: String -> Bool isLegalIdent [] = False isLegalIdent (c:cs) = if c == '`' then isQualIdent cs else (isAlpha c || c == '_') && isIdent (c:cs) where isIdent = checkTail . (dropWhile isAlphaNumOrUS) checkTail [] = True checkTail ("##") = True checkTail ('#':cs') = all isDigit cs' checkTail _ = False isAlphaNumOrUS c = isAlphaNum c || (c == '_') isAlphaNum c = isAlpha c || isNum c isAlpha c = c `elem` ['a'..'z'] ++ ['A'..'Z'] isNum c = c `elem` ['0'..'9'] isQualIdent cs = let cs' = skip cs in (not . null) cs' && (checkTail . tail) cs' skip [] = [] skip ('\'':cs) = '\'':cs skip ('\\':cs) = case cs of ('\'':cs') -> skip cs' ('\\':cs') -> skip cs' _ -> skip cs skip (c :cs) = skip cs -- given the lexeme of an identifier, yield the abstract identifier (EXPORTED) -- -- * the only attribute of the resulting identifier is its source text -- position; as provided in the first argument of this function -- -- * only minimal error checking, e.g., the characters of the identifier are -- not checked for being alphanumerical only; the correct lexis of the -- identifier should be ensured by the caller, e.g., the scanner or -- `isLegalIdent' -- -- * for reasons of simplicity the complete lexeme is hashed (with `quad') -- lexemeToIdent :: Position -> String -> Name -> Ident lexemeToIdent pos l name = Ident s k (quad s) (newAttrs pos name) where (s, k) = parseIdent pos l -- generate an internal identifier (has no position and cannot be asccociated -- with attributes) (EXPORTED) -- internalIdent :: String -> Ident internalIdent s = Ident s internARNum (quad s) (newAttrsOnlyPos nopos) -- generate a `only pos' identifier (may not be used to index attribute -- tables, but has a position value) (EXPORTED) -- onlyPosIdent :: Position -> String -> Ident onlyPosIdent pos l = Ident s k (quad s) (newAttrsOnlyPos pos) where (s, k) = parseIdent pos l -- Extract the name and ambiguousness resolving number from a lexeme. -- parseIdent :: Position -> String -> (String, Int) parseIdent pos l = if (null l) then interr $ "Idents: lexemeToIdent: Empty lexeme! " ++ show pos else if (head l == '\'') then parseQuoted (tail l) else parseNorm l where -- parse lexeme without quotes -- parseNorm [] = ([], noARNum) parseNorm ("##") = ([], primARNum) parseNorm ('#':cs) = ([], ((read . check) cs)::Int) parseNorm (c :cs) = let (cs', k) = parseNorm cs in (c:cs', k) check [] = interr "Idents: lexemeToIdent: Missing\ \ number!" check ('-':cs) = interr "Idents: lexemeToIdent: Illegal\ \ negative number!" check s = s -- parse lexeme with quotes -- parseQuoted [] = interr endInQuotes parseQuoted ('\\':cs) = parseSpecial cs parseQuoted ('\'':cs) = let (rmd, k) = parseNorm cs in if (null rmd) then ([], k) else interr afterQuotes parseQuoted (c :cs) = let (cs', k) = parseQuoted cs in (c:cs', k) endInQuotes = "Idents: lexemeToIdent: Unexpected end of\ \ lexeme (in quotes)!" afterQuotes = "Idents: lexemeToIdent: Superfluous\ \ characters after quotes!" endInSpecial = "Idents: lexemeToIdent: Unexpected end of\ \ lexeme (in escape sequence)!" illegalSpecial = "Idents: lexemeToIdent: Illegal escape\ \ sequence!" -- parse single escaped character, then continue with -- `parseQuoted' -- parseSpecial [] = interr endInSpecial parseSpecial (c1:c2:c3:cs) | isDigit c1 && isDigit c2 && isDigit c3 = let (cs', k) = parseQuoted cs ord0 = ord '0' d1 = ord c1 - ord0 d2 = ord c2 - ord0 d3 = ord c3 - ord0 in (chr (100*d1 + 10*d2 + d3) :cs', k) parseSpecial (c:cs) | c == '\\' = ('\\':cs', k) | c == '\"' = ('\"':cs', k) | c == '\'' = ('\'':cs', k) | c == 'n' = ('\n':cs', k) | c == 't' = ('\t':cs', k) | c == 'r' = ('\r':cs', k) where (cs', k) = parseQuoted cs parseSpecial _ = interr illegalSpecial -- create an identifier identical to the given one, but with its own set of -- attributes (EXPORTED) -- cloneIdent :: Ident -> Name -> Ident cloneIdent (Ident s k idnum at) name = Ident s k idnum (newAttrs (posOf at) name) -- given an abstract identifier, yield its lexeme (EXPORTED) -- identToLexeme :: Ident -> String identToLexeme (Ident s k _ _) = s ++ suffix where suffix = if (k == noARNum) then "" else if (k == primARNum) then "##" else if (k == internARNum) then "" else "#" ++ show k -- test if the given identifier is simple, i.e., has no ambiguousness -- resolving number and is not a primitive identifier (EXPORTED) -- isIdentSimple :: Ident -> Bool isIdentSimple (Ident _ k _ _) = k == noARNum -- test if the given identifier is a primitive identifier (EXPORTED) -- isIdentPrim :: Ident -> Bool isIdentPrim (Ident _ k _ _) = k == primARNum -- remove ambiguousness resolving of an identifier (EXPORTED) -- -- NOTE: The new identifier will not be equal (==) to the old one! -- stripIdentARNum :: Ident -> Ident stripIdentARNum (Ident s k id at) | k == primARNum || k == internARNum = interr "Idents: stripIdentARNum: \ \Not allowed!" | otherwise = Ident s noARNum id at -- get the ambiguousness resolving of an identifier (EXPORTED) -- getIdentARNum :: Ident -> Int getIdentARNum (Ident s k id at) | k == primARNum || k == internARNum = interr "Idents: getIdentARNum: \ \Not allowed!" | otherwise = k -- enter a new ambiguousness resolving into the identifier (EXPORTED) -- -- NOTE: The new identifier will not be equal (==) to the old one! -- newIdentARNum :: Ident -> Int -> Ident newIdentARNum (Ident s k id at) k' | k' < 0 = interr "Idents: newIdentARNum: \ \Negative number!" | k == primARNum || k == internARNum = interr "Idents: newIdentARNum: \ \Not allowed!" | otherwise = Ident s k' id at -- get the attribute identifier associated with the given identifier (EXPORTED) -- getIdentAttrs :: Ident -> Attrs getIdentAttrs (Ident _ _ _ as) = as -- dump the lexeme and its positions into a string for debugging purposes -- (EXPORTED) -- dumpIdent :: Ident -> String dumpIdent ide = identToLexeme ide ++ " at " ++ show (posOf ide) {-! for Ident derive : GhcBinary !-} {-* Generated by DrIFT : Look, but Don't Touch. *-} instance Binary Ident where put_ bh (Ident aa ab ac ad) = do putSharedString bh aa -- put_ bh aa put_ bh ab put_ bh ac put_ bh ad get bh = do aa <- getSharedString bh -- aa <- get bh ab <- get bh ac <- get bh ad <- get bh return (Ident aa ab ac ad) gtk2hs-buildtools-0.13.10.0/c2hs/base/syms/NameSpaces.hs0000644000000000000000000001423607346545000020710 0ustar0000000000000000-- Compiler Toolkit: name space management -- -- Author : Manuel M. T. Chakravarty -- Created: 12 November 95 -- -- Version $Revision: 1.2 $ from $Date: 2004/11/13 17:26:50 $ -- -- 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 NameSpaces (NameSpace, nameSpace, defGlobal, enterNewRange, leaveRange, defLocal, find, nameSpaceToList) where import Map (Map) import qualified Map as Map (empty, insert, lookup, toList) import Idents (Ident) import Errors (interr) import Binary (Binary(..)) -- name space (EXPORTED ABSTRACT) -- -- * 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 -- create a name space (EXPORTED) -- nameSpace :: NameSpace a nameSpace = NameSpace Map.empty [] -- add global definition (EXPORTED) -- -- * 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) id def = (NameSpace (Map.insert id def gs) lss, Map.lookup id gs) -- add new range (EXPORTED) -- enterNewRange :: NameSpace a -> NameSpace a enterNewRange (NameSpace gs lss) = NameSpace gs ([]:lss) -- pop topmost range and return its definitions (EXPORTED) -- 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 (EXPORTED) -- -- * 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 gs [] ) id def = defGlobal ns id def defLocal (NameSpace gs (ls:lss)) id def = (NameSpace gs (((id, def):ls):lss), lookup ls) where lookup [] = Nothing lookup ((id', def):ls) | id == id' = Just def | otherwise = lookup ls -- search for a definition (EXPORTED) -- -- * the definition from the innermost range is returned, if any -- find :: NameSpace a -> Ident -> Maybe a find (NameSpace gs lss) id = case (lookup lss) of Nothing -> Map.lookup id 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' ((id', def):ls) | id' == id = Just def | otherwise = lookup' ls -- dump a name space into a list (EXPORTED) -- -- * local ranges are concatenated -- nameSpaceToList :: NameSpace a -> [(Ident, a)] nameSpaceToList (NameSpace gs lss) = Map.toList gs ++ concat lss {-! for NameSpace derive : GhcBinary !-} {-* Generated by DrIFT : Look, but Don't Touch. *-} instance (Binary a) => Binary (NameSpace a) where put_ bh (NameSpace aa ab) = do put_ bh aa put_ bh ab get bh = do aa <- get bh ab <- get bh return (NameSpace aa ab) gtk2hs-buildtools-0.13.10.0/c2hs/base/syntax/0000755000000000000000000000000007346545000016662 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/c2hs/base/syntax/Lexers.hs0000644000000000000000000004425407346545000020471 0ustar0000000000000000-- Compiler Toolkit: Self-optimizing lexers -- -- Author : Manuel M. T. Chakravarty -- Created: 2 March 99 -- -- Version $Revision: 1.2 $ from $Date: 2004/11/13 17:26:51 $ -- -- 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 Lexers (Regexp, Lexer, Action, epsilon, char, (+>), lexaction, lexactionErr, lexmeta, (>|<), (>||<), ctrlChars, ctrlLexer, star, plus, quest, alt, string, LexerState, execLexer) where import Data.Maybe (fromMaybe, isNothing) import Data.Array (Ix(..), Array, array, (!), assocs, accumArray) import Position (Position(..), Pos (posOf), nopos, incPos, tabPos, retPos) import DLists (DList, openDL, zeroDL, unitDL, snocDL, joinDL, closeDL) import Errors (interr, ErrorLvl(..), 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) -- empty bounds -- nullBoundsNum :: BoundsNum nullBoundsNum = (0, maxBound, minBound) -- 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 (EXPORTED) -- -- * 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) -- (EXPORTED) -- 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 (EXPORTED ABSTRACTLY) -- -- * 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 (EXPORTED ABSTRACTLY) -- data LexAction s t = Action (Meta s t) | NoAction -- deriving Show -- a regular expression (EXPORTED) -- type Regexp s t = Lexer s t -> Lexer s t -- basic combinators -- ----------------- -- Empty lexeme (EXPORTED) -- epsilon :: Regexp s t epsilon = id -- One character regexp (EXPORTED) -- char :: Char -> Regexp s t char c = \l -> Lexer NoAction (Sparse (1, c, c) [(c, l)]) -- Concatenation of regexps (EXPORTED) -- (+>) :: Regexp s t -> Regexp s t -> Regexp s t (+>) = (.) -- Close a regular expression with an action that converts the lexeme into a -- token (EXPORTED) -- -- * 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@(Position fname row col) s = let col' = col + length lexeme in col' `seq` case a lexeme pos of Nothing -> (Nothing, (Position fname row col'), s, Nothing) Just t -> (Just (Right t), (Position fname row col'), s, Nothing) -- Variant for actions that may returns an error (EXPORTED) -- lexactionErr :: Regexp s t -> ActionErr t -> Lexer s t lexactionErr re a = re `lexmeta` a' where a' lexeme pos@(Position fname row col) s = let col' = col + length lexeme in col' `seq` (Just (a lexeme pos), (Position fname row col'), s, Nothing) -- Close a regular expression with a meta action (EXPORTED) -- -- * 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 (EXPORTED) -- (>|<) :: Regexp s t -> Regexp s t -> Regexp s t re >|< re' = \l -> re l >||< re' l -- disjunctive combination of two lexers (EXPORTED) -- (>||<) :: 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 f [] = [] 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', e'):kes) | k == k' = gather k (f e e') kes | otherwise = let (ke'', kes') = gather k e kes in (ke'', ke':kes') -- handling of control characters -- ------------------------------ -- control characters recognized by `ctrlLexer' (EXPORTED) -- ctrlChars :: [Char] ctrlChars = ['\n', '\r', '\f', '\t'] -- control lexer (EXPORTED) -- -- * 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, tabPos pos , s, Nothing) -- non-basic combinators -- --------------------- -- x `star` y corresponds to the regular expression x*y (EXPORTED) -- 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 (EXPORTED) -- 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 (EXPORTED) -- quest :: Regexp s t -> Regexp s t -> Regexp s t quest re1 re2 = (re1 +> re2) >|< re2 -- accepts a non-empty set of alternative characters (EXPORTED) -- 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 (EXPORTED) -- 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) (EXPORTED) -- type LexerState s = (String, Position, s) -- apply a lexer, yielding a token sequence and a list of errors (EXPORTED) -- -- * 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 l 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 zeroDL 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@(Position fname row col), s) = state err = makeError ErrorErr pos ["Lexical error!", "The character " ++ show (head cs) ++ " does not fit here; skipping it."] in (Just (Left err), l, (tail cs, (Position fname row (col + 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 c state csDL 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 `snocDL` c) last -- execute the action if present and finalise the current lexeme -- action (Action f) csDL (cs, pos, s) last = case f (closeDL 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 gtk2hs-buildtools-0.13.10.0/c2hs/c/0000755000000000000000000000000007346545000014644 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/c2hs/c/C.hs0000644000000000000000000001250707346545000015367 0ustar0000000000000000-- C->Haskell Compiler: interface to C processing routines -- -- Author : Manuel M. T. Chakravarty -- Created: 12 August 99 -- -- Version $Revision: 1.3 $ from $Date: 2005/06/22 16:01:20 $ -- -- 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 C (-- interface to KL for all non-KL modules -- -- stuff from `Common' (reexported) -- Pos(posOf), -- -- structure tree -- module CAST, -- -- attributed structure tree with operations (reexported from -- `CAttrs') -- AttrC, getCHeader, CObj(..), CTag(..), CDef(..), lookupDefObjC, lookupDefTagC, getDefOfIdentC, -- -- support for C structure tree traversals -- module CTrav, -- -- support for pretty printing C abstract trees -- module CPretty, -- loadAttrC, -- locally defined -- -- misc. reexported stuff -- Ident, Attrs, Attr(..), -- -- misc. own stuff -- csuffix, hsuffix, isuffix) where import Position (Position(..), Pos(posOf)) import Idents (Ident, lexemeToIdent) import Attributes (Attrs, Attr(..)) import C2HSState (CST, IOMode(..), readCST, transCST, runCST, nop, readFileCIO, writeFileCIO, openFileCIO, hCloseCIO, fatal, errorsPresent, showErrors, Traces(..), putTraceStr) import CAST import CParser (parseC) import CPretty import CAttrs (AttrC, attrC, getCHeader, CObj(..), CTag(..), CDef(..), lookupDefObjC, lookupDefTagC, getDefOfIdentC) import CNames (nameAnalysis) import CTrav -- suffix for files containing C (EXPORTED) -- csuffix, hsuffix, isuffix :: String csuffix = ".c" hsuffix = ".h" isuffix = ".i" -- given a file name (with suffix), parse that file as a C header and do the -- static analysis (collect defined names) (EXPORTED) -- -- * 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 <- readFileCIO fname -- parse -- traceInfoParse rawHeader <- parseC contents (Position fname 1 1) let header = attrC rawHeader -- 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") gtk2hs-buildtools-0.13.10.0/c2hs/c/CAST.hs0000644000000000000000000013154107346545000015737 0ustar0000000000000000-- C -> Haskell Compiler: Abstract Syntax for Header Files -- -- Author : Manuel M T Chakravarty -- Created: 7 March 99 -- -- Version $Revision: 1.10 $ from $Date: 2004/06/11 07:10:16 $ -- -- Copyright (c) [1999..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 --------------------------------------------------------------- -- -- Abstract syntax of C header files. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- The tree structure corresponds to the grammar in Appendix A of K&R. This -- abstract syntax simplifies the concrete syntax by merging similar concrete -- constructs into a single type of abstract tree structure: declarations are -- merged with structure declarations, parameter declarations and type names, -- and declarators are merged with abstract declarators. -- -- With K&R we refer to ``The C Programming Language'', second edition, Brain -- W. Kernighan and Dennis M. Ritchie, Prentice Hall, 1988. This module -- supports the C99 `restrict' extension -- , `inline' functions, and also -- the GNU C `alignof' extension. -- --- TODO ---------------------------------------------------------------------- -- module CAST (CHeader(..), CExtDecl(..), CFunDef(..), CStat(..), CBlockItem(..), CDecl(..), CDeclSpec(..), CStorageSpec(..), CTypeSpec(..), CTypeQual(..), CStructUnion(..), CStructTag(..), CEnum(..), CDeclr(..), CInit(..), CInitList, CDesignator(..), CExpr(..), CAssignOp(..), CBinaryOp(..), CUnaryOp(..), CConst (..)) where import Position (Position, Pos(posOf), nopos) import Idents (Ident) import Attributes (Attrs) import Binary (Binary(..), putByte, getByte) -- a complete C header file (K&R A10) (EXPORTED) -- data CHeader = CHeader [CExtDecl] Attrs instance Pos CHeader where posOf (CHeader _ at) = posOf at instance Eq CHeader where (CHeader _ at1) == (CHeader _ at2) = at1 == at2 -- external C declaration (K&R A10) (EXPORTED) -- data CExtDecl = CDeclExt CDecl | CFDefExt CFunDef | CAsmExt Attrs -- a chunk of assembly code (which is -- not itself recorded) instance Pos CExtDecl where posOf (CDeclExt decl) = posOf decl posOf (CFDefExt fdef) = posOf fdef posOf (CAsmExt at) = posOf at instance Eq CExtDecl where CDeclExt decl1 == CDeclExt decl2 = decl1 == decl2 CFDefExt fdef1 == CFDefExt fdef2 = fdef1 == fdef2 CAsmExt at1 == CAsmExt at2 = at1 == at2 -- C function definition (K&R A10.1) (EXPORTED) -- -- * The only type specifiers allowed are `extern' and `static'. -- -- * The declarator must specify explicitly that the declared identifier has -- function type. -- -- * The optional declaration list is for old-style function declarations. -- -- * The statement must be a compound statement. -- data CFunDef = CFunDef [CDeclSpec] -- type specifier and qualifier CDeclr -- declarator [CDecl] -- optional declaration list CStat -- compound statement Attrs instance Pos CFunDef where posOf (CFunDef _ _ _ _ at) = posOf at instance Eq CFunDef where CFunDef _ _ _ _ at1 == CFunDef _ _ _ _ at2 = at1 == at2 -- C statement (A9) (EXPORTED) -- data CStat = CLabel Ident -- label CStat Attrs | CCase CExpr -- constant expression CStat Attrs | CCases CExpr -- case range CExpr -- `case lower .. upper :' CStat Attrs | CDefault CStat -- default case Attrs | CExpr (Maybe CExpr) -- expression statement, maybe empty Attrs | CCompound [CBlockItem] -- list of declarations and statements Attrs | CIf CExpr -- conditional expression CStat (Maybe CStat) -- optional "else" case Attrs | CSwitch CExpr -- selector CStat Attrs | CWhile CExpr CStat Bool -- `True' implies "do-while" statement Attrs | CFor (Either (Maybe CExpr) CDecl) (Maybe CExpr) (Maybe CExpr) CStat Attrs | CGoto Ident -- label Attrs | CGotoPtr CExpr -- computed address Attrs | CCont Attrs -- continue statement | CBreak Attrs -- break statement | CReturn (Maybe CExpr) Attrs | CAsm Attrs -- a chunk of assembly code (which is -- not itself recorded) instance Pos CStat where posOf (CLabel _ _ at) = posOf at posOf (CCase _ _ at) = posOf at posOf (CCases _ _ _ at) = posOf at posOf (CDefault _ at) = posOf at posOf (CExpr _ at) = posOf at posOf (CCompound _ at) = posOf at posOf (CIf _ _ _ at) = posOf at posOf (CSwitch _ _ at) = posOf at posOf (CWhile _ _ _ at) = posOf at posOf (CFor _ _ _ _ at) = posOf at posOf (CGoto _ at) = posOf at posOf (CGotoPtr _ at) = posOf at posOf (CCont at) = posOf at posOf (CBreak at) = posOf at posOf (CReturn _ at) = posOf at posOf (CAsm at) = posOf at instance Eq CStat where (CLabel _ _ at1) == (CLabel _ _ at2) = at1 == at2 (CCase _ _ at1) == (CCase _ _ at2) = at1 == at2 (CCases _ _ _ at1) == (CCases _ _ _ at2) = at1 == at2 (CDefault _ at1) == (CDefault _ at2) = at1 == at2 (CExpr _ at1) == (CExpr _ at2) = at1 == at2 (CCompound _ at1) == (CCompound _ at2) = at1 == at2 (CIf _ _ _ at1) == (CIf _ _ _ at2) = at1 == at2 (CSwitch _ _ at1) == (CSwitch _ _ at2) = at1 == at2 (CWhile _ _ _ at1) == (CWhile _ _ _ at2) = at1 == at2 (CFor _ _ _ _ at1) == (CFor _ _ _ _ at2) = at1 == at2 (CGoto _ at1) == (CGoto _ at2) = at1 == at2 (CGotoPtr _ at1) == (CGotoPtr _ at2) = at1 == at2 (CCont at1) == (CCont at2) = at1 == at2 (CBreak at1) == (CBreak at2) = at1 == at2 (CReturn _ at1) == (CReturn _ at2) = at1 == at2 (CAsm at1) == (CAsm at2) = at1 == at2 -- C99 Block items, things that may appear in compound statements data CBlockItem = CBlockStmt CStat | CBlockDecl CDecl | CNestedFunDef CFunDef -- GNU C has nested functions instance Pos CBlockItem where posOf (CBlockStmt stmt) = posOf stmt posOf (CBlockDecl decl) = posOf decl posOf (CNestedFunDef fdef) = posOf fdef instance Eq CBlockItem where CBlockStmt stmt1 == CBlockStmt stmt2 = stmt1 == stmt2 CBlockDecl decl1 == CBlockDecl decl2 = decl1 == decl2 CNestedFunDef fdef1 == CNestedFunDef fdef2 = fdef1 == fdef2 -- C declaration (K&R A8), structure declaration (K&R A8.3), parameter -- declaration (K&R A8.6.3), and type name (K&R A8.8) (EXPORTED) -- -- * Toplevel declarations (K&R A8): -- -- - they require that the type specifier and qualifier list is not empty, -- but gcc allows it and just issues a warning; for the time being, we -- also allow it; -- - at most one storage class specifier is allowed per declaration; -- - declarators must be present and size expressions are not allowed, ie, -- the elements of K&R's init-declarator-list are represented by triples -- of the form `(Just declr, oinit, Nothing)', where `oinit' maybe -- `Nothing' or `Just init'; and -- - abstract declarators are not allowed. -- -- * Structure declarations (K&R A8.3): -- -- - do not allow storage specifiers; -- - do not allow initializers; -- - require a non-empty declarator-triple list, where abstract declarators -- are not allowed; and -- - each of the declarator-triples has to contain either a declarator or a -- size expression, or both, ie, it has the form `(Just decl, Nothing, -- Nothing)', `(Nothing, Nothing, Just size)', or `(Just decl, Nothing, -- Just size)'. -- -- * Parameter declarations (K&R A8.6.3): -- -- - allow neither initializers nor size expressions; -- - allow at most one declarator triple of the form `(Just declr, Nothing, -- Nothing)' (in case of an empty declarator, the list must be empty); and -- - allow abstract declarators. -- -- * Type names (A8.8): -- -- - do not allow storage specifiers; -- - allow neither initializers nor size expressions; and -- - allow at most one declarator triple of the form `(Just declr, Nothing, -- Nothing)' (in case of an empty declarator, the list must be empty), -- where the declarator must be abstract, ie, must not contain a declared -- identifier. -- data CDecl = CDecl [CDeclSpec] -- type specifier and qualifier [(Maybe CDeclr, -- declarator (may be omitted) Maybe CInit, -- optional initializer Maybe CExpr)] -- optional size (const expr) Attrs instance Pos CDecl where posOf (CDecl _ _ at) = posOf at instance Eq CDecl where (CDecl _ _ at1) == (CDecl _ _ at2) = at1 == at2 -- C declaration specifiers and qualifiers (EXPORTED) -- data CDeclSpec = CStorageSpec CStorageSpec | CTypeSpec CTypeSpec | CTypeQual CTypeQual deriving (Eq) instance Pos CDeclSpec where posOf (CStorageSpec sspec) = posOf sspec posOf (CTypeSpec tspec) = posOf tspec posOf (CTypeQual tqual) = posOf tqual -- C storage class specifier (K&R A8.1) (EXPORTED) -- data CStorageSpec = CAuto Attrs | CRegister Attrs | CStatic Attrs | CExtern Attrs | CTypedef Attrs -- syntactic awkwardness of C | CThread Attrs -- GNUC thread local storage instance Pos CStorageSpec where posOf (CAuto at) = posOf at posOf (CRegister at) = posOf at posOf (CStatic at) = posOf at posOf (CExtern at) = posOf at posOf (CTypedef at) = posOf at posOf (CThread at) = posOf at instance Eq CStorageSpec where (CAuto at1) == (CAuto at2) = at1 == at2 (CRegister at1) == (CRegister at2) = at1 == at2 (CStatic at1) == (CStatic at2) = at1 == at2 (CExtern at1) == (CExtern at2) = at1 == at2 (CTypedef at1) == (CTypedef at2) = at1 == at2 (CThread at1) == (CThread at2) = at1 == at2 -- C type specifier (K&R A8.2) (EXPORTED) -- data CTypeSpec = CVoidType Attrs | CCharType Attrs | CShortType Attrs | CIntType Attrs | CLongType Attrs | CFloatType Attrs | CFloat128Type Attrs | CDoubleType Attrs | CSignedType Attrs | CUnsigType Attrs | CBoolType Attrs | CComplexType Attrs | CSUType CStructUnion Attrs | CEnumType CEnum Attrs | CTypeDef Ident -- typedef name Attrs | CTypeOfExpr CExpr Attrs | CTypeOfType CDecl Attrs instance Pos CTypeSpec where posOf (CVoidType at) = posOf at posOf (CCharType at) = posOf at posOf (CShortType at) = posOf at posOf (CIntType at) = posOf at posOf (CLongType at) = posOf at posOf (CFloatType at) = posOf at posOf (CFloat128Type at) = posOf at posOf (CDoubleType at) = posOf at posOf (CSignedType at) = posOf at posOf (CUnsigType at) = posOf at posOf (CBoolType at) = posOf at posOf (CComplexType at) = posOf at posOf (CSUType _ at) = posOf at posOf (CEnumType _ at) = posOf at posOf (CTypeDef _ at) = posOf at posOf (CTypeOfExpr _ at) = posOf at posOf (CTypeOfType _ at) = posOf at instance Eq CTypeSpec where (CVoidType at1) == (CVoidType at2) = at1 == at2 (CCharType at1) == (CCharType at2) = at1 == at2 (CShortType at1) == (CShortType at2) = at1 == at2 (CIntType at1) == (CIntType at2) = at1 == at2 (CLongType at1) == (CLongType at2) = at1 == at2 (CFloatType at1) == (CFloatType at2) = at1 == at2 (CFloat128Type at1) == (CFloat128Type at2) = at1 == at2 (CDoubleType at1) == (CDoubleType at2) = at1 == at2 (CSignedType at1) == (CSignedType at2) = at1 == at2 (CUnsigType at1) == (CUnsigType at2) = at1 == at2 (CBoolType at1) == (CBoolType at2) = at1 == at2 (CComplexType at1) == (CComplexType at2) = at1 == at2 (CSUType _ at1) == (CSUType _ at2) = at1 == at2 (CEnumType _ at1) == (CEnumType _ at2) = at1 == at2 (CTypeDef _ at1) == (CTypeDef _ at2) = at1 == at2 (CTypeOfExpr _ at1) == (CTypeOfExpr _ at2) = at1 == at2 (CTypeOfType _ at1) == (CTypeOfType _ at2) = at1 == at2 -- C type qualifier (K&R A8.2) (EXPORTED) -- -- * plus `restrict' from C99 and `inline' -- data CTypeQual = CConstQual Attrs | CVolatQual Attrs | CRestrQual Attrs | CInlinQual Attrs instance Pos CTypeQual where posOf (CConstQual at) = posOf at posOf (CVolatQual at) = posOf at posOf (CRestrQual at) = posOf at posOf (CInlinQual at) = posOf at instance Eq CTypeQual where (CConstQual at1) == (CConstQual at2) = at1 == at2 (CVolatQual at1) == (CVolatQual at2) = at1 == at2 (CRestrQual at1) == (CRestrQual at2) = at1 == at2 (CInlinQual at1) == (CInlinQual at2) = at1 == at2 -- C structure of union declaration (K&R A8.3) (EXPORTED) -- -- * in both case, either the identifier is present or the list must be -- non-empty -- data CStructUnion = CStruct CStructTag (Maybe Ident) [CDecl] -- *structure* declaration Attrs instance Pos CStructUnion where posOf (CStruct _ _ _ at) = posOf at instance Eq CStructUnion where (CStruct _ _ _ at1) == (CStruct _ _ _ at2) = at1 == at2 -- (EXPORTED) -- data CStructTag = CStructTag | CUnionTag deriving (Eq) -- C enumeration declaration (K&R A8.4) (EXPORTED) -- data CEnum = CEnum (Maybe Ident) [(Ident, -- variant name Maybe CExpr)] -- explicit variant value Attrs instance Pos CEnum where posOf (CEnum _ _ at) = posOf at instance Eq CEnum where (CEnum _ _ at1) == (CEnum _ _ at2) = at1 == at2 -- C declarator (K&R A8.5) and abstract declarator (K&R A8.8) (EXPORTED) -- -- * We have one type qualifer list `[CTypeQual]' for each indirection (ie, -- each occurrence of `*' in the concrete syntax). -- -- * We unfold K&R's direct-declarators nonterminal into declarators. Note -- that `*(*x)' is equivalent to `**x'. -- -- * Declarators (A8.5) and abstract declarators (A8.8) are represented in the -- same structure. In the case of a declarator, the identifier in -- `CVarDeclr' must be present; in an abstract declarator it misses. -- `CVarDeclr Nothing ...' on its own is meaningless, it may only occur as -- part of a larger type (ie, there must be a pointer, an array, or function -- declarator around). -- -- * The qualifiers list in a `CPtrDeclr' may not be empty. -- -- * Old and new style function definitions are merged into a single case -- `CFunDeclr'. In case of an old style definition, the parameter list is -- empty and the variadic flag is `False' (ie, the parameter names are not -- stored in the tree). Remember, a new style definition with no parameters -- requires a single `void' in the argument list (according to the standard). -- -- * We unfold K&R's parameter-type-list nonterminal into the declarator -- variant for functions. -- data CDeclr = CVarDeclr (Maybe Ident) -- declared identifier Attrs | CPtrDeclr [CTypeQual] -- indirections CDeclr Attrs | CArrDeclr CDeclr [CTypeQual] (Maybe CExpr) -- array size Attrs | CFunDeclr CDeclr [CDecl] -- *parameter* declarations Bool -- is variadic? Attrs instance Pos CDeclr where posOf (CVarDeclr _ at) = posOf at posOf (CPtrDeclr _ _ at) = posOf at posOf (CArrDeclr _ _ _ at) = posOf at posOf (CFunDeclr _ _ _ at) = posOf at instance Eq CDeclr where (CVarDeclr _ at1) == (CVarDeclr _ at2) = at1 == at2 (CPtrDeclr _ _ at1) == (CPtrDeclr _ _ at2) = at1 == at2 (CArrDeclr _ _ _ at1) == (CArrDeclr _ _ _ at2) = at1 == at2 (CFunDeclr _ _ _ at1) == (CFunDeclr _ _ _ at2) = at1 == at2 -- C initializer (K&R A8.7) (EXPORTED) -- data CInit = CInitExpr CExpr Attrs -- assignment expression | CInitList CInitList Attrs type CInitList = [([CDesignator], CInit)] instance Pos CInit where posOf (CInitExpr _ at) = posOf at posOf (CInitList _ at) = posOf at instance Eq CInit where (CInitExpr _ at1) == (CInitExpr _ at2) = at1 == at2 (CInitList _ at1) == (CInitList _ at2) = at1 == at2 -- C initializer designator (EXPORTED) -- data CDesignator = CArrDesig CExpr Attrs | CMemberDesig Ident Attrs | CRangeDesig CExpr -- GNUC array range designator CExpr Attrs instance Pos CDesignator where posOf (CArrDesig _ at) = posOf at posOf (CMemberDesig _ at) = posOf at posOf (CRangeDesig _ _ at) = posOf at instance Eq CDesignator where (CArrDesig _ at1) == (CArrDesig _ at2) = at1 == at2 (CMemberDesig _ at1) == (CMemberDesig _ at2) = at1 == at2 (CRangeDesig _ _ at1) == (CRangeDesig _ _ at2) = at1 == at2 -- C expression (K&R A7) (EXPORTED) -- -- * these can be arbitrary expression, as the argument of `sizeof' can be -- arbitrary, even if appearing in a constant expression -- -- * GNU C extension: `alignof' -- data CExpr = CComma [CExpr] -- comma expression list, n >= 2 Attrs | CAssign CAssignOp -- assignment operator CExpr -- l-value CExpr -- r-value Attrs | CCond CExpr -- conditional (Maybe CExpr) -- true-expression (GNU allows omitting) CExpr -- false-expression Attrs | CBinary CBinaryOp -- binary operator CExpr -- lhs CExpr -- rhs Attrs | CCast CDecl -- type name CExpr Attrs | CUnary CUnaryOp -- unary operator CExpr Attrs | CSizeofExpr CExpr Attrs | CSizeofType CDecl -- type name Attrs | CAlignofExpr CExpr Attrs | CAlignofType CDecl -- type name Attrs | CIndex CExpr -- array CExpr -- index Attrs | CCall CExpr -- function [CExpr] -- arguments Attrs | CMember CExpr -- structure Ident -- member name Bool -- deref structure? (True for `->') Attrs | CVar Ident -- identifier (incl. enumeration const) Attrs | CConst CConst -- includes strings Attrs | CCompoundLit CDecl -- C99 compound literal CInitList -- type name & initialiser list Attrs | CStatExpr CStat -- GNUC compound statement as expr Attrs | CLabAddrExpr Ident -- GNUC address of label Attrs | CBuiltinExpr Attrs -- place holder for GNUC builtin exprs instance Pos CExpr where posOf (CComma _ at) = posOf at posOf (CAssign _ _ _ at) = posOf at posOf (CCond _ _ _ at) = posOf at posOf (CBinary _ _ _ at) = posOf at posOf (CCast _ _ at) = posOf at posOf (CUnary _ _ at) = posOf at posOf (CSizeofExpr _ at) = posOf at posOf (CSizeofType _ at) = posOf at posOf (CAlignofExpr _ at) = posOf at posOf (CAlignofType _ at) = posOf at posOf (CIndex _ _ at) = posOf at posOf (CCall _ _ at) = posOf at posOf (CMember _ _ _ at) = posOf at posOf (CVar _ at) = posOf at posOf (CConst _ at) = posOf at posOf (CCompoundLit _ _ at) = posOf at posOf (CStatExpr _ at) = posOf at posOf (CLabAddrExpr _ at) = posOf at posOf (CBuiltinExpr at) = posOf at instance Eq CExpr where (CComma _ at1) == (CComma _ at2) = at1 == at2 (CAssign _ _ _ at1) == (CAssign _ _ _ at2) = at1 == at2 (CCond _ _ _ at1) == (CCond _ _ _ at2) = at1 == at2 (CBinary _ _ _ at1) == (CBinary _ _ _ at2) = at1 == at2 (CCast _ _ at1) == (CCast _ _ at2) = at1 == at2 (CUnary _ _ at1) == (CUnary _ _ at2) = at1 == at2 (CSizeofExpr _ at1) == (CSizeofExpr _ at2) = at1 == at2 (CSizeofType _ at1) == (CSizeofType _ at2) = at1 == at2 (CAlignofExpr _ at1) == (CAlignofExpr _ at2) = at1 == at2 (CAlignofType _ at1) == (CAlignofType _ at2) = at1 == at2 (CIndex _ _ at1) == (CIndex _ _ at2) = at1 == at2 (CCall _ _ at1) == (CCall _ _ at2) = at1 == at2 (CMember _ _ _ at1) == (CMember _ _ _ at2) = at1 == at2 (CVar _ at1) == (CVar _ at2) = at1 == at2 (CConst _ at1) == (CConst _ at2) = at1 == at2 (CCompoundLit _ _ at1) == (CCompoundLit _ _ at2) = at1 == at2 (CStatExpr _ at1) == (CStatExpr _ at2) = at1 == at2 (CLabAddrExpr _ at1) == (CLabAddrExpr _ at2) = at1 == at2 (CBuiltinExpr at1) == (CBuiltinExpr at2) = at1 == at2 -- C assignment operators (K&R A7.17) (EXPORTED) -- data CAssignOp = CAssignOp | CMulAssOp | CDivAssOp | CRmdAssOp -- remainder and assignment | CAddAssOp | CSubAssOp | CShlAssOp | CShrAssOp | CAndAssOp | CXorAssOp | COrAssOp deriving (Eq) -- C binary operators (K&R A7.6-15) (EXPORTED) -- data CBinaryOp = CMulOp | CDivOp | CRmdOp -- remainder of division | CAddOp | CSubOp | CShlOp -- shift left | CShrOp -- shift right | CLeOp -- less | CGrOp -- greater | CLeqOp -- less or equal | CGeqOp -- greater or equal | CEqOp -- equal | CNeqOp -- not equal | CAndOp -- bitwise and | CXorOp -- exclusive bitwise or | COrOp -- inclusive bitwise or | CLndOp -- logical and | CLorOp -- logical or deriving (Eq) -- C unary operator (K&R A7.3-4) (EXPORTED) -- data CUnaryOp = CPreIncOp -- prefix increment operator | CPreDecOp -- prefix decrement operator | CPostIncOp -- postfix increment operator | CPostDecOp -- postfix decrement operator | CAdrOp -- address operator | CIndOp -- indirection operator | CPlusOp -- prefix plus | CMinOp -- prefix minus | CCompOp -- one's complement | CNegOp -- logical negation deriving (Eq) -- C constant (K&R A2.5 & A7.2) (EXPORTED) -- -- * we do not list enumeration constants here, as they are identifiers -- data CConst = CIntConst Integer Attrs | CCharConst Char Attrs | CFloatConst String Attrs | CStrConst String Attrs instance Pos CConst where posOf (CIntConst _ at) = posOf at posOf (CCharConst _ at) = posOf at posOf (CFloatConst _ at) = posOf at posOf (CStrConst _ at) = posOf at instance Eq CConst where (CIntConst _ at1) == (CIntConst _ at2) = at1 == at2 (CCharConst _ at1) == (CCharConst _ at2) = at1 == at2 (CFloatConst _ at1) == (CFloatConst _ at2) = at1 == at2 (CStrConst _ at1) == (CStrConst _ at2) = at1 == at2 {-! for CDecl derive : GhcBinary !-} {-! for CEnum derive : GhcBinary !-} {-! for CStructUnion derive : GhcBinary !-} {-! for CStructTag derive : GhcBinary !-} {-! for CExpr derive : GhcBinary !-} {-! for CInit derive : GhcBinary !-} {-! for CDeclr derive : GhcBinary !-} {-! for CDeclSpec derive : GhcBinary !-} {-! for CTypeSpec derive : GhcBinary !-} {-! for CStorageSpec derive : GhcBinary !-} {-! for CTypeQual derive : GhcBinary !-} {-! for CConst derive : GhcBinary !-} {-! for CUnaryOp derive : GhcBinary !-} {-! for CBinaryOp derive : GhcBinary !-} {-! for CAssignOp derive : GhcBinary !-} {-* Generated by DrIFT : Look, but Don't Touch. *-} instance Binary CDecl where put_ bh (CDecl aa ab ac) = do put_ bh aa put_ bh ab put_ bh ac get bh = do aa <- get bh ab <- get bh ac <- get bh return (CDecl aa ab ac) instance Binary CEnum where put_ bh (CEnum aa ab ac) = do put_ bh aa put_ bh ab put_ bh ac get bh = do aa <- get bh ab <- get bh ac <- get bh return (CEnum aa ab ac) instance Binary CStructUnion where put_ bh (CStruct aa ab ac ad) = do put_ bh aa put_ bh ab put_ bh ac put_ bh ad get bh = do aa <- get bh ab <- get bh ac <- get bh ad <- get bh return (CStruct aa ab ac ad) instance Binary CStructTag where put_ bh CStructTag = do putByte bh 0 put_ bh CUnionTag = do putByte bh 1 get bh = do h <- getByte bh case h of 0 -> do return CStructTag 1 -> do return CUnionTag instance Binary CExpr where put_ bh (CComma aa ab) = do putByte bh 0 put_ bh aa put_ bh ab put_ bh (CAssign ac ad ae af) = do putByte bh 1 put_ bh ac put_ bh ad put_ bh ae put_ bh af put_ bh (CCond ag ah ai aj) = do putByte bh 2 put_ bh ag put_ bh ah put_ bh ai put_ bh aj put_ bh (CBinary ak al am an) = do putByte bh 3 put_ bh ak put_ bh al put_ bh am put_ bh an put_ bh (CCast ao ap aq) = do putByte bh 4 put_ bh ao put_ bh ap put_ bh aq put_ bh (CUnary ar as at) = do putByte bh 5 put_ bh ar put_ bh as put_ bh at put_ bh (CSizeofExpr au av) = do putByte bh 6 put_ bh au put_ bh av put_ bh (CSizeofType aw ax) = do putByte bh 7 put_ bh aw put_ bh ax put_ bh (CAlignofExpr ay az) = do putByte bh 8 put_ bh ay put_ bh az put_ bh (CAlignofType aA aB) = do putByte bh 9 put_ bh aA put_ bh aB put_ bh (CIndex aC aD aE) = do putByte bh 10 put_ bh aC put_ bh aD put_ bh aE put_ bh (CCall aF aG aH) = do putByte bh 11 put_ bh aF put_ bh aG put_ bh aH put_ bh (CMember aI aJ aK aL) = do putByte bh 12 put_ bh aI put_ bh aJ put_ bh aK put_ bh aL put_ bh (CVar aM aN) = do putByte bh 13 put_ bh aM put_ bh aN put_ bh (CConst aO aP) = do putByte bh 14 put_ bh aO put_ bh aP get bh = do h <- getByte bh case h of 0 -> do aa <- get bh ab <- get bh return (CComma aa ab) 1 -> do ac <- get bh ad <- get bh ae <- get bh af <- get bh return (CAssign ac ad ae af) 2 -> do ag <- get bh ah <- get bh ai <- get bh aj <- get bh return (CCond ag ah ai aj) 3 -> do ak <- get bh al <- get bh am <- get bh an <- get bh return (CBinary ak al am an) 4 -> do ao <- get bh ap <- get bh aq <- get bh return (CCast ao ap aq) 5 -> do ar <- get bh as <- get bh at <- get bh return (CUnary ar as at) 6 -> do au <- get bh av <- get bh return (CSizeofExpr au av) 7 -> do aw <- get bh ax <- get bh return (CSizeofType aw ax) 8 -> do ay <- get bh az <- get bh return (CAlignofExpr ay az) 9 -> do aA <- get bh aB <- get bh return (CAlignofType aA aB) 10 -> do aC <- get bh aD <- get bh aE <- get bh return (CIndex aC aD aE) 11 -> do aF <- get bh aG <- get bh aH <- get bh return (CCall aF aG aH) 12 -> do aI <- get bh aJ <- get bh aK <- get bh aL <- get bh return (CMember aI aJ aK aL) 13 -> do aM <- get bh aN <- get bh return (CVar aM aN) 14 -> do aO <- get bh aP <- get bh return (CConst aO aP) instance Binary CInit where put_ bh (CInitExpr aa ab) = do putByte bh 0 put_ bh aa put_ bh ab put_ bh (CInitList ac ad) = do putByte bh 1 put_ bh ac put_ bh ad get bh = do h <- getByte bh case h of 0 -> do aa <- get bh ab <- get bh return (CInitExpr aa ab) 1 -> do ac <- get bh ad <- get bh return (CInitList ac ad) instance Binary CDesignator where put_ bh (CArrDesig aa ab) = do putByte bh 0 put_ bh aa put_ bh ab put_ bh (CMemberDesig ac ad) = do putByte bh 1 put_ bh ac put_ bh ad put_ bh (CRangeDesig ae af ag) = do putByte bh 2 put_ bh ae put_ bh af put_ bh ag get bh = do h <- getByte bh case h of 0 -> do aa <- get bh ab <- get bh return (CArrDesig aa ab) 1 -> do ac <- get bh ad <- get bh return (CMemberDesig ac ad) 2 -> do ae <- get bh af <- get bh ag <- get bh return (CRangeDesig ae af ag) instance Binary CDeclr where put_ bh (CVarDeclr aa ab) = do putByte bh 0 put_ bh aa put_ bh ab put_ bh (CPtrDeclr ac ad ae) = do putByte bh 1 put_ bh ac put_ bh ad put_ bh ae put_ bh (CArrDeclr af ag ah ai) = do putByte bh 2 put_ bh af put_ bh ag put_ bh ah put_ bh ai put_ bh (CFunDeclr ai aj ak al) = do putByte bh 3 put_ bh ai put_ bh aj put_ bh ak put_ bh al get bh = do h <- getByte bh case h of 0 -> do aa <- get bh ab <- get bh return (CVarDeclr aa ab) 1 -> do ac <- get bh ad <- get bh ae <- get bh return (CPtrDeclr ac ad ae) 2 -> do af <- get bh ag <- get bh ah <- get bh ai <- get bh return (CArrDeclr af ag ah ai) 3 -> do ai <- get bh aj <- get bh ak <- get bh al <- get bh return (CFunDeclr ai aj ak al) instance Binary CDeclSpec where put_ bh (CStorageSpec aa) = do putByte bh 0 put_ bh aa put_ bh (CTypeSpec ab) = do putByte bh 1 put_ bh ab put_ bh (CTypeQual ac) = do putByte bh 2 put_ bh ac get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (CStorageSpec aa) 1 -> do ab <- get bh return (CTypeSpec ab) 2 -> do ac <- get bh return (CTypeQual ac) instance Binary CTypeSpec where put_ bh (CVoidType aa) = do putByte bh 0 put_ bh aa put_ bh (CCharType ab) = do putByte bh 1 put_ bh ab put_ bh (CShortType ac) = do putByte bh 2 put_ bh ac put_ bh (CIntType ad) = do putByte bh 3 put_ bh ad put_ bh (CLongType ae) = do putByte bh 4 put_ bh ae put_ bh (CFloatType af) = do putByte bh 5 put_ bh af put_ bh (CDoubleType ag) = do putByte bh 6 put_ bh ag put_ bh (CSignedType ah) = do putByte bh 7 put_ bh ah put_ bh (CUnsigType ai) = do putByte bh 8 put_ bh ai put_ bh (CSUType aj ak) = do putByte bh 9 put_ bh aj put_ bh ak put_ bh (CEnumType al am) = do putByte bh 10 put_ bh al put_ bh am put_ bh (CTypeDef an ao) = do putByte bh 11 put_ bh an put_ bh ao put_ bh (CTypeOfExpr ap aq) = do putByte bh 12 put_ bh ap put_ bh aq put_ bh (CTypeOfType ar as) = do putByte bh 13 put_ bh ar put_ bh as put_ bh (CFloat128Type at) = do putByte bh 14 put_ bh at put_ bh (CBoolType at) = do putByte bh 15 put_ bh at get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (CVoidType aa) 1 -> do ab <- get bh return (CCharType ab) 2 -> do ac <- get bh return (CShortType ac) 3 -> do ad <- get bh return (CIntType ad) 4 -> do ae <- get bh return (CLongType ae) 5 -> do af <- get bh return (CFloatType af) 6 -> do ag <- get bh return (CDoubleType ag) 7 -> do ah <- get bh return (CSignedType ah) 8 -> do ai <- get bh return (CUnsigType ai) 9 -> do aj <- get bh ak <- get bh return (CSUType aj ak) 10 -> do al <- get bh am <- get bh return (CEnumType al am) 11 -> do an <- get bh ao <- get bh return (CTypeDef an ao) 12 -> do ap <- get bh aq <- get bh return (CTypeOfExpr ap aq) 13 -> do ar <- get bh as <- get bh return (CTypeOfType ar as) 14 -> do at <- get bh return (CFloat128Type at) 15 -> do at <- get bh return (CBoolType at) instance Binary CStorageSpec where put_ bh (CAuto aa) = do putByte bh 0 put_ bh aa put_ bh (CRegister ab) = do putByte bh 1 put_ bh ab put_ bh (CStatic ac) = do putByte bh 2 put_ bh ac put_ bh (CExtern ad) = do putByte bh 3 put_ bh ad put_ bh (CTypedef ae) = do putByte bh 4 put_ bh ae get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (CAuto aa) 1 -> do ab <- get bh return (CRegister ab) 2 -> do ac <- get bh return (CStatic ac) 3 -> do ad <- get bh return (CExtern ad) 4 -> do ae <- get bh return (CTypedef ae) instance Binary CTypeQual where put_ bh (CConstQual aa) = do putByte bh 0 put_ bh aa put_ bh (CVolatQual ab) = do putByte bh 1 put_ bh ab put_ bh (CRestrQual ac) = do putByte bh 2 put_ bh ac put_ bh (CInlinQual ad) = do putByte bh 3 put_ bh ad get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (CConstQual aa) 1 -> do ab <- get bh return (CVolatQual ab) 2 -> do ac <- get bh return (CRestrQual ac) 3 -> do ad <- get bh return (CInlinQual ad) instance Binary CConst where put_ bh (CIntConst aa ab) = do putByte bh 0 put_ bh aa put_ bh ab put_ bh (CCharConst ac ad) = do putByte bh 1 put_ bh ac put_ bh ad put_ bh (CFloatConst ae af) = do putByte bh 2 put_ bh ae put_ bh af put_ bh (CStrConst ag ah) = do putByte bh 3 put_ bh ag put_ bh ah get bh = do h <- getByte bh case h of 0 -> do aa <- get bh ab <- get bh return (CIntConst aa ab) 1 -> do ac <- get bh ad <- get bh return (CCharConst ac ad) 2 -> do ae <- get bh af <- get bh return (CFloatConst ae af) 3 -> do ag <- get bh ah <- get bh return (CStrConst ag ah) instance Binary CUnaryOp where put_ bh CPreIncOp = putByte bh 0 put_ bh CPreDecOp = putByte bh 1 put_ bh CPostIncOp = putByte bh 2 put_ bh CPostDecOp = putByte bh 3 put_ bh CAdrOp = putByte bh 4 put_ bh CIndOp = putByte bh 5 put_ bh CPlusOp = putByte bh 6 put_ bh CMinOp = putByte bh 7 put_ bh CCompOp = putByte bh 8 put_ bh CNegOp = putByte bh 9 get bh = do h <- getByte bh case h of 0 -> return CPreIncOp 1 -> return CPreDecOp 2 -> return CPostIncOp 3 -> return CPostDecOp 4 -> return CAdrOp 5 -> return CIndOp 6 -> return CPlusOp 7 -> return CMinOp 8 -> return CCompOp 9 -> return CNegOp instance Binary CBinaryOp where put_ bh CMulOp = putByte bh 0 put_ bh CDivOp = putByte bh 1 put_ bh CRmdOp = putByte bh 2 put_ bh CAddOp = putByte bh 3 put_ bh CSubOp = putByte bh 4 put_ bh CShlOp = putByte bh 5 put_ bh CShrOp = putByte bh 6 put_ bh CLeOp = putByte bh 7 put_ bh CGrOp = putByte bh 8 put_ bh CLeqOp = putByte bh 9 put_ bh CGeqOp = putByte bh 10 put_ bh CEqOp = putByte bh 11 put_ bh CNeqOp = putByte bh 12 put_ bh CAndOp = putByte bh 13 put_ bh CXorOp = putByte bh 14 put_ bh COrOp = putByte bh 15 put_ bh CLndOp = putByte bh 16 put_ bh CLorOp = putByte bh 17 get bh = do h <- getByte bh case h of 0 -> return CMulOp 1 -> return CDivOp 2 -> return CRmdOp 3 -> return CAddOp 4 -> return CSubOp 5 -> return CShlOp 6 -> return CShrOp 7 -> return CLeOp 8 -> return CGrOp 9 -> return CLeqOp 10 -> return CGeqOp 11 -> return CEqOp 12 -> return CNeqOp 13 -> return CAndOp 14 -> return CXorOp 15 -> return COrOp 16 -> return CLndOp 17 -> return CLorOp instance Binary CAssignOp where put_ bh CAssignOp = putByte bh 0 put_ bh CMulAssOp = putByte bh 1 put_ bh CDivAssOp = putByte bh 2 put_ bh CRmdAssOp = putByte bh 3 put_ bh CAddAssOp = putByte bh 4 put_ bh CSubAssOp = putByte bh 5 put_ bh CShlAssOp = putByte bh 6 put_ bh CShrAssOp = putByte bh 7 put_ bh CAndAssOp = putByte bh 8 put_ bh CXorAssOp = putByte bh 9 put_ bh COrAssOp = putByte bh 10 get bh = do h <- getByte bh case h of 0 -> return CAssignOp 1 -> return CMulAssOp 2 -> return CDivAssOp 3 -> return CRmdAssOp 4 -> return CAddAssOp 5 -> return CSubAssOp 6 -> return CShlAssOp 7 -> return CShrAssOp 8 -> return CAndAssOp 9 -> return CXorAssOp 10 -> return COrAssOp gtk2hs-buildtools-0.13.10.0/c2hs/c/CAttrs.hs0000644000000000000000000004032607346545000016405 0ustar0000000000000000-- C->Haskell Compiler: C attribute definitions and manipulation routines -- -- Author : Manuel M. T. Chakravarty -- Created: 12 August 99 -- -- Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:27 $ -- -- 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 CAttrs (-- attributed C -- AttrC, attrC, getCHeader, 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.List (isPrefixOf) import Data.Maybe (mapMaybe) import Position (Position, Pos(posOf), nopos, dontCarePos, builtinPos) import Errors (interr) import Idents (Ident, getIdentAttrs, identToLexeme, onlyPosIdent) import Attributes (Attr(..), AttrTable, getAttr, setAttr, updAttr, newAttrTable, freezeAttrTable, softenAttrTable) import NameSpaces (NameSpace, nameSpace, enterNewRange, leaveRange, defLocal, defGlobal, find, nameSpaceToList) import Binary (Binary(..), putByte, getByte) import CAST -- attributed C structure tree -- --------------------------- -- C unit together with the attributes relevant to the outside world -- (EXPORTED ABSTRACT) -- data AttrC = AttrC { headerAC :: CHeader, -- raw header defObjsAC :: CObjNS, -- defined objects defTagsAC :: CTagNS, -- defined tags shadowsAC :: CShadowNS, -- shadow definitions (prefix) defsAC :: CDefTable -- ident-def associations } -- make an attribute structure tree from a raw one (EXPORTED) -- attrC :: CHeader -> AttrC attrC header = AttrC { headerAC = header, defObjsAC = cObjNS, defTagsAC = cTagNS, shadowsAC = cShadowNS, defsAC = cDefTable } -- extract the raw structure tree from an attributes one (EXPORTED) -- getCHeader :: AttrC -> CHeader getCHeader = headerAC -- the name space operations -- -- enter a new range (EXPORTED) -- enterNewRangeC :: AttrC -> AttrC enterNewRangeC ac = ac { defObjsAC = enterNewRange . defObjsAC $ ac, defTagsAC = enterNewRange . defTagsAC $ ac } -- enter a new range, only for objects (EXPORTED) -- enterNewObjRangeC :: AttrC -> AttrC enterNewObjRangeC ac = ac { defObjsAC = enterNewRange . defObjsAC $ ac } -- leave the current range (EXPORTED) -- leaveRangeC :: AttrC -> AttrC leaveRangeC ac = ac { defObjsAC = fst . leaveRange . defObjsAC $ ac, defTagsAC = fst . leaveRange . defTagsAC $ ac } -- leave the current range, only for objects (EXPORTED) -- leaveObjRangeC :: AttrC -> AttrC leaveObjRangeC ac = ac { defObjsAC = fst . leaveRange . defObjsAC $ ac } -- add another definitions to the object name space (EXPORTED) -- -- * 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 (EXPORTED) -- 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 (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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 (EXPORTED) -- 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 (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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 prefix ide = case eat prefix (identToLexeme ide) of Nothing -> Nothing Just "" -> Nothing Just newName -> Just (onlyPosIdent (posOf ide) newName, ide) -- eat [] ('_':cs) = eat [] cs eat [] cs = Just cs eat (p:prefix) (c:cs) | toUpper p == toUpper c = eat prefix 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 (EXPORTED) -- getDefOfIdentC :: AttrC -> Ident -> CDef getDefOfIdentC ac = getAttr (defsAC ac) . getIdentAttrs setDefOfIdentC :: AttrC -> Ident -> CDef -> AttrC setDefOfIdentC ac id def = let tot' = setAttr (defsAC ac) (getIdentAttrs id) def in ac {defsAC = tot'} updDefOfIdentC :: AttrC -> Ident -> CDef -> AttrC updDefOfIdentC ac id def = let tot' = updAttr (defsAC ac) (getIdentAttrs id) 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)} -- C objects including operations -- ------------------------------ -- C objects data definition (EXPORTED) -- data CObj = TypeCO CDecl -- typedef declaration | ObjCO CDecl -- object or function declaration | EnumCO Ident CEnum -- enumerator | BuiltinCO -- builtin object -- 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 == decl2 (ObjCO decl1 ) == (ObjCO decl2 ) = decl1 == decl2 (EnumCO ide1 enum1) == (EnumCO ide2 enum2) = ide1 == ide2 && enum1 == 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 (EXPORTED) -- data CTag = StructUnionCT CStructUnion -- toplevel struct-union declaration | EnumCT CEnum -- toplevel enum declaration -- 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 == struct2 (EnumCT enum1 ) == (EnumCT enum2 ) = enum1 == enum2 _ == _ = False instance Pos CTag where posOf (StructUnionCT def) = posOf def posOf (EnumCT def) = posOf def -- C general definition -- -------------------- -- C general definition (EXPORTED) -- data CDef = UndefCD -- undefined object | DontCareCD -- don't care object | ObjCD CObj -- C object | TagCD CTag -- C tag -- 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 = dontCarePos posOf (ObjCD obj) = posOf obj posOf (TagCD tag) = posOf tag -- object tables (internal use only) -- --------------------------------- -- the object name space -- 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" {-! for AttrC derive : GhcBinary !-} {-! for CObj derive : GhcBinary !-} {-! for CTag derive : GhcBinary !-} {-! for CDef derive : GhcBinary !-} {-* Generated by DrIFT : Look, but Don't Touch. *-} instance Binary AttrC where put_ bh (AttrC aa ab ac ad ae) = do -- put_ bh aa put_ bh ab put_ bh ac put_ bh ad put_ bh ae get bh = do -- aa <- get bh ab <- get bh ac <- get bh ad <- get bh ae <- get bh return (AttrC (error "AttrC.headerAC should not be needed") ab ac ad ae) instance Binary CObj where put_ bh (TypeCO aa) = do putByte bh 0 put_ bh aa put_ bh (ObjCO ab) = do putByte bh 1 put_ bh ab put_ bh (EnumCO ac ad) = do putByte bh 2 put_ bh ac put_ bh ad put_ bh BuiltinCO = do putByte bh 3 get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (TypeCO aa) 1 -> do ab <- get bh return (ObjCO ab) 2 -> do ac <- get bh ad <- get bh return (EnumCO ac ad) 3 -> do return BuiltinCO instance Binary CTag where put_ bh (StructUnionCT aa) = do putByte bh 0 put_ bh aa put_ bh (EnumCT ab) = do putByte bh 1 put_ bh ab get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (StructUnionCT aa) 1 -> do ab <- get bh return (EnumCT ab) instance Binary CDef where put_ bh UndefCD = do putByte bh 0 put_ bh DontCareCD = do putByte bh 1 put_ bh (ObjCD aa) = do putByte bh 2 put_ bh aa put_ bh (TagCD ab) = do putByte bh 3 put_ bh ab get bh = do h <- getByte bh case h of 0 -> do return UndefCD 1 -> do return DontCareCD 2 -> do aa <- get bh return (ObjCD aa) 3 -> do ab <- get bh return (TagCD ab) gtk2hs-buildtools-0.13.10.0/c2hs/c/CBuiltin.hs0000644000000000000000000000273407346545000016717 0ustar0000000000000000-- C->Haskell Compiler: C builtin information -- -- Author : Manuel M. T. Chakravarty -- Created: 12 February 01 -- -- Version $Revision: 1.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 --------------------------------------------------------------- -- -- 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 CBuiltin ( builtinTypeNames ) where import Position (Position, Pos(..), builtinPos) import Idents (Ident, onlyPosIdent) import CAttrs (CObj(BuiltinCO)) -- predefined type names -- builtinTypeNames :: [(Ident, CObj)] builtinTypeNames = [(onlyPosIdent builtinPos "__builtin_va_list", BuiltinCO)] gtk2hs-buildtools-0.13.10.0/c2hs/c/CLexer.x0000644000000000000000000003726307346545000016232 0ustar0000000000000000-- C -> Haskell Compiler: Lexer for C Header Files -- -- Author : Manuel M T Chakravarty, Duncan Coutts -- Created: 24 May 2005 -- -- Version $Revision: 1.1.2.1 $ from $Date: 2005/06/14 00:16:14 $ -- -- Copyright (c) [1999..2004] Manuel M T Chakravarty -- Copyright (c) 2005 Duncan Coutts -- -- 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 C header files after being processed by the C preprocessor -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- We assume that the input already went through cpp. Thus, we do not handle -- comments and preprocessor directives here. The lexer recognizes all tokens -- of ANCI C except those occurring only in function bodies. It supports the -- C99 `restrict' extension: as -- well as inline functions. -- -- Comments: -- -- * There is no support for the optional feature of extended characters (see -- K&R A2.5.2) or the corresponding strings (A2.6). -- -- * We add `typedef-name' (K&R 8.9) as a token, as proposed in K&R A13. -- However, as these tokens cannot be recognized lexically, but require a -- context analysis, they are never produced by the lexer, but instead have -- to be introduced in a later phase (by converting the corresponding -- identifiers). -- -- * We also recognize GNU C `__attribute__', `__extension__', `__const', -- `__const__', `__inline', `__inline__', `__restrict', and `__restrict__'. -- -- * Any line starting with `#pragma' is ignored. -- -- With K&R we refer to ``The C Programming Language'', second edition, Brain -- W. Kernighan and Dennis M. Ritchie, Prentice Hall, 1988. -- --- TODO ---------------------------------------------------------------------- -- -- * `showsPrec' of `CTokCLit' should produce K&R-conforming escapes; -- same for `CTokSLit' -- -- * There are more GNU C specific keywords. Add them and change `CParser' -- correspondingly (in particular, most tokens within __attribute ((...)) -- expressions are actually keywords, but we handle them as identifiers at -- the moment). -- { module CLexer (lexC, parseError) where import Data.Char (isDigit, ord) import Data.Word (Word8) import Numeric (readDec, readOct, readHex) import Position (Position(..), Pos(posOf)) import Errors (interr) import UNames (Name) import Idents (Ident, lexemeToIdent, identToLexeme) import CTokens import CParserMonad } $space = [ \ \t ] -- horizontal white space $eol = \n $letter = [a-zA-Z_] $octdigit = 0-7 $digit = 0-9 $digitNZ = 1-9 $hexdigit = [0-9a-fA-F] $inchar = \0-\255 # [ \\ \' \n \r ] $instr = \0-\255 # [ \\ \" \n \r ] $anyButNL = \0-\255 # \n $infname = \ -\255 # [ \\ \" ] $visible = \ -\127 @int = $digitNZ$digit* @sp = $space* -- character escape sequence (follows K&R A2.5.2) -- -- * also used for strings -- @charesc = \\([ntvbrfae\\\?\'\"]|$octdigit{1,3}|x$hexdigit+) -- components of float constants (follows K&R A2.5.3) -- @digits = $digit+ @intpart = @digits @fractpart = @digits @mantpart = @intpart?\.@fractpart|@intpart\. @exppart = [eE][\+\-]?@digits @suffix = [fFlLqQwW] tokens :- -- whitespace (follows K&R A2.1) -- -- * horizontal and vertical tabs, newlines, and form feeds are filter out by -- `Lexers.ctrlLexer' -- -- * comments are not handled, as we assume the input already went through cpp -- $white+ ; -- #line directive (K&R A12.6) -- -- * allows further ints after the file name a la GCC; as the GCC CPP docu -- doesn't say how many ints there can be, we allow an unbound number -- \#$space*@digits$space*(\"($infname|@charesc)*\"$space*)?(@int$space*)*$eol { \pos len str -> setPos (adjustPos (take len str) pos) >> lexToken } -- #pragma directive (K&R A12.8) -- -- * we simply ignore any #pragma (but take care to update the position -- information) -- \#$space*pragma$anyButNL*$eol ; -- #itent directive, eg used by rcs/cvs -- -- * we simply ignore any #itent (but take care to update the position -- information) -- \#$space*ident$anyButNL*$eol ; -- identifiers and keywords (follows K&R A2.3 and A2.4) -- $letter($letter|$digit)* { \pos len str -> idkwtok (take len str) pos } -- constants (follows K&R A2.5) -- -- * K&R explicit mentions `enumeration-constants'; however, as they are -- lexically identifiers, we do not have an extra case for them -- -- integer constants (follows K&R A2.5.1) -- 0$octdigit*[uUlL]{0,3} { token CTokILit (fst . head . readOct) } $digitNZ$digit*[uUlL]{0,3} { token CTokILit (fst . head . readDec) } 0[xX]$hexdigit*[uUlL]{0,3} { token CTokILit (fst . head . readHex . drop 2) } -- character constants (follows K&R A2.5.2) -- \'($inchar|@charesc)\' { token CTokCLit (fst . oneChar . tail) } L\'($inchar|@charesc)\' { token CTokCLit (fst . oneChar . tail . tail) } -- float constants (follows K&R A2.5.3) -- (@mantpart@exppart?|@intpart@exppart)@suffix? { token CTokFLit id } -- string literal (follows K&R A2.6) -- \"($instr|@charesc)*\" { token CTokSLit normalizeEscapes } L\"($instr|@charesc)*\" { token CTokSLit (normalizeEscapes . tail) } -- operators and separators -- "(" { token_ CTokLParen } ")" { token_ CTokRParen } "[" { token_ CTokLBracket } "]" { token_ CTokRBracket } "->" { token_ CTokArrow } "." { token_ CTokDot } "!" { token_ CTokExclam } "~" { token_ CTokTilde } "++" { token_ CTokInc } "--" { token_ CTokDec } "+" { token_ CTokPlus } "-" { token_ CTokMinus } "*" { token_ CTokStar } "/" { token_ CTokSlash } "%" { token_ CTokPercent } "&" { token_ CTokAmper } "<<" { token_ CTokShiftL } ">>" { token_ CTokShiftR } "<" { token_ CTokLess } "<=" { token_ CTokLessEq } ">" { token_ CTokHigh } ">=" { token_ CTokHighEq } "==" { token_ CTokEqual } "!=" { token_ CTokUnequal } "^" { token_ CTokHat } "|" { token_ CTokBar } "&&" { token_ CTokAnd } "||" { token_ CTokOr } "?" { token_ CTokQuest } ":" { token_ CTokColon } "=" { token_ CTokAssign } "+=" { token_ CTokPlusAss } "-=" { token_ CTokMinusAss } "*=" { token_ CTokStarAss } "/=" { token_ CTokSlashAss } "%=" { token_ CTokPercAss } "&=" { token_ CTokAmpAss } "^=" { token_ CTokHatAss } "|=" { token_ CTokBarAss } "<<=" { token_ CTokSLAss } ">>=" { token_ CTokSRAss } "," { token_ CTokComma } \; { token_ CTokSemic } "{" { token_ CTokLBrace } "}" { token_ CTokRBrace } "..." { token_ CTokEllipsis } { -- We use the odd looking list of string patterns here rather than normal -- string literals since GHC converts the latter into a sequence of string -- comparisons (ie a linear search) but it translates the former using its -- efficient pattern matching which gives us the expected radix-style search. -- This gives change makes a significant performance difference. -- idkwtok :: String -> Position -> P CToken idkwtok ('a':'l':'i':'g':'n':'o':'f':[]) = tok CTokAlignof idkwtok ('_':'_':'a':'l':'i':'g':'n':'o':'f':[]) = tok CTokAlignof idkwtok ('_':'_':'a':'l':'i':'g':'n':'o':'f':'_':'_':[]) = tok CTokAlignof idkwtok ('a':'s':'m':[]) = tok CTokAsm idkwtok ('_':'_':'a':'s':'m':[]) = tok CTokAsm idkwtok ('_':'_':'a':'s':'m':'_':'_':[]) = tok CTokAsm idkwtok ('a':'u':'t':'o':[]) = tok CTokAuto idkwtok ('b':'r':'e':'a':'k':[]) = tok CTokBreak idkwtok ('_':'B':'o':'o':'l':[]) = tok CTokBool idkwtok ('c':'a':'s':'e':[]) = tok CTokCase idkwtok ('c':'h':'a':'r':[]) = tok CTokChar idkwtok ('c':'o':'n':'s':'t':[]) = tok CTokConst idkwtok ('_':'_':'c':'o':'n':'s':'t':[]) = tok CTokConst idkwtok ('_':'_':'c':'o':'n':'s':'t':'_':'_':[]) = tok CTokConst idkwtok ('c':'o':'n':'t':'i':'n':'u':'e':[]) = tok CTokContinue idkwtok ('_':'C':'o':'m':'p':'l':'e':'x':[]) = tok CTokComplex idkwtok ('d':'e':'f':'a':'u':'l':'t':[]) = tok CTokDefault idkwtok ('d':'o':[]) = tok CTokDo idkwtok ('d':'o':'u':'b':'l':'e':[]) = tok CTokDouble idkwtok ('e':'l':'s':'e':[]) = tok CTokElse idkwtok ('e':'n':'u':'m':[]) = tok CTokEnum idkwtok ('e':'x':'t':'e':'r':'n':[]) = tok CTokExtern idkwtok ('_':'_':'f':'l':'o':'a':'t':'1':'2':'8':[]) = tok CTokFloat128 idkwtok ('f':'l':'o':'a':'t':[]) = tok CTokFloat idkwtok ('f':'o':'r':[]) = tok CTokFor idkwtok ('g':'o':'t':'o':[]) = tok CTokGoto idkwtok ('i':'f':[]) = tok CTokIf idkwtok ('i':'n':'l':'i':'n':'e':[]) = tok CTokInline idkwtok ('_':'_':'i':'n':'l':'i':'n':'e':[]) = tok CTokInline idkwtok ('_':'_':'i':'n':'l':'i':'n':'e':'_':'_':[]) = tok CTokInline idkwtok ('i':'n':'t':[]) = tok CTokInt idkwtok ('_':'_':'u':'i':'n':'t':'1':'2':'8':'_':'t':[]) = tok CTokInt idkwtok ('_':'_':'i':'n':'t':'1':'2':'8':'_':'t':[]) = tok CTokInt idkwtok ('_':'_':'u':'i':'n':'t':'1':'2':'8':[]) = tok CTokInt idkwtok ('_':'_':'i':'n':'t':'1':'2':'8':[]) = tok CTokInt idkwtok ('l':'o':'n':'g':[]) = tok CTokLong idkwtok ('r':'e':'g':'i':'s':'t':'e':'r':[]) = tok CTokRegister idkwtok ('r':'e':'s':'t':'r':'i':'c':'t':[]) = tok CTokRestrict idkwtok ('_':'_':'r':'e':'s':'t':'r':'i':'c':'t':[]) = tok CTokRestrict idkwtok ('_':'_':'r':'e':'s':'t':'r':'i':'c':'t':'_':'_':[]) = tok CTokRestrict idkwtok ('r':'e':'t':'u':'r':'n':[]) = tok CTokReturn idkwtok ('s':'h':'o':'r':'t':[]) = tok CTokShort idkwtok ('s':'i':'g':'n':'e':'d':[]) = tok CTokSigned idkwtok ('_':'_':'s':'i':'g':'n':'e':'d':[]) = tok CTokSigned idkwtok ('_':'_':'s':'i':'g':'n':'e':'d':'_':'_':[]) = tok CTokSigned idkwtok ('s':'i':'z':'e':'o':'f':[]) = tok CTokSizeof idkwtok ('s':'t':'a':'t':'i':'c':[]) = tok CTokStatic idkwtok ('s':'t':'r':'u':'c':'t':[]) = tok CTokStruct idkwtok ('s':'w':'i':'t':'c':'h':[]) = tok CTokSwitch idkwtok ('t':'y':'p':'e':'d':'e':'f':[]) = tok CTokTypedef idkwtok ('t':'y':'p':'e':'o':'f':[]) = tok CTokTypeof idkwtok ('_':'_':'t':'y':'p':'e':'o':'f':[]) = tok CTokTypeof idkwtok ('_':'_':'t':'y':'p':'e':'o':'f':'_':'_':[]) = tok CTokTypeof idkwtok ('_':'_':'t':'h':'r':'e':'a':'d':[]) = tok CTokThread idkwtok ('u':'n':'i':'o':'n':[]) = tok CTokUnion idkwtok ('u':'n':'s':'i':'g':'n':'e':'d':[]) = tok CTokUnsigned idkwtok ('v':'o':'i':'d':[]) = tok CTokVoid idkwtok ('v':'o':'l':'a':'t':'i':'l':'e':[]) = tok CTokVolatile idkwtok ('_':'_':'v':'o':'l':'a':'t':'i':'l':'e':[]) = tok CTokVolatile idkwtok ('_':'_':'v':'o':'l':'a':'t':'i':'l':'e':'_':'_':[]) = tok CTokVolatile idkwtok ('w':'h':'i':'l':'e':[]) = tok CTokWhile idkwtok ('_':'_':'l':'a':'b':'e':'l':'_':'_':[]) = tok CTokLabel idkwtok ('_':'_':'a':'t':'t':'r':'i':'b':'u':'t':'e':[]) = tok (CTokGnuC GnuCAttrTok) -- ignoreAttribute >> lexToken idkwtok ('_':'_':'a':'t':'t':'r':'i':'b':'u':'t':'e':'_':'_':[]) = tok (CTokGnuC GnuCAttrTok) -- ignoreAttribute >> lexToken idkwtok ('_':'_':'e':'x':'t':'e':'n':'s':'i':'o':'n':'_':'_':[]) = tok (CTokGnuC GnuCExtTok) idkwtok ('_':'_':'b':'u':'i':'l':'t':'i':'n':'_':rest) | rest == "va_arg" = tok (CTokGnuC GnuCVaArg) | rest == "offsetof" = tok (CTokGnuC GnuCOffsetof) | rest == "types_compatible_p" = tok (CTokGnuC GnuCTyCompat) idkwtok cs = \pos -> do name <- getNewName let ident = lexemeToIdent pos cs name tyident <- isTypeIdent ident if tyident then return (CTokTyIdent pos ident) else return (CTokIdent pos ident) ignoreAttribute :: P () ignoreAttribute = skipTokens 0 where skipTokens n = do tok <- lexToken case tok of CTokRParen _ | n == 1 -> return () | otherwise -> skipTokens (n-1) CTokLParen _ -> skipTokens (n+1) _ -> skipTokens n tok :: (Position -> CToken) -> Position -> P CToken tok tc pos = return (tc pos) -- converts the first character denotation of a C-style string to a character -- and the remaining string -- oneChar :: String -> (Char, String) oneChar ('\\':c:cs) = case c of 'n' -> ('\n', cs) 't' -> ('\t', cs) 'v' -> ('\v', cs) 'b' -> ('\b', cs) 'r' -> ('\r', cs) 'f' -> ('\f', cs) 'a' -> ('\a', cs) 'e' -> ('\ESC', cs) --GNU C extension '\\' -> ('\\', cs) '?' -> ('?', cs) '\'' -> ('\'', cs) '"' -> ('"', cs) 'x' -> case head (readHex cs) of (i, cs') -> (toEnum i, cs') _ -> case head (readOct (c:cs)) of (i, cs') -> (toEnum i, cs') oneChar (c :cs) = (c, cs) normalizeEscapes [] = [] normalizeEscapes cs = case oneChar cs of (c, cs') -> c : normalizeEscapes cs' adjustPos :: String -> Position -> Position adjustPos str (Position fname row _) = Position fname' row' 0 where str' = dropWhite . drop 1 $ 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') {-# INLINE token_ #-} -- token that ignores the string token_ :: (Position -> CToken) -> Position -> Int -> String -> P CToken token_ tok pos _ _ = return (tok pos) {-# INLINE token #-} -- token that uses the string token :: (Position -> a -> CToken) -> (String -> a) -> Position -> Int -> String -> P CToken token tok read pos len str = return (tok pos (read $ take len str)) -- ----------------------------------------------------------------------------- -- The input type type AlexInput = (Position, -- current position, String) -- current input string alexInputPrevChar :: AlexInput -> Char alexInputPrevChar _ = error "alexInputPrevChar not used" -- For alex >= 3.0 alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) alexGetByte (p,[]) = Nothing alexGetByte (p,(c:s)) = let p' = alexMove p c in p' `seq` Just (fromIntegral $ ord c, (p', s)) -- For alex < 3.0 alexGetChar :: AlexInput -> Maybe (Char,AlexInput) alexGetChar (p,[]) = Nothing alexGetChar (p,(c:s)) = let p' = alexMove p c in p' `seq` Just (c, (p', s)) alexMove :: Position -> Char -> Position alexMove (Position f l c) '\t' = Position f l (((c+7) `div` 8)*8+1) alexMove (Position f l c) '\n' = Position f (l+1) 1 alexMove (Position f l c) _ = Position f l (c+1) lexicalError :: P a lexicalError = do pos <- getPos (c:cs) <- getInput failP pos ["Lexical error!", "The character " ++ show c ++ " does not fit here."] parseError :: P a parseError = do tok <- getLastToken failP (posOf tok) ["Syntax error!", "The symbol `" ++ show tok ++ "' does not fit here."] lexToken :: P CToken lexToken = do pos <- getPos inp <- getInput case alexScan (pos, inp) 0 of AlexEOF -> return CTokEof AlexError inp' -> lexicalError AlexSkip (pos', inp') len -> do setPos pos' setInput inp' lexToken AlexToken (pos', inp') len action -> do setPos pos' setInput inp' tok <- action pos len inp setLastToken tok return tok lexC :: (CToken -> P a) -> P a lexC cont = do tok <- lexToken cont tok } gtk2hs-buildtools-0.13.10.0/c2hs/c/CNames.hs0000644000000000000000000001676207346545000016362 0ustar0000000000000000-- C->Haskell Compiler: C name analysis -- -- Author : Manuel M. T. Chakravarty -- Created: 16 October 99 -- -- Version $Revision: 1.2 $ from $Date: 2005/07/29 01:26:56 $ -- -- 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 CNames (nameAnalysis) where import Control.Monad (when, mapM_) import Position (Position, posOf) import Idents (Ident, identToLexeme) import C2HSState (CST, nop) import CAST import CAttrs (AttrC, CObj(..), CTag(..), CDef(..)) import CBuiltin (builtinTypeNames) import CTrav (CT, getCHeaderCT, runCT, enter, enterObjs, leave, leaveObjs, ifCTExc, raiseErrorCTExc, defObj, findTypeObj, findValueObj, defTag, refersToDef, isTypedef) -- monad and wrapper -- ----------------- -- local instance of the C traversal monad -- type NA a = CT () a -- name analysis of C header files (EXPORTED) -- nameAnalysis :: AttrC -> CST s AttrC nameAnalysis ac = do (ac', _) <- runCT naCHeader ac () return ac' -- name analyis traversal -- ---------------------- -- traverse a complete header file -- -- * in case of an error, back off the current declaration -- naCHeader :: NA () naCHeader = do -- establish definitions for builtins -- mapM_ (uncurry defObjOrErr) builtinTypeNames -- -- analyse the header -- CHeader decls _ <- getCHeaderCT mapM_ (\decl -> naCExtDecl decl `ifCTExc` nop) 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 (CAsmExt at ) = 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 _ = nop 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 _ = nop naCStructUnion :: CTag -> CStructUnion -> NA () naCStructUnion tag (CStruct _ oide decls _) = do mapMaybeM_ (`defTagOrErr` tag) oide enterObjs -- enter local struct range for objects mapM_ naCDecl decls leaveObjs -- leave range naCEnum :: CTag -> CEnum -> NA () naCEnum tag enum@(CEnum oide enumrs _) = do mapMaybeM_ (`defTagOrErr` tag) oide mapM_ naEnumr enumrs where naEnumr (ide, oexpr) = do ide `defObjOrErr` EnumCO ide enum mapMaybeM_ naCExpr oexpr naCDeclr :: CObj -> CDeclr -> NA () naCDeclr obj (CVarDeclr oide _) = mapMaybeM_ (`defObjOrErr` obj) oide naCDeclr obj (CPtrDeclr _ declr _ ) = naCDeclr obj declr naCDeclr obj (CArrDeclr declr _ oexpr _ ) = do naCDeclr obj declr mapMaybeM_ naCExpr oexpr naCDeclr obj (CFunDeclr declr decls _ _ ) = do naCDeclr obj declr enterObjs -- enter range of function arguments mapM_ naCDecl decls leaveObjs -- end of function arguments 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 _ _) = nop naCExpr (CCompoundLit _ inits _) = mapM_ (naCInit . snd) inits -- 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 -> nop 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 >> nop -- maps some monad operation into a `Maybe', discarding the result -- mapMaybeM_ :: Monad m => (a -> m b) -> Maybe a -> m () mapMaybeM_ m 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 `" ++ identToLexeme ide ++ "' was already declared at " ++ show otherPos ++ "."] gtk2hs-buildtools-0.13.10.0/c2hs/c/CParser.y0000644000000000000000000015433207346545000016405 0ustar0000000000000000-- C -> Haskell Compiler: Parser for C Header Files -- -- Author : Duncan Coutts, Manuel M T Chakravarty -- Created: 29 May 2005 -- -- Copyright (c) 2005-2007 Duncan Coutts -- Copyright (c) [1999..2004] Manuel M T Chakravarty -- Portions Copyright (c) 1989, 1990 James A. Roskind -- -- 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 --------------------------------------------------------------- -- -- Parser for C translation units, which have already been run through the C -- preprocessor. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- The parser recognizes all of ISO C 99 and most common GNU C extensions. -- -- With C99 we refer to the ISO C99 standard, specifically the section numbers -- used below refer to this report: -- -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf -- -- -- Since some of the grammar productions are quite difficult to read -- (especially those involved with the decleration syntax) we document them -- with an extended syntax that allows a more consise representation: -- -- Ordinary rules -- -- foo named terminal or non-terminal -- -- 'c' terminal, literal character token -- -- A B concatenation -- -- A | B alternation -- -- (A) grouping -- -- Extended rules -- -- A? optional, short hand for (A|) or [A]{ 0==A || 1==A } -- -- ... stands for some part of the grammar omitted for clarity -- -- [A] represents sequences, 0 or more. -- -- [A]{C} sequences with some constraint, usually on the number of -- terminals or non-terminals appearing in the sequence. -- -- Constraints on sequences -- -- n==t terminal or non-terminal t must appear exactly n times -- -- n>=t terminal or non-terminal t must appear at least n times -- -- C1 && C1 conjunction of constraints -- -- C1 || C2 disjunction of constraints -- -- C1 |x| C2 exclusive disjunction of constraints -- -- -- Comments: -- -- * Subtrees representing empty declarators of the form `CVarDeclr Nothing -- at' have *no* valid attribute handle in `at' (only a `newAttrsOnlyPos -- nopos'). -- -- * Builtin type names are imported from `CBuiltin'. -- --- TODO ---------------------------------------------------------------------- -- -- * GNUC __attribute__s should be enetered into the parse tree since they -- contain useful api/abi information. -- -- * Some other extensions are currently recognised by the parser but not -- entered into the parse tree. -- { {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -w #-} module CParser (parseC) where import Prelude hiding (reverse) import qualified Data.List as List import Position (Position, Pos(..), nopos) import UNames (names) import Idents (Ident) import Attributes (Attrs, newAttrs, newAttrsOnlyPos) import State (PreCST, raiseFatal, getNameSupply) import CLexer (lexC, parseError) import CAST (CHeader(..), CExtDecl(..), CFunDef(..), CStat(..), CBlockItem(..), CDecl(..), CDeclSpec(..), CStorageSpec(..), CTypeSpec(..), CTypeQual(..), CStructUnion(..), CStructTag(..), CEnum(..), CDeclr(..), CInit(..), CInitList, CDesignator(..), CExpr(..), CAssignOp(..), CBinaryOp(..), CUnaryOp(..), CConst (..)) import CBuiltin (builtinTypeNames) import CTokens (CToken(..), GnuCTok(..)) import CParserMonad (P, execParser, getNewName, addTypedef, shadowTypedef, enterScope, leaveScope ) } %name header header %tokentype { CToken } %monad { P } { >>= } { return } %lexer { lexC } { CTokEof } %expect 1 %token '(' { CTokLParen _ } ')' { CTokRParen _ } '[' { CTokLBracket _ } ']' { CTokRBracket _ } "->" { CTokArrow _ } '.' { CTokDot _ } '!' { CTokExclam _ } '~' { CTokTilde _ } "++" { CTokInc _ } "--" { CTokDec _ } '+' { CTokPlus _ } '-' { CTokMinus _ } '*' { CTokStar _ } '/' { CTokSlash _ } '%' { CTokPercent _ } '&' { CTokAmper _ } "<<" { CTokShiftL _ } ">>" { CTokShiftR _ } '<' { CTokLess _ } "<=" { CTokLessEq _ } '>' { CTokHigh _ } ">=" { CTokHighEq _ } "==" { CTokEqual _ } "!=" { CTokUnequal _ } '^' { CTokHat _ } '|' { CTokBar _ } "&&" { CTokAnd _ } "||" { CTokOr _ } '?' { CTokQuest _ } ':' { CTokColon _ } '=' { CTokAssign _ } "+=" { CTokPlusAss _ } "-=" { CTokMinusAss _ } "*=" { CTokStarAss _ } "/=" { CTokSlashAss _ } "%=" { CTokPercAss _ } "&=" { CTokAmpAss _ } "^=" { CTokHatAss _ } "|=" { CTokBarAss _ } "<<=" { CTokSLAss _ } ">>=" { CTokSRAss _ } ',' { CTokComma _ } ';' { CTokSemic _ } '{' { CTokLBrace _ } '}' { CTokRBrace _ } "..." { CTokEllipsis _ } alignof { CTokAlignof _ } asm { CTokAsm _ } auto { CTokAuto _ } break { CTokBreak _ } "_Bool" { CTokBool _ } case { CTokCase _ } char { CTokChar _ } const { CTokConst _ } continue { CTokContinue _ } "_Complex" { CTokComplex _ } default { CTokDefault _ } do { CTokDo _ } double { CTokDouble _ } else { CTokElse _ } enum { CTokEnum _ } extern { CTokExtern _ } float { CTokFloat _ } "__float128" { CTokFloat128 _ } for { CTokFor _ } goto { CTokGoto _ } if { CTokIf _ } inline { CTokInline _ } int { CTokInt _ } long { CTokLong _ } "__label__" { CTokLabel _ } register { CTokRegister _ } restrict { CTokRestrict _ } return { CTokReturn _ } short { CTokShort _ } signed { CTokSigned _ } sizeof { CTokSizeof _ } static { CTokStatic _ } struct { CTokStruct _ } switch { CTokSwitch _ } typedef { CTokTypedef _ } typeof { CTokTypeof _ } "__thread" { CTokThread _ } union { CTokUnion _ } unsigned { CTokUnsigned _ } void { CTokVoid _ } volatile { CTokVolatile _ } while { CTokWhile _ } cchar { CTokCLit _ _ } -- character constant cint { CTokILit _ _ } -- integer constant cfloat { CTokFLit _ _ } -- float constant cstr { CTokSLit _ _ } -- string constant (no escapes) ident { CTokIdent _ $$ } -- identifier tyident { CTokTyIdent _ $$ } -- `typedef-name' identifier "__attribute__" { CTokGnuC GnuCAttrTok _ } -- special GNU C tokens "__extension__" { CTokGnuC GnuCExtTok _ } -- special GNU C tokens -- special GNU C builtin 'functions' that actually take types as parameters: "__builtin_va_arg" { CTokGnuC GnuCVaArg _ } "__builtin_offsetof" { CTokGnuC GnuCOffsetof _ } "__builtin_types_compatible_p" { CTokGnuC GnuCTyCompat _ } %% -- parse a complete C header file -- header :: { CHeader } header : translation_unit {% withAttrs $1 $ CHeader (reverse $1) } -- parse a complete C translation unit (C99 6.9) -- -- * GNU extensions: -- allow empty translation_unit -- allow redundant ';' -- translation_unit :: { Reversed [CExtDecl] } translation_unit : {- empty -} { empty } | translation_unit ';' { $1 } | translation_unit external_declaration { $1 `snoc` $2 } -- parse external C declaration (C99 6.9) -- -- * GNU extensions: -- allow extension keyword before external declaration -- asm definitions -- external_declaration :: { CExtDecl } external_declaration : attrs_opt function_definition { CFDefExt $2 } | attrs_opt declaration { CDeclExt $2 } | "__extension__" external_declaration { $2 } | asm '(' string_literal ')' ';' {% withAttrs $2 CAsmExt } -- parse C function definition (C99 6.9.1) -- function_definition :: { CFunDef } function_definition : function_declarator compound_statement {% leaveScope >> (withAttrs $1 $ CFunDef [] $1 [] $2) } | declaration_specifier function_declarator compound_statement {% leaveScope >> (withAttrs $1 $ CFunDef $1 $2 [] $3) } | type_specifier function_declarator compound_statement {% leaveScope >> (withAttrs $1 $ CFunDef $1 $2 [] $3) } | declaration_qualifier_list function_declarator compound_statement {% leaveScope >> (withAttrs $1 $ CFunDef (reverse $1) $2 [] $3) } | type_qualifier_list function_declarator compound_statement {% leaveScope >> (withAttrs $1 $ CFunDef (liftTypeQuals $1) $2 [] $3) } | old_function_declarator declaration_list compound_statement {% withAttrs $1 $ CFunDef [] $1 (reverse $2) $3 } | declaration_specifier old_function_declarator declaration_list compound_statement {% withAttrs $1 $ CFunDef $1 $2 (reverse $3) $4 } | type_specifier old_function_declarator declaration_list compound_statement {% withAttrs $1 $ CFunDef $1 $2 (reverse $3) $4 } | declaration_qualifier_list old_function_declarator declaration_list compound_statement {% withAttrs $1 $ CFunDef (reverse $1) $2 (reverse $3) $4 } | type_qualifier_list old_function_declarator declaration_list compound_statement {% withAttrs $1 $ CFunDef (liftTypeQuals $1) $2 (reverse $3) $4 } function_declarator :: { CDeclr } function_declarator : identifier_declarator {% enterScope >> doFuncParamDeclIdent $1 >> return $1 } declaration_list :: { Reversed [CDecl] } declaration_list : {- empty -} { empty } | declaration_list declaration { $1 `snoc` $2 } -- parse C statement (C99 6.8) -- -- * GNU extension: ' __asm__ (...); ' statements -- statement :: { CStat } statement : labeled_statement { $1 } | compound_statement { $1 } | expression_statement { $1 } | selection_statement { $1 } | iteration_statement { $1 } | jump_statement { $1 } | asm_statement { $1 } -- parse C labeled statement (C99 6.8.1) -- -- * GNU extension: case ranges -- labeled_statement :: { CStat } labeled_statement : identifier ':' attrs_opt statement {% withAttrs $2 $ CLabel $1 $4} | case constant_expression ':' statement {% withAttrs $1 $ CCase $2 $4 } | default ':' statement {% withAttrs $1 $ CDefault $3 } | case constant_expression "..." constant_expression ':' statement {% withAttrs $1 $ CCases $2 $4 $6 } -- parse C compound statement (C99 6.8.2) -- -- * GNU extension: '__label__ ident;' declarations -- compound_statement :: { CStat } compound_statement : '{' enter_scope block_item_list leave_scope '}' {% withAttrs $1 $ CCompound (reverse $3) } | '{' enter_scope label_declarations block_item_list leave_scope '}' {% withAttrs $1 $ CCompound (reverse $4) } -- No syntax for these, just side effecting semantic actions. -- enter_scope :: { () } enter_scope : {% enterScope } leave_scope :: { () } leave_scope : {% leaveScope } block_item_list :: { Reversed [CBlockItem] } block_item_list : {- empty -} { empty } | block_item_list block_item { $1 `snoc` $2 } block_item :: { CBlockItem } block_item : statement { CBlockStmt $1 } | nested_declaration { $1 } nested_declaration :: { CBlockItem } nested_declaration : declaration { CBlockDecl $1 } | attrs declaration { CBlockDecl $2 } | nested_function_definition { CNestedFunDef $1 } | attrs nested_function_definition { CNestedFunDef $2 } | "__extension__" nested_declaration { $2 } nested_function_definition :: { CFunDef } nested_function_definition : declaration_specifier function_declarator compound_statement {% leaveScope >> (withAttrs $1 $ CFunDef $1 $2 [] $3) } | type_specifier function_declarator compound_statement {% leaveScope >> (withAttrs $1 $ CFunDef $1 $2 [] $3) } | declaration_qualifier_list function_declarator compound_statement {% leaveScope >> (withAttrs $1 $ CFunDef (reverse $1) $2 [] $3) } | type_qualifier_list function_declarator compound_statement {% leaveScope >> (withAttrs $1 $ CFunDef (liftTypeQuals $1) $2 [] $3) } label_declarations :: { () } label_declarations : "__label__" identifier_list ';' { () } | label_declarations "__label__" identifier_list ';' { () } -- parse C expression statement (C99 6.8.3) -- expression_statement :: { CStat } expression_statement : ';' {% withAttrs $1 $ CExpr Nothing } | expression ';' {% withAttrs $1 $ CExpr (Just $1) } -- parse C selection statement (C99 6.8.4) -- selection_statement :: { CStat } selection_statement : if '(' expression ')' statement {% withAttrs $1 $ CIf $3 $5 Nothing } | if '(' expression ')' statement else statement {% withAttrs $1 $ CIf $3 $5 (Just $7) } | switch '(' expression ')' statement {% withAttrs $1 $ CSwitch $3 $5 } -- parse C iteration statement (C99 6.8.5) -- iteration_statement :: { CStat } iteration_statement : while '(' expression ')' statement {% withAttrs $1 $ CWhile $3 $5 False } | do statement while '(' expression ')' ';' {% withAttrs $1 $ CWhile $5 $2 True } | for '(' expression_opt ';' expression_opt ';' expression_opt ')' statement {% withAttrs $1 $ CFor (Left $3) $5 $7 $9 } | for '(' enter_scope declaration expression_opt ';' expression_opt ')' statement leave_scope {% withAttrs $1 $ CFor (Right $4) $5 $7 $9 } -- parse C jump statement (C99 6.8.6) -- -- * GNU extension: computed gotos -- jump_statement :: { CStat } jump_statement : goto identifier ';' {% withAttrs $1 $ CGoto $2 } | goto '*' expression ';' {% withAttrs $1 $ CGotoPtr $3 } | continue ';' {% withAttrs $1 $ CCont } | break ';' {% withAttrs $1 $ CBreak } | return expression_opt ';' {% withAttrs $1 $ CReturn $2 } -- parse GNU C __asm__ (...) statement (recording only a place holder result) -- asm_statement :: { CStat } asm_statement : asm maybe_type_qualifier '(' expression ')' ';' {% withAttrs $1 CAsm } | asm maybe_type_qualifier '(' expression ':' asm_operands ')' ';' {% withAttrs $1 CAsm } | asm maybe_type_qualifier '(' expression ':' asm_operands ':' asm_operands ')' ';' {% withAttrs $1 CAsm } | asm maybe_type_qualifier '(' expression ':' asm_operands ':' asm_operands ':' asm_clobbers ')' ';' {% withAttrs $1 CAsm } maybe_type_qualifier :: { () } maybe_type_qualifier : {- empty -} { () } | type_qualifier { () } asm_operands :: { () } asm_operands : {- empty -} { () } | nonnull_asm_operands { () } nonnull_asm_operands :: { () } nonnull_asm_operands : asm_operand { () } | nonnull_asm_operands ',' asm_operand { () } asm_operand :: { () } asm_operand : string_literal '(' expression ')' { () } | '[' ident ']' string_literal '(' expression ')' { () } | '[' tyident ']' string_literal '(' expression ')' { () } asm_clobbers :: { () } asm_clobbers : string_literal { () } | asm_clobbers ',' string_literal { () } -- parse C declaration (C99 6.7) -- declaration :: { CDecl } declaration : sue_declaration_specifier ';' {% withAttrs $1 $ CDecl (reverse $1) [] } | sue_type_specifier ';' {% withAttrs $1 $ CDecl (reverse $1) [] } | declaring_list ';' { case $1 of CDecl declspecs dies attr -> CDecl declspecs (List.reverse dies) attr } | default_declaring_list ';' { case $1 of CDecl declspecs dies attr -> CDecl declspecs (List.reverse dies) attr } -- Note that if a typedef were redeclared, then a declaration -- specifier must be supplied -- -- Can't redeclare typedef names -- default_declaring_list :: { CDecl } default_declaring_list : declaration_qualifier_list identifier_declarator asm_opt attrs_opt {-{}-} initializer_opt {% let declspecs = reverse $1 in doDeclIdent declspecs $2 >> (withAttrs $1 $ CDecl declspecs [(Just $2, $5, Nothing)]) } | type_qualifier_list identifier_declarator asm_opt attrs_opt {-{}-} initializer_opt {% let declspecs = liftTypeQuals $1 in doDeclIdent declspecs $2 >> (withAttrs $1 $ CDecl declspecs [(Just $2, $5, Nothing)]) } | default_declaring_list ',' identifier_declarator asm_opt attrs_opt {-{}-} initializer_opt {% case $1 of CDecl declspecs dies attr -> do doDeclIdent declspecs $3 return (CDecl declspecs ((Just $3, $6, Nothing) : dies) attr) } declaring_list :: { CDecl } declaring_list : declaration_specifier declarator asm_opt attrs_opt {-{}-} initializer_opt {% doDeclIdent $1 $2 >> (withAttrs $1 $ CDecl $1 [(Just $2, $5, Nothing)]) } | type_specifier declarator asm_opt attrs_opt {-{}-} initializer_opt {% doDeclIdent $1 $2 >> (withAttrs $1 $ CDecl $1 [(Just $2, $5, Nothing)]) } | declaring_list ',' declarator asm_opt attrs_opt {-{}-} initializer_opt {% case $1 of CDecl declspecs dies attr -> do doDeclIdent declspecs $3 return (CDecl declspecs ((Just $3, $6, Nothing) : dies) attr) } -- parse C declaration specifiers (C99 6.7) -- -- * summary: -- [ type_qualifier | storage_class -- | basic_type_name | elaborated_type_name | tyident ]{ -- ( 1 >= basic_type_name -- |x| 1 == elaborated_type_name -- |x| 1 == tyident -- ) && 1 >= storage_class -- } -- declaration_specifier :: { [CDeclSpec] } declaration_specifier : basic_declaration_specifier { reverse $1 } -- Arithmetic or void | sue_declaration_specifier { reverse $1 } -- Struct/Union/Enum | typedef_declaration_specifier { reverse $1 } -- Typedef -- A mixture of type qualifiers and storage class specifiers in any order, but -- containing at least one storage class specifier. -- -- * summary: -- [type_qualifier | storage_class]{ 1 >= storage_class } -- -- * detail: -- [type_qualifier] storage_class [type_qualifier | storage_class] -- declaration_qualifier_list :: { Reversed [CDeclSpec] } declaration_qualifier_list : storage_class { singleton (CStorageSpec $1) } | type_qualifier_list storage_class { rmap CTypeQual $1 `snoc` CStorageSpec $2 } | declaration_qualifier_list declaration_qualifier { $1 `snoc` $2 } | declaration_qualifier_list attr { $1 } declaration_qualifier :: { CDeclSpec } declaration_qualifier : storage_class { CStorageSpec $1 } | type_qualifier { CTypeQual $1 } -- const or volatile -- parse C storage class specifier (C99 6.7.1) -- -- * GNU extensions: '__thread' thread local storage -- storage_class :: { CStorageSpec } storage_class : typedef {% withAttrs $1 $ CTypedef } | extern {% withAttrs $1 $ CExtern } | static {% withAttrs $1 $ CStatic } | auto {% withAttrs $1 $ CAuto } | register {% withAttrs $1 $ CRegister } | "__thread" {% withAttrs $1 $ CThread } -- parse C type specifier (C99 6.7.2) -- -- This recignises a whole list of type specifiers rather than just one -- as in the C99 grammar. -- -- * summary: -- [type_qualifier | basic_type_name | elaborated_type_name | tyident]{ -- 1 >= basic_type_name -- |x| 1 == elaborated_type_name -- |x| 1 == tyident -- } -- type_specifier :: { [CDeclSpec] } type_specifier : basic_type_specifier { reverse $1 } -- Arithmetic or void | sue_type_specifier { reverse $1 } -- Struct/Union/Enum | typedef_type_specifier { reverse $1 } -- Typedef basic_type_name :: { CTypeSpec } basic_type_name : void {% withAttrs $1 $ CVoidType } | char {% withAttrs $1 $ CCharType } | short {% withAttrs $1 $ CShortType } | int {% withAttrs $1 $ CIntType } | long {% withAttrs $1 $ CLongType } | float {% withAttrs $1 $ CFloatType } | "__float128" {% withAttrs $1 $ CFloat128Type } | double {% withAttrs $1 $ CDoubleType } | signed {% withAttrs $1 $ CSignedType } | unsigned {% withAttrs $1 $ CUnsigType } | "_Bool" {% withAttrs $1 $ CBoolType } | "_Complex" {% withAttrs $1 $ CComplexType } -- A mixture of type qualifiers, storage class and basic type names in any -- order, but containing at least one basic type name and at least one storage -- class specifier. -- -- * summary: -- [type_qualifier | storage_class | basic_type_name]{ -- 1 >= storage_class && 1 >= basic_type_name -- } -- basic_declaration_specifier :: { Reversed [CDeclSpec] } basic_declaration_specifier : declaration_qualifier_list basic_type_name { $1 `snoc` CTypeSpec $2 } | basic_type_specifier storage_class { $1 `snoc` CStorageSpec $2 } | basic_declaration_specifier declaration_qualifier { $1 `snoc` $2 } | basic_declaration_specifier basic_type_name { $1 `snoc` CTypeSpec $2 } | basic_declaration_specifier attr { $1 } -- A mixture of type qualifiers and basic type names in any order, but -- containing at least one basic type name. -- -- * summary: -- [type_qualifier | basic_type_name]{ 1 >= basic_type_name } -- basic_type_specifier :: { Reversed [CDeclSpec] } basic_type_specifier -- Arithmetic or void : basic_type_name { singleton (CTypeSpec $1) } | type_qualifier_list basic_type_name { rmap CTypeQual $1 `snoc` CTypeSpec $2 } | basic_type_specifier type_qualifier { $1 `snoc` CTypeQual $2 } | basic_type_specifier basic_type_name { $1 `snoc` CTypeSpec $2 } | basic_type_specifier attr { $1 } -- A named or anonymous struct, union or enum type along with at least one -- storage class and any mix of type qualifiers. -- -- * summary: -- [type_qualifier | storage_class | elaborated_type_name]{ -- 1 == elaborated_type_name && 1 >= storage_class -- } -- sue_declaration_specifier :: { Reversed [CDeclSpec] } sue_declaration_specifier : declaration_qualifier_list elaborated_type_name { $1 `snoc` CTypeSpec $2 } | sue_type_specifier storage_class { $1 `snoc` CStorageSpec $2 } | sue_declaration_specifier declaration_qualifier { $1 `snoc` $2 } | sue_declaration_specifier attr { $1 } -- A struct, union or enum type (named or anonymous) with optional leading and -- trailing type qualifiers. -- -- * summary: -- [type_qualifier] elaborated_type_name [type_qualifier] -- sue_type_specifier :: { Reversed [CDeclSpec] } sue_type_specifier -- struct/union/enum : elaborated_type_name { singleton (CTypeSpec $1) } | type_qualifier_list elaborated_type_name { rmap CTypeQual $1 `snoc` CTypeSpec $2 } | sue_type_specifier type_qualifier { $1 `snoc` CTypeQual $2 } | sue_type_specifier attr { $1 } -- A typedef'ed type identifier with at least one storage qualifier and any -- number of type qualifiers -- -- * Summary: -- [type_qualifier | storage_class | tyident]{ -- 1 == tyident && 1 >= storage_class -- } -- -- * Note: -- the tyident can also be a: typeof '(' ... ')' -- typedef_declaration_specifier :: { Reversed [CDeclSpec] } typedef_declaration_specifier : typedef_type_specifier storage_class { $1 `snoc` CStorageSpec $2 } | declaration_qualifier_list tyident {% withAttrs $1 $ \attr -> $1 `snoc` CTypeSpec (CTypeDef $2 attr) } | declaration_qualifier_list typeof '(' expression ')' {% withAttrs $1 $ \attr -> $1 `snoc` CTypeSpec (CTypeOfExpr $4 attr) } | declaration_qualifier_list typeof '(' type_name ')' {% withAttrs $1 $ \attr -> $1 `snoc` CTypeSpec (CTypeOfType $4 attr) } | typedef_declaration_specifier declaration_qualifier { $1 `snoc` $2 } | typedef_declaration_specifier attr { $1 } -- typedef'ed type identifier with optional leading and trailing type qualifiers -- -- * Summary: -- [type_qualifier] ( tyident | typeof '('...')' ) [type_qualifier] -- typedef_type_specifier :: { Reversed [CDeclSpec] } typedef_type_specifier : tyident {% withAttrs $1 $ \attr -> singleton (CTypeSpec (CTypeDef $1 attr)) } | typeof '(' expression ')' {% withAttrs $1 $ \attr -> singleton (CTypeSpec (CTypeOfExpr $3 attr)) } | typeof '(' type_name ')' {% withAttrs $1 $ \attr -> singleton (CTypeSpec (CTypeOfType $3 attr)) } | type_qualifier_list tyident {% withAttrs $2 $ \attr -> rmap CTypeQual $1 `snoc` CTypeSpec (CTypeDef $2 attr) } | type_qualifier_list typeof '(' expression ')' {% withAttrs $2 $ \attr -> rmap CTypeQual $1 `snoc` CTypeSpec (CTypeOfExpr $4 attr) } | type_qualifier_list typeof '(' type_name ')' {% withAttrs $2 $ \attr -> rmap CTypeQual $1 `snoc` CTypeSpec (CTypeOfType $4 attr) } | typedef_type_specifier type_qualifier { $1 `snoc` CTypeQual $2 } | typedef_type_specifier attr { $1 } -- A named or anonymous struct, union or enum type. -- -- * summary: -- (struct|union|enum) (identifier? '{' ... '}' | identifier) -- elaborated_type_name :: { CTypeSpec } elaborated_type_name : struct_or_union_specifier {% withAttrs $1 $ CSUType $1 } | enum_specifier {% withAttrs $1 $ CEnumType $1 } -- parse C structure or union declaration (C99 6.7.2.1) -- -- * summary: -- (struct|union) (identifier? '{' ... '}' | identifier) -- struct_or_union_specifier :: { CStructUnion } struct_or_union_specifier : struct_or_union attrs_opt identifier '{' struct_declaration_list '}' {% withAttrs $1 $ CStruct (unL $1) (Just $3) (reverse $5) } | struct_or_union attrs_opt '{' struct_declaration_list '}' {% withAttrs $1 $ CStruct (unL $1) Nothing (reverse $4) } | struct_or_union attrs_opt identifier {% withAttrs $1 $ CStruct (unL $1) (Just $3) [] } struct_or_union :: { Located CStructTag } struct_or_union : struct { L CStructTag (posOf $1) } | union { L CUnionTag (posOf $1) } struct_declaration_list :: { Reversed [CDecl] } struct_declaration_list : {- empty -} { empty } | struct_declaration_list ';' { $1 } | struct_declaration_list struct_declaration { $1 `snoc` $2 } -- parse C structure declaration (C99 6.7.2.1) -- struct_declaration :: { CDecl } struct_declaration : struct_declaring_list ';' { case $1 of CDecl declspecs dies attr -> CDecl declspecs (List.reverse dies) attr } | struct_default_declaring_list ';' { case $1 of CDecl declspecs dies attr -> CDecl declspecs (List.reverse dies) attr } | "__extension__" struct_declaration { $2 } -- doesn't redeclare typedef struct_default_declaring_list :: { CDecl } struct_default_declaring_list : attrs_opt type_qualifier_list struct_identifier_declarator attrs_opt {% withAttrs $2 $ case $3 of (d,s) -> CDecl (liftTypeQuals $2) [(d,Nothing,s)] } | struct_default_declaring_list ',' attrs_opt struct_identifier_declarator attrs_opt { case $1 of CDecl declspecs dies attr -> case $4 of (d,s) -> CDecl declspecs ((d,Nothing,s) : dies) attr } -- * GNU extensions: -- allow anonymous nested structures and unions -- struct_declaring_list :: { CDecl } struct_declaring_list : attrs_opt type_specifier struct_declarator attrs_opt {% withAttrs $2 $ case $3 of (d,s) -> CDecl $2 [(d,Nothing,s)] } | struct_declaring_list ',' attrs_opt struct_declarator attrs_opt { case $1 of CDecl declspecs dies attr -> case $4 of (d,s) -> CDecl declspecs ((d,Nothing,s) : dies) attr } -- We're being far too liberal in the parsing here, we realyl want to just -- allow unnamed struct and union fields but we're actually allowing any -- unnamed struct member. Making it allow only unnamed structs or unions in -- the parser is far too tricky, it makes things ambiguous. So we'll have to -- diagnose unnamed fields that are not structs/unions in a later stage. | attrs_opt type_specifier {% withAttrs $2 $ CDecl $2 [] } -- parse C structure declarator (C99 6.7.2.1) -- struct_declarator :: { (Maybe CDeclr, Maybe CExpr) } struct_declarator : declarator { (Just $1, Nothing) } | ':' constant_expression { (Nothing, Just $2) } | declarator ':' constant_expression { (Just $1, Just $3) } struct_identifier_declarator :: { (Maybe CDeclr, Maybe CExpr) } struct_identifier_declarator : identifier_declarator { (Just $1, Nothing) } | ':' constant_expression { (Nothing, Just $2) } | identifier_declarator ':' constant_expression { (Just $1, Just $3) } -- parse C enumeration declaration (C99 6.7.2.2) -- -- * summary: -- enum (identifier? '{' ... '}' | identifier) -- enum_specifier :: { CEnum } enum_specifier : enum attrs_opt '{' enumerator_list '}' {% withAttrs $1 $ CEnum Nothing (reverse $4) } | enum attrs_opt '{' enumerator_list ',' '}' {% withAttrs $1 $ CEnum Nothing (reverse $4) } | enum attrs_opt identifier '{' enumerator_list '}' {% withAttrs $1 $ CEnum (Just $3) (reverse $5) } | enum attrs_opt identifier '{' enumerator_list ',' '}' {% withAttrs $1 $ CEnum (Just $3) (reverse $5) } | enum attrs_opt identifier {% withAttrs $1 $ CEnum (Just $3) [] } enumerator_list :: { Reversed [(Ident, Maybe CExpr)] } enumerator_list : enumerator { singleton $1 } | enumerator_list ',' enumerator { $1 `snoc` $3 } enumerator :: { (Ident, Maybe CExpr) } enumerator : identifier { ($1, Nothing) } | identifier '=' constant_expression { ($1, Just $3) } -- parse C type qualifier (C99 6.7.3) -- type_qualifier :: { CTypeQual } type_qualifier : const {% withAttrs $1 $ CConstQual } | volatile {% withAttrs $1 $ CVolatQual } | restrict {% withAttrs $1 $ CRestrQual } | inline {% withAttrs $1 $ CInlinQual } -- parse C declarator (C99 6.7.5) -- declarator :: { CDeclr } declarator : identifier_declarator { $1 } | typedef_declarator { $1 } -- Parse GNU C's asm annotations -- asm_opt :: { () } asm_opt : {- empty -} { () } | asm '(' string_literal_list ')' { () } typedef_declarator :: { CDeclr } typedef_declarator -- would be ambiguous as parameter : paren_typedef_declarator { $1 } -- not ambiguous as param | parameter_typedef_declarator { $1 } parameter_typedef_declarator :: { CDeclr } parameter_typedef_declarator : tyident {% withAttrs $1 $ CVarDeclr (Just $1) } | tyident postfixing_abstract_declarator {% withAttrs $1 $ \attrs -> $2 (CVarDeclr (Just $1) attrs) } | clean_typedef_declarator { $1 } -- The following have at least one '*'. -- There is no (redundant) '(' between the '*' and the tyident. clean_typedef_declarator :: { CDeclr } clean_typedef_declarator : clean_postfix_typedef_declarator { $1 } | '*' parameter_typedef_declarator {% withAttrs $1 $ CPtrDeclr [] $2 } | '*' type_qualifier_list parameter_typedef_declarator {% withAttrs $1 $ CPtrDeclr (reverse $2) $3 } | '*' attrs parameter_typedef_declarator {% withAttrs $1 $ CPtrDeclr [] $3 } | '*' attrs type_qualifier_list parameter_typedef_declarator {% withAttrs $1 $ CPtrDeclr (reverse $3) $4 } clean_postfix_typedef_declarator :: { CDeclr } clean_postfix_typedef_declarator : '(' clean_typedef_declarator ')' { $2 } | '(' attrs clean_typedef_declarator ')' { $3 } | '(' clean_typedef_declarator ')' postfixing_abstract_declarator { $4 $2 } | '(' attrs clean_typedef_declarator ')' postfixing_abstract_declarator { $5 $3 } -- The following have a redundant '(' placed -- immediately to the left of the tyident paren_typedef_declarator :: { CDeclr } paren_typedef_declarator : paren_postfix_typedef_declarator { $1 } -- redundant paren | '*' '(' simple_paren_typedef_declarator ')' {% withAttrs $1 $ CPtrDeclr [] $3 } -- redundant paren | '*' type_qualifier_list '(' simple_paren_typedef_declarator ')' {% withAttrs $1 $ CPtrDeclr (reverse $2) $4 } | '*' paren_typedef_declarator {% withAttrs $1 $ CPtrDeclr [] $2 } | '*' type_qualifier_list paren_typedef_declarator {% withAttrs $1 $ CPtrDeclr (reverse $2) $3 } | '*' attrs '(' simple_paren_typedef_declarator ')' {% withAttrs $1 $ CPtrDeclr [] $4 } -- redundant paren | '*' attrs type_qualifier_list '(' simple_paren_typedef_declarator ')' {% withAttrs $1 $ CPtrDeclr (reverse $3) $5 } | '*' attrs paren_typedef_declarator {% withAttrs $1 $ CPtrDeclr [] $3 } | '*' attrs type_qualifier_list paren_typedef_declarator {% withAttrs $1 $ CPtrDeclr (reverse $3) $4 } -- redundant paren to left of tname paren_postfix_typedef_declarator :: { CDeclr } paren_postfix_typedef_declarator : '(' paren_typedef_declarator ')' { $2 } -- redundant paren | '(' simple_paren_typedef_declarator postfixing_abstract_declarator ')' { $3 $2 } | '(' paren_typedef_declarator ')' postfixing_abstract_declarator { $4 $2 } -- Just a type name in any number of nested brackets -- simple_paren_typedef_declarator :: { CDeclr } simple_paren_typedef_declarator : tyident {% withAttrs $1 $ CVarDeclr (Just $1) } | '(' simple_paren_typedef_declarator ')' { $2 } identifier_declarator :: { CDeclr } identifier_declarator : unary_identifier_declarator { $1 } | paren_identifier_declarator { $1 } unary_identifier_declarator :: { CDeclr } unary_identifier_declarator : postfix_identifier_declarator { $1 } | '*' identifier_declarator {% withAttrs $1 $ CPtrDeclr [] $2 } | '*' type_qualifier_list identifier_declarator {% withAttrs $1 $ CPtrDeclr (reverse $2) $3 } | '*' attrs identifier_declarator {% withAttrs $1 $ CPtrDeclr [] $3 } | '*' attrs type_qualifier_list identifier_declarator {% withAttrs $1 $ CPtrDeclr (reverse $3) $4 } postfix_identifier_declarator :: { CDeclr } postfix_identifier_declarator : paren_identifier_declarator postfixing_abstract_declarator { $2 $1 } | '(' unary_identifier_declarator ')' { $2 } | '(' unary_identifier_declarator ')' postfixing_abstract_declarator { $4 $2 } | '(' attrs unary_identifier_declarator ')' { $3 } | '(' attrs unary_identifier_declarator ')' postfixing_abstract_declarator { $5 $3 } paren_identifier_declarator :: { CDeclr } paren_identifier_declarator : ident {% withAttrs $1 $ CVarDeclr (Just $1) } | '(' paren_identifier_declarator ')' { $2 } old_function_declarator :: { CDeclr } old_function_declarator : postfix_old_function_declarator { $1 } | '*' old_function_declarator {% withAttrs $1 $ CPtrDeclr [] $2 } | '*' type_qualifier_list old_function_declarator {% withAttrs $1 $ CPtrDeclr (reverse $2) $3 } postfix_old_function_declarator :: { CDeclr } postfix_old_function_declarator : paren_identifier_declarator '(' identifier_list ')' {% withAttrs $2 $ CFunDeclr $1 [] False } | '(' old_function_declarator ')' { $2 } | '(' old_function_declarator ')' postfixing_abstract_declarator { $4 $2 } type_qualifier_list :: { Reversed [CTypeQual] } type_qualifier_list : type_qualifier { singleton $1 } | type_qualifier_list type_qualifier { $1 `snoc` $2 } | type_qualifier_list attr { $1 } -- parse C parameter type list (C99 6.7.5) -- parameter_type_list :: { ([CDecl], Bool) } parameter_type_list : {- empty -} { ([], False)} | parameter_list { (reverse $1, False) } | parameter_list ',' "..." { (reverse $1, True) } parameter_list :: { Reversed [CDecl] } parameter_list : parameter_declaration { singleton $1 } | attrs parameter_declaration { singleton $2 } | parameter_list ',' attrs_opt parameter_declaration { $1 `snoc` $4 } parameter_declaration :: { CDecl } parameter_declaration : declaration_specifier {% withAttrs $1 $ CDecl $1 [] } | declaration_specifier abstract_declarator {% withAttrs $1 $ CDecl $1 [(Just $2, Nothing, Nothing)] } | declaration_specifier identifier_declarator attrs_opt {% withAttrs $1 $ CDecl $1 [(Just $2, Nothing, Nothing)] } | declaration_specifier parameter_typedef_declarator attrs_opt {% withAttrs $1 $ CDecl $1 [(Just $2, Nothing, Nothing)] } | declaration_qualifier_list {% withAttrs $1 $ CDecl (reverse $1) [] } | declaration_qualifier_list abstract_declarator {% withAttrs $1 $ CDecl (reverse $1) [(Just $2, Nothing, Nothing)] } | declaration_qualifier_list identifier_declarator attrs_opt {% withAttrs $1 $ CDecl (reverse $1) [(Just $2, Nothing, Nothing)] } | type_specifier {% withAttrs $1 $ CDecl $1 [] } | type_specifier abstract_declarator {% withAttrs $1 $ CDecl $1 [(Just $2, Nothing, Nothing)] } | type_specifier identifier_declarator attrs_opt {% withAttrs $1 $ CDecl $1 [(Just $2, Nothing, Nothing)] } | type_specifier parameter_typedef_declarator attrs_opt {% withAttrs $1 $ CDecl $1 [(Just $2, Nothing, Nothing)] } | type_qualifier_list {% withAttrs $1 $ CDecl (liftTypeQuals $1) [] } | type_qualifier_list abstract_declarator {% withAttrs $1 $ CDecl (liftTypeQuals $1) [(Just $2, Nothing, Nothing)] } | type_qualifier_list identifier_declarator attrs_opt {% withAttrs $1 $ CDecl (liftTypeQuals $1) [(Just $2, Nothing, Nothing)] } identifier_list :: { Reversed [Ident] } identifier_list : ident { singleton $1 } | identifier_list ',' ident { $1 `snoc` $3 } -- parse C type name (C99 6.7.6) -- type_name :: { CDecl } type_name : attrs_opt type_specifier {% withAttrs $2 $ CDecl $2 [] } | attrs_opt type_specifier abstract_declarator {% withAttrs $2 $ CDecl $2 [(Just $3, Nothing, Nothing)] } | attrs_opt type_qualifier_list {% withAttrs $2 $ CDecl (liftTypeQuals $2) [] } | attrs_opt type_qualifier_list abstract_declarator {% withAttrs $2 $ CDecl (liftTypeQuals $2) [(Just $3, Nothing, Nothing)] } -- parse C abstract declarator (C99 6.7.6) -- abstract_declarator :: { CDeclr } abstract_declarator : unary_abstract_declarator { $1 } | postfix_abstract_declarator { $1 } | postfixing_abstract_declarator attrs_opt { $1 emptyDeclr } postfixing_abstract_declarator :: { CDeclr -> CDeclr } postfixing_abstract_declarator : array_abstract_declarator { $1 } | '(' parameter_type_list ')' {% withAttrs $1 $ \attrs declr -> case $2 of (params, variadic) -> CFunDeclr declr params variadic attrs } -- * Note that we recognise but ignore the C99 static keyword (see C99 6.7.5.3) -- -- * We do not distinguish in the AST between incomplete array types and -- complete variable length arrays ([ '*' ] means the latter). (see C99 6.7.5.2) -- array_abstract_declarator :: { CDeclr -> CDeclr } array_abstract_declarator : postfix_array_abstract_declarator { $1 } | array_abstract_declarator postfix_array_abstract_declarator { \decl -> $2 ($1 decl) } postfix_array_abstract_declarator :: { CDeclr -> CDeclr } postfix_array_abstract_declarator : '[' assignment_expression_opt ']' {% withAttrs $1 $ \attrs declr -> CArrDeclr declr [] $2 attrs } | '[' type_qualifier_list assignment_expression_opt ']' {% withAttrs $1 $ \attrs declr -> CArrDeclr declr (reverse $2) $3 attrs } | '[' static assignment_expression ']' {% withAttrs $1 $ \attrs declr -> CArrDeclr declr [] (Just $3) attrs } | '[' static type_qualifier_list assignment_expression ']' {% withAttrs $1 $ \attrs declr -> CArrDeclr declr (reverse $3) (Just $4) attrs } | '[' type_qualifier_list static assignment_expression ']' {% withAttrs $1 $ \attrs declr -> CArrDeclr declr (reverse $2) (Just $4) attrs } | '[' '*' ']' {% withAttrs $1 $ \attrs declr -> CArrDeclr declr [] Nothing attrs } | '[' type_qualifier_list '*' ']' {% withAttrs $1 $ \attrs declr -> CArrDeclr declr (reverse $2) Nothing attrs } unary_abstract_declarator :: { CDeclr } unary_abstract_declarator : '*' {% withAttrs $1 $ CPtrDeclr [] emptyDeclr } | '*' type_qualifier_list {% withAttrs $1 $ CPtrDeclr (reverse $2) emptyDeclr } | '*' abstract_declarator {% withAttrs $1 $ CPtrDeclr [] $2 } | '*' type_qualifier_list abstract_declarator {% withAttrs $1 $ CPtrDeclr (reverse $2) $3 } | '*' attrs {% withAttrs $1 $ CPtrDeclr [] emptyDeclr } | '*' attrs type_qualifier_list {% withAttrs $1 $ CPtrDeclr (reverse $3) emptyDeclr } | '*' attrs abstract_declarator {% withAttrs $1 $ CPtrDeclr [] $3 } | '*' attrs type_qualifier_list abstract_declarator {% withAttrs $1 $ CPtrDeclr (reverse $3) $4 } postfix_abstract_declarator :: { CDeclr } postfix_abstract_declarator : '(' unary_abstract_declarator ')' { $2 } | '(' postfix_abstract_declarator ')' { $2 } | '(' postfixing_abstract_declarator ')' { $2 emptyDeclr } | '(' unary_abstract_declarator ')' postfixing_abstract_declarator { $4 $2 } | '(' attrs unary_abstract_declarator ')' { $3 } | '(' attrs postfix_abstract_declarator ')' { $3 } | '(' attrs postfixing_abstract_declarator ')' { $3 emptyDeclr } | '(' attrs unary_abstract_declarator ')' postfixing_abstract_declarator { $5 $3 } | postfix_abstract_declarator attr { $1 } -- parse C initializer (C99 6.7.8) -- initializer :: { CInit } initializer : assignment_expression {% withAttrs $1 $ CInitExpr $1 } | '{' initializer_list '}' {% withAttrs $1 $ CInitList (reverse $2) } | '{' initializer_list ',' '}' {% withAttrs $1 $ CInitList (reverse $2) } initializer_opt :: { Maybe CInit } initializer_opt : {- empty -} { Nothing } | '=' initializer { Just $2 } initializer_list :: { Reversed CInitList } initializer_list : {- empty -} { empty } | initializer { singleton ([],$1) } | designation initializer { singleton ($1,$2) } | initializer_list ',' initializer { $1 `snoc` ([],$3) } | initializer_list ',' designation initializer { $1 `snoc` ($3,$4) } -- designation -- -- * GNU extensions: -- old style member designation: 'ident :' -- array range designation -- designation :: { [CDesignator] } designation : designator_list '=' { reverse $1 } | identifier ':' {% withAttrs $1 $ \at -> [CMemberDesig $1 at] } | array_designator { [$1] } designator_list :: { Reversed [CDesignator] } designator_list : designator { singleton $1 } | designator_list designator { $1 `snoc` $2 } designator :: { CDesignator } designator : '[' constant_expression ']' {% withAttrs $1 $ CArrDesig $2 } | '.' identifier {% withAttrs $1 $ CMemberDesig $2 } | array_designator { $1 } array_designator :: { CDesignator } array_designator : '[' constant_expression "..." constant_expression ']' {% withAttrs $1 $ CRangeDesig $2 $4 } -- parse C primary expression (C99 6.5.1) -- -- We cannot use a typedef name as a variable -- -- * GNU extensions: -- allow a compound statement as an expression -- various __builtin_* forms that take type parameters -- primary_expression :: { CExpr } primary_expression : ident {% withAttrs $1 $ CVar $1 } | constant {% withAttrs $1 $ CConst $1 } | string_literal {% withAttrs $1 $ CConst $1 } | '(' expression ')' { $2 } | '(' compound_statement ')' {% withAttrs $1 $ CStatExpr $2 } | "__builtin_va_arg" '(' assignment_expression ',' type_name ')' {% withAttrs $1 CBuiltinExpr } | "__builtin_offsetof" '(' type_name ',' offsetof_member_designator ')' {% withAttrs $1 CBuiltinExpr } | "__builtin_types_compatible_p" '(' type_name ',' type_name ')' {% withAttrs $1 CBuiltinExpr } offsetof_member_designator :: { () } offsetof_member_designator : ident { () } | offsetof_member_designator '.' ident { () } | offsetof_member_designator '[' expression ']' { () } --parse C postfix expression (C99 6.5.2) -- postfix_expression :: { CExpr } postfix_expression : primary_expression { $1 } | postfix_expression '[' expression ']' {% withAttrs $2 $ CIndex $1 $3 } | postfix_expression '(' ')' {% withAttrs $2 $ CCall $1 [] } | postfix_expression '(' argument_expression_list ')' {% withAttrs $2 $ CCall $1 (reverse $3) } | postfix_expression '.' identifier {% withAttrs $2 $ CMember $1 $3 False } | postfix_expression "->" identifier {% withAttrs $2 $ CMember $1 $3 True } | postfix_expression "++" {% withAttrs $2 $ CUnary CPostIncOp $1 } | postfix_expression "--" {% withAttrs $2 $ CUnary CPostDecOp $1 } | '(' type_name ')' '{' initializer_list '}' {% withAttrs $4 $ CCompoundLit $2 (reverse $5) } | '(' type_name ')' '{' initializer_list ',' '}' {% withAttrs $4 $ CCompoundLit $2 (reverse $5) } argument_expression_list :: { Reversed [CExpr] } argument_expression_list : assignment_expression { singleton $1 } | argument_expression_list ',' assignment_expression { $1 `snoc` $3 } -- parse C unary expression (C99 6.5.3) -- -- * GNU extensions: -- 'alignof' expression or type -- '__extension__' to suppress warnings about extensions -- allow taking address of a label with: && label -- unary_expression :: { CExpr } unary_expression : postfix_expression { $1 } | "++" unary_expression {% withAttrs $1 $ CUnary CPreIncOp $2 } | "--" unary_expression {% withAttrs $1 $ CUnary CPreDecOp $2 } | "__extension__" cast_expression { $2 } | unary_operator cast_expression {% withAttrs $1 $ CUnary (unL $1) $2 } | sizeof unary_expression {% withAttrs $1 $ CSizeofExpr $2 } | sizeof '(' type_name ')' {% withAttrs $1 $ CSizeofType $3 } | alignof unary_expression {% withAttrs $1 $ CAlignofExpr $2 } | alignof '(' type_name ')' {% withAttrs $1 $ CAlignofType $3 } | "&&" identifier {% withAttrs $1 $ CLabAddrExpr $2 } unary_operator :: { Located CUnaryOp } unary_operator : '&' { L CAdrOp (posOf $1) } | '*' { L CIndOp (posOf $1) } | '+' { L CPlusOp (posOf $1) } | '-' { L CMinOp (posOf $1) } | '~' { L CCompOp (posOf $1) } | '!' { L CNegOp (posOf $1) } -- parse C cast expression (C99 6.5.4) -- cast_expression :: { CExpr } cast_expression : unary_expression { $1 } | '(' type_name ')' cast_expression {% withAttrs $1 $ CCast $2 $4 } -- parse C multiplicative expression (C99 6.5.5) -- multiplicative_expression :: { CExpr } multiplicative_expression : cast_expression { $1 } | multiplicative_expression '*' cast_expression {% withAttrs $2 $ CBinary CMulOp $1 $3 } | multiplicative_expression '/' cast_expression {% withAttrs $2 $ CBinary CDivOp $1 $3 } | multiplicative_expression '%' cast_expression {% withAttrs $2 $ CBinary CRmdOp $1 $3 } -- parse C additive expression (C99 6.5.6) -- additive_expression :: { CExpr } additive_expression : multiplicative_expression { $1 } | additive_expression '+' multiplicative_expression {% withAttrs $2 $ CBinary CAddOp $1 $3 } | additive_expression '-' multiplicative_expression {% withAttrs $2 $ CBinary CSubOp $1 $3 } -- parse C shift expression (C99 6.5.7) -- shift_expression :: { CExpr } shift_expression : additive_expression { $1 } | shift_expression "<<" additive_expression {% withAttrs $2 $ CBinary CShlOp $1 $3 } | shift_expression ">>" additive_expression {% withAttrs $2 $ CBinary CShrOp $1 $3 } -- parse C relational expression (C99 6.5.8) -- relational_expression :: { CExpr } relational_expression : shift_expression { $1 } | relational_expression '<' shift_expression {% withAttrs $2 $ CBinary CLeOp $1 $3 } | relational_expression '>' shift_expression {% withAttrs $2 $ CBinary CGrOp $1 $3 } | relational_expression "<=" shift_expression {% withAttrs $2 $ CBinary CLeqOp $1 $3 } | relational_expression ">=" shift_expression {% withAttrs $2 $ CBinary CGeqOp $1 $3 } -- parse C equality expression (C99 6.5.9) -- equality_expression :: { CExpr } equality_expression : relational_expression { $1 } | equality_expression "==" relational_expression {% withAttrs $2 $ CBinary CEqOp $1 $3 } | equality_expression "!=" relational_expression {% withAttrs $2 $ CBinary CNeqOp $1 $3 } -- parse C bitwise and expression (C99 6.5.10) -- and_expression :: { CExpr } and_expression : equality_expression { $1 } | and_expression '&' equality_expression {% withAttrs $2 $ CBinary CAndOp $1 $3 } -- parse C bitwise exclusive or expression (C99 6.5.11) -- exclusive_or_expression :: { CExpr } exclusive_or_expression : and_expression { $1 } | exclusive_or_expression '^' and_expression {% withAttrs $2 $ CBinary CXorOp $1 $3 } -- parse C bitwise or expression (C99 6.5.12) -- inclusive_or_expression :: { CExpr } inclusive_or_expression : exclusive_or_expression { $1 } | inclusive_or_expression '|' exclusive_or_expression {% withAttrs $2 $ CBinary COrOp $1 $3 } -- parse C logical and expression (C99 6.5.13) -- logical_and_expression :: { CExpr } logical_and_expression : inclusive_or_expression { $1 } | logical_and_expression "&&" inclusive_or_expression {% withAttrs $2 $ CBinary CLndOp $1 $3 } -- parse C logical or expression (C99 6.5.14) -- logical_or_expression :: { CExpr } logical_or_expression : logical_and_expression { $1 } | logical_or_expression "||" logical_and_expression {% withAttrs $2 $ CBinary CLorOp $1 $3 } -- parse C conditional expression (C99 6.5.15) -- -- * GNU extensions: -- omitting the `then' part -- conditional_expression :: { CExpr } conditional_expression : logical_or_expression { $1 } | logical_or_expression '?' expression ':' conditional_expression {% withAttrs $2 $ CCond $1 (Just $3) $5 } | logical_or_expression '?' ':' conditional_expression {% withAttrs $2 $ CCond $1 Nothing $4 } -- parse C assignment expression (C99 6.5.16) -- assignment_expression :: { CExpr } assignment_expression : conditional_expression { $1 } | unary_expression assignment_operator assignment_expression {% withAttrs $2 $ CAssign (unL $2) $1 $3 } assignment_operator :: { Located CAssignOp } assignment_operator : '=' { L CAssignOp (posOf $1) } | "*=" { L CMulAssOp (posOf $1) } | "/=" { L CDivAssOp (posOf $1) } | "%=" { L CRmdAssOp (posOf $1) } | "+=" { L CAddAssOp (posOf $1) } | "-=" { L CSubAssOp (posOf $1) } | "<<=" { L CShlAssOp (posOf $1) } | ">>=" { L CShrAssOp (posOf $1) } | "&=" { L CAndAssOp (posOf $1) } | "^=" { L CXorAssOp (posOf $1) } | "|=" { L COrAssOp (posOf $1) } -- parse C expression (C99 6.5.17) -- expression :: { CExpr } expression : assignment_expression { $1 } | assignment_expression ',' comma_expression {% let es = reverse $3 in withAttrs es $ CComma ($1:es) } comma_expression :: { Reversed [CExpr] } comma_expression : assignment_expression { singleton $1 } | comma_expression ',' assignment_expression { $1 `snoc` $3 } -- The following was used for clarity expression_opt :: { Maybe CExpr } expression_opt : {- empty -} { Nothing } | expression { Just $1 } -- The following was used for clarity assignment_expression_opt :: { Maybe CExpr } assignment_expression_opt : {- empty -} { Nothing } | assignment_expression { Just $1 } -- parse C constant expression (C99 6.6) -- constant_expression :: { CExpr } constant_expression : conditional_expression { $1 } -- parse C constants -- constant :: { CConst } constant : cint {% withAttrs $1 $ case $1 of CTokILit _ i -> CIntConst i } | cchar {% withAttrs $1 $ case $1 of CTokCLit _ c -> CCharConst c } | cfloat {% withAttrs $1 $ case $1 of CTokFLit _ f -> CFloatConst f } string_literal :: { CConst } string_literal : cstr {% withAttrs $1 $ case $1 of CTokSLit _ s -> CStrConst s } | cstr string_literal_list {% withAttrs $1 $ case $1 of CTokSLit _ s -> CStrConst (concat (s : reverse $2)) } string_literal_list :: { Reversed [String] } string_literal_list : cstr { case $1 of CTokSLit _ s -> singleton s } | string_literal_list cstr { case $2 of CTokSLit _ s -> $1 `snoc` s } identifier :: { Ident } identifier : ident { $1 } | tyident { $1 } -- parse GNU C attribute annotation (junking the result) -- attrs_opt :: { () } attrs_opt : {- empty -} { () } | attrs_opt attr { () } attrs :: { () } attrs : attr { () } | attrs attr { () } attr :: { () } attr : "__attribute__" '(' '(' attribute_list ')' ')' { () } attribute_list :: { () } : attribute { () } | attribute_list ',' attribute { () } attribute :: { () } attribute : {- empty -} { () } | ident { () } | const { () } | ident '(' attribute_params ')' { () } | ident '(' ')' { () } attribute_params :: { () } attribute_params : attribute_param { () } | attribute_params ',' attribute_param { () } attribute_param :: { () } attribute_param : constant_expression { () } | ident '=' cfloat { () } { infixr 5 `snoc` -- Due to the way the grammar is constructed we very often have to build lists -- in reverse. To make sure we do this consistently and correctly we have a -- newtype to wrap the reversed style of list: -- newtype Reversed a = Reversed a empty :: Reversed [a] empty = Reversed [] singleton :: a -> Reversed [a] singleton x = Reversed [x] snoc :: Reversed [a] -> a -> Reversed [a] snoc (Reversed xs) x = Reversed (x : xs) rmap :: (a -> b) -> Reversed [a] -> Reversed [b] rmap f (Reversed xs) = Reversed (map f xs) reverse :: Reversed [a] -> [a] reverse (Reversed xs) = List.reverse xs -- We occasionally need things to have a location when they don't naturally -- have one built in as tokens and most AST elements do. -- data Located a = L !a !Position unL :: Located a -> a unL (L a pos) = a instance Pos (Located a) where posOf (L _ pos) = pos {-# INLINE withAttrs #-} withAttrs :: Pos node => node -> (Attrs -> a) -> P a withAttrs node mkAttributedNode = do name <- getNewName let attrs = newAttrs (posOf node) name attrs `seq` return (mkAttributedNode attrs) -- this functions gets used repeatedly so take them out of line: -- liftTypeQuals :: Reversed [CTypeQual] -> [CDeclSpec] liftTypeQuals (Reversed xs) = revmap [] xs where revmap a [] = a revmap a (x:xs) = revmap (CTypeQual x : a) xs -- convenient instance, the position of a list of things is the position of -- the first thing in the list -- instance Pos a => Pos [a] where posOf (x:_) = posOf x instance Pos a => Pos (Reversed a) where posOf (Reversed x) = posOf x emptyDeclr = CVarDeclr Nothing (newAttrsOnlyPos nopos) -- Take the identifiers and use them to update the typedef'ed identifier set -- if the decl is defining a typedef then we add it to the set, -- if it's a var decl then that shadows typedefed identifiers -- doDeclIdent :: [CDeclSpec] -> CDeclr -> P () doDeclIdent declspecs declr = case getCDeclrIdent declr of Nothing -> return () Just ident | any isTypeDef declspecs -> addTypedef ident | otherwise -> shadowTypedef ident where isTypeDef (CStorageSpec (CTypedef _)) = True isTypeDef _ = False doFuncParamDeclIdent :: CDeclr -> P () doFuncParamDeclIdent (CFunDeclr _ params _ _) = sequence_ [ case getCDeclrIdent declr of Nothing -> return () Just ident -> shadowTypedef ident | CDecl _ dle _ <- params , (Just declr, _, _) <- dle ] doFuncParamDeclIdent (CPtrDeclr _ declr _ ) = doFuncParamDeclIdent declr doFuncParamDeclIdent _ = return () -- extract all identifiers getCDeclrIdent :: CDeclr -> Maybe Ident getCDeclrIdent (CVarDeclr optIde _) = optIde getCDeclrIdent (CPtrDeclr _ declr _) = getCDeclrIdent declr getCDeclrIdent (CArrDeclr declr _ _ _) = getCDeclrIdent declr getCDeclrIdent (CFunDeclr declr _ _ _) = getCDeclrIdent declr happyError :: P a happyError = parseError parseC :: String -> Position -> PreCST s s' CHeader parseC input initialPosition = do nameSupply <- getNameSupply let ns = names nameSupply case execParser header input initialPosition (map fst builtinTypeNames) ns of Left header -> return header Right (message, position) -> raiseFatal "Error in C header file." position message } gtk2hs-buildtools-0.13.10.0/c2hs/c/CParserMonad.hs0000644000000000000000000001370707346545000017526 0ustar0000000000000000-- C -> Haskell Compiler: Lexer for C Header Files -- -- Author : Manuel M T Chakravarty, Duncan Coutts -- Created: 12 Febuary 2007 -- -- Copyright (c) [1999..2004] Manuel M T Chakravarty -- Copyright (c) 2005-2007 Duncan Coutts -- -- 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 --------------------------------------------------------------- -- -- Monad for the C lexer and parser -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- This monad has to be usable with Alex and Happy. Some things in it are -- dictated by that, eg having to be able to remember the last token. -- -- The monad also provides a unique name supply (via the Names module) -- -- For parsing C we have to maintain a set of identifiers that we know to be -- typedef'ed type identifiers. We also must deal correctly with scope so we -- keep a list of sets of identifiers so we can save the outer scope when we -- enter an inner scope. -- --- TODO ---------------------------------------------------------------------- -- -- {-# LANGUAGE CPP #-} module CParserMonad ( P, execParser, failP, getNewName, -- :: P Name addTypedef, -- :: Ident -> P () shadowTypedef, -- :: Ident -> P () isTypeIdent, -- :: Ident -> P Bool enterScope, -- :: P () leaveScope, -- :: P () setPos, -- :: Position -> P () getPos, -- :: P Position getInput, -- :: P String setInput, -- :: String -> P () getLastToken, -- :: P CToken setLastToken, -- :: CToken -> P () ) where import Position (Position(..), Pos(posOf)) import Errors (interr) import UNames (Name) import Idents (Ident, lexemeToIdent, identToLexeme) import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap) import Control.Monad.Fail (MonadFail (..)) import Data.Set (Set) import qualified Data.Set as Set (fromList, insert, member, delete) import CTokens (CToken) data ParseResult a = POk !PState a | PFailed [String] Position -- The error message and position data PState = PState { curPos :: !Position, -- position at current input location curInput :: !String, -- the current input prevToken :: CToken, -- the previous token namesupply :: ![Name], -- the name unique supply tyidents :: !(Set Ident), -- the set of typedef'ed identifiers scopes :: ![Set Ident] -- the tyident sets for outer scopes } newtype P a = P { unP :: PState -> ParseResult a } instance MonadFail P where fail m = getPos >>= \pos -> failP pos [m] instance Functor P where fmap = liftM instance Applicative P where pure = return (<*>) = ap instance Monad P where return = returnP (>>=) = thenP #if !MIN_VERSION_base(4,13,0) fail m = getPos >>= \pos -> failP pos [m] #endif execParser :: P a -> String -> Position -> [Ident] -> [Name] -> Either a ([String], Position) execParser (P parser) input pos builtins names = case parser initialState of POk _ result -> Left result PFailed message pos -> Right (message, pos) where initialState = PState { curPos = pos, curInput = input, prevToken = interr "CLexer.execParser: Touched undefined token!", namesupply = names, tyidents = Set.fromList builtins, scopes = [] } {-# INLINE returnP #-} returnP :: a -> P a returnP a = P $ \s -> POk s a {-# INLINE thenP #-} thenP :: P a -> (a -> P b) -> P b (P m) `thenP` k = P $ \s -> case m s of POk s' a -> (unP (k a)) s' PFailed err pos -> PFailed err pos failP :: Position -> [String] -> P a failP pos msg = P $ \_ -> PFailed msg pos getNewName :: P Name getNewName = P $ \s@PState{namesupply=(n:ns)} -> POk s{namesupply=ns} n setPos :: Position -> P () setPos pos = P $ \s -> POk s{curPos=pos} () getPos :: P Position getPos = P $ \s@PState{curPos=pos} -> POk s pos addTypedef :: Ident -> P () addTypedef ident = (P $ \s@PState{tyidents=tyidents} -> POk s{tyidents = ident `Set.insert` tyidents} ()) shadowTypedef :: Ident -> P () shadowTypedef ident = (P $ \s@PState{tyidents=tyidents} -> -- optimisation: mostly the ident will not be in -- the tyident set so do a member lookup to avoid -- churn induced by calling delete POk s{tyidents = if ident `Set.member` tyidents then ident `Set.delete` tyidents else tyidents } ()) isTypeIdent :: Ident -> P Bool isTypeIdent ident = P $ \s@PState{tyidents=tyidents} -> POk s $! Set.member ident tyidents enterScope :: P () enterScope = P $ \s@PState{tyidents=tyidents,scopes=ss} -> POk s{scopes=tyidents:ss} () leaveScope :: P () leaveScope = P $ \s@PState{scopes=ss} -> case ss of [] -> interr "leaveScope: already in global scope" (tyidents:ss') -> POk s{tyidents=tyidents, scopes=ss'} () getInput :: P String getInput = P $ \s@PState{curInput=i} -> POk s i setInput :: String -> P () setInput i = P $ \s -> POk s{curInput=i} () getLastToken :: P CToken getLastToken = P $ \s@PState{prevToken=tok} -> POk s tok setLastToken :: CToken -> P () setLastToken tok = P $ \s -> POk s{prevToken=tok} () gtk2hs-buildtools-0.13.10.0/c2hs/c/CPretty.hs0000644000000000000000000001032207346545000016570 0ustar0000000000000000{-# LANGUAGE CPP #-} -- C->Haskell Compiler: pretty printing of C abstract syntax -- -- Author : Manuel M T Chakravarty -- Created: 25 August 1 -- -- Version $Revision: 1.3 $ from $Date: 2005/06/22 16:01:21 $ -- -- Copyright (c) [2001..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 --------------------------------------------------------------- -- -- Pretty printing support for abstract C trees. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- --- TODO ---------------------------------------------------------------------- -- -- * So far, only covers a small fraction of the abstract tree definition -- module CPretty ( -- we are just providing instances to the class `Pretty' ) where #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif import Idents (Ident, identToLexeme) import Text.PrettyPrint.HughesPJ import CAST -- pretty printing of AST nodes -- ---------------------------- instance Show CDecl where showsPrec _ = showString . render . pretty -- overloaded pretty-printing function (EXPORTED) -- class Pretty a where pretty :: a -> Doc prettyPrec :: Int -> a -> Doc pretty = prettyPrec 0 prettyPrec _ = pretty -- actual structure tree traversals -- -------------------------------- instance Pretty CDecl where pretty (CDecl specs declrs _) = hsep (map pretty specs) `hang` 2 $ hsep (punctuate comma (map prettyDeclr declrs)) <> semi instance Pretty CDeclSpec where pretty (CStorageSpec sspec) = pretty sspec pretty (CTypeSpec tspec) = pretty tspec pretty (CTypeQual qspec) = pretty qspec instance Pretty CStorageSpec where pretty (CAuto _) = text "auto" pretty (CRegister _) = text "register" pretty (CStatic _) = text "static" pretty (CExtern _) = text "extern" pretty (CTypedef _) = text "typedef" instance Pretty CTypeSpec where pretty (CVoidType _) = text "void" pretty (CCharType _) = text "char" pretty (CShortType _) = text "short" pretty (CIntType _) = text "int" pretty (CLongType _) = text "long" pretty (CFloatType _) = text "float" pretty (CFloat128Type _) = text "__float128" pretty (CDoubleType _) = text "double" pretty (CSignedType _) = text "signed" pretty (CUnsigType _) = text "unsigned" pretty (CSUType struct _) = text "<>" pretty (CEnumType enum _) = text "<>" pretty (CTypeDef ide _) = ident ide instance Pretty CTypeQual where pretty (CConstQual _) = text "const" pretty (CVolatQual _) = text "volatile" pretty (CRestrQual _) = text "restrict" prettyDeclr :: (Maybe CDeclr, Maybe CInit, Maybe CExpr) -> Doc prettyDeclr (odeclr, oinit, oexpr) = maybe empty pretty odeclr <+> maybe empty ((text "=" <+>) . pretty) oinit <+> maybe empty ((text ":" <+>) . pretty) oexpr instance Pretty CDeclr where pretty (CVarDeclr oide _) = maybe empty ident oide pretty (CPtrDeclr inds declr _) = let oneLevel ind = parens . (hsep (map pretty ind) <+>) . (text "*" <>) in oneLevel inds (pretty declr) pretty (CArrDeclr declr _ oexpr _) = pretty declr <> brackets (maybe empty pretty oexpr) pretty (CFunDeclr declr decls isVariadic _) = let varDoc = if isVariadic then text ", ..." else empty in pretty declr <+> parens (hsep (punctuate comma (map pretty decls)) <> varDoc) instance Pretty CInit where pretty _ = text "<>" instance Pretty CExpr where pretty _ = text "<>" -- auxilliary functions -- -------------------- ident :: Ident -> Doc ident = text . identToLexeme gtk2hs-buildtools-0.13.10.0/c2hs/c/CTokens.hs0000644000000000000000000004041707346545000016554 0ustar0000000000000000-- C -> Haskell Compiler: Lexer for C Header Files -- -- Author : Manuel M T Chakravarty, Duncan Coutts -- Created: 24 May 2005 -- -- Version $Revision: 1.1.2.1 $ from $Date: 2005/06/14 00:16:14 $ -- -- Copyright (c) [1999..2004] Manuel M T Chakravarty -- Copyright (c) 2005 Duncan Coutts -- -- 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 --------------------------------------------------------------- -- -- C Tokens for the C lexer. -- module CTokens (CToken(..), GnuCTok(..)) where import Position (Position(..), Pos(posOf)) import Idents (Ident, identToLexeme) -- token definition -- ---------------- -- possible tokens (EXPORTED) -- data CToken = CTokLParen !Position -- `(' | CTokRParen !Position -- `)' | CTokLBracket !Position -- `[' | CTokRBracket !Position -- `]' | CTokArrow !Position -- `->' | CTokDot !Position -- `.' | CTokExclam !Position -- `!' | CTokTilde !Position -- `~' | CTokInc !Position -- `++' | CTokDec !Position -- `--' | CTokPlus !Position -- `+' | CTokMinus !Position -- `-' | CTokStar !Position -- `*' | CTokSlash !Position -- `/' | CTokPercent !Position -- `%' | CTokAmper !Position -- `&' | CTokShiftL !Position -- `<<' | CTokShiftR !Position -- `>>' | CTokLess !Position -- `<' | CTokLessEq !Position -- `<=' | CTokHigh !Position -- `>' | CTokHighEq !Position -- `>=' | CTokEqual !Position -- `==' | CTokUnequal !Position -- `!=' | CTokHat !Position -- `^' | CTokBar !Position -- `|' | CTokAnd !Position -- `&&' | CTokOr !Position -- `||' | CTokQuest !Position -- `?' | CTokColon !Position -- `:' | CTokAssign !Position -- `=' | CTokPlusAss !Position -- `+=' | CTokMinusAss !Position -- `-=' | CTokStarAss !Position -- `*=' | CTokSlashAss !Position -- `/=' | CTokPercAss !Position -- `%=' | CTokAmpAss !Position -- `&=' | CTokHatAss !Position -- `^=' | CTokBarAss !Position -- `|=' | CTokSLAss !Position -- `<<=' | CTokSRAss !Position -- `>>=' | CTokComma !Position -- `,' | CTokSemic !Position -- `;' | CTokLBrace !Position -- `{' | CTokRBrace !Position -- | CTokEllipsis !Position -- `...' | CTokAlignof !Position -- `alignof' -- (or `__alignof', -- `__alignof__') | CTokAsm !Position -- `asm' -- (or `__asm', -- `__asm__') | CTokAuto !Position -- `auto' | CTokBreak !Position -- `break' | CTokBool !Position -- `_Bool' | CTokCase !Position -- `case' | CTokChar !Position -- `char' | CTokConst !Position -- `const' -- (or `__const', `__const__') | CTokContinue !Position -- `continue' | CTokComplex !Position -- `_Complex' | CTokDefault !Position -- `default' | CTokDo !Position -- `do' | CTokDouble !Position -- `double' | CTokElse !Position -- `else' | CTokEnum !Position -- `enum' | CTokExtern !Position -- `extern' | CTokFloat !Position -- `float' | CTokFloat128 !Position -- `__float128' | CTokFor !Position -- `for' | CTokGoto !Position -- `goto' | CTokIf !Position -- `if' | CTokInline !Position -- `inline' -- (or `__inline', -- `__inline__') | CTokInt !Position -- `int' | CTokLong !Position -- `long' | CTokLabel !Position -- `__label__' | CTokRegister !Position -- `register' | CTokRestrict !Position -- `restrict' -- (or `__restrict', -- `__restrict__') | CTokReturn !Position -- `return' | CTokShort !Position -- `short' | CTokSigned !Position -- `signed' -- (or `__signed', -- `__signed__') | CTokSizeof !Position -- `sizeof' | CTokStatic !Position -- `static' | CTokStruct !Position -- `struct' | CTokSwitch !Position -- `switch' | CTokTypedef !Position -- `typedef' | CTokTypeof !Position -- `typeof' | CTokThread !Position -- `__thread' | CTokUnion !Position -- `union' | CTokUnsigned !Position -- `unsigned' | CTokVoid !Position -- `void' | CTokVolatile !Position -- `volatile' -- (or `__volatile', -- `__volatile__') | CTokWhile !Position -- `while' | CTokCLit !Position !Char -- character constant | CTokILit !Position !Integer -- integer constant | CTokFLit !Position String -- float constant | CTokSLit !Position String -- string constant (no escapes) | CTokIdent !Position !Ident -- identifier -- not generated here, but in `CParser.parseCHeader' | CTokTyIdent !Position !Ident -- `typedef-name' identifier | CTokGnuC !GnuCTok !Position -- special GNU C tokens | CTokEof -- end of file -- special tokens used in GNU C extensions to ANSI C -- data GnuCTok = GnuCAttrTok -- `__attribute__' | GnuCExtTok -- `__extension__' | GnuCVaArg -- `__builtin_va_arg' | GnuCOffsetof -- `__builtin_offsetof' | GnuCTyCompat -- `__builtin_types_compatible_p' instance Pos CToken where posOf (CTokLParen pos ) = pos posOf (CTokRParen pos ) = pos posOf (CTokLBracket pos ) = pos posOf (CTokRBracket pos ) = pos posOf (CTokArrow pos ) = pos posOf (CTokDot pos ) = pos posOf (CTokExclam pos ) = pos posOf (CTokTilde pos ) = pos posOf (CTokInc pos ) = pos posOf (CTokDec pos ) = pos posOf (CTokPlus pos ) = pos posOf (CTokMinus pos ) = pos posOf (CTokStar pos ) = pos posOf (CTokSlash pos ) = pos posOf (CTokPercent pos ) = pos posOf (CTokAmper pos ) = pos posOf (CTokShiftL pos ) = pos posOf (CTokShiftR pos ) = pos posOf (CTokLess pos ) = pos posOf (CTokLessEq pos ) = pos posOf (CTokHigh pos ) = pos posOf (CTokHighEq pos ) = pos posOf (CTokEqual pos ) = pos posOf (CTokUnequal pos ) = pos posOf (CTokHat pos ) = pos posOf (CTokBar pos ) = pos posOf (CTokAnd pos ) = pos posOf (CTokOr pos ) = pos posOf (CTokQuest pos ) = pos posOf (CTokColon pos ) = pos posOf (CTokAssign pos ) = pos posOf (CTokPlusAss pos ) = pos posOf (CTokMinusAss pos ) = pos posOf (CTokStarAss pos ) = pos posOf (CTokSlashAss pos ) = pos posOf (CTokPercAss pos ) = pos posOf (CTokAmpAss pos ) = pos posOf (CTokHatAss pos ) = pos posOf (CTokBarAss pos ) = pos posOf (CTokSLAss pos ) = pos posOf (CTokSRAss pos ) = pos posOf (CTokComma pos ) = pos posOf (CTokSemic pos ) = pos posOf (CTokLBrace pos ) = pos posOf (CTokRBrace pos ) = pos posOf (CTokEllipsis pos ) = pos posOf (CTokAlignof pos ) = pos posOf (CTokAsm pos ) = pos posOf (CTokAuto pos ) = pos posOf (CTokBreak pos ) = pos posOf (CTokBool pos ) = pos posOf (CTokCase pos ) = pos posOf (CTokChar pos ) = pos posOf (CTokConst pos ) = pos posOf (CTokContinue pos ) = pos posOf (CTokComplex pos ) = pos posOf (CTokDefault pos ) = pos posOf (CTokDo pos ) = pos posOf (CTokDouble pos ) = pos posOf (CTokElse pos ) = pos posOf (CTokEnum pos ) = pos posOf (CTokExtern pos ) = pos posOf (CTokFloat pos ) = pos posOf (CTokFloat128 pos ) = pos posOf (CTokFor pos ) = pos posOf (CTokGoto pos ) = pos posOf (CTokInt pos ) = pos posOf (CTokInline pos ) = pos posOf (CTokIf pos ) = pos posOf (CTokLong pos ) = pos posOf (CTokLabel pos ) = pos posOf (CTokRegister pos ) = pos posOf (CTokRestrict pos ) = pos posOf (CTokReturn pos ) = pos posOf (CTokShort pos ) = pos posOf (CTokSigned pos ) = pos posOf (CTokSizeof pos ) = pos posOf (CTokStatic pos ) = pos posOf (CTokStruct pos ) = pos posOf (CTokSwitch pos ) = pos posOf (CTokTypedef pos ) = pos posOf (CTokTypeof pos ) = pos posOf (CTokThread pos ) = pos posOf (CTokUnion pos ) = pos posOf (CTokUnsigned pos ) = pos posOf (CTokVoid pos ) = pos posOf (CTokVolatile pos ) = pos posOf (CTokWhile pos ) = pos posOf (CTokCLit pos _) = pos posOf (CTokILit pos _) = pos posOf (CTokFLit pos _) = pos posOf (CTokSLit pos _) = pos posOf (CTokIdent pos _) = pos posOf (CTokTyIdent pos _) = pos posOf (CTokGnuC _ pos ) = pos instance Show CToken where showsPrec _ (CTokLParen _ ) = showString "(" showsPrec _ (CTokRParen _ ) = showString ")" showsPrec _ (CTokLBracket _ ) = showString "[" showsPrec _ (CTokRBracket _ ) = showString "]" showsPrec _ (CTokArrow _ ) = showString "->" showsPrec _ (CTokDot _ ) = showString "." showsPrec _ (CTokExclam _ ) = showString "!" showsPrec _ (CTokTilde _ ) = showString "~" showsPrec _ (CTokInc _ ) = showString "++" showsPrec _ (CTokDec _ ) = showString "--" showsPrec _ (CTokPlus _ ) = showString "+" showsPrec _ (CTokMinus _ ) = showString "-" showsPrec _ (CTokStar _ ) = showString "*" showsPrec _ (CTokSlash _ ) = showString "/" showsPrec _ (CTokPercent _ ) = showString "%" showsPrec _ (CTokAmper _ ) = showString "&" showsPrec _ (CTokShiftL _ ) = showString "<<" showsPrec _ (CTokShiftR _ ) = showString ">>" showsPrec _ (CTokLess _ ) = showString "<" showsPrec _ (CTokLessEq _ ) = showString "<=" showsPrec _ (CTokHigh _ ) = showString ">" showsPrec _ (CTokHighEq _ ) = showString ">=" showsPrec _ (CTokEqual _ ) = showString "==" showsPrec _ (CTokUnequal _ ) = showString "!=" showsPrec _ (CTokHat _ ) = showString "^" showsPrec _ (CTokBar _ ) = showString "|" showsPrec _ (CTokAnd _ ) = showString "&&" showsPrec _ (CTokOr _ ) = showString "||" showsPrec _ (CTokQuest _ ) = showString "?" showsPrec _ (CTokColon _ ) = showString ":" showsPrec _ (CTokAssign _ ) = showString "=" showsPrec _ (CTokPlusAss _ ) = showString "+=" showsPrec _ (CTokMinusAss _ ) = showString "-=" showsPrec _ (CTokStarAss _ ) = showString "*=" showsPrec _ (CTokSlashAss _ ) = showString "/=" showsPrec _ (CTokPercAss _ ) = showString "%=" showsPrec _ (CTokAmpAss _ ) = showString "&=" showsPrec _ (CTokHatAss _ ) = showString "^=" showsPrec _ (CTokBarAss _ ) = showString "|=" showsPrec _ (CTokSLAss _ ) = showString "<<=" showsPrec _ (CTokSRAss _ ) = showString ">>=" showsPrec _ (CTokComma _ ) = showString "," showsPrec _ (CTokSemic _ ) = showString ";" showsPrec _ (CTokLBrace _ ) = showString "{" showsPrec _ (CTokRBrace _ ) = showString "}" showsPrec _ (CTokEllipsis _ ) = showString "..." showsPrec _ (CTokAlignof _ ) = showString "alignof" showsPrec _ (CTokAsm _ ) = showString "asm" showsPrec _ (CTokAuto _ ) = showString "auto" showsPrec _ (CTokBreak _ ) = showString "break" showsPrec _ (CTokCase _ ) = showString "case" showsPrec _ (CTokChar _ ) = showString "char" showsPrec _ (CTokConst _ ) = showString "const" showsPrec _ (CTokContinue _ ) = showString "continue" showsPrec _ (CTokDefault _ ) = showString "default" showsPrec _ (CTokDouble _ ) = showString "double" showsPrec _ (CTokDo _ ) = showString "do" showsPrec _ (CTokElse _ ) = showString "else" showsPrec _ (CTokEnum _ ) = showString "enum" showsPrec _ (CTokExtern _ ) = showString "extern" showsPrec _ (CTokFloat _ ) = showString "float" showsPrec _ (CTokFloat128 _ ) = showString "__float128" showsPrec _ (CTokFor _ ) = showString "for" showsPrec _ (CTokGoto _ ) = showString "goto" showsPrec _ (CTokIf _ ) = showString "if" showsPrec _ (CTokInline _ ) = showString "inline" showsPrec _ (CTokInt _ ) = showString "int" showsPrec _ (CTokLong _ ) = showString "long" showsPrec _ (CTokLabel _ ) = showString "__label__" showsPrec _ (CTokRegister _ ) = showString "register" showsPrec _ (CTokRestrict _ ) = showString "restrict" showsPrec _ (CTokReturn _ ) = showString "return" showsPrec _ (CTokShort _ ) = showString "short" showsPrec _ (CTokSigned _ ) = showString "signed" showsPrec _ (CTokSizeof _ ) = showString "sizeof" showsPrec _ (CTokStatic _ ) = showString "static" showsPrec _ (CTokStruct _ ) = showString "struct" showsPrec _ (CTokSwitch _ ) = showString "switch" showsPrec _ (CTokTypedef _ ) = showString "typedef" showsPrec _ (CTokTypeof _ ) = showString "typeof" showsPrec _ (CTokThread _ ) = showString "__thread" showsPrec _ (CTokUnion _ ) = showString "union" showsPrec _ (CTokUnsigned _ ) = showString "unsigned" showsPrec _ (CTokVoid _ ) = showString "void" showsPrec _ (CTokVolatile _ ) = showString "volatile" showsPrec _ (CTokWhile _ ) = showString "while" showsPrec _ (CTokCLit _ c) = showChar c showsPrec _ (CTokILit _ i) = (showString . show) i showsPrec _ (CTokFLit _ s) = showString s showsPrec _ (CTokSLit _ s) = showString s showsPrec _ (CTokIdent _ i) = (showString . identToLexeme) i showsPrec _ (CTokTyIdent _ i) = (showString . identToLexeme) i showsPrec _ (CTokGnuC GnuCAttrTok _) = showString "__attribute__" showsPrec _ (CTokGnuC GnuCExtTok _) = showString "__extension__" showsPrec _ (CTokGnuC GnuCVaArg _) = showString "__builtin_va_arg" showsPrec _ (CTokGnuC GnuCOffsetof _) = showString "__builtin_offsetof" showsPrec _ (CTokGnuC GnuCTyCompat _) = showString "__builtin_types_compatible_p" gtk2hs-buildtools-0.13.10.0/c2hs/c/CTrav.hs0000644000000000000000000010261207346545000016221 0ustar0000000000000000-- C->Haskell Compiler: traversals of C structure tree -- -- Author : Manuel M. T. Chakravarty -- Created: 16 October 99 -- -- Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:27 $ -- -- 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 CTrav (CT, readCT, transCT, getCHeaderCT, 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, isArrDeclr, isPtrDeclr, dropPtrDeclr, isPtrDecl, isFunDeclr, structFromDecl, funResultAndArgs, chaseDecl, findAndChaseDecl, checkForAlias, checkForOneAliasName, lookupEnum, lookupStructUnion, lookupDeclOrTag) where import Data.List (find) import Data.Maybe (fromMaybe) import Control.Monad (liftM) import Control.Exception (assert) import Position (Position, Pos(..), nopos) import Errors (interr) import Idents (Ident, dumpIdent, identToLexeme) import Attributes (Attr(..), newAttrsOnlyPos) import C2HSState (CST, nop, readCST, transCST, runCST, raiseError, catchExc, throwExc, Traces(..), putTraceStr) import CAST import CAttrs (AttrC, getCHeader, enterNewRangeC, enterNewObjRangeC, leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC, lookupDefObjCShadow, addDefTagC, lookupDefTagC, lookupDefTagCShadow, applyPrefix, getDefOfIdentC, setDefOfIdentC, updDefOfIdentC, CObj(..), CTag(..), CDef(..)) -- the C traversal monad -- --------------------- -- C traversal monad (EXPORTED ABSTRACTLY) -- 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 (EXPORTED) -- readCT :: (s -> a) -> CT s a readCT reader = readCST $ \(_, s) -> reader s -- transform user-defined state (EXPORTED) -- 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 -- -- get the raw C header from the monad (EXPORTED) -- getCHeaderCT :: CT s CHeader getCHeaderCT = readAttrCCT getCHeader -- execute a traversal monad (EXPORTED) -- -- * 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 (EXPORTED) -- throwCTExc :: CT s a throwCTExc = throwExc ctExc "Error during traversal of a C structure tree" -- catch a `ctExc' (EXPORTED) -- 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 (EXPORTED) -- raiseErrorCTExc :: Position -> [String] -> CT s a raiseErrorCTExc pos errs = raiseError pos errs >> throwCTExc -- attribute manipulation -- ---------------------- -- name spaces -- -- enter a new local range (EXPORTED) -- enter :: CT s () enter = transAttrCCT $ \ac -> (enterNewRangeC ac, ()) -- enter a new local range, only for objects (EXPORTED) -- enterObjs :: CT s () enterObjs = transAttrCCT $ \ac -> (enterNewObjRangeC ac, ()) -- leave the current local range (EXPORTED) -- leave :: CT s () leave = transAttrCCT $ \ac -> (leaveRangeC ac, ()) -- leave the current local range, only for objects (EXPORTED) -- leaveObjs :: CT s () leaveObjs = transAttrCCT $ \ac -> (leaveObjRangeC ac, ()) -- enter an object definition into the object name space (EXPORTED) -- -- * if a definition of the same name was already present, it is returned -- defObj :: Ident -> CObj -> CT s (Maybe CObj) defObj ide obj = transAttrCCT $ \ac -> addDefObjC ac ide obj -- find a definition in the object name space (EXPORTED) -- 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 (EXPORTED) -- findObjShadow :: Ident -> CT s (Maybe (CObj, Ident)) findObjShadow ide = readAttrCCT $ \ac -> lookupDefObjCShadow ac ide -- enter a tag definition into the tag name space (EXPORTED) -- -- * 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 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) [] _)) tag@(StructUnionCT (CStruct _ (Just _ ) _ _)) = Just (tag, ide) isRefinedOrUse tag@(StructUnionCT (CStruct _ (Just _ ) _ _)) (StructUnionCT (CStruct _ (Just ide) [] _)) = Just (tag, ide) isRefinedOrUse tag@(EnumCT (CEnum (Just _ ) _ _)) (EnumCT (CEnum (Just ide) [] _)) = Just (tag, ide) isRefinedOrUse _ _ = Nothing -- find an definition in the tag name space (EXPORTED) -- 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 (EXPORTED) -- 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 (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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 (EXPORTED) -- refersToDef :: Ident -> CDef -> CT s () refersToDef ide def = transAttrCCT $ \akl -> (setDefOfIdentC akl ide def, ()) -- update the definition of an identifier (EXPORTED) -- refersToNewDef :: Ident -> CDef -> CT s () refersToNewDef ide def = transAttrCCT $ \akl -> (updDefOfIdentC akl ide def, ()) -- get the declarator of an identifier (EXPORTED) -- 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 `" ++ identToLexeme 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 (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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 (EXPORTED) -- isTypedef :: CDecl -> Bool isTypedef (CDecl specs _ _) = not . null $ [() | CStorageSpec (CTypedef _) <- specs] -- discard all declarators but the one declaring the given identifier -- (EXPORTED) -- -- * 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 `" ++ identToLexeme ide ++ "' in decl \ \at " ++ show (posOf at) -- extract the declarator that declares the given identifier (EXPORTED) -- -- * 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 (EXPORTED) -- declrNamed :: CDeclr -> Ident -> Bool declr `declrNamed` ide = declrName declr == Just ide -- get the declarator of a declaration that has at most one declarator -- (EXPORTED) -- 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 -- (EXPORTED) -- declaredName :: CDecl -> Maybe Ident declaredName decl = declaredDeclr decl >>= declrName -- obtains the member definitions and the tag of a struct (EXPORTED) -- -- * member definitions are expanded -- structMembers :: CStructUnion -> ([CDecl], CStructTag) structMembers (CStruct tag _ members _) = (concat . map expandDecl $ members, tag) -- expand declarators declaring more than one identifier into multiple -- declarators, eg, `int x, y;' becomes `int x; int y;' (EXPORTED) -- expandDecl :: CDecl -> [CDecl] expandDecl (CDecl specs decls at) = map (\decl -> CDecl specs [decl] at) decls -- get a struct's name (EXPORTED) -- structName :: CStructUnion -> Maybe Ident structName (CStruct _ oide _ _) = oide -- get an enum's name (EXPORTED) -- enumName :: CEnum -> Maybe Ident enumName (CEnum oide _ _) = oide -- get a tag's name (EXPORTED) -- -- * 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 (EXPORTED) -- -- * as far as parameter passing is concerned, arrays are also pointer -- isPtrDeclr :: CDeclr -> Bool isPtrDeclr (CPtrDeclr _ (CVarDeclr _ _) _) = True isPtrDeclr (CPtrDeclr _ declr _) = isPtrDeclr declr isPtrDeclr (CArrDeclr (CVarDeclr _ _) _ _ _) = True isPtrDeclr (CArrDeclr declr _ _ _) = isPtrDeclr declr isPtrDeclr (CFunDeclr declr _ _ _) = isPtrDeclr declr isPtrDeclr _ = False -- checks whether the given declarator defines an object that is an array of -- some other type (EXPORTED) -- -- * difference between arrays and pure pointers is important for size -- calculations -- isArrDeclr :: CDeclr -> Bool isArrDeclr (CArrDeclr declr _ _ _) = True isArrDeclr _ = False -- drops the first pointer level from the given declarator (EXPORTED) -- -- * the declarator must declare a pointer object -- -- 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 (CPtrDeclr qs declr@(CVarDeclr _ _) ats) = declr dropPtrDeclr (CPtrDeclr qs declr ats) = let declr' = dropPtrDeclr declr in CPtrDeclr qs declr' ats dropPtrDeclr (CArrDeclr declr@(CVarDeclr _ _) _ _ _) = declr dropPtrDeclr (CArrDeclr declr tq e ats) = let declr' = dropPtrDeclr declr in CArrDeclr declr' tq e ats dropPtrDeclr (CFunDeclr declr args vari ats) = let declr' = dropPtrDeclr declr in CFunDeclr declr' args vari ats dropPtrDeclr _ = interr "CTrav.dropPtrDeclr: No pointer!" -- checks whether the given declaration defines a pointer object (EXPORTED) -- -- * 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 (EXPORTED) -- isFunDeclr :: CDeclr -> Bool isFunDeclr (CPtrDeclr _ declr _) = isFunDeclr declr isFunDeclr (CArrDeclr declr _ _ _) = isFunDeclr declr isFunDeclr (CFunDeclr (CVarDeclr _ _) _ _ _) = True isFunDeclr (CFunDeclr declr _ _ _) = isFunDeclr declr isFunDeclr _ = False -- extract the structure from the type specifiers of a declaration (EXPORTED) -- 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 -- (EXPORTED) -- -- * the boolean result indicates whether the function is variadic -- funResultAndArgs :: CDecl -> ([CDecl], CDecl, Bool) funResultAndArgs (CDecl specs [(Just declr, _, _)] _) = let (args, declr', variadic) = funArgs declr result = CDecl specs [(Just declr', Nothing, Nothing)] (newAttrsOnlyPos nopos) in (args, result, variadic) where funArgs (CFunDeclr var@(CVarDeclr _ _) args variadic _) = (args, var, variadic) funArgs (CPtrDeclr qs declr at) = let (args, declr', variadic) = funArgs declr in (args, CPtrDeclr qs declr' at, variadic) funArgs (CArrDeclr declr tqs oe at) = let (args, declr', variadic) = funArgs declr in (args, CArrDeclr declr' tqs oe at, variadic) funArgs (CFunDeclr declr args var at) = let (args, declr', variadic) = funArgs declr in (args, CFunDeclr declr' args var at, variadic) funArgs _ = 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'') (EXPORTED) -- -- * 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 `" ++ identToLexeme ide ++ "' " ++ (if ind then "" else "not ") ++ "following indirections...\n" -- find type object in object name space and then chase it (EXPORTED) -- -- * 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 (EXPORTED) -- 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 (EXPORTED) -- checkForOneAliasName :: CDecl -> Maybe Ident checkForOneAliasName decl = fmap fst $ extractAlias decl False -- 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 (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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 (EXPORTED) -- -- * 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 (CVarDeclr _ _ ) -> Just (ide', ind) Just (CPtrDeclr [_] (CVarDeclr _ _) _) | 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') [] _ -> do -- found forward definition def <- getDefOf ide' case def of TagCD tag -> extractStruct pos tag _ -> err _ -> return su where err = interr "CTrav.extractStruct: Illegal reference!" -- yield the name declared by a declarator if any -- declrName :: CDeclr -> Maybe Ident declrName (CVarDeclr oide _) = oide declrName (CPtrDeclr _ declr _) = declrName declr declrName (CArrDeclr declr _ _ _) = declrName declr declrName (CFunDeclr declr _ _ _) = declrName declr -- 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 (CArrDeclr (CFunDeclr (CVarDeclr _ _) _ _ _) _ _ _) = illegalFunResultErr pos assertFunDeclr pos (CFunDeclr (CVarDeclr _ _) _ _ _) = nop -- everything is ok assertFunDeclr pos (CFunDeclr declr _ _ _) = assertFunDeclr pos declr assertFunDeclr pos (CPtrDeclr _ declr _) = assertFunDeclr pos declr assertFunDeclr pos (CArrDeclr declr _ _ _) = assertFunDeclr pos declr 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 _ [] at)) = enumForwardErr (posOf at) assertIfEnumThenFull _ = nop -- 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 `" ++ identToLexeme ide ++ "' in the \ \header file."] typedefExpectedErr :: Ident -> CT s a typedefExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected type definition!", "The identifier `" ++ identToLexeme 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 `" ++ identToLexeme 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!"] gtk2hs-buildtools-0.13.10.0/c2hs/chs/0000755000000000000000000000000007346545000015177 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/c2hs/chs/CHS.hs0000644000000000000000000014151207346545000016154 0ustar0000000000000000-- C->Haskell Compiler: CHS file abstraction -- -- Author : Manuel M T Chakravarty -- Created: 16 August 99 -- -- Version $Revision: 1.3 $ from $Date: 2005/01/23 15:44:36 $ -- -- Copyright (c) [1999..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 --------------------------------------------------------------- -- -- 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'] [`nolock'] idalias -- | `fun' [`pure'] [`unsafe'] [`nolock'] idalias parms -- | `get' apath -- | `set' apath -- | `pointer' ['*'] idalias ptrkind -- | `class' [ident `=>'] ident ident -- ctxt -> [`lib' `=' string] [prefix] [lock] -- idalias -> ident [`as' (ident | `^')] -- prefix -> `prefix' `=' string -- lock -> `lock' `=' 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' -- | ident `as' ident -- ptrkind -> [`foreign' | `stable' ] ['newtype' | '->' ident] -- -- If `underscoreToCase' occurs in a translation table, it must be the first -- entry. -- -- 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 CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSParm(..), CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..), skipToLangPragma, hasCPP, loadCHS, dumpCHS, hssuffix, chssuffix, loadAllCHI, loadCHI, dumpCHI, chisuffix, showCHSParm) where -- standard libraries import Data.Char (isSpace, toUpper, toLower) import Data.List (intersperse) import Control.Monad (when, unless) -- Compiler Toolkit import Position (Position(..), Pos(posOf), nopos, isBuiltinPos) import Errors (interr) import Idents (Ident, identToLexeme, onlyPosIdent) -- C->Haskell import C2HSState (CST, nop, doesFileExistCIO, readFileCIO, writeFileCIO, getId, getSwitch, chiPathSB, catchExc, throwExc, raiseError, fatal, errorsPresent, showErrors, Traces(..), putTraceStr) -- friends import CHSLexer (CHSToken(..), lexCHS) -- CHS abstract syntax -- ------------------- -- representation of a CHS module (EXPORTED) -- data CHSModule = CHSModule [CHSFrag] -- a CHS code fragament (EXPORTED) -- -- * `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 | CHSLang [String] -- GHC language pragma Position 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 posOf (CHSLang _ pos) = pos -- a CHS binding hook (EXPORTED) -- data CHSHook = CHSImport Bool -- qualified? Ident -- module name String -- content of .chi file Position | CHSContext (Maybe String) -- library name (Maybe String) -- prefix (Maybe String) -- lock function Position | CHSType Ident -- C type Position | CHSSizeof 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 | CHSCall Bool -- is a pure function? Bool -- is unsafe? Bool -- is without lock? Ident -- C function (Maybe Ident) -- Haskell name Position | CHSFun Bool -- is a pure function? Bool -- is unsafe? Bool -- is without lock? Ident -- 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 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 (CHSEnum _ _ _ _ _ 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 olock1 _ ) == (CHSContext olib2 opref2 olock2 _ ) = olib1 == olib1 && opref1 == opref2 && olock1 == olock2 (CHSType ide1 _) == (CHSType ide2 _) = ide1 == ide2 (CHSSizeof ide1 _) == (CHSSizeof ide2 _) = ide1 == ide2 (CHSEnum ide1 oalias1 _ _ _ _) == (CHSEnum ide2 oalias2 _ _ _ _) = oalias1 == oalias2 && 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 (EXPORTED) -- data CHSTrans = CHSTrans Bool -- underscore to case? [(Ident, Ident)] -- alias list -- marshalling descriptor for function hooks (EXPORTED) -- -- * a marshaller consists of a function name and flag indicating whether it -- has to be executed in the IO monad -- data CHSParm = CHSParm (Maybe (Ident, CHSArg)) -- "in" marshaller String -- Haskell type Bool -- C repr: two values? (Maybe (Ident, CHSArg)) -- "out" marshaller Position -- kinds of arguments in function hooks (EXPORTED) -- data CHSArg = CHSValArg -- plain value argument | CHSIOArg -- reference argument | CHSVoidArg -- no argument deriving (Eq) -- structure member access types (EXPORTED) -- data CHSAccess = CHSSet -- set structure field | CHSGet -- get structure field deriving (Eq) -- structure access path (EXPORTED) -- data CHSAPath = CHSRoot Ident -- root of access path | CHSDeref CHSAPath Position -- dereferencing | CHSRef CHSAPath Ident -- member referencing deriving (Eq) -- pointer options (EXPORTED) -- 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 _ _ = [] -- return a modified module description that starts off with a LANGUAGE pragma -- if it contains a LANGUAGE pragma at all skipToLangPragma :: CHSModule -> Maybe CHSModule skipToLangPragma (CHSModule frags) = hLP frags where hLP all@(CHSLang exts _:_) = Just (CHSModule all) hLP (x:xs) = hLP xs hLP [] = Nothing -- test if the language pragma contains the CPP option hasCPP :: CHSModule -> Bool hasCPP (CHSModule (CHSLang exts _:_)) = "CPP" `elem` exts hasCPP _ = False -- load and dump a CHS file -- ------------------------ hssuffix, chssuffix :: String hssuffix = ".hs" chssuffix = ".chs" -- parse a CHS module (EXPORTED) -- -- * 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 -- parse -- traceInfoRead fname contents <- readFileCIO fname traceInfoParse mod <- parseCHSModule (Position fname 1 1) 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 (EXPORTED) -- -- * 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)") (version, _, _) <- getId writeFileCIO (fname ++ suffix) (contents version kind) where contents version kind | hasCPP mod = showCHSModule mod pureHaskell | otherwise = "-- 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 frags) pureHaskell = showFrags pureHaskell Emit frags [] 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 (Position fname line _) = pos generated = isBuiltinPos pos emitNow = state == Emit || (state == Wait && not (null s) && nlStart) nlStart = head s == '\n' nextState = if generated then Wait else NoLine in (if emitNow then showString ("\n{-# LINE " ++ show (line `max` 0) ++ " " ++ show fname ++ " #-}" ++ (if nlStart then "" else "\n")) else id) . showString s . showFrags pureHs nextState frags showFrags False _ (CHSHook hook : frags) = showString "{#" . showCHSHook hook . showString "#}" . showFrags False Wait frags showFrags False _ (CHSCPP s _ : 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 _ _ : frags) = interr "showCHSFrag: Cannot print `CHSCond'!" showFrags pureHs _ (CHSLang exts _ : frags) = let extsNoCPP = filter ((/=) "CPP") exts in if null extsNoCPP then showFrags pureHs Emit frags else showString "{-# LANGUAGE " . showString (concat (intersperse "," extsNoCPP)) . showString " #-}\n" . showFrags pureHs Emit frags 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 olock _) = showString "context " . (case olib of Nothing -> showString "" Just lib -> showString "lib = " . showString lib . showString " ") . showPrefix oprefix False . (case olock of Nothing -> showString "" Just lock -> showString "lock = " . showString lock . showString " ") showCHSHook (CHSType ide _) = showString "type " . showCHSIdent ide showCHSHook (CHSSizeof ide _) = showString "sizeof " . 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 identToLexeme derive)) ++ ") " showCHSHook (CHSCall isPure isUns isNol ide oalias _) = showString "call " . (if isPure then showString "pure " else id) . (if isUns then showString "unsafe " else id) . (if isNol then showString "nolock " else id) . showIdAlias ide oalias showCHSHook (CHSFun isPure isUns isNol ide oalias octxt parms parm _) = showString "fun " . (if isPure then showString "pure " else id) . (if isUns then showString "unsafe " else id) . (if isNol then showString "nolock " else id) . showIdAlias 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 _) = 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 "") 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) 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 (ide, argKind)) = showCHSIdent ide . (case argKind of CHSValArg -> id CHSIOArg -> showString "*" CHSVoidArg -> showString "-") -- showHsVerb str = showChar '`' . showString str . showChar '\'' showCHSTrans :: CHSTrans -> ShowS showCHSTrans (CHSTrans _2Case assocs) = showString "{" . (if _2Case then showString ("underscoreToCase" ++ maybeComma) else id) . foldr (.) id (intersperse (showString ", ") (map showAssoc assocs)) . showString "}" where maybeComma = if null assocs then "" else ", " -- showAssoc (ide1, ide2) = showCHSIdent ide1 . showString " as " . showCHSIdent ide2 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 . identToLexeme -- load and dump a CHI file -- ------------------------ chisuffix :: String chisuffix = ".chi" versionPrefix :: String versionPrefix = "C->Haskell Interface Version " -- replace all import names with the content of the CHI file loadAllCHI :: CHSModule -> CST s CHSModule loadAllCHI (CHSModule frags) = do let checkFrag (CHSHook (CHSImport qual name fName pos)) = do chi <- loadCHI fName return (CHSHook (CHSImport qual name chi pos)) checkFrag h = return h frags' <- mapM checkFrag frags return (CHSModule frags') -- load a CHI file (EXPORTED) -- -- * 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 <- readFileCIO 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 (version, _, _) <- getId 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 <- doesFileExistCIO 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 (EXPORTED) -- -- * the correct suffix will automagically be appended -- dumpCHI :: String -> String -> CST s () dumpCHI fname contents = do (version, _, _) <- getId writeFileCIO (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 toks = do parseFrags0 toks `ifError` contFrags toks 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 (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 (CHSTokPragma pos :toks) = parsePragma 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 let fName = moduleNameToFileName . identToLexeme $ modid toks'' <- parseEndHook toks' frags <- parseFrags toks'' return $ CHSHook (CHSImport qual modid fName 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 ide (CHSTokDot _ : CHSTokIdent _ ide' : toks) = let catIdent ide ide' = onlyPosIdent (posOf ide) --FIXME: unpleasent hack (identToLexeme ide ++ '.' : identToLexeme ide') 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 ) <- parseOptLib toks (opref , toks) <- parseOptPrefix False toks (olock , toks) <- parseOptLock toks toks <- parseEndHook toks frags <- parseFrags toks let frag = CHSContext olib opref olock 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 parseEnum :: Position -> [CHSToken] -> CST s [CHSFrag] 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 (isNolock, toks ) <- parseIsNolock toks (ide , toks ) <- parseIdent toks (oalias , toks ) <- parseOptAs ide False toks toks <- parseEndHook toks frags <- parseFrags toks return $ CHSHook (CHSCall isPure isUnsafe isNolock ide (norm ide oalias) pos) : frags parseFun :: Position -> [CHSToken] -> CST s [CHSFrag] parseFun pos toks = do (isPure , toks' ) <- parseIsPure toks (isUnsafe, toks'2) <- parseIsUnsafe toks' (isNolock, toks'3) <- parseIsNolock toks'2 (ide , toks'4) <- parseIdent toks'3 (oalias , toks'5) <- parseOptAs ide False toks'4 (octxt , toks'6) <- parseOptContext toks'5 (parms , toks'7) <- parseParms toks'6 (parm , toks'8) <- parseParm toks'7 toks'9 <- parseEndHook toks'8 frags <- parseFrags toks'9 return $ CHSHook (CHSFun isPure isUnsafe isNolock ide (norm ide 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' ) <- parseParm toks (parms, toks'') <- parseParms' toks' return (parm:parms, toks'') 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) parseIsNolock :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsNolock (CHSTokNolock _:toks) = return (True , toks) parseIsNolock toks = return (False, toks) norm :: Ident -> Maybe Ident -> Maybe Ident norm ide Nothing = Nothing norm ide (Just ide') | ide == ide' = Nothing | otherwise = Just ide' 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 (Maybe (Ident, CHSArg), [CHSToken]) parseOptMarsh (CHSTokIdent _ ide:CHSTokStar _ :toks) = return (Just (ide, CHSIOArg) , toks) parseOptMarsh (CHSTokIdent _ ide:CHSTokMinus _:toks) = return (Just (ide, CHSVoidArg), toks) parseOptMarsh (CHSTokIdent _ ide :toks) = return (Just (ide, CHSValArg) , toks) parseOptMarsh toks = return (Nothing, toks) parseField :: Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag] parseField pos access toks = do (path, toks') <- parsePath 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) toks'5 <- parseEndHook toks'4 frags <- parseFrags toks'5 return $ CHSHook (CHSPointer isStar ide (norm ide oalias) ptrType isNewtype oRefType 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 ide Nothing = Nothing norm ide (Just ide') | ide == ide' = Nothing | otherwise = Just ide' parsePragma :: Position -> [CHSToken] -> CST s [CHSFrag] parsePragma pos toks = do let parseExts exts (CHSTokIdent _ ide:CHSTokComma _:toks) = parseExts (identToLexeme ide:exts) toks parseExts exts (CHSTokIdent _ ide:CHSTokPragEnd _:toks) = return (reverse (identToLexeme ide:exts), toks) parseExts exts toks = syntaxError toks (exts, toks) <- parseExts [] toks frags <- parseFrags toks return (CHSLang exts pos : frags) 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) parseOptLock :: [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptLock (CHSTokLock _ : CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks) parseOptLock (CHSTokLock _:toks ) = syntaxError toks parseOptLock 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 = identToLexeme ide ps = filter (not . null) . parts $ lexeme in onlyPosIdent pos . adjustHead . 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 -- 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 (CHSTokStar pos:toks) = do (path, toks') <- parsePath toks return (CHSDeref path pos, toks') parsePath (CHSTokIdent _ ide:toks) = do (pathWithHole, toks') <- parsePath' toks return (pathWithHole (CHSRoot ide), toks') parsePath toks = syntaxError toks -- `s->m' is represented by `(*s).m' in the tree -- parsePath' :: [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken]) parsePath' (CHSTokDot _:CHSTokIdent _ ide:toks) = do (pathWithHole, toks') <- parsePath' toks return (pathWithHole . (\hole -> CHSRef hole ide), toks') parsePath' (CHSTokDot _:toks) = syntaxError toks parsePath' (CHSTokArrow pos:CHSTokIdent _ ide:toks) = do (pathWithHole, toks') <- parsePath' toks return (pathWithHole . (\hole -> CHSRef (CHSDeref hole pos) ide), toks') parsePath' (CHSTokArrow _:toks) = syntaxError toks parsePath' toks = do toks' <- parseEndHook toks return (id, toks') parseTrans :: [CHSToken] -> CST s (CHSTrans, [CHSToken]) parseTrans (CHSTokLBrace _:toks) = do (_2Case, toks' ) <- parse_2Case toks case toks' of (CHSTokRBrace _:toks'') -> return (CHSTrans _2Case [], toks'') _ -> do -- if there was no `underscoreToCase', we add a comma token to meet -- the invariant of `parseTranss' -- (transs, toks'') <- if _2Case then parseTranss toks' else parseTranss (CHSTokComma nopos:toks') return (CHSTrans _2Case transs, toks'') where parse_2Case (CHSTok_2Case _:toks) = return (True, toks) parse_2Case toks = return (False, toks) -- parseTranss (CHSTokRBrace _:toks) = return ([], toks) parseTranss (CHSTokComma _:toks) = do (assoc, toks' ) <- parseAssoc toks (trans, toks'') <- parseTranss toks' return (assoc:trans, toks'') parseTranss toks = syntaxError toks -- parseAssoc (CHSTokIdent _ ide1:CHSTokAs _:CHSTokIdent _ ide2:toks) = return ((ide1, ide2), toks) parseAssoc (CHSTokIdent _ ide1:CHSTokAs _:toks ) = syntaxError toks parseAssoc (CHSTokIdent _ ide1: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) parseIdent :: [CHSToken] -> CST s (Ident, [CHSToken]) parseIdent (CHSTokIdent _ ide:toks) = return (ide, toks) parseIdent toks = syntaxError 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 errorCHINotFound :: String -> CST s a errorCHINotFound ide = do raiseError nopos ["Unknown .chi file!", "Cannot find the .chi file for `" ++ ide ++ "'."] 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 gtk2hs-buildtools-0.13.10.0/c2hs/chs/CHSLexer.hs0000644000000000000000000010127607346545000017157 0ustar0000000000000000-- C->Haskell Compiler: Lexer for CHS Files -- -- Author : Manuel M T Chakravarty -- Created: 13 August 99 -- -- Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:35 $ -- -- Copyright (c) [1999..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 --------------------------------------------------------------- -- -- 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 | `\'')* -- | `\'' letter (letter | digit)* `\'' -- reservedid -> `as' | `call' | `class' | `context' | `deriving' -- | `enum' | `foreign' | `fun' | `get' | `lib' -- | `newtype' | `pointer' | `prefix' | `pure' | `set' -- | `sizeof' | `stable' | `type' | `underscoreToCase' -- | `unsafe' | `with' | 'lock' | 'unlock' -- reservedsym -> `{#' | `#}' | `{' | `}' | `,' | `.' | `->' | `=' -- | `=>' | '-' | `*' | `&' | `^' -- string -> `"' instr* `"' -- verbhs -> `\`' instr* `\'' -- instr -> ` '..`\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. -- -- * 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 can be enclosed in single quotes to avoid collision with -- C->Haskell keywords, but those 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 CHSLexer (CHSToken(..), lexCHS) where import Data.List ((\\)) import Data.Char (isDigit) import Control.Monad (liftM) import Numeric (readDec, readOct, readHex) import Position (Position(..), Pos(posOf), incPos, retPos, tabPos) import Errors (ErrorLvl(..), Error, makeError) import UNames (NameSupply, Name, names) import Idents (Ident, lexemeToIdent, identToLexeme) import Lexers (Regexp, Lexer, Action, epsilon, char, (+>), lexaction, lexactionErr, lexmeta, (>|<), (>||<), ctrlLexer, star, plus, quest, alt, string, LexerState, execLexer) import C2HSState (CST, raise, raiseError, nop, getNameSupply) -- token definition -- ---------------- -- possible tokens (EXPORTED) -- 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' | CHSTokEnum Position -- `enum' | CHSTokForeign Position -- `foreign' | CHSTokFun Position -- `fun' | CHSTokGet Position -- `get' | CHSTokImport Position -- `import' | CHSTokLib Position -- `lib' | CHSTokNewtype Position -- `newtype' | CHSTokPointer Position -- `pointer' | CHSTokPrefix Position -- `prefix' | CHSTokPure Position -- `pure' | CHSTokQualif Position -- `qualified' | CHSTokSet Position -- `set' | CHSTokSizeof Position -- `sizeof' | CHSTokStable Position -- `stable' | CHSTokType Position -- `type' | CHSTok_2Case Position -- `underscoreToCase' | CHSTokUnsafe Position -- `unsafe' | CHSTokWith Position -- `with' | CHSTokLock Position -- `lock' | CHSTokNolock Position -- `nolock' | CHSTokString Position String -- string | CHSTokHSVerb Position String -- verbatim 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 | CHSTokPragma Position -- '{-# LANGUAGE' language pragma begin | CHSTokPragEnd Position -- '#-}' language pragma end 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 (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 (CHSTokPointer pos ) = pos posOf (CHSTokPrefix pos ) = pos posOf (CHSTokPure pos ) = pos posOf (CHSTokQualif pos ) = pos posOf (CHSTokSet pos ) = pos posOf (CHSTokSizeof pos ) = pos posOf (CHSTokStable pos ) = pos posOf (CHSTokType pos ) = pos posOf (CHSTok_2Case pos ) = pos posOf (CHSTokUnsafe pos ) = pos posOf (CHSTokWith pos ) = pos posOf (CHSTokLock pos ) = pos posOf (CHSTokNolock pos ) = pos posOf (CHSTokString pos _) = pos posOf (CHSTokHSVerb pos _) = pos posOf (CHSTokIdent pos _) = pos posOf (CHSTokHaskell pos _) = pos posOf (CHSTokCPP pos _) = pos posOf (CHSTokC pos _) = pos posOf (CHSTokCtrl pos _) = pos posOf (CHSTokPragma pos ) = pos posOf (CHSTokPragEnd 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 (CHSTokEnum _ ) == (CHSTokEnum _ ) = True (CHSTokForeign _ ) == (CHSTokForeign _ ) = True (CHSTokFun _ ) == (CHSTokFun _ ) = True (CHSTokGet _ ) == (CHSTokGet _ ) = True (CHSTokImport _ ) == (CHSTokImport _ ) = True (CHSTokLib _ ) == (CHSTokLib _ ) = True (CHSTokNewtype _ ) == (CHSTokNewtype _ ) = True (CHSTokPointer _ ) == (CHSTokPointer _ ) = True (CHSTokPrefix _ ) == (CHSTokPrefix _ ) = True (CHSTokPure _ ) == (CHSTokPure _ ) = True (CHSTokQualif _ ) == (CHSTokQualif _ ) = True (CHSTokSet _ ) == (CHSTokSet _ ) = True (CHSTokSizeof _ ) == (CHSTokSizeof _ ) = True (CHSTokStable _ ) == (CHSTokStable _ ) = True (CHSTokType _ ) == (CHSTokType _ ) = True (CHSTok_2Case _ ) == (CHSTok_2Case _ ) = True (CHSTokUnsafe _ ) == (CHSTokUnsafe _ ) = True (CHSTokWith _ ) == (CHSTokWith _ ) = True (CHSTokLock _ ) == (CHSTokLock _ ) = True (CHSTokNolock _ ) == (CHSTokNolock _ ) = True (CHSTokString _ _) == (CHSTokString _ _) = True (CHSTokHSVerb _ _) == (CHSTokHSVerb _ _) = True (CHSTokIdent _ _) == (CHSTokIdent _ _) = True (CHSTokHaskell _ _) == (CHSTokHaskell _ _) = True (CHSTokCPP _ _) == (CHSTokCPP _ _) = True (CHSTokC _ _) == (CHSTokC _ _) = True (CHSTokCtrl _ _) == (CHSTokCtrl _ _) = True (CHSTokPragma _ ) == (CHSTokPragma _ ) = True (CHSTokPragEnd _ ) == (CHSTokPragEnd _ ) = 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 _ (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 _ (CHSTokPointer _ ) = showString "pointer" showsPrec _ (CHSTokPrefix _ ) = showString "prefix" showsPrec _ (CHSTokPure _ ) = showString "pure" showsPrec _ (CHSTokQualif _ ) = showString "qualified" showsPrec _ (CHSTokSet _ ) = showString "set" showsPrec _ (CHSTokSizeof _ ) = showString "sizeof" showsPrec _ (CHSTokStable _ ) = showString "stable" showsPrec _ (CHSTokType _ ) = showString "type" showsPrec _ (CHSTok_2Case _ ) = showString "underscoreToCase" showsPrec _ (CHSTokUnsafe _ ) = showString "unsafe" showsPrec _ (CHSTokWith _ ) = showString "with" showsPrec _ (CHSTokLock _ ) = showString "lock" showsPrec _ (CHSTokNolock _ ) = showString "nolock" showsPrec _ (CHSTokString _ s) = showString ("\"" ++ s ++ "\"") showsPrec _ (CHSTokHSVerb _ s) = showString ("`" ++ s ++ "'") showsPrec _ (CHSTokIdent _ i) = (showString . identToLexeme) i showsPrec _ (CHSTokHaskell _ s) = showString s showsPrec _ (CHSTokCPP _ s) = showString s showsPrec _ (CHSTokC _ s) = showString s showsPrec _ (CHSTokCtrl _ c) = showChar c showsPrec _ (CHSTokPragma _ ) = showString "{-# LANGUAGE" showsPrec _ (CHSTokPragEnd _ ) = showString "#-}" -- 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 :: CST s CHSLexerState initialState = do namesup <- liftM names getNameSupply return $ CHSLS { nestLvl = 0, inHook = False, namesup = namesup } -- 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 = nop -- 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 = pragma -- LANGUAGE pragma >||< 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') -- the LANGUAGE pragma pragma :: CHSLexer pragma = string "{-# LANGUAGE" `lexmeta` \_ pos s -> (Just $ Right (CHSTokPragma pos), incPos pos 12, s, Just langLexer) langLexer :: CHSLexer langLexer = whitespace >||< identOrKW >||< symbol >||< (string "#-}" `lexmeta` \_ pos s -> (Just $ Right (CHSTokPragEnd pos), incPos pos 3, s, Just chslexer)) -- 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 ErrorErr 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 ErrorErr 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 (tabPos pos) 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 (Position fname _ _) = (Position fname' row' 0) where 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 >||< 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) >||< -- identifier in single quotes (char '\'' +> letter +> (letter >|< digit)`star` char '\'' `lexactionName` \cs pos name -> (mkid $!pos) cs name) -- NB: quotes are removed by lexemeToIdent 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 "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 "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 "stable" _ = CHSTokStable pos idkwtok pos "type" _ = CHSTokType pos idkwtok pos "underscoreToCase" _ = CHSTok_2Case pos idkwtok pos "unsafe" _ = CHSTokUnsafe pos idkwtok pos "with" _ = CHSTokWith pos idkwtok pos "lock" _ = CHSTokLock pos idkwtok pos "nolock" _ = CHSTokNolock pos idkwtok pos cs name = mkid pos cs name -- mkid pos cs name = CHSTokIdent pos (lexemeToIdent pos cs name) -- 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)) -- regular expressions -- letter, digit, instr, inchar, inhsverb :: Regexp s t letter = alt ['a'..'z'] >|< alt ['A'..'Z'] >|< char '_' digit = alt ['0'..'9'] instr = alt ([' '..'\127'] \\ "\"\\") inchar = alt ([' '..'\127'] \\ "\'") 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 -- (EXPORTED) -- -- * the given position is attributed to the first character in the string -- -- * errors are entered into the compiler state -- lexCHS :: String -> Position -> CST s [CHSToken] lexCHS cs pos = do state <- initialState let (ts, lstate, errs) = execLexer chslexer (cs, pos, state) (_, pos', state') = lstate mapM raise errs assertFinalState pos' state' return ts gtk2hs-buildtools-0.13.10.0/c2hs/gen/0000755000000000000000000000000007346545000015173 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/c2hs/gen/CInfo.hs0000644000000000000000000001651707346545000016537 0ustar0000000000000000-- C->Haskell Compiler: information about the C implementation -- -- Author : Manuel M T Chakravarty -- Created: 5 February 01 -- -- Version $Revision: 1.2 $ from $Date: 2005/01/16 21:31:21 $ -- -- 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 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 CInfo ( CPrimType(..), size, alignment, bitfieldDirection, bitfieldPadding, bitfieldIntSigned, bitfieldAlignment ) where import Foreign.C -- we can't rely on the compiler used to compile c2hs already having the new -- FFI, so this is system dependent -- import C2HSConfig (Ptr, FunPtr, bitfieldDirection, bitfieldPadding, bitfieldIntSigned, bitfieldAlignment) import qualified C2HSConfig as Storable (Storable(sizeOf, alignment)) -- calibration of C's primitive types -- ---------------------------------- -- C's primitive types (EXPORTED) -- -- * `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 (EXPORTED) -- -- * 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) --size CLDoublePT = Storable.sizeOf (undefined :: CLDouble) size (CSFieldPT bs) = -bs size (CUFieldPT bs) = -bs -- alignment of C's primitive types (EXPORTED) -- -- * more precisely, the padding put before the type's member starts when the -- preceding component is a char -- alignment :: CPrimType -> Int alignment CPtrPT = Storable.alignment (undefined :: Ptr ()) alignment CFunPtrPT = Storable.alignment (undefined :: FunPtr ()) alignment CCharPT = 1 alignment CUCharPT = 1 alignment CSCharPT = 1 alignment CIntPT = Storable.alignment (undefined :: CInt) alignment CShortPT = Storable.alignment (undefined :: CShort) alignment CLongPT = Storable.alignment (undefined :: CLong) alignment CLLongPT = Storable.alignment (undefined :: CLLong) alignment CUIntPT = Storable.alignment (undefined :: CUInt) alignment CUShortPT = Storable.alignment (undefined :: CUShort) alignment CULongPT = Storable.alignment (undefined :: CULong) alignment CULLongPT = Storable.alignment (undefined :: CULLong) alignment CFloatPT = Storable.alignment (undefined :: CFloat) alignment CDoublePT = Storable.alignment (undefined :: CDouble) --alignment CLDoublePT = Storable.alignment (undefined :: CLDouble) 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 -> Int fieldAlignment 0 = - (size CIntPT - 1) fieldAlignment bs | bitfieldPadding = - bs | otherwise = 0 gtk2hs-buildtools-0.13.10.0/c2hs/gen/GBMonad.hs0000644000000000000000000004152207346545000017002 0ustar0000000000000000-- C->Haskell Compiler: monad for the binding generator -- -- Author : Manuel M T Chakravarty -- Derived: 18 February 2 (extracted from GenBind.hs) -- -- Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:41 $ -- -- Copyright (c) [2002..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 --------------------------------------------------------------- -- -- 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 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 GBMonad ( TransFun, transTabToTransFun, HsObject(..), GB, HsPtrRep, initialGBState, setContext, getLibrary, getPrefix, getLock, 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) -- Compiler Toolkit import Position (Position, Pos(posOf), nopos, builtinPos) import Errors (interr) import Idents (Ident, identToLexeme, onlyPosIdent) import Map (Map) import qualified Map as Map (empty, insert, lookup, fromList, toList, union) -- C -> Haskell import C (CT, readCT, transCT, raiseErrorCTExc) -- friends import CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSAccess(..), CHSAPath(..), 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 :: TransFun underscoreToCase ide = let lexeme = identToLexeme ide 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 -- 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' -- -- * the details of handling the prefix are given in the DOCU section at the -- beginning of this file -- transTabToTransFun :: String -> CHSTrans -> TransFun transTabToTransFun prefix (CHSTrans _2Case table) = \ide -> let lexeme = identToLexeme ide dft = if _2Case -- default uses maybe the... then underscoreToCase ide -- ..._2case transformed... else lexeme -- ...lexeme in case lookup ide table of -- lookup original ident Just ide' -> identToLexeme ide' -- original ident matches Nothing -> case eat prefix lexeme of Nothing -> dft -- no match & no prefix Just eatenLexeme -> let eatenIde = onlyPosIdent (posOf ide) eatenLexeme eatenDft = if _2Case then underscoreToCase eatenIde else eatenLexeme in case lookup eatenIde table of -- lookup without prefix Nothing -> eatenDft -- orig ide without prefix Just ide' -> identToLexeme 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:prefix) (c:cs) | toUpper p == toUpper c = eat prefix 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" -- -- * the co-domain details how this pointer is represented in Haskell. -- See HsPtrRep. -- type PointerMap = Map (Bool, Ident) HsPtrRep -- Define how pointers are represented in Haskell. -- -- * The first element is true if the pointer points to a function. -- The second is the Haskell pointer type (plain -- Ptr, ForeignPtr or StablePtr). The third field is (Just wrap) if the -- pointer is wrapped in a newtype. Where "wrap" -- contains the name of the Haskell data type that was defined for this -- pointer. The forth element contains the type argument of the -- Ptr, ForeignPtr or StablePtr and is the same as "wrap" -- unless the user overrode it with the -> notation. type HsPtrRep = (Bool, CHSPtrType, Maybe 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 [(onlyPosIdent nopos 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) an optional wrapper function that acquires a lock, this may also -- be specified on the command line -- (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 mLock :: Maybe String, -- a lock function frags :: [(CHSHook, CHSFrag)], -- delayed code (with hooks) ptrmap :: PointerMap, -- pointer representation objmap :: HsObjectMap -- generated Haskell objects } type GB a = CT GBState a initialGBState :: Maybe String -> GBState initialGBState mLock = GBState { lib = "", prefix = "", mLock = mLock, frags = [], ptrmap = Map.empty, objmap = Map.empty } -- set the dynamic library and library prefix -- setContext :: (Maybe String) -> (Maybe String) -> (Maybe String) -> GB () setContext lib prefix newMLock = transCT $ \state -> (state {lib = fromMaybe "" lib, prefix = fromMaybe "" prefix, mLock = case newMLock of Nothing -> mLock state Just _ -> newMLock }, ()) -- get the dynamic library -- getLibrary :: GB String getLibrary = readCT lib -- get the prefix string -- getPrefix :: GB String getPrefix = readCT prefix -- get the lock function getLock :: GB (Maybe String) getLock = readCT mLock -- 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) -> HsPtrRep -> 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 HsPtrRep) 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 let pos = posOf hsName 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 let pos = posOf hsName 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 (ptrmap state) readPtrMap, objmap = Map.union (objmap state) readObjMap }, ())) where (ptrAssoc, objAssoc) = read str readPtrMap = Map.fromList [((isStar, onlyPosIdent nopos ide), repr) | ((isStar, ide), repr) <- ptrAssoc] readObjMap = Map.fromList [(onlyPosIdent nopos 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, identToLexeme ide), repr) | ((isStar, ide), repr) <- Map.toList ptrFM], [(identToLexeme 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 `" ++ identToLexeme 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 `" ++ identToLexeme ide ++ "' to be a type name introduced by", "a pointer hook."] hsObjExpectedErr :: Ident -> GB a hsObjExpectedErr ide = raiseErrorCTExc (posOf ide) ["Unknown name!", "`" ++ identToLexeme ide ++ "' is unknown; it has *not* been defined by", "a previous hook."] gtk2hs-buildtools-0.13.10.0/c2hs/gen/GenBind.hs0000644000000000000000000025635207346545000017052 0ustar0000000000000000-- C->Haskell Compiler: binding generator -- -- Author : Manuel M T Chakravarty -- Created: 17 August 99 -- -- Version $Revision: 1.3 $ from $Date: 2005/10/17 20:41:30 $ -- -- 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 --------------------------------------------------------------- -- -- Module implementing the expansion of the binding hooks. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * 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 precede 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 GenBind (expandHooks) where -- standard libraries import Data.Char (toUpper, toLower, isSpace) import Data.List (deleteBy, intersperse, isPrefixOf, find, nubBy) import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Control.Monad (when, unless, liftM, mapAndUnzipM) import Data.Bits ((.&.), (.|.), xor, complement) -- Compiler Toolkit import Position (Position, Pos(posOf), nopos, builtinPos) import Errors (interr, todo) import Idents (Ident, identToLexeme, onlyPosIdent) import Attributes (newAttrsOnlyPos) -- C->Haskell import C2HSConfig (dlsuffix) import C2HSState (CST, nop, errorsPresent, showErrors, fatal, SwitchBoard(..), Traces(..), putTraceStr, getSwitch, printCIO) import C (AttrC, CObj(..), CTag(..), lookupDefObjC, lookupDefTagC, CHeader(..), CExtDecl, CDecl(..), CDeclSpec(..), CStorageSpec(..), CTypeSpec(..), CTypeQual(..), CStructUnion(..), CStructTag(..), CEnum(..), CDeclr(..), CInit(..), CExpr(..), CAssignOp(..), CBinaryOp(..), CUnaryOp(..), CConst (..), CT, readCT, transCT, getCHeaderCT, runCT, ifCTExc, raiseErrorCTExc, findValueObj, findFunObj, findTag, findTypeObj, applyPrefixToNameSpaces, isTypedef, simplifyDecl, declrFromDecl, declrNamed, structMembers, structName, tagName, declaredName , structFromDecl, funResultAndArgs, chaseDecl, findAndChaseDecl, findObjShadow, checkForAlias, checkForOneAliasName, lookupEnum, lookupStructUnion, lookupDeclOrTag, isPtrDeclr, isArrDeclr, dropPtrDeclr, isPtrDecl, getDeclOf, isFunDeclr, refersToNewDef, CDef(..)) -- friends import CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSParm(..), CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..), showCHSParm) import CInfo (CPrimType(..), size, alignment, bitfieldIntSigned, bitfieldAlignment) import GBMonad (TransFun, transTabToTransFun, HsObject(..), GB, HsPtrRep, initialGBState, setContext, getPrefix, getLock, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, queryObj, 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 (Maybe (Ident, CHSArg)) lookupDftMarshIn "Bool" [PrimET pt] | isIntegralCPrimType pt = return $ Just (cFromBoolIde, CHSValArg) lookupDftMarshIn hsTy [PrimET pt] | isIntegralHsType hsTy &&isIntegralCPrimType pt = return $ Just (cIntConvIde, CHSValArg) lookupDftMarshIn hsTy [PrimET pt] | isFloatHsType hsTy &&isFloatCPrimType pt = return $ Just (cFloatConvIde, CHSValArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT)] = return $ Just (withCStringIde, CHSIOArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt] | isIntegralCPrimType pt = return $ Just (withCStringLenIde, CHSIOArg) lookupDftMarshIn hsTy [PtrET ty] | showExtType ty == hsTy = return $ Just (withIde, CHSIOArg) lookupDftMarshIn hsTy [PtrET (PrimET pt)] | isIntegralHsType hsTy && isIntegralCPrimType pt = return $ Just (withIntConvIde, CHSIOArg) lookupDftMarshIn hsTy [PtrET (PrimET pt)] | isFloatHsType hsTy && isFloatCPrimType pt = return $ Just (withFloatConvIde, CHSIOArg) lookupDftMarshIn "Bool" [PtrET (PrimET pt)] | isIntegralCPrimType pt = return $ Just (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 (Maybe (Ident, CHSArg)) lookupDftMarshOut "()" _ = return $ Just (voidIde, CHSVoidArg) lookupDftMarshOut "Bool" [PrimET pt] | isIntegralCPrimType pt = return $ Just (cToBoolIde, CHSValArg) lookupDftMarshOut hsTy [PrimET pt] | isIntegralHsType hsTy &&isIntegralCPrimType pt = return $ Just (cIntConvIde, CHSValArg) lookupDftMarshOut hsTy [PrimET pt] | isFloatHsType hsTy &&isFloatCPrimType pt = return $ Just (cFloatConvIde, CHSValArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT)] = return $ Just (peekCStringIde, CHSIOArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT), PrimET pt] | isIntegralCPrimType pt = return $ Just (peekCStringLenIde, CHSIOArg) lookupDftMarshOut hsTy [PtrET ty] | showExtType ty == hsTy = return $ Just (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 -- 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 = noPosIdent "void" -- never appears in the output cFromBoolIde = noPosIdent "cFromBool" cToBoolIde = noPosIdent "cToBool" cIntConvIde = noPosIdent "cIntConv" cFloatConvIde = noPosIdent "cFloatConv" withIde = noPosIdent "with" withCStringIde = noPosIdent "withCString" withCStringLenIde = noPosIdent "withCStringLenIntConv" withIntConvIde = noPosIdent "withIntConv" withFloatConvIde = noPosIdent "withFloatConv" withFromBoolIde = noPosIdent "withFromBoolConv" peekIde = noPosIdent "peek" peekCStringIde = noPosIdent "peekCString" peekCStringLenIde = noPosIdent "peekCStringLenIntConv" -- 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 (EXPORTED) -- -- * 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 mLock <- getSwitch lockFunSB (_, res) <- runCT (expandModule mod) ac (initialGBState mLock) 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 prag@(CHSLang _ _ ) = return [prag] 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 $ identToLexeme 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 "") ++ identToLexeme ide expandHook (CHSContext olib oprefix olock _) = do setContext olib oprefix olock -- 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 pos decl traceInfoDump decl ty return $ "(" ++ showExtType ty ++ ")" where traceInfoType = traceGenBind "** Type hook:\n" traceInfoDump decl ty = traceGenBind $ "Declaration\n" ++ show decl ++ "\ntranslates to\n" ++ showExtType ty ++ "\n" expandHook (CHSSizeof ide pos) = do traceInfoSizeof decl <- findAndChaseDecl ide False True -- no indirection, but shadows (size, _) <- sizeAlignOf decl traceInfoDump decl size return $ show (fromIntegral . padBits $ size) where traceInfoSizeof = traceGenBind "** Sizeof hook:\n" traceInfoDump decl size = traceGenBind $ "Size of declaration\n" ++ show decl ++ "\nis " ++ show (fromIntegral . padBits $ size) ++ "\n" 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 = fromMaybe gprefix oprefix trans = transTabToTransFun prefix chsTrans hide = identToLexeme . fromMaybe cide $ oalias enumDef enum hide trans (map identToLexeme derive) expandHook hook@(CHSCall isPure isUns isNol 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 mLock <- if isNol then return Nothing else getLock let ideLexeme = identToLexeme ide -- orignal name might have been a shadow hsLexeme = ideLexeme `maybe` identToLexeme $ oalias cdecl' = ide `simplifyDecl` cdecl callImport hook isPure isUns mLock ideLexeme hsLexeme cdecl' pos where traceEnter = traceGenBind $ "** Call hook for `" ++ identToLexeme ide ++ "':\n" expandHook hook@(CHSFun isPure isUns isNol 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 mLock <- if isNol then return Nothing else getLock let ideLexeme = identToLexeme ide -- orignal name might have been a shadow hsLexeme = ideLexeme `maybe` identToLexeme $ oalias fiLexeme = hsLexeme ++ "'_" -- *Urgh* - probably unique... fiIde = onlyPosIdent nopos fiLexeme cdecl' = cide `simplifyDecl` cdecl callHook = CHSCall isPure isUns isNol cide (Just fiIde) pos callImport callHook isPure isUns mLock (identToLexeme cide) fiLexeme cdecl' pos funDef isPure hsLexeme fiLexeme cdecl' ctxt mLock parms parm pos where traceEnter = traceGenBind $ "** Fun hook for `" ++ identToLexeme ide ++ "':\n" expandHook (CHSField access path pos) = do traceInfoField (decl, offsets) <- accessPath path traceDepth offsets ty <- extractSimpleType 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 pos) = do traceInfoPointer let hsIde = fromMaybe cName oalias hsName = identToLexeme 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 let et' = adjustPtr isStar et return (showExtType et', isFunExtType et') Just hsType -> return (identToLexeme 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 realCName <- liftM (maybe cName snd) $ findObjShadow cName pointerDef isStar realCName hsName ptrKind isNewtype hsType isFun 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 -> identToLexeme hsType traceInfoHsType hsName hsType pointerDef isStar cNameFull hsName ptrKind isNewtype hsType False where -- remove a pointer level if the first argument is `False' -- adjustPtr True et = et adjustPtr False (PtrET et) = et adjustPtr _ _ = interr "GenBind.adjustPtr: Where is the Ptr?" -- traceInfoPointer = traceGenBind "** Pointer hook:\n" traceInfoCName kind ide = traceGenBind $ "found C " ++ kind ++ " for `" ++ identToLexeme ide ++ "'\n" traceInfoHsType name ty = traceGenBind $ "associated with Haskell entity `" ++ name ++ "'\nhaving type " ++ ty ++ "\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 (identToLexeme classIde) (identToLexeme 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 $ (identToLexeme ide, identToLexeme 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@(CEnum _ 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 cpos = posOf cenum -- 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 val' at1) at2):list', False) FloatResult _ -> illegalConstExprErr (posOf exp) "a float result" where at1 = newAttrsOnlyPos nopos at2 = 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 indent [] = "" enumBody indent ((ide, _):list) = ide ++ "\n" ++ replicate indent ' ' ++ (if null list then "" else "| " ++ enumBody indent list) -- 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 flatList ++ "\n" ++ toDef flatList ++ "\n" ++ succDef names ++ "\n" ++ predDef names ++ "\n" ++ enumFromToDef names where names = map fst list flatList = flatten list 0 flatten [] n = [] flatten ((ide, exp):list) n = (ide, val) : flatten 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 fromDef list = concat [ " fromEnum " ++ ide ++ " = " ++ show' val ++ "\n" | (ide, val) <- list ] toDef list = concat [ " toEnum " ++ show' val ++ " = " ++ ide ++ "\n" | (ide, val) <- nubBy (\x y -> snd x == snd y) list ] ++ " toEnum unmatched = error (\"" ++ ident ++ ".toEnum: Cannot match \" ++ show unmatched)\n" succDef [] = " succ _ = undefined\n" succDef [x] = " succ _ = undefined\n" succDef (x:x':xs) = " succ " ++ x ++ " = " ++ x' ++ "\n" ++ succDef (x':xs) predDef [] = " pred _ = undefined\n" predDef [x] = " pred _ = undefined\n" predDef (x:x':xs) = " pred " ++ x' ++ " = " ++ x ++ "\n" ++ predDef (x':xs) enumFromToDef [] = "" enumFromToDef names = " enumFromTo x y | fromEnum x == fromEnum y = [ y ]\n" ++ " | otherwise = x : enumFromTo (succ x) y\n" ++ " enumFrom x = enumFromTo x " ++ last names ++ "\n" ++ " enumFromThen _ _ = " ++ " error \"Enum "++ident++": enumFromThen not implemented\"\n" ++ " enumFromThenTo _ _ _ = " ++ " error \"Enum "++ident++": enumFromThenTo not implemented\"\n" -- 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 -> Maybe String -> String -> String -> CDecl -> Position -> GB String callImport hook isPure isUns mLock ideLexeme hsLexeme cdecl pos = do -- compute the external type from the declaration, and delay the foreign -- export declaration -- (mHsPtrRep, extType) <- extractFunType pos cdecl isPure header <- getSwitch headerSB delayCode hook (foreignImport header ideLexeme hsLexeme isUns extType) traceFunType extType -- if the type any special pointer aliases, generate a lambda expression -- which strips off the constructors if any isJust mHsPtrRep then createLambdaExpr mHsPtrRep else return funStr where createLambdaExpr :: [Maybe HsPtrRep] -> GB String createLambdaExpr foreignVec = return $ "(\\" ++ unwords (zipWith wrPattern foreignVec [1..])++ " -> "++ concat (zipWith wrForPtr foreignVec [1..])++funStr++" "++ unwords (zipWith wrArg foreignVec [1..])++")" wrPattern (Just (_,_,Just con,_)) n = "("++con++" arg"++show n++")" wrPattern _ n = "arg"++show n wrForPtr (Just (_,CHSForeignPtr,_,_)) n = "withForeignPtr arg"++show n++" $ \\argPtr"++show n++" ->" wrForPtr _ n = "" wrArg (Just (_,CHSForeignPtr,_,_)) n = "argPtr"++show n wrArg (Just (_,CHSStablePtr,_,_)) n = "(castStablePtrToPtr arg"++show n++")" wrArg _ n = "arg"++show n funStr = case mLock of Nothing -> hsLexeme Just lockFun -> lockFun ++ " $ " ++ hsLexeme traceFunType et = traceGenBind $ "Imported function type: " ++ showExtType et ++ "\n" -- Haskell code for the foreign import declaration needed by a call hook -- -- On Windows, the paths for headers in "entity" may include backslashes, like -- dist\build\System\Types\GIO.h -- It seems GHC expects these to be escaped. Below, we make an educated guess -- that it in fact expects a Haskell string, and use the "show" function to do -- the escaping of this (and any other cases) for us. foreignImport :: String -> String -> String -> Bool -> ExtType -> String foreignImport header ident hsIdent isUnsafe ty = "foreign import ccall " ++ safety ++ " " ++ show entity ++ "\n " ++ hsIdent ++ " :: " ++ showExtType ty ++ "\n" where safety = if isUnsafe then "unsafe" else "safe" entity | null header = ident | otherwise = header ++ " " ++ ident -- produce a Haskell function definition for a fun hook -- funDef :: Bool -- pure function? -> String -- name of the new Haskell function -> String -- Haskell name of the foreign imported C function -> CDecl -- simplified declaration of the C function -> Maybe String -- type context of the new Haskell function -> Maybe String -- lock function -> [CHSParm] -- parameter marshalling description -> CHSParm -- result marshalling description -> Position -- source location of the hook -> GB String -- Haskell code in text form funDef isPure hsLexeme fiLexeme cdecl octxt mLock parms parm pos = do (parms', parm', isImpure) <- addDftMarshaller pos parms parm cdecl 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 | (_, _, callArg, _, _) <- marshs] marshOuts = [marshOut | (_, _, _, marshOut, _) <- marshs, marshOut /= ""] retArgs = [retArg | (_, _, _, _, retArg) <- marshs, retArg /= ""] funHead = hsLexeme ++ join funArgs ++ " =\n" ++ if isPure && isImpure then " unsafePerformIO $\n" else "" lock = case mLock of Nothing -> "" Just lock -> lock ++ " $" call = if isPure then " let {res = " ++ fiLexeme ++ join callArgs ++ "} in\n" else " " ++ lock ++ fiLexeme ++ join callArgs ++ " >>= \\res ->\n" marshRes = case parm' of CHSParm _ _ twoCVal (Just (_ , CHSVoidArg)) _ -> "" CHSParm _ _ twoCVal (Just (omIde, CHSIOArg )) _ -> " " ++ identToLexeme omIde ++ " res >>= \\res' ->\n" CHSParm _ _ twoCVal (Just (omIde, CHSValArg )) _ -> " let {res' = " ++ identToLexeme omIde ++ " res} in\n" CHSParm _ _ _ Nothing _ -> interr "GenBind.funDef: marshRes: no default?" retArgs' = case parm' of CHSParm _ _ _ (Just (_, CHSVoidArg)) _ -> retArgs _ -> "res'":retArgs ret = "(" ++ concat (intersperse ", " retArgs') ++ ")" funBody = joinLines marshIns ++ 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 -- -- for an argument marshaller, generate all "in" and "out" marshalling -- code fragments -- marshArg i (CHSParm (Just (imIde, imArgKind)) _ twoCVal (Just (omIde, omArgKind)) _ ) = let a = "a" ++ show i imStr = identToLexeme imIde 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 " callArg = if twoCVal then "" ++ a ++ "'1 " ++ a ++ "'2" else a ++ "'" omApp = identToLexeme omIde ++ " " ++ callArg outBndr = a ++ "''" marshOut = case omArgKind of CHSVoidArg -> "" CHSIOArg -> omApp ++ ">>= \\" ++ outBndr ++ " -> " CHSValArg -> "let {" ++ outBndr ++ " = " ++ omApp ++ "} in " retArg = if omArgKind == CHSVoidArg then "" else outBndr in (funArg, marshIn, callArg, 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 -> CDecl -> GB ([CHSParm], CHSParm, Bool) addDftMarshaller pos parms parm cdecl = do (_, fType) <- extractFunType pos cdecl True let (resTy, argTys) = splitFunTy fType (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):parms) [] = 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 (noPosIdent "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 root@(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 (CVarDeclr _ _), _, _) -> nop _ -> 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 [declr] at) = case declr of (Just (CPtrDeclr [_] declr at), oinit, oexpr) -> return $ CDecl specs [(Just declr, oinit, oexpr)] at (Just (CPtrDeclr (_:quals) declr at), oinit, oexpr) -> return $ CDecl specs [(Just (CPtrDeclr quals declr at), oinit, oexpr)] at _ -> ptrExpectedErr pos -- 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` ide = 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 ty' = case ty of t@(DefinedET _ _) -> PtrET t t -> t 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 $ 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 : offsets) = do code <- setGetBody offsets 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 (IOET _ ) = interr "GenBind.setGet: Illegal \ \type!" checkType (UnitET ) = voidFieldErr pos 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? -> GB String pointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun = do keepOld <- getSwitch oldFFI let ptrArg = if keepOld then "()" -- legacy FFI interface else 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) thePtr `ptrMapsTo` (isFun, ptrKind, if isNewtype then Just hsName else Nothing, ptrArg) return $ if isNewtype then "newtype " ++ hsName ++ " = " ++ hsName ++ " (" ++ ptrType ++ ")" else "type " ++ hsName ++ " = " ++ ptrType -- 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 => " classDef = "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 $ classDef ++ 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 HsPtrRep -- aliased type | PrimET CPrimType -- basic C type | UnitET -- void 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 _ rep ) == (DefinedET _ rep' ) = rep == rep' (PrimET t ) == (PrimET 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 (IOET _ ) = True isFunExtType (DefinedET _ (isFun,_,_,_)) = isFun isFunExtType _ = False -- pretty print an external type -- -- * a previous version of this function attempted to not print unnecessary -- brackets; this however doesn't work consistently due to `DefinedET'; so, -- we give up on the idea (preferring simplicity) -- showExtType :: ExtType -> String showExtType (FunET UnitET res) = showExtType res showExtType (FunET arg res) = "(" ++ showExtType arg ++ " -> " ++ showExtType res ++ ")" showExtType (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 ([Maybe HsPtrRep], 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 when variadic $ variadicErr pos cpos preResultType <- liftM (snd . expandSpecialPtrs) $ extractSimpleType pos resultDecl -- -- we can now add the `IO' monad if this is no pure function -- let resultType = if isPure then preResultType else IOET preResultType -- -- compute function arguments and create a function type (a function -- prototype with `void' as its single argument declares a nullary -- function) -- (foreignSyn, argTypes) <- liftM (unzip . map expandSpecialPtrs) $ mapM (extractSimpleType pos) args return (foreignSyn, foldr FunET resultType argTypes) where cpos = posOf cdecl -- provide info on Haskell wrappers around C pointers expandSpecialPtrs :: ExtType -> (Maybe HsPtrRep, ExtType) -- no special treatment for a simple type synonym expandSpecialPtrs all@(DefinedET cdecl (_, CHSPtr, Nothing, _)) = (Nothing, PtrET all) -- all other Haskell pointer wrappings require -- special calling conventions expandSpecialPtrs all@(DefinedET cdecl hsPtrRep) = (Just hsPtrRep, PtrET all) -- non-pointer arguments are passed normal expandSpecialPtrs all = (Nothing, all) -- compute a non-struct/union type from the given declaration -- -- * the declaration may have at most one declarator -- -- * C functions are represented as `Ptr (FunEt ...)' or `Addr' if in -- compatibility mode (ie, `--old-ffi=yes') -- extractSimpleType :: Position -> CDecl -> GB ExtType extractSimpleType pos cdecl = do traceEnter ct <- extractCompType cdecl case ct of ExtType et -> return et SUType _ -> illegalStructUnionErr (posOf cdecl) pos where traceEnter = traceGenBind $ "Entering `extractSimpleType'...\n" -- compute a Haskell type for a type referenced in a C pointer type -- -- * the declaration may have at most one declarator -- -- * struct/union types are mapped to `()' -- -- * NB: this is by definition not a result type -- extractPtrType :: CDecl -> GB ExtType extractPtrType cdecl = do ct <- extractCompType 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 -- -- * all C pointers (including functions) are represented as `Addr' if in -- compatibility mode (--old-ffi) -- -- * typedef'ed types are chased -- -- * 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 :: CDecl -> GB CompType extractCompType 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? oHsRepr <- case oalias of Nothing -> return $ Nothing Just ide -> queryPtr (True, ide) case oHsRepr of Just repr -> ptrAlias repr -- got an alias Nothing -> do -- no alias => recurs ct <- extractCompType 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 Nothing -> 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 sdecl Just repr -> ptrAlias repr -- found a pointer hook alias -- -- compute the result for a pointer alias -- ptrAlias (isFun, ptrTy, wrapped, tyArg) = returnX $ DefinedET cdecl (isFun, ptrTy, wrapped, tyArg) -- -- wrap an `ExtType' into a `CompType' and convert parametrised pointers -- to `Addr' if needed -- returnX retval@(PtrET et) = do keepOld <- getSwitch oldFFI if keepOld then return $ ExtType (PrimET CPtrPT) else return $ ExtType retval 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 `" ++ identToLexeme 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 -- isUnsupportedType (PrimET et) = size et == 0 -- can't be a bitfield (yet) 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 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 -- 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 = size CIntPT * 8 (overflow, rest) = (b1 + b2) `divMod` bitsPerBitfield -- pad any storage unit that is partially used by a bitfield -- padBits :: BitSize -> Int padBits (BitSize o 0) = o padBits (BitSize o _) = o + size CIntPT -- compute the offset of the declarator in the second argument when it is -- preceded by the declarators in the first argument -- offsetInStruct :: [CDecl] -> CDecl -> CStructTag -> GB BitSize offsetInStruct [] _ _ = return $ BitSize 0 0 offsetInStruct decls decl tag = do (offset, _) <- sizeAlignOfStruct decls tag (_, align) <- sizeAlignOf decl return $ alignOffset offset align -- 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 (offset, preAlign) <- sizeAlignOfStruct (init decls) CStructTag (size, align) <- sizeAlignOf (last decls) let sizeOfStruct = alignOffset offset align `addBitSize` size align' = if align > 0 then align else bitfieldAlignment alignOfStruct = preAlign `max` align' return (sizeOfStruct, alignOfStruct) sizeAlignOfStruct decls CUnionTag = do (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 (size, align) <- sizeAlignOfStruct decls tag return (alignOffset size align, align) -- compute the size and alignment constraint of a given C declaration -- sizeAlignOf :: CDecl -> GB (BitSize, Int) -- -- * we make use of the assertion that `extractCompType' can only return a -- `DefinedET' when the declaration is a pointer declaration -- sizeAlignOf (CDecl specs [(Just declr, _, size)] ats) | isArrDeclr declr = interr $ "sizeAlignOf: calculating size of constant array not supported." sizeAlignOf cdecl = do ct <- extractCompType cdecl case ct of ExtType (FunET _ _ ) -> return (bitSize CFunPtrPT, alignment CFunPtrPT) ExtType (IOET _ ) -> interr "GenBind.sizeof: Illegal IO type!" ExtType (PtrET t ) | isFunExtType t -> return (bitSize CFunPtrPT, alignment CFunPtrPT) | otherwise -> return (bitSize CPtrPT, alignment CPtrPT) ExtType (DefinedET _ _ ) -> return (bitSize CPtrPT, alignment CPtrPT) -- FIXME: The defined type could be a function pointer!!! ExtType (PrimET pt ) -> return (bitSize pt, alignment pt) 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 = 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 -- alignOffset :: BitSize -> Int -> BitSize alignOffset offset@(BitSize octetOffset bitOffset) align | align > 0 && bitOffset /= 0 = -- close bitfield first alignOffset (BitSize (octetOffset + (bitOffset + 7) `div` 8) 0) align | 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 | otherwise = -- stays in current bitfield offset where bitsPerBitfield = size CIntPT * 8 overflowingBitfield = bitOffset - align >= bitsPerBitfield -- note, `align' is negative -- constant folding -- ---------------- -- evaluate a constant expression -- -- FIXME: this is a bit too simplistic, as the range of expression allowed as -- constant expression varies depending on the context in which the -- constant expression occurs -- evalConstCExpr :: CExpr -> GB ConstResult evalConstCExpr (CComma _ at) = illegalConstExprErr (posOf at) "a comma expression" evalConstCExpr (CAssign _ _ _ at) = illegalConstExprErr (posOf at) "an assignment" evalConstCExpr (CCond b (Just t) e _) = do bv <- evalConstCExpr b case bv of IntResult bvi -> if bvi /= 0 then evalConstCExpr t else evalConstCExpr e FloatResult _ -> illegalConstExprErr (posOf b) "a float result" evalConstCExpr (CBinary op lhs rhs at) = do lhsVal <- evalConstCExpr lhs rhsVal <- evalConstCExpr rhs let (lhsVal', rhsVal') = usualArithConv lhsVal rhsVal applyBin (posOf at) op lhsVal' rhsVal' evalConstCExpr (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 _ 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 i evalCConst (CCharConst c _ ) = return $ IntResult (toInteger (fromEnum c)) evalCConst (CFloatConst s _ ) = todo "GenBind.evalCConst: Float conversion from literal misses." evalCConst (CStrConst s 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 cpos CMulOp (IntResult x) (IntResult y) = return $ IntResult (x * y) applyBin cpos CMulOp (FloatResult x) (FloatResult y) = return $ FloatResult (x * y) applyBin cpos CDivOp (IntResult x) (IntResult y) = return $ IntResult (x `div` y) applyBin cpos CDivOp (FloatResult x) (FloatResult y) = return $ FloatResult (x / y) applyBin cpos CRmdOp (IntResult x) (IntResult y) = return$ IntResult (x `mod` y) applyBin cpos CRmdOp (FloatResult x) (FloatResult y) = illegalConstExprErr cpos "a % operator applied to a float" applyBin cpos CAddOp (IntResult x) (IntResult y) = return $ IntResult (x + y) applyBin cpos CAddOp (FloatResult x) (FloatResult y) = return $ FloatResult (x + y) applyBin cpos CSubOp (IntResult x) (IntResult y) = return $ IntResult (x - y) applyBin cpos CSubOp (FloatResult x) (FloatResult y) = return $ FloatResult (x - y) applyBin cpos CShlOp (IntResult x) (IntResult y) = return $ IntResult (x * 2^y) applyBin cpos CShlOp (FloatResult x) (FloatResult y) = illegalConstExprErr cpos "a << operator applied to a float" applyBin cpos CShrOp (IntResult x) (IntResult y) = return $ IntResult (x `div` 2^y) applyBin cpos CShrOp (FloatResult x) (FloatResult y) = illegalConstExprErr cpos "a >> operator applied to a float" applyBin cpos CAndOp (IntResult x) (IntResult y) = return $ IntResult (x .&. y) applyBin cpos COrOp (IntResult x) (IntResult y) = return $ IntResult (x .|. y) applyBin cpos CXorOp (IntResult x) (IntResult y) = return $ IntResult (x `xor` y) applyBin cpos _ (IntResult x) (IntResult y) = todo "GenBind.applyBin: Not yet implemented operator in constant expression." applyBin cpos _ (FloatResult x) (FloatResult y) = 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 cpos CPlusOp arg = return arg applyUnary cpos CMinOp (IntResult x) = return (IntResult (-x)) applyUnary cpos CMinOp (FloatResult x) = return (FloatResult (-x)) applyUnary cpos CCompOp (IntResult x) = return (IntResult (complement x)) applyUnary cpos 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 -- -------------------- -- create an identifier without position information -- noPosIdent :: String -> Ident noPosIdent = onlyPosIdent nopos -- 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_ m 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 `" ++ identToLexeme 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 C \ \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 `" ++ identToLexeme 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."] 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!", "There may not be an \"in\" marshaller for the result."] 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))] gtk2hs-buildtools-0.13.10.0/c2hs/gen/GenHeader.hs0000644000000000000000000002505007346545000017353 0ustar0000000000000000-- C->Haskell Compiler: custom header generator -- -- Author : Manuel M T Chakravarty -- Created: 5 February 2003 -- -- Version $Revision: 1.1 $ -- -- 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 GenHeader ( genHeader ) where -- standard libraries import Control.Monad (when) -- Compiler Toolkit import Position (Position, Pos(..), nopos) import DLists (DList, openDL, closeDL, zeroDL, unitDL, joinDL, snocDL) import Errors (interr) import Idents (onlyPosIdent) import UNames (NameSupply, Name, names) -- C->Haskell import C2HSState (CST, getNameSupply, runCST, transCST, raiseError, catchExc, throwExc, errorsPresent, showErrors, fatal) -- friends import CHS (CHSModule(..), CHSFrag(..)) -- 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 supply <- getNameSupply (header, mod) <- runCST (ghModule mod) (names supply) `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 conditionl. -- newName :: CST [Name] String newName = transCST $ \supply -> (tail supply, "C2HS_COND_SENTRY_" ++ show (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 (closeDL 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 (zeroDL, [], 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 `joinDL` 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 (zeroDL, EOF, []) ghFrag (frag@(CHSVerb _ _ ) : frags) = return (zeroDL, Frag frag, frags) ghFrag (frag@(CHSHook _ ) : frags) = return (zeroDL, Frag frag, frags) ghFrag (frag@(CHSLine _ ) : frags) = return (zeroDL, Frag frag, frags) ghFrag (frag@(CHSLang _ _ ) : frags) = return (zeroDL, Frag frag, frags) ghFrag ( (CHSC s _ ) : frags) = do (header, frag, frags' ) <- ghFrag frags -- scan for next CHS fragment return (unitDL s `joinDL` header, frag, frags') -- FIXME: this is not tail recursive... ghFrag ( (CHSCond _ _ ) : frags) = interr "GenHeader.ghFrags: There can't be a structured conditional yet!" ghFrag (frag@(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 (zeroDL , Else pos , frags) "elif" -> return (zeroDL , Elif s pos , frags) "endif" -> return (zeroDL , Endif pos , frags) _ -> return (openDL ['#':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 pos -> closeIf ((headerTh `snocDL` "#else\n") `joinDL` (headerEl `snocDL` "#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 `joinDL` headerEl) (s, fragsTh) alts dft rest _ -> interr "GenHeader.ghFrag: Expected CHSCond!" Endif pos -> closeIf (headerTh `snocDL` "#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 = onlyPosIdent nopos 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 = openDL ['#':s, "\n", "struct ", sentryName, ";\n"] `joinDL` 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."] gtk2hs-buildtools-0.13.10.0/c2hs/state/0000755000000000000000000000000007346545000015542 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/c2hs/state/C2HSState.hs0000644000000000000000000000616507346545000017606 0ustar0000000000000000-- C -> Haskell Compiler: C2HS's state -- -- Author : Manuel M. T. Chakravarty -- Created: 6 March 1999 -- -- Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:41 $ -- -- 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 C2HSState (-- re-exports all of `State' -- module 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 State import Switches (SwitchBoard(..), Traces(..), initialSwitchBoard) -- instantiation of the extra state -- -------------------------------- -- the extra state consists of the `SwitchBoard' (EXPORTED) -- type CST s a = PreCST SwitchBoard s a -- execution of c2hs starts with the initial `SwitchBoard' -- runC2HS :: (String, String, String) -> CST () a -> IO a runC2HS vcd = run vcd 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 $ hPutStrCIO 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 gtk2hs-buildtools-0.13.10.0/c2hs/state/Switches.hs0000644000000000000000000001164307346545000017674 0ustar0000000000000000-- C -> Haskell Compiler: management of switches -- -- Author : Manuel M T Chakravarty -- Created: 6 March 99 -- -- Version $Revision: 1.3 $ from $Date: 2005/06/22 16:01:21 $ -- -- Copyright (c) [1999..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 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 `hpaths' switch lists all directories that should be considered when -- searching for a header file. -- -- * The `keep' flag says whether the intermediate file produced by the C -- pre-processor should be retained or not. -- -- * 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. -- -- * The pre-compiled header switch is unset if no pre-compiled header should -- be read or generated. If the option is set and a header file is given -- a concise version of the header will be written to the FilePath. If -- a binding file is given, the pre-compiled header is used to expand the -- module unless the binding file contains itself C declarations. -- --- TODO ---------------------------------------------------------------------- -- module Switches ( SwitchBoard(..), Traces(..), initialSwitchBoard ) where -- the switch board contains all toolkit switches -- ---------------------------------------------- -- all switches of the toolkit (EXPORTED) -- data SwitchBoard = SwitchBoard { cppOptsSB :: [String], -- cpp options cppSB :: FilePath, -- cpp executable hpathsSB :: [FilePath], -- header file directories -- since 0.11.1 `hpathsSB' isn't really needed anymore.. -- ..remove from 0.12 series keepSB :: Bool, -- keep intermediate file tracesSB :: Traces, -- trace flags outputSB :: FilePath, -- basename of generated files outDirSB :: FilePath, -- dir where generated files go headerSB :: FilePath, -- generated header file preCompSB :: Maybe FilePath,-- optional binary header r/w oldFFI :: Bool, -- GHC 4.XX compatible code chiPathSB :: [FilePath], -- .chi file directories lockFunSB :: Maybe String -- a function to wrap each call } -- switch states on startup (EXPORTED) -- initialSwitchBoard :: SwitchBoard initialSwitchBoard = SwitchBoard { cppOptsSB = [], cppSB = "cpp", hpathsSB = [], keepSB = False, tracesSB = initialTraces, outputSB = "", outDirSB = "", headerSB = "", preCompSB = Nothing, oldFFI = False, chiPathSB = ["."], lockFunSB = Nothing } -- traces -- ------ -- different kinds of traces possible (EXPORTED) -- 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 } gtk2hs-buildtools-0.13.10.0/c2hs/toplevel/0000755000000000000000000000000007346545000016254 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/c2hs/toplevel/C2HSConfig.hs0000644000000000000000000001044607346545000020442 0ustar0000000000000000-- -*-haskell-*- -- =========================================================================== -- C -> Haskell Compiler: configuration -- -- Author : Manuel M T Chakravarty -- Created: 27 September 99 -- -- Version $Revision: 1.3 $ from $Date: 2005/02/07 00:04:28 $ -- -- 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 --------------------------------------------------------------- -- -- Configuration options; largely set by `configure'. -- --- TODO ---------------------------------------------------------------------- -- module C2HSConfig ( -- -- programs and paths -- cpp, cppopts, cppoptsdef, hpaths, dlsuffix, tmpdir, -- -- system-dependent definitions, as the New FFI isn't fully supported on all -- systems yet -- Ptr, FunPtr, Storable(sizeOf, alignment), -- -- parameters of the targeted C compiler -- bitfieldDirection, bitfieldPadding, bitfieldIntSigned, bitfieldAlignment ) where import Data.Ix (Ix) import Data.Array (Array, array) import Foreign (Ptr, FunPtr) import Foreign (Storable(sizeOf, alignment), toBool) import Foreign.C (CInt(..)) import System.Info (os) -- program settings -- ---------------- -- C preprocessor executable (EXPORTED) -- cpp :: FilePath cpp = case os of "darwin" -> "gcc" _ -> "cpp" -- C preprocessor options (EXPORTED) -- -- * `-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 ("openbsd","cpp") -> ["-xc", "-w"] (_,"cpp") -> ["-x", "c", "-w"] (_,"gcc") -> ["-E", "-x", "c", "-w"] _ -> [] -- C preprocessor option for including only definitions (EXPORTED) cppoptsdef :: String cppoptsdef = "-imacros" -- standard system search paths for header files (EXPORTED) -- hpaths :: [FilePath] hpaths = [".", "/usr/include", "/usr/local/include"] -- OS-dependent suffix for dynamic libraries -- dlsuffix :: String dlsuffix = error "C2HSConfig.dlsuffix" -- used to be: "@DLSUFFIX@" -- possibly system-dependent location for temporary files -- tmpdir :: String tmpdir = error "C2HSConfig.tmpdir" -- used to be: "@TMPDIR@" -- tmpdir is unused and it causes problems on widows since it ends up with -- the value "C:\TMP" which is not a valid string. It'd need to be "C:\\TMP" -- so just remove the thing for now. -- parameters of the targeted C compiler -- ------------------------------------- -- indicates in which direction the C compiler fills bitfields (EXPORTED) -- -- * 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 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 (EXPORTED) -- -- * `True' means that such a bitfield introduces padding (instead of being -- split) -- bitfieldPadding :: Bool bitfieldPadding = toBool bitfield_padding foreign import ccall bitfield_padding :: CInt -- indicates whether a bitfield of type `int' is signed in the targeted C -- compiler (EXPORTED) -- bitfieldIntSigned :: Bool bitfieldIntSigned = toBool bitfield_int_signed foreign import ccall bitfield_int_signed :: CInt -- the alignment constraint for a bitfield (EXPORTED) -- -- * 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 bitfield_alignment :: CInt gtk2hs-buildtools-0.13.10.0/c2hs/toplevel/Gtk2HsC2Hs.hs0000644000000000000000000006104607346545000020401 0ustar0000000000000000-- C -> Haskell Compiler: main module -- -- Author : Manuel M T Chakravarty -- Derived: 12 August 99 -- -- Version $Revision: 1.6 $ from $Date: 2005/07/03 14:58:16 $ -- -- Copyright (c) [1999..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 is the main module of the compiler. It sets the version, processes -- the command line arguments, and controls the compilation process. -- -- Originally, derived from `Main.hs' of the Nepal Compiler. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- 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'). -- -- -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. -- -- -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 error output) the version and copyright -- information of the compiler (before doing anything else). -- -- -p FILE -- --precomp=FILE -- Use or generate a precompiled header. If a header file is -- given write a condensed version of the header file into -- FILE. If a binding file is given that does not contain any C -- declarations itself, use the condensed information in FILE -- to generate the binding. Using a precompiled header file will -- significantly speed up the translation of a binding module. -- -- --old-ffi [=yes|=no] -- Generate hooks using pre-standard FFI libraries. This currently -- affects only call hooks where instead of `Addr' types -- `Ptr ' is used. -- -- --lock=NAME -- Wrap each foreign function call in the function NAME. This -- function is usually a function that acquires a lock for -- the memory region that the called function is about to access. -- A wrap function can also be specificed within the file in the -- context hook, in which case it overrides the command line function. -- The wrapper function can be omitted on a call-by-call basis by -- using the nolock option in the call hook. -- --- TODO ---------------------------------------------------------------------- -- module Gtk2HsC2Hs (c2hsMain) where -- standard libraries import Data.List (isPrefixOf) import System.IO (openFile) import System.Process (runProcess, waitForProcess) import Control.Monad (when, unless, mapM) import Data.Maybe (fromJust) -- base libraries import System.Console.GetOpt (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) import FNameOps (suffix, basename, dirname, stripSuffix, addPath, splitSearchPath) import Errors (interr) import UNames (saveRootNameSupply, restoreRootNameSupply) import Binary (Binary(..), putBinFileWithDict, getBinFileWithDict) -- c2hs modules import C2HSState (CST, nop, runC2HS, fatal, fatalsHandledBy, getId, ExitCode(..), stderr, IOMode(..), putStrCIO, hPutStrCIO, hPutStrLnCIO, exitWithCIO, getProgNameCIO, ioeGetErrorString, ioeGetFileName, doesFileExistCIO, removeFileCIO, liftIO, fileFindInCIO, mktempCIO, openFileCIO, hCloseCIO, SwitchBoard(..), Traces(..), setTraces, traceSet, setSwitch, getSwitch, putTraceStr) import C (AttrC, hsuffix, isuffix, loadAttrC) import CHS (CHSModule, skipToLangPragma, hasCPP, loadCHS, dumpCHS, loadAllCHI, hssuffix, chssuffix, dumpCHI) import GenHeader (genHeader) import GenBind (expandHooks) import Version (version, copyright, disclaimer) import C2HSConfig (cpp, cppopts, cppoptsdef, hpaths, tmpdir) -- wrapper running the compiler -- ============================ c2hsMain :: [String] -> IO () c2hsMain = runC2HS (version, copyright, disclaimer) . 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 -> String -> String -> String header version copyright disclaimer = 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 | Include String -- list of directories to search .chi files | Output String -- file where the generated file should go | OutDir String -- directory where generates files should go | PreComp String -- write or read a precompiled header | LockFun String -- wrap each function call in this function | Version -- print version information on stderr | Error String -- error occured during processing of options deriving Eq data DumpType = Trace -- compiler trace | GenBind -- trace `GenBind' | CTrav -- trace `CTrav' | CHS -- dump binding file deriving Eq -- option description suitable for `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 ['o'] ["output"] (ReqArg Output "FILE") "output result to FILE (should end in .hs)", Option ['t'] ["output-dir"] (ReqArg OutDir "PATH") "place generated files in PATH", Option ['p'] ["precomp"] (ReqArg PreComp "FILE") "generate or read precompiled header file FILE", Option ['l'] ["lock"] (ReqArg LockFun "NAME") "wrap each foreign call with the function NAME", Option ['v'] ["version"] (NoArg Version) "show version information"] -- 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 :: [String] -> CST s () compile cmdLine = do setup case getOpt RequireOrder options cmdLine of ([Help] , [] , []) -> doExecute [Help] [] ([Version], [] , []) -> doExecute [Version] [] (opts , args, []) | properArgs args -> doExecute opts args | otherwise -> raiseErrs [wrongNoOfArgsErr] (_ , _ , errs) -> raiseErrs errs where properArgs [file1, file2] = suffix file1 == hsuffix && suffix file2 == chssuffix properArgs _ = False -- doExecute opts args = execute opts args `fatalsHandledBy` failureHandler -- wrongNoOfArgsErr = "Supply the header file followed by the binding file.\n\ \The header file can be omitted if it is supplied in the binding file.\n\ \The binding file can be omitted if the --precomp flag is given.\n" -- -- exception handler -- failureHandler err = do let msg = ioeGetErrorString err fnMsg = case ioeGetFileName err of Nothing -> "" Just s -> " (file: `" ++ s ++ "')" hPutStrLnCIO stderr (msg ++ fnMsg) exitWithCIO $ ExitFailure 1 -- set up base configuration -- setup :: CST s () setup = do setCPP cpp addCPPOpts cppopts addHPaths hpaths -- output error message -- raiseErrs :: [String] -> CST s a raiseErrs errs = do hPutStrCIO stderr (concat errs) hPutStrCIO stderr errTrailer exitWithCIO $ 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] -> [FilePath] -> CST s () execute opts args | Help `elem` opts = help | otherwise = do let vs = filter (== Version) opts opts' = filter (/= Version) opts mapM_ processOpt (atMostOne vs ++ opts') let (headerFile, bndFile) = determineFileTypes args preCompFile <- getSwitch preCompSB unless (preCompFile==Nothing) $ preCompileHeader headerFile (fromJust preCompFile) `fatalsHandledBy` ioErrorHandler let bndFileWithoutSuffix = stripSuffix bndFile unless (null bndFile) $ do computeOutputName bndFileWithoutSuffix process headerFile preCompFile bndFileWithoutSuffix `fatalsHandledBy` ioErrorHandler where atMostOne = (foldl (\_ x -> [x]) []) determineFileTypes [hfile, bfile] = (hfile, bfile) determineFileTypes [file] | suffix file==hsuffix = (file, "") | otherwise = ("", file) determineFileTypes [] = ("", "") ioErrorHandler ioerr = do name <- getProgNameCIO putStrCIO $ name ++ ": " ++ ioeGetErrorString ioerr ++ "\n" exitWithCIO $ ExitFailure 1 -- emit help message -- help :: CST s () help = do (version, copyright, disclaimer) <- getId putStrCIO (usageInfo (header version copyright disclaimer) options) putStrCIO trailer -- 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 (Include dirs ) = setInclude dirs processOpt (Output fname ) = setOutput fname processOpt (OutDir fname ) = setOutDir fname processOpt (PreComp fname ) = setPreComp fname processOpt (LockFun name ) = setLockFun name processOpt Version = do (version, _, _) <- getId putStrCIO (version ++ "\n") processOpt (Error msg ) = abort msg -- emit error message and raise an error -- abort :: String -> CST s () abort msg = do hPutStrLnCIO stderr msg hPutStrCIO 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 = do output <- getSwitch outputSB outDir <- getSwitch outDirSB let dir = if null outDir && null output then dirname bndFileNoSuffix else if null outDir then dirname output else outDir let base = if null output then basename bndFileNoSuffix else basename output setSwitch $ \sb -> sb { outputSB = dir `addPath` base, outDirSB = dir } -- set switches -- ------------ -- set the options for the C proprocessor -- -- * any header search path that is set with `-IDIR' is also added to -- `hpathsSB' -- addCPPOpts :: [String] -> CST s () addCPPOpts opts = do let iopts = [opt | opt <- opts, "-I" `isPrefixOf` opt, "-I-" /= opt] addHPaths . map (drop 2) $ iopts addOpts opts where addOpts 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} -- add header file search paths -- addHPaths :: [FilePath] -> CST s () addHPaths paths = setSwitch $ \sb -> sb {hpathsSB = paths ++ hpathsSB sb} -- 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 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 = splitSearchPath str setSwitch $ \sb -> sb {chiPathSB = fp ++ (chiPathSB sb)} -- set the output file name -- setOutput :: FilePath -> CST s () setOutput fname = do when (suffix fname /= hssuffix) $ raiseErrs ["Output file should end in .hs!\n"] setSwitch $ \sb -> sb {outputSB = stripSuffix fname} -- 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} -- set the file name in which the precompiled header ends up -- setPreComp :: FilePath -> CST s () setPreComp fname = setSwitch $ \sb -> sb { preCompSB = Just fname } -- set the name of the wrapper function that acquires a lock -- setLockFun :: String -> CST s () setLockFun name = setSwitch $ \sb -> sb { lockFunSB = Just name } -- 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 -> Maybe FilePath -> FilePath -> CST s () process headerFile preCompFile bndFileStripped = do -- load the Haskell binding module, any imported module with CHI information is -- only inserted as file name, the content of the CHI modules is inserted below -- using 'loadAllCHI'. This ensures that we don't look for a CHI file that is -- commented out using an #ifdef -- (chsMod , warnmsgs) <- loadCHS bndFile putStrCIO warnmsgs -- check if a CPP language pragma is present and, if so, run CPP on the file -- and re-read it chsMod <- case skipToLangPragma chsMod of Nothing -> loadAllCHI chsMod Just chsMod | not (hasCPP chsMod) -> loadAllCHI chsMod | otherwise -> do outFName <- getSwitch outputSB let outFileBase = if null outFName then basename bndFile else outFName let ppFile = outFileBase ++ "_pp" ++ chssuffix cpp <- getSwitch cppSB cppOpts <- getSwitch cppOptsSB let args = cppOpts ++ [cppoptsdef, headerFile, bndFile] tracePreproc (unwords (cpp:args)) exitCode <- liftIO $ do ppHnd <- openFile ppFile WriteMode process <- runProcess cpp args Nothing Nothing Nothing (Just ppHnd) Nothing waitForProcess process case exitCode of ExitFailure _ -> fatal "Error during preprocessing chs file" _ -> nop (chsMod , warnmsgs) <- loadCHS ppFile keep <- getSwitch keepSB unless keep $ removeFileCIO ppFile case skipToLangPragma chsMod of Just chsMod -> loadAllCHI chsMod 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, warnmsgs) <- genHeader chsMod putStrCIO warnmsgs pcFileExists <- maybe (return False) doesFileExistCIO preCompFile cheader <- if null header && pcFileExists then do -- there are no cpp directives in the .chs file, use the precompiled header -- traceReadPrecomp (fromJust preCompFile) WithNameSupply cheader <- liftIO $ getBinFileWithDict (fromJust preCompFile) return cheader else do -- -- create new header file, make it #include `headerFile', and emit -- CPP and inline-C of .chs file into the new header -- outFName <- getSwitch outputSB let newHeaderFile = outFName ++ hsuffix let preprocFile = basename newHeaderFile ++ isuffix newHeader <- openFileCIO newHeaderFile WriteMode unless (null headerFile) $ hPutStrLnCIO newHeader $ "#include \"" ++ headerFile ++ "\"" mapM (hPutStrCIO newHeader) header hCloseCIO newHeader setHeader newHeaderFile -- -- run C preprocessor over the header -- cpp <- getSwitch cppSB cppOpts <- getSwitch cppOptsSB let args = cppOpts ++ [newHeaderFile] tracePreproc (unwords (cpp:args)) exitCode <- liftIO $ do preprocHnd <- openFile preprocFile WriteMode process <- runProcess cpp args Nothing Nothing Nothing (Just preprocHnd) Nothing waitForProcess process case exitCode of ExitFailure _ -> fatal "Error during preprocessing custom header file" _ -> nop -- -- load and analyse the C header file -- (cheader, warnmsgs) <- loadAttrC preprocFile putStrCIO warnmsgs -- -- remove the custom header and the pre-processed header -- keep <- getSwitch keepSB unless keep $ removeFileCIO preprocFile return cheader -- -- expand binding hooks into plain Haskell -- (hsMod, chi, warnmsgs) <- expandHooks cheader strippedCHSMod putStrCIO warnmsgs -- -- output the result -- outFName <- getSwitch outputSB let hsFile = if null outFName then basename bndFile else outFName dumpCHS hsFile hsMod True dumpCHI hsFile chi -- different suffix will be appended where bndFile = bndFileStripped ++ chssuffix traceReadPrecomp fName = putTraceStr tracePhasesSW $ "Reading precompiled header file " ++ fName ++ "...\n" tracePreproc cmd = putTraceStr tracePhasesSW $ "Invoking cpp as `" ++ cmd ++ "'...\n" traceCHSDump mod = do flag <- traceSet dumpCHSSW when flag $ (do putStrCIO ("...dumping CHS to `" ++ chsName ++ "'...\n") dumpCHS chsName mod False) chsName = basename bndFile ++ ".dump" preCompileHeader :: FilePath -> FilePath -> CST s () preCompileHeader headerFile preCompFile = do let preprocFile = basename headerFile ++ isuffix pcFileExists <- doesFileExistCIO preCompFile unless pcFileExists $ do hpaths <- getSwitch hpathsSB realHeaderFile <- headerFile `fileFindInCIO` hpaths -- -- run C preprocessor over the header -- cpp <- getSwitch cppSB cppOpts <- getSwitch cppOptsSB let args = cppOpts ++ [realHeaderFile] tracePreproc (unwords (cpp:args)) exitCode <- liftIO $ do preprocHnd <- openFile preprocFile WriteMode process <- runProcess cpp args Nothing Nothing Nothing (Just preprocHnd) Nothing waitForProcess process case exitCode of ExitFailure _ -> fatal "Error during preprocessing" _ -> nop -- -- load and analyse the C header file -- (cheader, warnmsgs) <- loadAttrC preprocFile putStrCIO warnmsgs -- -- save the attributed C to disk -- liftIO $ putBinFileWithDict preCompFile (WithNameSupply cheader) -- -- remove the pre-processed header -- keep <- getSwitch keepSB unless keep $ removeFileCIO preprocFile return () where tracePreproc cmd = putTraceStr tracePhasesSW $ "Invoking cpp as `" ++ cmd ++ "'...\n" -- dummy type so we can save and restore the name supply data WithNameSupply a = WithNameSupply a instance Binary a => Binary (WithNameSupply a) where put_ bh (WithNameSupply x) = do put_ bh x nameSupply <- saveRootNameSupply put_ bh nameSupply get bh = do x <- get bh nameSupply <- get bh restoreRootNameSupply nameSupply return (WithNameSupply x) gtk2hs-buildtools-0.13.10.0/c2hs/toplevel/Version.hs0000644000000000000000000000134107346545000020234 0ustar0000000000000000module Version (version, copyright, disclaimer) where -- version number is major.minor.patchlvl; don't change the format of the -- `versnum' line as it is `grep'ed for by a Makefile -- idstr = "$Id: Version.hs,v 1.1 2012/05/27 16:49:07 dmwit Exp $" name = "C->Haskell Compiler" versnum = "0.13.13 (gtk2hs branch)" versnick = "\"Bin IO\"" date = "27 May 2012" version = name ++ ", version " ++ versnum ++ " " ++ versnick ++ ", " ++ date copyright = "Copyright (c) [1999..2004] Manuel M T Chakravarty" 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." gtk2hs-buildtools-0.13.10.0/c2hs/toplevel/c2hs_config.c0000644000000000000000000000576507346545000020621 0ustar0000000000000000/* C -> Haskell Compiler: configuration query routines * * Author : Manuel M T Chakravarty * Created: 12 November 1 * * Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:42 $ * * 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 "c2hs_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; } gtk2hs-buildtools-0.13.10.0/c2hs/toplevel/c2hs_config.h0000644000000000000000000000255307346545000020616 0ustar0000000000000000/* C -> Haskell Compiler: configuration query header * * Author : Manuel M T Chakravarty * Created: 12 November 1 * * Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:42 $ * * 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*/ gtk2hs-buildtools-0.13.10.0/callbackGen/0000755000000000000000000000000007346545000015751 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/callbackGen/HookGenerator.hs0000644000000000000000000006044107346545000021061 0ustar0000000000000000{-# LANGUAGE CPP #-} -- HookGenerator.hs -*-haskell-*- -- Takes a type list of possible hooks from the GTK+ distribution and produces -- Haskell functions to connect to these callbacks. module HookGenerator(hookGen) where import Data.Char (showLitChar) import Data.List (nub, isPrefixOf) import System.Exit (exitWith, ExitCode(..)) import System.IO (stderr, hPutStr) import Paths_gtk2hs_buildtools (getDataFileName) -- Define all possible data types the GTK will supply in callbacks. -- data Types = Tunit -- () | Tbool -- Bool | Tchar | Tuchar | Tint -- Int | Tuint | Tlong | Tulong | Tenum | Tflags | Tfloat | Tdouble | Tstring | Tmstring | Tgstring | Tmgstring | Tboxed -- a struct which is passed by value | Tptr -- pointer | Ttobject -- foreign with WidgetClass context | Tmtobject -- foreign with WidgetClass context using a Maybe type | Tobject -- foreign with GObjectClass context | Tmobject -- foreign with GObjectClass context using a Maybe type deriving Eq type Signature = (Types,[Types]) type Signatures = [Signature] ------------------------------------------------------------------------------- -- Parsing ------------------------------------------------------------------------------- parseSignatures :: String -> Signatures parseSignatures content = (nub.parseSig 1.scan) content data Token = TokColon | TokType Types | TokComma | TokEOL instance Show Token where showsPrec _ TokColon = shows ":" showsPrec _ (TokType _) = shows "" showsPrec _ TokComma = shows "," showsPrec _ TokEOL = shows "" parseSig :: Int -> [Token] -> Signatures parseSig l [] = [] parseSig l (TokEOL: rem) = parseSig (l+1) rem parseSig l (TokType ret: TokColon: TokType Tunit:rem) = (ret,[]):parseSig l rem parseSig l (TokType ret: TokColon: rem) = let (args,rem') = parseArg l rem in (ret,args): parseSig (l+1) rem' parseSig l rem = error ("parse error on line "++show l++ ": expected type and colon, found\n"++ concatMap show (take 5 rem)) parseArg :: Int -> [Token] -> ([Types],[Token]) parseArg l [TokType ty] = ([ty],[]) parseArg l (TokType ty: TokEOL:rem) = ([ty],rem) parseArg l (TokType ty: TokComma:rem) = let (args,rem') = parseArg l rem in (ty:args, rem') parseArg l rem = error ("parse error on line "++show l++": expected type"++ " followed by comma or EOL, found\n "++ concatMap show (take 5 rem)) scan :: String -> [Token] scan "" = [] scan ('#':xs) = (scan.dropWhile (/='\n')) xs scan ('\n':xs) = TokEOL:scan xs scan (' ':xs) = scan xs scan ('\t':xs) = scan xs scan (':':xs) = TokColon:scan xs scan (',':xs) = TokComma:scan xs scan ('V':'O':'I':'D':xs) = TokType Tunit:scan xs scan ('B':'O':'O':'L':'E':'A':'N':xs) = TokType Tbool:scan xs scan ('C':'H':'A':'R':xs) = TokType Tchar:scan xs scan ('U':'C':'H':'A':'R':xs) = TokType Tuchar:scan xs scan ('I':'N':'T':xs) = TokType Tint:scan xs scan ('U':'I':'N':'T':xs) = TokType Tuint:scan xs scan ('L':'O':'N':'G':xs) = TokType Tuint:scan xs scan ('U':'L':'O':'N':'G':xs) = TokType Tulong:scan xs scan ('E':'N':'U':'M':xs) = TokType Tenum:scan xs scan ('F':'L':'A':'G':'S':xs) = TokType Tflags:scan xs scan ('F':'L':'O':'A':'T':xs) = TokType Tfloat:scan xs scan ('D':'O':'U':'B':'L':'E':xs) = TokType Tdouble:scan xs scan ('S':'T':'R':'I':'N':'G':xs) = TokType Tstring:scan xs scan ('M':'S':'T':'R':'I':'N':'G':xs) = TokType Tmstring:scan xs scan ('G':'L':'I':'B':'S':'T':'R':'I':'N':'G':xs) = TokType Tgstring:scan xs scan ('M':'G':'L':'I':'B':'S':'T':'R':'I':'N':'G':xs) = TokType Tmgstring:scan xs scan ('B':'O':'X':'E':'D':xs) = TokType Tboxed:scan xs scan ('P':'O':'I':'N':'T':'E':'R':xs) = TokType Tptr:scan xs scan ('T':'O':'B':'J':'E':'C':'T':xs) = TokType Ttobject:scan xs scan ('M':'T':'O':'B':'J':'E':'C':'T':xs) = TokType Tmtobject:scan xs scan ('O':'B':'J':'E':'C':'T':xs) = TokType Tobject:scan xs scan ('M':'O':'B':'J':'E':'C':'T':xs) = TokType Tmobject:scan xs scan ('N':'O':'N':'E':xs) = TokType Tunit:scan xs scan ('B':'O':'O':'L':xs) = TokType Tbool:scan xs scan str = error ("Invalid character in input file:\n"++ concatMap ((flip showLitChar) "") (take 5 str)) ------------------------------------------------------------------------------- -- Helper functions ------------------------------------------------------------------------------- ss = showString sc = showChar indent :: Int -> ShowS indent c = ss ("\n"++replicate (2*c) ' ') ------------------------------------------------------------------------------- -- Tables of code fragments ------------------------------------------------------------------------------- identifier :: Types -> ShowS identifier Tunit = ss "NONE" identifier Tbool = ss "BOOL" identifier Tchar = ss "CHAR" identifier Tuchar = ss "UCHAR" identifier Tint = ss "INT" identifier Tuint = ss "WORD" identifier Tlong = ss "LONG" identifier Tulong = ss "ULONG" identifier Tenum = ss "ENUM" identifier Tflags = ss "FLAGS" identifier Tfloat = ss "FLOAT" identifier Tdouble = ss "DOUBLE" identifier Tstring = ss "STRING" identifier Tmstring = ss "MSTRING" identifier Tgstring = ss "GLIBSTRING" identifier Tmgstring = ss "MGLIBSTRING" identifier Tboxed = ss "BOXED" identifier Tptr = ss "PTR" identifier Ttobject = ss "OBJECT" identifier Tmtobject = ss "MOBJECT" identifier Tobject = ss "OBJECT" identifier Tmobject = ss "MOBJECT" #ifdef USE_GCLOSURE_SIGNALS_IMPL -- The monomorphic type which is used to export the function signature. rawtype :: Types -> ShowS rawtype Tunit = ss "()" rawtype Tbool = ss "Bool" rawtype Tchar = ss "Char" rawtype Tuchar = ss "Char" rawtype Tint = ss "Int" rawtype Tuint = ss "Word" rawtype Tlong = ss "Int" rawtype Tulong = ss "Word" rawtype Tenum = ss "Int" rawtype Tflags = ss "Word" rawtype Tfloat = ss "Float" rawtype Tdouble = ss "Double" rawtype Tstring = ss "CString" rawtype Tmstring = ss "CString" rawtype Tgstring = ss "CString" rawtype Tmgstring = ss "CString" rawtype Tboxed = ss "Ptr ()" rawtype Tptr = ss "Ptr ()" rawtype Ttobject = ss "Ptr GObject" rawtype Tmtobject = ss "Ptr GObject" rawtype Tobject = ss "Ptr GObject" rawtype Tmobject = ss "Ptr GObject" #else -- The monomorphic type which is used to export the function signature. rawtype :: Types -> ShowS rawtype Tunit = ss "()" rawtype Tbool = ss "{#type gboolean#}" rawtype Tchar = ss "{#type gchar#}" rawtype Tuchar = ss "{#type guchar#}" rawtype Tint = ss "{#type gint#}" rawtype Tuint = ss "{#type guint#}" rawtype Tlong = ss "{#type glong#}" rawtype Tulong = ss "{#type gulong#}" rawtype Tenum = ss "{#type gint#}" rawtype Tflags = ss "{#type guint#}" rawtype Tfloat = ss "{#type gfloat#}" rawtype Tdouble = ss "{#type gdouble#}" rawtype Tstring = ss "CString" rawtype Tmstring = ss "CString" rawtype Tgstring = ss "CString" rawtype Tmgstring = ss "CString" rawtype Tboxed = ss "Ptr ()" rawtype Tptr = ss "Ptr ()" rawtype Ttobject = ss "Ptr GObject" rawtype Tmtobject = ss "Ptr GObject" rawtype Tobject = ss "Ptr GObject" rawtype Tmobject = ss "Ptr GObject" #endif -- The possibly polymorphic type which usertype :: Types -> [Char] -> (ShowS,[Char]) usertype Tunit cs = (ss "()",cs) usertype Tbool (c:cs) = (ss "Bool",cs) usertype Tchar (c:cs) = (ss "Char",cs) usertype Tuchar (c:cs) = (ss "Char",cs) usertype Tint (c:cs) = (ss "Int",cs) usertype Tuint (c:cs) = (ss "Word",cs) usertype Tlong (c:cs) = (ss "Int",cs) usertype Tulong (c:cs) = (ss "Int",cs) usertype Tenum (c:cs) = (sc c,cs) usertype Tflags cs = usertype Tenum cs usertype Tfloat (c:cs) = (ss "Float",cs) usertype Tdouble (c:cs) = (ss "Double",cs) usertype Tstring (c:cs) = (ss "String",cs) usertype Tmstring (c:cs) = (ss "Maybe String",cs) usertype Tgstring (c:cs) = (sc c.sc '\'',cs) usertype Tmgstring (c:cs) = (ss "Maybe ".sc c.sc '\'',cs) usertype Tboxed (c:cs) = (sc c,cs) usertype Tptr (c:cs) = (ss "Ptr ".sc c,cs) usertype Ttobject (c:cs) = (sc c.sc '\'',cs) usertype Tmtobject (c:cs) = (ss "Maybe ".sc c.sc '\'',cs) usertype Tobject (c:cs) = (sc c.sc '\'',cs) usertype Tmobject (c:cs) = (ss "Maybe ".sc c.sc '\'',cs) -- type declaration: only consume variables when they are needed -- -- * Tint is used as return value as well. Therefore Integral has to be added -- to the context. Grrr. -- context :: [Types] -> [Char] -> [ShowS] context (Tenum:ts) (c:cs) = ss "Enum ".sc c: context ts cs context (Tflags:ts) (c:cs) = ss "Flags ".sc c: context ts cs context (Ttobject:ts) (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs context (Tmtobject:ts) (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs context (Tobject:ts) (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs context (Tmobject:ts) (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs context (Tgstring:ts) (c:cs) = ss "Glib.GlibString ".sc c.sc '\'': context ts cs context (Tmgstring:ts) (c:cs) = ss "Glib.GlibString ".sc c.sc '\'': context ts cs context (_:ts) (c:cs) = context ts cs context [] _ = [] marshType :: [Types] -> [Char] -> [ShowS] marshType (Tint:ts) (c:cs) = marshType ts cs marshType (Tuint:ts) (c:cs) = marshType ts cs marshType (Tenum:ts) (c:cs) = marshType ts cs marshType (Tflags:ts) cs = marshType (Tenum:ts) cs marshType (Tboxed:ts) (c:cs) = ss "(Ptr ".sc c.ss "' -> IO ". sc c.ss ") -> ": marshType ts cs marshType (Tptr:ts) (c:cs) = marshType ts cs marshType (Tobject:ts) (c:cs) = marshType ts cs marshType (_:ts) (c:cs) = marshType ts cs marshType [] _ = [] -- arguments for user defined marshalling type ArgNo = Int marshArg :: Types -> ArgNo -> ShowS marshArg Tboxed c = ss "boxedPre".shows c.sc ' ' marshArg _ _ = id -- generate a name for every passed argument, nameArg :: Types -> ArgNo -> ShowS nameArg Tunit _ = id nameArg Tbool c = ss "bool".shows c nameArg Tchar c = ss "char".shows c nameArg Tuchar c = ss "char".shows c nameArg Tint c = ss "int".shows c nameArg Tuint c = ss "int".shows c nameArg Tlong c = ss "long".shows c nameArg Tulong c = ss "long".shows c nameArg Tenum c = ss "enum".shows c nameArg Tflags c = ss "flags".shows c nameArg Tfloat c = ss "float".shows c nameArg Tdouble c = ss "double".shows c nameArg Tstring c = ss "str".shows c nameArg Tmstring c = ss "str".shows c nameArg Tgstring c = ss "str".shows c nameArg Tmgstring c = ss "str".shows c nameArg Tboxed c = ss "box".shows c nameArg Tptr c = ss "ptr".shows c nameArg Ttobject c = ss "obj".shows c nameArg Tmtobject c = ss "obj".shows c nameArg Tobject c = ss "obj".shows c nameArg Tmobject c = ss "obj".shows c -- describe marshalling between the data passed from the registered function -- to the user supplied Haskell function #ifdef USE_GCLOSURE_SIGNALS_IMPL marshExec :: Types -> ShowS -> Int -> (ShowS -> ShowS) marshExec Tbool arg _ body = body. sc ' '. arg marshExec Tchar arg _ body = body. sc ' '. arg marshExec Tuchar arg _ body = body. sc ' '. arg marshExec Tint arg _ body = body. sc ' '. arg marshExec Tuint arg _ body = body. sc ' '. arg marshExec Tlong arg _ body = body. sc ' '. arg marshExec Tulong arg _ body = body. sc ' '. arg marshExec Tenum arg _ body = body. ss " (toEnum ". arg. sc ')' marshExec Tflags arg _ body = body. ss " (toFlags ". arg. sc ')' marshExec Tfloat arg _ body = body. sc ' '. arg marshExec Tdouble arg _ body = body. sc ' '. arg marshExec Tstring arg _ body = indent 5. ss "peekUTFString ". arg. ss " >>= \\". arg. ss "\' ->". body. sc ' '. arg. sc '\'' marshExec Tmstring arg _ body = indent 5. ss "maybePeekUTFString ". arg. ss " >>= \\". arg. ss "\' ->". body. sc ' '. arg. sc '\'' marshExec Tgstring arg _ body = indent 5. ss "peekUTFString ". arg. ss " >>= \\". arg. ss "\' ->". body. sc ' '. arg. sc '\'' marshExec Tmgstring arg _ body = indent 5. ss "maybePeekUTFString ". arg. ss " >>= \\". arg. ss "\' ->". body. sc ' '. arg. sc '\'' marshExec Tboxed arg n body = indent 5. ss "boxedPre". ss (show n). ss " (castPtr ". arg. ss ") >>= \\". arg. ss "\' ->". body. sc ' '. arg. sc '\'' marshExec Tptr arg _ body = body. ss " (castPtr ". arg. sc ')' marshExec Ttobject arg _ body = indent 5.ss "makeNewGObject (GObject, objectUnrefFromMainloop) (return ". arg. ss ") >>= \\". arg. ss "\' ->". body. ss " (unsafeCastGObject ". arg. ss "\')" marshExec Tmtobject arg _ body = indent 5.ss "maybeNull (makeNewGObject (GObject, objectUnrefFromMainloop)) (return ". arg. ss ") >>= \\". arg. ss "\' ->". body. ss " (liftM unsafeCastGObject ". arg. ss "\')" marshExec Tobject arg _ body = indent 5.ss "makeNewGObject (GObject, objectUnref) (return ". arg. ss ") >>= \\". arg. ss "\' ->". body. ss " (unsafeCastGObject ". arg. ss "\')" marshExec Tmobject arg _ body = indent 5.ss "maybeNull (makeNewGObject (GObject, objectUnref)) (return ". arg. ss ") >>= \\". arg. ss "\' ->". body. ss " (liftM unsafeCastGObject ". arg. ss "\')" marshRet :: Types -> (ShowS -> ShowS) marshRet Tunit body = body marshRet Tbool body = body marshRet Tint body = body marshRet Tuint body = body marshRet Tlong body = body marshRet Tulong body = body marshRet Tenum body = indent 5. ss "liftM fromEnum $ ". body marshRet Tflags body = indent 5. ss "liftM fromFlags $ ". body marshRet Tfloat body = body marshRet Tdouble body = body marshRet Tstring body = body. indent 5. ss ">>= newUTFString" marshRet Tgstring body = body. indent 5. ss ">>= newUTFString" marshRet Tptr body = indent 5. ss "liftM castPtr $ ". body marshRet _ _ = error "Signal handlers cannot return structured types." #else marshExec :: Types -> ArgNo -> ShowS marshExec Tbool n = indent 4.ss "let bool".shows n. ss "' = toBool bool".shows n marshExec Tchar n = indent 4.ss "let char".shows n. ss "' = (toEnum.fromEnum) char".shows n marshExec Tuchar n = indent 4.ss "let char".shows n. ss "' = (toEnum.fromEnum) char".shows n marshExec Tint n = indent 4.ss "let int".shows n. ss "' = fromIntegral int".shows n marshExec Tuint n = indent 4.ss "let int".shows n. ss "' = fromIntegral int".shows n marshExec Tlong n = indent 4.ss "let long".shows n. ss "' = toInteger long".shows n marshExec Tulong n = indent 4.ss "let long".shows n. ss "' = toInteger long".shows n marshExec Tenum n = indent 4.ss "let enum".shows n. ss "' = (toEnum.fromEnum) enum".shows n marshExec Tflags n = indent 4.ss "let flags".shows n. ss "' = (toEnum.fromEnum) flags".shows n marshExec Tfloat n = indent 4.ss "let float".shows n. ss "' = (fromRational.toRational) float".shows n marshExec Tdouble n = indent 4.ss "let double".shows n. ss "' = (fromRational.toRational) double".shows n marshExec Tstring n = indent 4.ss "str".shows n. ss "' <- peekCString str".shows n marshExec Tmstring n = indent 4.ss "str".shows n. ss "' <- maybePeekCString str".shows n marshExec Tgstring n = indent 4.ss "str".shows n. ss "' <- peekCString str".shows n marshExec Tmgstring n = indent 4.ss "str".shows n. ss "' <- maybePeekCString str".shows n marshExec Tboxed n = indent 4.ss "box".shows n.ss "' <- boxedPre". shows n.ss " $ castPtr box".shows n marshExec Tptr n = indent 4.ss "let ptr".shows n.ss "' = castPtr ptr". shows n marshExec Ttobject n = indent 4.ss "objectRef obj".shows n. indent 4.ss "obj".shows n. ss "' <- liftM (unsafeCastGObject. fst mkGObject) $". indent 5.ss "newForeignPtr obj".shows n.ss " (snd mkGObject)" marshExec Tobject n = indent 4.ss "objectRef obj".shows n. indent 4.ss "obj".shows n. ss "' <- liftM (unsafeCastGObject. fst mkGObject) $". indent 5.ss "newForeignPtr obj".shows n.ss " (snd mkGObject)" marshExec _ _ = id marshRet :: Types -> ShowS marshRet Tunit = ss "id" marshRet Tbool = ss "fromBool" marshRet Tint = ss "fromIntegral" marshRet Tuint = ss "fromIntegral" marshRet Tlong = ss "fromIntegral" marshRet Tulong = ss "fromIntegral" marshRet Tenum = ss "(toEnum.fromEnum)" marshRet Tflags = ss "fromFlags" marshRet Tfloat = ss "(toRational.fromRational)" marshRet Tdouble = ss "(toRational.fromRational)" marshRet Tptr = ss "castPtr" marshRet _ = ss "(error \"Signal handlers cannot return structured types.\")" #endif ------------------------------------------------------------------------------- -- generation of parameterized fragments ------------------------------------------------------------------------------- mkUserType :: Signature -> ShowS mkUserType (ret,ts) = let (str,cs) = foldl (\(str,cs) t -> let (str',cs') = usertype t cs in (str.str'.ss " -> ",cs')) (sc '(',['a'..]) ts (str',_) = usertype ret cs str'' = if ' ' `elem` (str' "") then (sc '('.str'.sc ')') else str' in str.ss "IO ".str''.sc ')' mkContext :: Signature -> ShowS mkContext (ret,ts) = let ctxts = context (ts++[ret]) ['a'..] in if null ctxts then ss "GObjectClass obj =>" else sc '('. foldl1 (\a b -> a.ss ", ".b) ctxts.ss ", GObjectClass obj) =>" mkMarshType :: Signature -> [ShowS] mkMarshType (ret,ts) = marshType (ts++[ret]) ['a'..] mkType sig = let types = mkMarshType sig in if null types then id else foldl (.) (indent 1) types mkMarshArg :: Signature -> [ShowS] mkMarshArg (ret,ts) = zipWith marshArg (ts++[ret]) [1..] mkArg sig = foldl (.) (sc ' ') $ mkMarshArg sig #ifdef USE_GCLOSURE_SIGNALS_IMPL mkMarshExec :: Signature -> ShowS mkMarshExec (ret,ts) = foldl (\body marshaler -> marshaler body) (indent 5.ss "user") (paramMarshalers++[returnMarshaler]) where paramMarshalers = [ marshExec t (nameArg t n) n | (t,n) <- zip ts [1..] ] returnMarshaler = marshRet ret #else mkMarshExec :: Signature -> ShowS mkMarshExec (_,ts) = foldl (.) id $ zipWith marshExec ts [1..] #endif mkIdentifier :: Signature -> ShowS mkIdentifier (ret,[]) = identifier Tunit . ss "__".identifier ret mkIdentifier (ret,ts) = foldl1 (\a b -> a.sc '_'.b) (map identifier ts). ss "__".identifier ret mkRawtype :: Signature -> ShowS mkRawtype (ret,ts) = foldl (.) id (map (\ty -> rawtype ty.ss " -> ") ts). (case ret of Tboxed -> ss "IO (".rawtype ret.sc ')' Tptr -> ss "IO (".rawtype ret.sc ')' Ttobject -> ss "IO (".rawtype ret.sc ')' Tmtobject -> ss "IO (".rawtype ret.sc ')' Tobject -> ss "IO (".rawtype ret.sc ')' Tmobject -> ss "IO (".rawtype ret.sc ')' _ -> ss "IO ".rawtype ret) mkLambdaArgs :: Signature -> ShowS mkLambdaArgs (_,ts) = foldl (.) id $ zipWith (\a b -> nameArg a b.sc ' ') ts [1..] #ifndef USE_GCLOSURE_SIGNALS_IMPL mkFuncArgs :: Signature -> ShowS mkFuncArgs (_,ts) = foldl (.) id $ zipWith (\a b -> sc ' '.nameArg a b.sc '\'') ts [1..] mkMarshRet :: Signature -> ShowS mkMarshRet (ret,_) = marshRet ret #endif ------------------------------------------------------------------------------- -- start of code generation ------------------------------------------------------------------------------- usage = do hPutStr stderr $ "Program to generate callback hook for Gtk signals. Usage:\n\n"++ "HookGenerator [--template=] --types=\n"++ " [--import=] --modname= > \n"++ "where\n"++ " the module name for \n"++ " a path to the Signal.chs.template file\n"++ " a path to a gtkmarshal.list file\n"++ " a module to be imported into the template file\n" exitWith $ ExitFailure 1 hookGen :: [String] -> IO String hookGen args = do let showHelp = not (null (filter ("-h" `isPrefixOf`) args++ filter ("--help" `isPrefixOf`) args)) || null args if showHelp then usage else do let outModuleName = case map (drop 10) (filter ("--modname=" `isPrefixOf`) args) of (modName:_) -> modName templateFile <- case map (drop 11) (filter ("--template=" `isPrefixOf`) args) of [tplName] -> return tplName _ -> getDataFileName "callbackGen/Signal.chs.template" typesFile <- case map (drop 8) (filter ("--types=" `isPrefixOf`) args) of [typName] -> return typName _ -> usage let extraImports = map (drop 9) (filter ("--import=" `isPrefixOf`) args) content <- readFile typesFile let sigs = parseSignatures content template <- readFile templateFile return $ templateSubstitute template (\var -> case var of "MODULE_NAME" -> ss outModuleName "MODULE_EXPORTS" -> genExport sigs "MODULE_IMPORTS" -> genImports extraImports "MODULE_BODY" -> foldl (.) id (map generate sigs) _ -> error var ) "" templateSubstitute :: String -> (String -> ShowS) -> ShowS templateSubstitute template varSubst = doSubst template where doSubst [] = id doSubst ('\\':'@':cs) = sc '@' . doSubst cs doSubst ('@':cs) = let (var,_:cs') = span ('@'/=) cs in varSubst var . doSubst cs' doSubst (c:cs) = sc c . doSubst cs ------------------------------------------------------------------------------- -- generate dynamic fragments ------------------------------------------------------------------------------- genExport :: Signatures -> ShowS genExport sigs = foldl (.) id (map mkId sigs) where mkId sig = ss "connect_".mkIdentifier sig.sc ','.indent 1 genImports :: [String] -> ShowS genImports mods = foldl (.) id (map mkImp mods) where mkImp m = ss "import " . ss m . indent 0 #ifdef USE_GCLOSURE_SIGNALS_IMPL generate :: Signature -> ShowS generate sig = let ident = mkIdentifier sig in indent 0.ss "connect_".ident.ss " :: ". indent 1.mkContext sig.ss " SignalName ->". mkType sig. indent 1.ss "ConnectAfter -> obj ->". indent 1.mkUserType sig.ss " ->". indent 1.ss "IO (ConnectId obj)". indent 0.ss "connect_".ident.ss " signal". mkArg sig. ss "after obj user =". indent 1.ss "connectGeneric signal after obj action". indent 1.ss "where action :: Ptr GObject -> ".mkRawtype sig. indent 1.ss " action _ ".mkLambdaArgs sig. sc '='. indent 5.ss "failOnGError $". mkMarshExec sig. indent 0 #else generate :: Signature -> ShowS generate sig = let ident = mkIdentifier sig in indent 0.ss "type Tag_".ident.ss " = Ptr () -> ". indent 1.mkRawtype sig. indent 0. indent 0.ss "foreign".ss " import ccall \"wrapper\" ".ss "mkHandler_".ident.ss " ::". indent 1.ss "Tag_".ident.ss " -> ". indent 1.ss "IO (FunPtr ".ss "Tag_".ident.sc ')'. indent 0. indent 0.ss "connect_".ident.ss " :: ". indent 1.mkContext sig.ss " SignalName ->". mkType sig. indent 1.ss "ConnectAfter -> obj ->". indent 1.mkUserType sig.ss " ->". indent 1.ss "IO (ConnectId obj)". indent 0.ss "connect_".ident.ss " signal". mkArg sig. indent 1.ss "after obj user =". indent 1.ss "do". indent 2.ss "hPtr <- mkHandler_".ident. indent 3.ss "(\\_ ".mkLambdaArgs sig.ss "-> failOnGError $ do". mkMarshExec sig. indent 4.ss "liftM ".mkMarshRet sig.ss " $". indent 5.ss "user".mkFuncArgs sig. indent 3.sc ')'. indent 2.ss "dPtr <- mkFunPtrClosureNotify hPtr". indent 2.ss "sigId <- withCString signal $ \\nPtr ->". indent 3.ss "withForeignPtr ((unGObject.toGObject) obj) $ \\objPtr ->". indent 4.ss "{#call unsafe g_signal_connect_data#} (castPtr objPtr)". indent 5.ss "nPtr (castFunPtr hPtr) nullPtr dPtr (fromBool after)". indent 2.ss "return $ ConnectId sigId obj". indent 0 #endif gtk2hs-buildtools-0.13.10.0/callbackGen/Signal.chs.template0000644000000000000000000000473007346545000021503 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- -*-haskell-*- -- -------------------- automatically generated file - do not edit ------------ -- Callback installers for the GIMP Toolkit (GTK) Binding for Haskell -- -- Author : Axel Simon -- -- Created: 1 July 2000 -- -- Copyright (C) 2000-2005 Axel Simon -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. -- -- This 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 -- Lesser General Public License for more details. -- -- #hide -- These functions are used to connect signals to widgets. They are auto- -- matically created through HookGenerator.hs which takes a list of possible -- function signatures that are included in the GTK sources (gtkmarshal.list). -- -- The object system in the second version of GTK is based on GObject from -- GLIB. This base class is rather primitive in that it only implements -- ref and unref methods (and others that are not interesting to us). If -- the marshall list mentions OBJECT it refers to an instance of this -- GObject which is automatically wrapped with a ref and unref call. -- Structures which are not derived from GObject have to be passed as -- BOXED which gives the signal connect function a possibility to do the -- conversion into a proper ForeignPtr type. In special cases the signal -- connect function use a PTR type which will then be mangled in the -- user function directly. The latter is needed if a signal delivers a -- pointer to a string and its length in a separate integer. -- module @MODULE_NAME@ ( module System.Glib.Signals, @MODULE_EXPORTS@ ) where import Control.Monad (liftM) import System.Glib.FFI import System.Glib.UTFString (peekUTFString,maybePeekUTFString,newUTFString) import qualified System.Glib.UTFString as Glib import System.Glib.GError (failOnGError) {#import System.Glib.Signals#} {#import System.Glib.GObject#} @MODULE_IMPORTS@ {#context lib="gtk" prefix="gtk" #} -- Here are the generators that turn a Haskell function into -- a C function pointer. The fist Argument is always the widget, -- the last one is the user g_pointer. Both are ignored. @MODULE_BODY@ gtk2hs-buildtools-0.13.10.0/exe/0000755000000000000000000000000007346545000014344 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/exe/gtk2hsC2hsMain.hs0000644000000000000000000000016607346545000017432 0ustar0000000000000000module Main (main) where import System.Environment (getArgs) import Gtk2HsC2Hs (c2hsMain) main = getArgs >>= c2hsMain gtk2hs-buildtools-0.13.10.0/exe/gtk2hsHookGeneratorMain.hs0000644000000000000000000000020207346545000021371 0ustar0000000000000000module Main (main) where import System.Environment (getArgs) import HookGenerator (hookGen) main = getArgs >>= hookGen >>= putStr gtk2hs-buildtools-0.13.10.0/exe/gtk2hsTypeGenMain.hs0000644000000000000000000000017407346545000020205 0ustar0000000000000000module Main (main) where import System.Environment (getArgs) import TypeGen (typeGen) main = getArgs >>= typeGen >>= putStr gtk2hs-buildtools-0.13.10.0/gtk2hs-buildtools.cabal0000644000000000000000000001227107346545000020132 0ustar0000000000000000cabal-version: 3.0 Name: gtk2hs-buildtools Version: 0.13.10.0 License: GPL-2.0-only License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team Author: Axel Simon, Duncan Coutts, Manuel Chakravaty Maintainer: gtk2hs-devel@lists.sourceforge.net Build-Type: Simple Stability: stable homepage: http://projects.haskell.org/gtk2hs/ bug-reports: https://github.com/gtk2hs/gtk2hs/issues Synopsis: Tools to build the Gtk2Hs suite of User Interface libraries. Description: This package provides a set of helper programs necessary to build the Gtk2Hs suite of libraries. These tools include a modified c2hs binding tool that is used to generate FFI declarations, a tool to build a type hierarchy that mirrors the C type hierarchy of GObjects found in glib, and a generator for signal declarations that are used to call back from C to Haskell. These tools are not needed to actually run Gtk2Hs programs. Category: Development Tested-With: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 Data-Files: callbackGen/Signal.chs.template hierarchyGen/hierarchy.list hierarchyGen/Hierarchy.chs.template Extra-Source-Files: c2hs/toplevel/c2hs_config.h Source-Repository head type: git location: https://github.com/gtk2hs/gtk2hs subdir: tools Flag ClosureSignals Description: Use the the GClosure-based signals implementation. -- if ! (arch(sparc) || arch(x86_64) || impl(ghc >= 6.4.1)) -- Default: False Library build-depends: base >= 4 && < 5, process, array, pretty, filepath, random, Cabal >= 1.24.0.0, filepath >= 1.3.0.0, directory >= 1.2.0.0, containers >= 0.5.5.1 if !impl(ghc >= 8.0) build-depends: fail if impl(ghc >= 7.7) build-depends: hashtables build-tool-depends: alex:alex >= 3.0.1, happy:happy >= 1.18.9 hs-source-dirs: src hierarchyGen callbackGen c2hs/toplevel c2hs/state c2hs/gen c2hs/chs c2hs/c c2hs/base/admin c2hs/base/general c2hs/base/state c2hs/base/errors c2hs/base/syms c2hs/base/syntax c-sources: c2hs/toplevel/c2hs_config.c exposed-modules: Gtk2HsSetup TypeGen HookGenerator Gtk2HsC2Hs autogen-modules: Paths_gtk2hs_buildtools other-modules: Paths_gtk2hs_buildtools -- gtk2hsC2hs Modules BaseVersion Config Errors Binary DLists FastMutInt FileOps FNameOps Map Position Set UNames CIO State StateBase StateTrans Attributes Idents NameSpaces Lexers C CAST CAttrs CBuiltin CLexer CNames CParser CParserMonad CPretty CTokens CTrav CHS CHSLexer CInfo GBMonad GenBind GenHeader C2HSState Switches C2HSConfig Version default-language: Haskell98 default-extensions: ForeignFunctionInterface BangPatterns if flag(ClosureSignals) cpp-options: -DUSE_GCLOSURE_SIGNALS_IMPL if os(darwin) cpp-options: -D_C2HS_CPP_IS_GCC else cpp-options: -D_C2HS_CPP_LANG_SINGLE Executable gtk2hsTypeGen main-is: gtk2hsTypeGenMain.hs hs-source-dirs: exe build-depends: base, gtk2hs-buildtools default-language: Haskell98 Executable gtk2hsHookGenerator main-is: gtk2hsHookGeneratorMain.hs hs-source-dirs: exe build-depends: base, gtk2hs-buildtools default-language: Haskell98 Executable gtk2hsC2hs main-is: gtk2hsC2hsMain.hs hs-source-dirs: exe build-depends: base, gtk2hs-buildtools default-language: Haskell98 gtk2hs-buildtools-0.13.10.0/hierarchyGen/0000755000000000000000000000000007346545000016173 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/hierarchyGen/Hierarchy.chs.template0000644000000000000000000000500607346545000022423 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- -*-haskell-*- -- -------------------- automatically generated file - do not edit ---------- -- Object hierarchy for the GIMP Toolkit (GTK) Binding for Haskell -- -- Author : Axel Simon -- -- Copyright (C) 2001-2005 Axel Simon -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. -- -- This 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 -- Lesser General Public License for more details. -- -- #hide -- | -- Maintainer : gtk2hs-users\@lists.sourceforge.net -- Stability : provisional -- Portability : portable (depends on GHC) -- -- This file reflects the Gtk+ object hierarchy in terms of Haskell classes. -- -- Note: the mk... functions were originally meant to simply be an alias -- for the constructor. However, in order to communicate the destructor -- of an object to objectNew, the mk... functions are now a tuple containing -- Haskell constructor and the destructor function pointer. This hack avoids -- changing all modules that simply pass mk... to objectNew. -- module @MODULE_NAME@ ( @MODULE_EXPORTS@ ) where import Foreign.ForeignPtr (ForeignPtr, castForeignPtr) -- TODO work around cpphs https://ghc.haskell.org/trac/ghc/ticket/13553 #if __GLASGOW_HASKELL__ >= 707 || __GLASGOW_HASKELL__ == 0 import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) #else import Foreign.ForeignPtr (unsafeForeignPtrToPtr) #endif import Foreign.C.Types (CULong(..), CUInt(..), CULLong(..)) import System.Glib.GType (GType, typeInstanceIsA) @MODULE_IMPORTS@ {# context lib="@CONTEXT_LIB@" prefix="@CONTEXT_PREFIX@" #} -- The usage of foreignPtrToPtr should be safe as the evaluation will only be -- forced if the object is used afterwards -- castTo :: (@ROOTOBJECT@Class obj, @ROOTOBJECT@Class obj') => GType -> String -> (obj -> obj') castTo gtype objTypeName obj = case to@ROOTOBJECT@ obj of gobj\@(@ROOTOBJECT@ objFPtr) | typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr) objFPtr) gtype -> unsafeCast@ROOTOBJECT@ gobj | otherwise -> error $ "Cannot cast object to " ++ objTypeName @DECLARATIONS@ gtk2hs-buildtools-0.13.10.0/hierarchyGen/TypeGen.hs0000644000000000000000000003307507346545000020112 0ustar0000000000000000-- TypeGen.hs -- Takes a hierarchical list of all objects in GTK+ and produces -- Haskell class that reflect this hierarchy. module TypeGen (typeGen) where import Data.Char (isAlpha, isAlphaNum, toLower, toUpper, isUpper) import Data.List (isPrefixOf) import Control.Monad (when) import System.Exit (exitWith, ExitCode(..)) import System.IO (stderr, hPutStr) import Paths_gtk2hs_buildtools (getDataFileName) -- The current object and its inheritence relationship is defined by all -- ancestors and their column position. type ObjectSpec = [(Int,String)] -- This is a mapping from a type name to a) the type name in Haskell and -- b) the info on this type 'TypeInfo'. type TypeQuery = (String, TypeInfo) -- The information of on the type. data TypeInfo = TypeInfo { tiQueryFunction :: String, -- the GTK blah_get_type function tiAlternateName :: Maybe String, tiNoEqualInst :: Bool, tiDefaultDestr :: Bool } type TypeTable = [TypeQuery] -- A Tag is a string restricting the generation of type entries to -- those lines that have the appropriate "if " at the end. type Tag = String data ParserState = ParserState { line :: Int, col :: Int, hierObjs :: ObjectSpec, onlyTags :: [Tag] } freshParserState :: [Tag] -> ParserState freshParserState = ParserState 1 1 [] -- The parser returns a list of ObjectSpec and possibly a special type query -- function. Each ObjectSpec describes one object with all its parents. pFreshLine :: ParserState -> String -> [(ObjectSpec, TypeQuery)] pFreshLine ps input = pFL ps input where pFL ps ('#':rem) = pFL ps (dropWhile ((/=) '\n') rem) pFL ps ('\n':rem) = pFL (ps {line = line ps+1, col=1}) rem pFL ps (' ':rem) = pFL (ps {col=col ps+1}) rem pFL ps ('\t':rem) = pFL (ps {col=col ps+8}) rem pFL ps all@('G':'t':'k':rem)= pGetObject ps all rem pFL ps all@('G':'d':'k':rem)= pGetObject ps all rem pFL ps all@('G':'s':'t':rem)= pGetObject ps all rem pFL ps all@('G':'n':'o':'m':'e':rem)= pGetObject ps all rem pFL ps [] = [] pFL ps all = pGetObject ps all all pGetObject :: ParserState -> String -> String -> [(ObjectSpec, TypeQuery)] pGetObject ps@ParserState { onlyTags=tags } txt txt' = (if readTag `elem` tags then (:) (spec, specialQuery) else id) $ pFreshLine (ps { hierObjs=spec}) (dropWhile ((/=) '\n') rem''') where isBlank c = c==' ' || c=='\t' isAlphaNum_ c = isAlphaNum c || c=='_' isTagName c = isAlphaNum_ c || c=='-' || c=='.' --to allow tag 'gtk-2.4' (origCName,rem) = span isAlphaNum txt (origHsName,_) = span isAlphaNum txt' (eqInst,rem') = let r = dropWhile isBlank rem in if "noEq" `isPrefixOf` r then (True, drop 4 r) else (False, r) (defDestr,rem'') = let r = dropWhile isBlank rem' in if "noDestr" `isPrefixOf` r then (True, drop 7 r) else (False, r) (name,specialQuery,rem''') = case (dropWhile isBlank rem'') of ('a':'s':r) -> let (tyName,r') = span isAlphaNum_ (dropWhile isBlank r) in case (dropWhile isBlank r') of (',':r) -> let (tyQuery,r') = span isAlphaNum_ (dropWhile isBlank r) in (tyName, (tyName, TypeInfo origCName (Just tyQuery) eqInst defDestr), r') r -> (tyName, (tyName, TypeInfo origCName Nothing eqInst defDestr), r) r -> (origHsName, (origHsName, TypeInfo origCName Nothing eqInst defDestr), r) parents = dropWhile (\(c,_) -> c>=col ps) (hierObjs ps) spec = (col ps,name):parents (readTag, rem'''') = case (dropWhile isBlank rem''') of ('i':'f':r) -> span isTagName (dropWhile isBlank r) r -> ("default",r) ------------------------------------------------------------------------------- -- Helper functions ------------------------------------------------------------------------------- ss = showString sc = showChar indent :: Int -> ShowS indent c = ss ("\n"++replicate (2*c) ' ') ------------------------------------------------------------------------------- -- start of code generation ------------------------------------------------------------------------------- typeGen :: [String] -> IO String typeGen args = do let showHelp = not (null (filter ("-h" `isPrefixOf`) args++ filter ("--help" `isPrefixOf`) args)) || null args if showHelp then usage else do ----------------------------------------------------------------------------- -- Parse command line parameters -- let rem = args let tags = map (drop 6) (filter ("--tag=" `isPrefixOf`) rem) let lib = case map (drop 6) (filter ("--lib=" `isPrefixOf`) rem) of [] -> "gtk" (lib:_) -> lib let prefix = case map (drop 9) (filter ("--prefix=" `isPrefixOf`) rem) of [] -> "gtk" (prefix:_) -> prefix let modName = case map (drop 10) (filter ("--modname=" `isPrefixOf`) rem) of [] -> "Hierarchy" (modName:_) -> modName where bareFName = reverse . takeWhile isAlphaNum . drop 1 . dropWhile isAlpha . reverse let extraNames = map (drop 9) (filter ("--import=" `isPrefixOf`) rem) let rootObject = case map (drop 7) (filter ("--root=" `isPrefixOf`) rem) of [] -> "GObject" (rootObject:_) -> rootObject let forwardNames = map (drop 10) (filter ("--forward=" `isPrefixOf`) rem) let destrFun = case map (drop 13) (filter ("--destructor=" `isPrefixOf`) rem) of [] -> "objectUnref" (destrFun:_) -> destrFun ----------------------------------------------------------------------------- -- Read in the hierarchy and template files -- hierFile <- case map (drop 12) (filter ("--hierarchy=" `isPrefixOf`) rem) of [] -> getDataFileName "hierarchyGen/hierarchy.list" (hierFile:_) -> return hierFile hierarchy <- readFile hierFile templateFile <- getDataFileName "hierarchyGen/Hierarchy.chs.template" template <- readFile templateFile ----------------------------------------------------------------------------- -- Parse the contents of the hierarchy file -- let (objs', specialQueries) = unzip $ pFreshLine (freshParserState tags) hierarchy objs = map (map snd) objs' let showImport ('*':m ) = ss "{#import " .ss m .ss "#}" . indent 0 showImport m = ss "import " . ss m . indent 0 ----------------------------------------------------------------------------- -- return the result after substituting values into the template file -- return $ templateSubstitute template (\var -> case var of "MODULE_NAME" -> ss modName "MODULE_EXPORTS" -> generateExports rootObject (map (dropWhile ((==) '*')) forwardNames) objs "MODULE_IMPORTS" -> foldl (.) id (map showImport (extraNames++forwardNames)) "CONTEXT_LIB" -> ss lib "CONTEXT_PREFIX" -> ss prefix "DECLARATIONS" -> generateDeclarations rootObject destrFun prefix objs specialQueries "ROOTOBJECT" -> ss rootObject _ -> ss "" ) "" usage = do hPutStr stderr "\nProgram to generate Gtk's object hierarchy in Haskell. Usage:\n\ \TypeGenerator {--tag=} [--lib=] [--prefix=]\n\ \ [--modname=] {--import=<*>}\n\ \ {--forward=<*>} [--destructor=]\n\ \ [--hierarchy=]\n\ \where\n\ \ generate entries that have the tag \n\ \ specify `default' for types without tags\n\ \ set the lib to use in the c2hs {#context #}\n\ \ declaration (the default is \"gtk\")\n\ \ set the prefix to use in the c2hs {#context #}\n\ \ declaration (the default is \"gtk\")\n\ \ specify module name if it does not match the\n\ \ file name, eg a hierarchical module name\n\ \ additionally import this module without\n\ \ re-exporting it\n\ \ specify a number of modules that are imported\n\ \ <*> use an asterix as prefix if the import should\n\ \ be a .chs import statement\n\ \ as well as exported from the generated module\n\ \ specify a non-standard C function pointer that\n\ \ is called to destroy the objects\n\ \ the name of the file containing the hierarchy list,\n\ \ defaults to the built-in list\n\ \\n\ \The resulting Haskell module is written to the standard output.\n" exitWith $ ExitFailure 1 ------------------------------------------------------------------------------- -- generate dynamic fragments ------------------------------------------------------------------------------- generateExports :: String -> [String] -> [[String]] -> ShowS generateExports rootObject forwardNames objs = drop 1. foldl (\s1 s2 -> s1.ss ",".indent 1.ss "module ".s2) id (map ss forwardNames). foldl (\s1 s2 -> s1.ss ",".s2) id [ indent 1.ss n.ss "(".ss n.ss "), ".ss n.ss "Class,". indent 1.ss "to".ss n.ss ", ". indent 1.ss "mk".ss n.ss ", un".ss n.sc ','. indent 1.ss "castTo".ss n.ss ", gType".ss n | (n:_) <- objs , n /= rootObject ] generateDeclarations :: String -> String -> String -> [[String]] -> TypeTable -> ShowS generateDeclarations rootObject destr prefix objs typeTable = foldl (.) id [ makeClass rootObject destr prefix typeTable obj . makeUpcast rootObject obj . makeGType typeTable obj | obj <- objs ] makeUpcast :: String -> [String] -> ShowS makeUpcast rootObject [obj] = id -- no casting for root makeUpcast rootObject (obj:_:_) = indent 0.ss "castTo".ss obj.ss " :: ".ss rootObject.ss "Class obj => obj -> ".ss obj. indent 0.ss "castTo".ss obj.ss " = castTo gType".ss obj.ss " \"".ss obj.ss "\"". indent 0 makeGType :: TypeTable -> [String] -> ShowS makeGType table [obj] = id -- no GType for root makeGType table (obj:_:_) = indent 0.ss "gType".ss obj.ss " :: GType". indent 0.ss "gType".ss obj.ss " =". indent 1.ss "{# call fun unsafe ". ss (case lookup obj table of (Just TypeInfo { tiAlternateName = Just get_type_func }) -> get_type_func (Just TypeInfo { tiQueryFunction = cname}) -> tail $ c2u True cname++"_get_type"). ss " #}". indent 0 where -- case to underscore translation: the boolean arg specifies whether -- the first uppercase letter X is to be replaced by _x (True) or by x. -- -- translation: HButtonBox -> hbutton_box c2u :: Bool -> String -> String c2u True (x:xs) | isUpper x = '_':toLower x:c2u False xs c2u False (x:xs) | isUpper x = toLower x:c2u True xs c2u _ (x:xs) | otherwise = x:c2u True xs c2u _ [] = [] makeOrd fill [] = id makeOrd fill (obj:preds) = indent 1.ss "compare ".ss obj.ss "Tag ". fill obj.ss obj.ss "Tag".fill obj. ss " = EQ".makeGT obj preds where makeGT obj [] = id makeGT obj (pr:eds) = indent 1.ss "compare ".ss obj.ss "Tag ". fill obj.ss pr.ss "Tag".fill pr. ss " = GT".makeGT obj eds makeClass :: String -> String -> String -> TypeTable -> [String] -> ShowS makeClass rootObject destr prefix table (name:[]) = id makeClass rootObject destr prefix table (name:parents) = indent 0.ss "-- ".ss (replicate (75-length name) '*').sc ' '.ss name. indent 0. indent 0.ss "{#pointer *". (case lookup name table of (Just TypeInfo { tiQueryFunction = cname }) -> ss cname.ss " as ".ss name ). ss " foreign newtype #}". (case lookup name table of (Just (TypeInfo { tiNoEqualInst = False })) -> ss " deriving (Eq,Ord)" _ -> id ). indent 0. indent 0.ss "mk".ss name.ss " = (".ss name.ss ", ". (case lookup name table of Just TypeInfo { tiDefaultDestr = False } -> ss destr Just TypeInfo { tiDefaultDestr = True } -> ss "objectUnref").ss ")". indent 0.ss "un".ss name.ss " (".ss name.ss " o) = o". indent 0. indent 0.ss "class ".ss (head parents).ss "Class o => ".ss name.ss "Class o". indent 0.ss "to".ss name.ss " :: ".ss name.ss "Class o => o -> ".ss name. indent 0.ss "to".ss name.ss " = unsafeCast".ss rootObject.ss " . to".ss rootObject. indent 0. makeInstance name (name:init parents). makeRootInstance rootObject name. indent 0 makeInstance :: String -> [String] -> ShowS makeInstance name [] = id makeInstance name (par:ents) = indent 0.ss "instance ".ss par.ss "Class ".ss name. makeInstance name ents makeRootInstance :: String -> String -> ShowS makeRootInstance rootObject name = indent 0.ss "instance ".ss rootObject.ss "Class ".ss name.ss " where". indent 1.ss "to".ss rootObject.ss " = ".ss rootObject.ss" . castForeignPtr . un".ss name. indent 1.ss "unsafeCast".ss rootObject.ss " = ".ss name.ss " . castForeignPtr . un".ss rootObject templateSubstitute :: String -> (String -> ShowS) -> ShowS templateSubstitute template varSubst = doSubst template where doSubst [] = id doSubst ('\\':'@':cs) = sc '@' . doSubst cs doSubst ('@':cs) = let (var,_:cs') = span ('@'/=) cs in varSubst var . doSubst cs' doSubst (c:cs) = sc c . doSubst cs gtk2hs-buildtools-0.13.10.0/hierarchyGen/hierarchy.list0000644000000000000000000004032707346545000021054 0ustar0000000000000000# This list is the result of a copy-and-paste from the GtkObject hierarchy # html documentation. Deprecated widgets are uncommented. Some additional # object have been defined at the end of the copied list. # The Gtk prefix of every object is removed, the other prefixes are # kept. The indentation implies the object hierarchy. In case the # type query function cannot be derived from the name or the type name # is different, an alternative name and type query function can be # specified by appending 'as typename, '. In case this # function is not specified, the is converted to # gtk__get_type where is where each upperscore # letter is converted to an underscore and lowerletter. The underscore # is omitted if an upperscore letter preceeded: GtkHButtonBox -> # gtk_hbutton_box_get_type. The generation of a type can be # conditional by appending 'if '. Such types are only produces if # --tag= is given on the command line of TypeGenerator. GObject GdkDrawable GdkWindow as DrawWindow, gdk_window_object_get_type # GdkDrawableImplX11 # GdkWindowImplX11 GdkPixmap GdkGLPixmap if gtkglext GdkGLWindow if gtkglext GdkColormap GdkScreen if gtk-2.2 GdkDisplay if gtk-2.2 GdkVisual GdkDevice GtkSettings GtkTextBuffer GtkSourceBuffer if sourceview GtkSourceBuffer if gtksourceview2 GtkTextTag GtkSourceTag if sourceview GtkTextTagTable GtkSourceTagTable if sourceview GtkStyle GtkRcStyle GdkDragContext GdkPixbuf GdkPixbufAnimation GdkPixbufSimpleAnim GdkPixbufAnimationIter GtkTextChildAnchor GtkTextMark GtkSourceMarker if sourceview GtkSourceMark if gtksourceview2 GtkObject GtkWidget GtkMisc GtkLabel GtkAccelLabel GtkTipsQuery if deprecated GtkArrow GtkImage GtkContainer WebKitWebView as WebView, webkit_web_view_get_type if webkit GtkBin GtkAlignment GtkFrame GtkAspectFrame GtkButton GtkToggleButton GtkCheckButton GtkRadioButton GtkColorButton if gtk-2.4 GtkFontButton if gtk-2.4 GtkOptionMenu if deprecated GtkItem GtkMenuItem GtkCheckMenuItem GtkRadioMenuItem GtkTearoffMenuItem GtkImageMenuItem GtkSeparatorMenuItem GtkListItem if deprecated # GtkTreeItem GtkWindow GtkDialog GtkAboutDialog if gtk-2.6 GtkColorSelectionDialog GtkFileSelection GtkFileChooserDialog if gtk-2.4 GtkFontSelectionDialog GtkInputDialog GtkMessageDialog GtkPlug if plugNsocket GtkEventBox GtkHandleBox GtkScrolledWindow GtkViewport GtkExpander if gtk-2.4 GtkComboBox if gtk-2.4 GtkComboBoxEntry if gtk-2.4 GtkToolItem if gtk-2.4 GtkToolButton if gtk-2.4 GtkMenuToolButton if gtk-2.6 GtkToggleToolButton if gtk-2.4 GtkRadioToolButton if gtk-2.4 GtkSeparatorToolItem if gtk-2.4 GtkMozEmbed if mozembed VteTerminal as Terminal if vte GtkStack GtkBox GtkButtonBox GtkHButtonBox GtkVButtonBox GtkVBox GtkColorSelection GtkFontSelection GtkFileChooserWidget if gtk-2.4 GtkHBox GtkCombo if deprecated GtkFileChooserButton if gtk-2.6 GtkStatusbar GtkCList if deprecated GtkCTree if deprecated GtkFixed GtkPaned GtkHPaned GtkVPaned GtkIconView if gtk-2.6 GtkLayout GtkList if deprecated GtkMenuShell GtkMenu GtkMenuBar GtkNotebook # GtkPacker GtkSocket if plugNsocket GtkTable GtkTextView GtkSourceView if sourceview GtkSourceView if gtksourceview2 GtkToolbar GtkTreeView GtkStack GtkCalendar GtkCellView if gtk-2.6 GtkDrawingArea GtkEntry GtkSpinButton GtkRuler GtkHRuler GtkVRuler GtkRange GtkScale GtkHScale GtkVScale GtkScrollbar GtkHScrollbar GtkVScrollbar GtkSeparator GtkHSeparator GtkVSeparator GtkInvisible # GtkOldEditable # GtkText GtkPreview if deprecated # Progress is deprecated, ProgressBar contains everything necessary # GtkProgress GtkProgressBar GtkAdjustment GtkIMContext GtkIMMulticontext GtkItemFactory if deprecated GtkTooltips # These object were added by hand because they do not show up in the hierarchy # chart. # These are derived from GtkObject: GtkTreeViewColumn GtkCellRenderer GtkCellRendererPixbuf GtkCellRendererText GtkCellRendererCombo if gtk-2.6 GtkCellRendererToggle GtkCellRendererProgress if gtk-2.6 GtkFileFilter if gtk-2.4 GtkBuilder if gtk-2.12 # These are actually interfaces, but all objects that implement it are at # least GObjects. GtkCellLayout if gtk-2.4 GtkTreeSortable if gtk-2.4 GtkTooltip if gtk-2.12 # These are derived from GObject: GtkStatusIcon if gtk-2.10 GtkTreeSelection GtkTreeModel GtkTreeStore GtkListStore GtkTreeModelSort GtkTreeModelFilter if gtk-2.4 GtkIconFactory GtkIconTheme GtkSizeGroup GtkClipboard if gtk-2.2 GtkAccelGroup GtkAccelMap if gtk-2.4 GtkEntryCompletion if gtk-2.4 GtkAction if gtk-2.4 GtkToggleAction if gtk-2.4 GtkRadioAction if gtk-2.4 GtkActionGroup if gtk-2.4 GtkUIManager if gtk-2.4 GtkWindowGroup GtkSourceLanguage if sourceview GtkSourceLanguage if gtksourceview2 GtkSourceLanguagesManager if sourceview GtkSourceLanguageManager if gtksourceview2 GladeXML as GladeXML, glade_xml_get_type if libglade GConfClient as GConf if gconf # These ones are actualy interfaces, but interface implementations are GObjects GtkEditable GtkSourceStyle as SourceStyleObject if gtksourceview2 GtkSourceStyleScheme if sourceview GtkSourceStyleScheme if gtksourceview2 GtkSourceStyleSchemeManager if gtksourceview2 GtkFileChooser if gtk-2.4 ## This now became a GObject in version 2: GdkGC as GC, gdk_gc_get_type ## These are Pango structures PangoContext as PangoContext, pango_context_get_type if pango PangoLayout as PangoLayoutRaw, pango_layout_get_type if pango PangoFont as Font, pango_font_get_type if pango PangoFontFamily as FontFamily, pango_font_family_get_type if pango PangoFontFace as FontFace, pango_font_face_get_type if pango PangoFontMap as FontMap, pango_font_face_get_type if pango PangoFontset as FontSet, pango_fontset_get_type if pango ## This type is only available for PANGO_ENABLE_BACKEND compiled source ## PangoFontsetSimple as FontSetSimple, pango_fontset_simple_get_type ## GtkGlExt classes GdkGLContext if gtkglext GdkGLConfig if gtkglext GdkGLDrawable if gtkglext ## GnomeVFS classes GnomeVFSVolume as Volume, gnome_vfs_volume_get_type if gnomevfs GnomeVFSDrive as Drive, gnome_vfs_drive_get_type if gnomevfs GnomeVFSVolumeMonitor as VolumeMonitor, gnome_vfs_volume_monitor_get_type if gnomevfs ## GIO classes # Note on all the "as" clauses: the prefix G is unfortunate since it leads # to two consecutive upper case letters which are not translated with an # underscore each (e.g. GConf -> gconf, GtkHButtonBox -> gtk_hbutton_box). # GUnixMountMonitor as UnixMountMonitor, g_unix_mount_monitor_get_type if gio GOutputStream as OutputStream, g_output_stream_get_type if gio GFilterOutputStream as FilterOutputStream, g_filter_output_stream_get_type if gio GDataOutputStream as DataOutputStream, g_data_output_stream_get_type if gio GBufferedOutputStream as BufferedOutputStream, g_buffered_output_stream_get_type if gio # GUnixOutputStream as UnixOutputStream, g_unix_output_stream_get_type if gio GFileOutputStream as FileOutputStream, g_file_output_stream_get_type if gio GMemoryOutputStream as MemoryOutputStream, g_memory_output_stream_get_type if gio GInputStream as InputStream, g_input_stream_get_type if gio # GUnixInputStream as UnixInputStream, g_unix_input_stream_get_type if gio GMemoryInputStream as MemoryInputStream, g_memory_input_stream_get_type if gio GFilterInputStream as FilterInputStream, g_filter_input_stream_get_type if gio GBufferedInputStream as BufferedInputStream, g_buffered_input_stream_get_type if gio GDataInputStream as DataInputStream, g_data_input_stream_get_type if gio GFileInputStream as FileInputStream, g_file_input_stream_get_type if gio # GDesktopAppInfo as DesktopAppInfo, g_desktop_app_info_get_type if gio GFileMonitor as FileMonitor, g_file_monitor_get_type if gio GVfs as Vfs, g_vfs_get_type if gio GMountOperation as MountOperation, g_mount_operation_get_type if gio GThemedIcon as ThemedIcon, g_themed_icon_get_type if gio GEmblem as Emblem, g_emblem_get_type if gio GEmblemedIcon as EmblemedIcon, g_emblemed_icon_get_type if gio GFileEnumerator as FileEnumerator, g_file_enumerator_get_type if gio GFilenameCompleter as FilenameCompleter, g_filename_completer_get_type if gio GFileIcon as FileIcon, g_file_icon_get_type if gio GVolumeMonitor as VolumeMonitor, g_volume_monitor_get_type if gio GCancellable as Cancellable, g_cancellable_get_type if gio GSimpleAsyncResult as SimpleAsyncResult, g_async_result_get_type if gio GFileInfo as FileInfo, g_file_info_get_type if gio GAppLaunchContext as AppLaunchContext, g_app_launch_context_get_type if gio ## these are actually GInterfaces GIcon as Icon, g_icon_get_type if gio GSeekable as Seekable, g_seekable_get_type if gio GAppInfo as AppInfo, g_app_info_get_type if gio GVolume as Volume, g_volume_get_type if gio GAsyncResult as AsyncResult, g_async_result_get_type if gio GLoadableIcon as LoadableIcon, g_loadable_icon_get_type if gio GDrive as Drive, g_drive_get_type if gio GFile noEq as File, g_file_get_type if gio GMount as Mount, g_mount_get_type if gio ## GStreamer classes GstObject as Object, gst_object_get_type if gstreamer GstPad as Pad, gst_pad_get_type if gstreamer GstGhostPad as GhostPad, gst_ghost_pad_get_type if gstreamer GstPluginFeature as PluginFeature, gst_plugin_feature_get_type if gstreamer GstElementFactory as ElementFactory, gst_element_factory_get_type if gstreamer GstTypeFindFactory as TypeFindFactory, gst_type_find_factory_get_type if gstreamer GstIndexFactory as IndexFactory, gst_index_factory_get_type if gstreamer GstElement as Element, gst_element_get_type if gstreamer GstBin as Bin, gst_bin_get_type if gstreamer GstPipeline as Pipeline, gst_pipeline_get_type if gstreamer GstImplementsInterface as ImplementsInterface, gst_implements_interface_get_type if gstreamer GstTagSetter as TagSetter, gst_tag_setter_get_type if gstreamer GstBaseSrc as BaseSrc, gst_base_src_get_type if gstreamer GstPushSrc as PushSrc, gst_push_src_get_type if gstreamer GstBaseSink as BaseSink, gst_base_sink_get_type if gstreamer GstBaseTransform as BaseTransform, gst_base_transform_get_type if gstreamer GstPlugin as Plugin, gst_plugin_get_type if gstreamer GstRegistry as Registry, gst_registry_get_type if gstreamer GstBus as Bus, gst_bus_get_type if gstreamer GstClock as Clock, gst_clock_get_type if gstreamer GstAudioClock as AudioClock, gst_audio_clock_get_type if gstreamer GstSystemClock as SystemClock, gst_system_clock_get_type if gstreamer GstNetClientClock as NetClientClock, gst_net_client_clock_get_type if gstreamer GstIndex as Index, gst_index_get_type if gstreamer GstPadTemplate as PadTemplate, gst_pad_template_get_type if gstreamer GstTask as Task, gst_task_get_type if gstreamer GstXML as XML, gst_xml_get_type if gstreamer GstChildProxy as ChildProxy, gst_child_proxy_get_type if gstreamer GstCollectPads as CollectPads, gst_collect_pads_get_type if gstreamer ## these are actually GInterfaces GstURIHandler as URIHandler, gst_uri_handler_get_type if gstreamer GstAdapter as Adapter, gst_adapter_get_type if gstreamer GstController as Controller, gst_controller_get_type if gstreamer WebKitWebFrame as WebFrame, webkit_web_frame_get_type if webkit WebKitWebSettings as WebSettings, webkit_web_settings_get_type if webkit WebKitNetworkRequest as NetworkRequest, webkit_network_request_get_type if webkit WebKitNetworkResponse as NetworkResponse, webkit_network_response_get_type if webkit WebKitDownload as Download, webkit_download_get_type if webkit WebKitWebBackForwardList as WebBackForwardList, webkit_web_back_forward_list_get_type if webkit WebKitWebHistoryItem as WebHistoryItem, webkit_web_history_item_get_type if webkit WebKitWebInspector as WebInspector, webkit_web_inspector_get_type if webkit WebKitHitTestResult as HitTestResult, webkit_hit_test_result_get_type if webkit WebKitSecurityOrigin as SecurityOrigin, webkit_security_origin_get_type if webkit WebKitSoupAuthDialog as SoupAuthDialog, webkit_soup_auth_dialog_get_type if webkit WebKitWebDatabase as WebDatabase, webkit_web_database_get_type if webkit WebKitWebDataSource as WebDataSource, webkit_web_data_source_get_type if webkit WebKitWebNavigationAction as WebNavigationAction, webkit_web_navigation_action_get_type if webkit WebKitWebPolicyDecision as WebPolicyDecision, webkit_web_policy_decision_get_type if webkit WebKitWebResource as WebResource, webkit_web_resource_get_type if webkit WebKitWebWindowFeatures as WebWindowFeatures, webkit_web_window_features_get_type if webkit gtk2hs-buildtools-0.13.10.0/src/0000755000000000000000000000000007346545000014352 5ustar0000000000000000gtk2hs-buildtools-0.13.10.0/src/Gtk2HsSetup.hs0000644000000000000000000006112707346545000017040 0ustar0000000000000000{-# LANGUAGE CPP, ViewPatterns #-} -- | Build a Gtk2hs package. -- module Gtk2HsSetup ( gtk2hsUserHooks, getPkgConfigPackages, checkGtk2hsBuildtools, typeGenProgram, signalGenProgram, c2hsLocal ) where import Data.Maybe (mapMaybe) #if MIN_VERSION_Cabal(2,4,0) import Distribution.Pretty (prettyShow) #else import Distribution.Simple.LocalBuildInfo (getComponentLocalBuildInfo) #endif import Distribution.Simple import Distribution.Simple.PreProcess import Distribution.InstalledPackageInfo ( importDirs, showInstalledPackageInfo, libraryDirs, extraLibraries, extraGHCiLibraries ) import Distribution.Simple.PackageIndex ( lookupUnitId ) import Distribution.PackageDescription as PD ( PackageDescription(..), updatePackageDescription, BuildInfo(..), emptyBuildInfo, allBuildInfo, Library(..), explicitLibModules, hasLibs) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(withPackageDB, buildDir, localPkgDescr, installedPkgs, withPrograms), InstallDirs(..), ComponentLocalBuildInfo, componentPackageDeps, absoluteInstallDirs, relocatable, compiler) import Distribution.Types.LocalBuildInfo as LBI (componentNameCLBIs) import qualified Distribution.Types.LocalBuildInfo as LBI import Distribution.Simple.Compiler ( Compiler(..) ) import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), runDbProgram, getDbProgramOutput, programName, programPath, c2hsProgram, pkgConfigProgram, gccProgram, requireProgram, ghcPkgProgram, simpleProgram, lookupProgram, getProgramOutput, ProgArg) #if MIN_VERSION_Cabal(2,0,0) import Distribution.Simple.Program.HcPkg ( defaultRegisterOptions ) import Distribution.Types.PkgconfigDependency ( PkgconfigDependency(..) ) import Distribution.Types.PkgconfigName #endif import Distribution.ModuleName ( ModuleName, components, toFilePath ) import Distribution.Simple.Utils hiding (die) import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..), defaultCopyFlags, ConfigFlags(configVerbosity), fromFlag, toFlag, RegisterFlags(..), flagToMaybe, fromFlagOrDefault, defaultRegisterFlags) #if MIN_VERSION_Cabal(2,0,0) import Distribution.Simple.BuildPaths ( autogenPackageModulesDir ) #endif import Distribution.Simple.Install ( install ) import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage ) import Distribution.Text ( simpleParse, display ) import System.FilePath import System.Exit (die, exitFailure) import System.Directory ( doesFileExist, getDirectoryContents, doesDirectoryExist ) import Distribution.Version (Version(..)) import Distribution.Verbosity import Control.Monad (when, unless, filterM, liftM, forM, forM_) import Data.Maybe ( isJust, isNothing, fromMaybe, maybeToList, catMaybes ) import Data.List (isPrefixOf, isSuffixOf, nub, minimumBy, stripPrefix, tails ) import Data.Ord as Ord (comparing) import Data.Char (isAlpha, isNumber) import qualified Data.Map as M import qualified Data.Set as S import qualified Distribution.PackageDescription as PD import qualified Distribution.Simple.LocalBuildInfo as LBI import qualified Distribution.InstalledPackageInfo as IPI (installedUnitId) import Distribution.Simple.Compiler (compilerVersion) import qualified Distribution.Compat.Graph as Graph #if MIN_VERSION_Cabal(3,6,0) import Distribution.Utils.Path (getSymbolicPath) #endif import Control.Applicative ((<$>)) import Distribution.Simple.Program.Find ( defaultProgramSearchPath ) import Gtk2HsC2Hs (c2hsMain) import HookGenerator (hookGen) import TypeGen (typeGen) import UNames (unsafeResetRootNameSupply) #if !MIN_VERSION_Cabal(2,0,0) versionNumbers :: Version -> [Int] versionNumbers = versionBranch #endif onDefaultSearchPath f a b = f a b defaultProgramSearchPath #if MIN_VERSION_Cabal(2,5,0) componentsConfigs :: LocalBuildInfo -> [(LBI.ComponentName, ComponentLocalBuildInfo, [LBI.ComponentName])] componentsConfigs lbi = [ (LBI.componentLocalName clbi, clbi, mapMaybe (fmap LBI.componentLocalName . flip Graph.lookup g) (LBI.componentInternalDeps clbi)) | clbi <- Graph.toList g ] where g = LBI.componentGraph lbi libraryConfig lbi = case [clbi | (LBI.CLibName _, clbi, _) <- componentsConfigs lbi] of #else libraryConfig lbi = case [clbi | (LBI.CLibName, clbi, _) <- LBI.componentsConfigs lbi] of #endif [clbi] -> Just clbi _ -> Nothing -- the name of the c2hs pre-compiled header file precompFile = "precompchs.bin" gtk2hsUserHooks = simpleUserHooks { -- hookedPrograms is only included for backwards compatibility with older Setup.hs. hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal], hookedPreProcessors = [("chs", ourC2hs)], confHook = \pd cf -> (fmap adjustLocalBuildInfo (confHook simpleUserHooks pd cf)), postConf = \args cf pd lbi -> do genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi postConf simpleUserHooks args cf pd lbi, buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd -> buildHook simpleUserHooks pd lbi uh bf, copyHook = \pd lbi uh flags -> copyHook simpleUserHooks pd lbi uh flags >> installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)), instHook = \pd lbi uh flags -> #if defined(mingw32_HOST_OS) || defined(__MINGW32__) installHook pd lbi uh flags >> installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest, regHook = registerHook #else instHook simpleUserHooks pd lbi uh flags >> installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest #endif } ------------------------------------------------------------------------------ -- Lots of stuff for windows ghci support ------------------------------------------------------------------------------ getDlls :: [FilePath] -> IO [FilePath] getDlls dirs = filter ((== ".dll") . takeExtension) . concat <$> mapM getDirectoryContents dirs fixLibs :: [FilePath] -> [String] -> [String] fixLibs dlls = concatMap $ \ lib -> case filter (isLib lib) dlls of dlls@(_:_) -> [dropExtension (pickDll dlls)] _ -> if lib == "z" then [] else [lib] where -- If there are several .dll files matching the one we're after then we -- just have to guess. For example for recent Windows cairo builds we get -- libcairo-2.dll libcairo-gobject-2.dll libcairo-script-interpreter-2.dll -- Our heuristic is to pick the one with the shortest name. -- Yes this is a hack but the proper solution is hard: we would need to -- parse the .a file and see which .dll file(s) it needed to link to. pickDll = minimumBy (Ord.comparing length) isLib lib dll = case stripPrefix ("lib"++lib) dll of Just ('.':_) -> True Just ('-':n:_) | isNumber n -> True _ -> False -- The following code is a big copy-and-paste job from the sources of -- Cabal 1.8 just to be able to fix a field in the package file. Yuck. installHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () installHook pkg_descr localbuildinfo _ flags = do let copyFlags = defaultCopyFlags { copyDistPref = installDistPref flags, copyDest = toFlag NoCopyDest, copyVerbosity = installVerbosity flags } install pkg_descr localbuildinfo copyFlags let registerFlags = defaultRegisterFlags { regDistPref = installDistPref flags, regInPlace = installInPlace flags, regPackageDB = installPackageDB flags, regVerbosity = installVerbosity flags } when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags registerHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () registerHook pkg_descr localbuildinfo _ flags = if hasLibs pkg_descr then register pkg_descr localbuildinfo flags else setupMessage verbosity "Package contains no library to register:" (packageId pkg_descr) where verbosity = fromFlag (regVerbosity flags) #if MIN_VERSION_Cabal(2,4,0) getComponentLocalBuildInfo :: LocalBuildInfo -> LBI.ComponentName -> ComponentLocalBuildInfo getComponentLocalBuildInfo lbi cname = case LBI.componentNameCLBIs lbi cname of [clbi] -> clbi [] -> error $ "internal error: there is no configuration data " ++ "for component " ++ show cname clbis -> error $ "internal error: the component name " ++ show cname ++ "is ambiguous. Refers to: " ++ intercalate ", " (map (prettyShow . LBI.componentUnitId) clbis) #endif register :: PackageDescription -> LocalBuildInfo -> RegisterFlags -- ^Install in the user's database?; verbose -> IO () register pkg@PackageDescription { library = Just lib } lbi regFlags = do let clbi = getComponentLocalBuildInfo lbi #if MIN_VERSION_Cabal(2,5,0) (LBI.CLibName $ PD.libName lib) #else LBI.CLibName #endif absPackageDBs <- absolutePackageDBPaths packageDbs installedPkgInfoRaw <- generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref (registrationPackageDB absPackageDBs) dllsInScope <- getSearchPath >>= (filterM doesDirectoryExist) >>= getDlls let libs = fixLibs dllsInScope (extraLibraries installedPkgInfoRaw) installedPkgInfo = installedPkgInfoRaw { extraGHCiLibraries = libs } when (fromFlag (regPrintId regFlags)) $ do putStrLn (display (IPI.installedUnitId installedPkgInfo)) -- Three different modes: case () of _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo | modeGenerateRegScript -> die "Generate Reg Script not supported" | otherwise -> do setupMessage verbosity "Registering" (packageId pkg) registerPackage verbosity (compiler lbi) (withPrograms lbi) #if MIN_VERSION_Cabal(2,0,0) packageDbs installedPkgInfo defaultRegisterOptions #else False packageDbs installedPkgInfo #endif where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) regFile = fromMaybe (display (packageId pkg) <.> "conf") (fromFlag (regGenPkgConf regFlags)) modeGenerateRegScript = fromFlag (regGenScript regFlags) inplace = fromFlag (regInPlace regFlags) reloc = relocatable lbi packageDbs = nub $ withPackageDB lbi ++ maybeToList (flagToMaybe (regPackageDB regFlags)) distPref = fromFlag (regDistPref regFlags) verbosity = fromFlag (regVerbosity regFlags) writeRegistrationFile installedPkgInfo = do notice verbosity ("Creating package registration file: " ++ regFile) writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) register _ _ regFlags = notice verbosity "No package to register" where verbosity = fromFlag (regVerbosity regFlags) ------------------------------------------------------------------------------ -- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later ------------------------------------------------------------------------------ #if MIN_VERSION_Cabal(2,0,0) adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo adjustLocalBuildInfo = id #else adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo adjustLocalBuildInfo lbi = let extra = (Just libBi, []) libBi = emptyBuildInfo { includeDirs = [ autogenPackageModulesDir lbi , buildDir lbi ] } in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) } #endif ------------------------------------------------------------------------------ -- Processing .chs files with our local c2hs. ------------------------------------------------------------------------------ #if MIN_VERSION_Cabal(2,0,0) ourC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ourC2hs bi lbi _ = PreProcessor { #else ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor ourC2hs bi lbi = PreProcessor { #endif #if MIN_VERSION_Cabal(3,8,1) ppOrdering = \_ _ ms -> return ms, #endif platformIndependent = False, runPreProcessor = runC2HS bi lbi } runC2HS :: BuildInfo -> LocalBuildInfo -> (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO () runC2HS bi lbi (inDir, inFile) (outDir, outFile) verbosity = do -- have the header file name if we don't have the precompiled header yet header <- case lookup "x-c2hs-header" (customFieldsBI bi) of Just h -> return h Nothing -> die ("Need x-c2hs-Header definition in the .cabal Library section "++ "that sets the C header file to process .chs.pp files.") -- c2hs will output files in out dir, removing any leading path of the input file. -- Thus, append the dir of the input file to the output dir. let (outFileDir, newOutFile) = splitFileName outFile let newOutDir = outDir outFileDir -- additional .chi files might be needed that other packages have installed; -- we assume that these are installed in the same place as .hi files let chiDirs = [ dir | ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi), dir <- maybe [] importDirs (lookupUnitId (installedPkgs lbi) ipi) ] (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) unsafeResetRootNameSupply c2hsMain $ map ("--include=" ++) (outDir:chiDirs) ++ [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] ++ ["--output-dir=" ++ newOutDir, "--output=" ++ newOutFile, "--precomp=" ++ buildDir lbi precompFile, header, inDir inFile] return () getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] getCppOptions bi lbi = nub $ ["-I" ++ dir | dir <- PD.includeDirs bi] ++ [opt | opt@('-':c:_) <- PD.cppOptions bi ++ PD.ccOptions bi, c `elem` "DIU"] installCHI :: PackageDescription -- ^information from the .cabal file -> LocalBuildInfo -- ^information from the configure step -> Verbosity -> CopyDest -- ^flags sent to copy or install -> IO () installCHI pkg@PD.PackageDescription { library = Just lib } lbi verbosity copydest = do let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest -- cannot use the recommended 'findModuleFiles' since it fails if there exists -- a modules that does not have a .chi file mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi] . toFilePath) (PD.explicitLibModules lib) let files = [ f | Just f <- mFiles ] installOrdinaryFiles verbosity libPref files installCHI _ _ _ _ = return () ------------------------------------------------------------------------------ -- Generating the type hierarchy and signal callback .hs files. ------------------------------------------------------------------------------ genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () genSynthezisedFiles verb pd lbi = do cPkgs <- getPkgConfigPackages verb lbi pd let xList = maybe [] (customFieldsBI . libBuildInfo) (library pd) ++customFieldsPD pd typeOpts :: String -> [ProgArg] typeOpts tag = concat [ map (\val -> '-':'-':drop (length tag) field ++ '=':val) (words content) | (field,content) <- xList, tag `isPrefixOf` field, field /= (tag++"file")] ++ [ "--tag=" ++ tag #if MIN_VERSION_Cabal(2,0,0) | PackageIdentifier name version <- cPkgs , let major:minor:_ = versionNumbers version #else | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs #endif , let name' = filter isAlpha (display name) , tag <- name' :[ name' ++ "-" ++ show maj ++ "." ++ show d2 | (maj, d2) <- [(maj, d2) | maj <- [0..(major-1)], d2 <- [0,2..20]] ++ [(major, d2) | d2 <- [0,2..minor]] ] ] signalsOpts :: [ProgArg] signalsOpts = concat [ map (\val -> '-':'-':drop 10 field++'=':val) (words content) | (field,content) <- xList, "x-signals-" `isPrefixOf` field, field /= "x-signals-file"] genFile :: ([String] -> IO String) -> [ProgArg] -> FilePath -> IO () genFile prog args outFile = do res <- prog args rewriteFileEx verb outFile res forM_ (filter (\(tag,_) -> "x-types-" `isPrefixOf` tag && "file" `isSuffixOf` tag) xList) $ \(fileTag, f) -> do let tag = reverse (drop 4 (reverse fileTag)) info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.") genFile typeGen (typeOpts tag) f case lookup "x-signals-file" xList of Nothing -> return () Just f -> do info verb ("Ensuring that callback hooks in "++f++" are up-to-date.") genFile hookGen signalsOpts f writeFile "gtk2hs_macros.h" $ generateMacros cPkgs -- Based on Cabal/Distribution/Simple/Build/Macros.hs generateMacros :: [PackageId] -> String generateMacros cPkgs = concat $ "/* DO NOT EDIT: This file is automatically generated by Gtk2HsSetup.hs */\n\n" : [ concat ["/* package ",display pkgid," */\n" ,"#define VERSION_",pkgname," ",show (display version),"\n" ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n" ," (major1) < ",major1," || \\\n" ," (major1) == ",major1," && (major2) < ",major2," || \\\n" ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" ,"\n\n" ] | pkgid@(PackageIdentifier name version) <- cPkgs , let (major1:major2:minor:_) = map show (versionNumbers version ++ repeat 0) pkgname = map fixchar (display name) ] where fixchar '-' = '_' fixchar '.' = '_' fixchar c = c --FIXME: Cabal should tell us the selected pkg-config package versions in the -- LocalBuildInfo or equivalent. -- In the mean time, ask pkg-config again. getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId] getPkgConfigPackages verbosity lbi pkg = sequence [ do version <- pkgconfig ["--modversion", display pkgname] case simpleParse version of Nothing -> die "parsing output of pkg-config --modversion failed" #if MIN_VERSION_Cabal(2,0,0) Just v -> return (PackageIdentifier (mkPackageName $ unPkgconfigName pkgname) v) | PkgconfigDependency pkgname _ #else Just v -> return (PackageIdentifier pkgname v) | Dependency pkgname _ #endif <- concatMap pkgconfigDepends (allBuildInfo pkg) ] where pkgconfig = getDbProgramOutput verbosity pkgConfigProgram (withPrograms lbi) ------------------------------------------------------------------------------ -- Dependency calculation amongst .chs files. ------------------------------------------------------------------------------ -- Given all files of the package, find those that end in .chs and extract the -- .chs files they depend upon. Then return the PackageDescription with these -- files rearranged so that they are built in a sequence that files that are -- needed by other files are built first. fixDeps :: PackageDescription -> IO PackageDescription fixDeps pd@PD.PackageDescription { PD.library = Just lib@PD.Library { PD.exposedModules = expMods, PD.libBuildInfo = bi@PD.BuildInfo { PD.hsSourceDirs = srcDirs, PD.otherModules = othMods }}} = do let toPath = #if MIN_VERSION_Cabal(3,6,0) getSymbolicPath #else id #endif let findModule m = findFileWithExtension [".chs.pp",".chs"] (map toPath srcDirs) (joinPath (components m)) mExpFiles <- mapM findModule expMods mOthFiles <- mapM findModule othMods -- tag all exposed files with True so we throw an error if we need to build -- an exposed module before an internal modules (we cannot express this) let modDeps = zipWith (ModDep True []) expMods mExpFiles++ zipWith (ModDep False []) othMods mOthFiles modDeps <- mapM extractDeps modDeps let (othMods, expMods) = span (not . mdExposed) $ reverse $ sortTopological modDeps return pd { PD.library = Just lib { PD.exposedModules = map mdOriginal (reverse expMods), PD.libBuildInfo = bi { PD.otherModules = map mdOriginal (reverse othMods) } }} data ModDep = ModDep { mdExposed :: Bool, mdRequires :: [ModuleName], mdOriginal :: ModuleName, mdLocation :: Maybe FilePath } instance Show ModDep where show x = show (mdLocation x) instance Eq ModDep where ModDep { mdOriginal = m1 } == ModDep { mdOriginal = m2 } = m1==m2 instance Ord ModDep where compare ModDep { mdOriginal = m1 } ModDep { mdOriginal = m2 } = compare m1 m2 -- Extract the dependencies of this file. This is intentionally rather naive as it -- ignores CPP conditionals. We just require everything which means that the -- existance of a .chs module may not depend on some CPP condition. extractDeps :: ModDep -> IO ModDep extractDeps md@ModDep { mdLocation = Nothing } = return md extractDeps md@ModDep { mdLocation = Just f } = withUTF8FileContents f $ \con -> do let findImports acc (('{':'#':xs):xxs) = case (dropWhile (' ' ==) xs) of ('i':'m':'p':'o':'r':'t':' ':ys) -> case simpleParse (takeWhile ('#' /=) ys) of Just m -> findImports (m:acc) xxs Nothing -> die ("cannot parse chs import in "++f++":\n"++ "offending line is {#"++xs) -- no more imports after the first non-import hook _ -> return acc findImports acc (_:xxs) = findImports acc xxs findImports acc [] = return acc mods <- findImports [] (lines con) return md { mdRequires = mods } -- Find a total order of the set of modules that are partially sorted by their -- dependencies on each other. The function returns the sorted list of modules -- together with a list of modules that are required but not supplied by this -- in the input set of modules. sortTopological :: [ModDep] -> [ModDep] sortTopological ms = reverse $ fst $ foldl visit ([], S.empty) (map mdOriginal ms) where set = M.fromList (map (\m -> (mdOriginal m, m)) ms) visit (out,visited) m | m `S.member` visited = (out,visited) | otherwise = case m `M.lookup` set of Nothing -> (out, m `S.insert` visited) Just md -> (md:out', visited') where (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md) -- Included for backwards compatibility with older Setup.hs. checkGtk2hsBuildtools :: [Program] -> IO () checkGtk2hsBuildtools programs = do programInfos <- mapM (\ prog -> do location <- onDefaultSearchPath programFindLocation prog normal return (programName prog, location) ) programs let printError name = do putStrLn $ "Cannot find " ++ name ++ "\n" ++ "Please install `gtk2hs-buildtools` first and check that the install directory is in your PATH (e.g. HOME/.cabal/bin)." exitFailure forM_ programInfos $ \ (name, location) -> when (isNothing location) (printError name) -- Included for backwards compatibility with older Setup.hs. typeGenProgram :: Program typeGenProgram = simpleProgram "gtk2hsTypeGen" -- Included for backwards compatibility with older Setup.hs. signalGenProgram :: Program signalGenProgram = simpleProgram "gtk2hsHookGenerator" -- Included for backwards compatibility with older Setup.hs. -- We are not going to use this, so reporting the version we will use c2hsLocal :: Program c2hsLocal = (simpleProgram "gtk2hsC2hs") { programFindVersion = \_ _ -> return . Just $ #if MIN_VERSION_Cabal(2,0,0) mkVersion [0,13,13] #else Version [0,13,13] [] #endif }