Menu
▾
▴
[Gtk2hs-commit] gtk2hs/tools/c2hs/gen CInfo.hs,NONE,1.1 GBMonad.hs,NONE,1.1 GenBind.hs,NONE,1.1 GenHeader.hs,NONE,1.1
|
From: Axel S. <as...@us...> - 2004-11-21 22:21:14
|
Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/gen In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9807/gen Added Files: CInfo.hs GBMonad.hs GenBind.hs GenHeader.hs Log Message: Moved the c2hs directories one level up like it was in the old setup. --- NEW FILE: GenHeader.hs --- -- 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<unique number>; -- -- 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 Monad (when) -- Compiler Toolkit import Common (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 ( (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."] --- NEW FILE: GBMonad.hs --- -- 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, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, queryObj, queryClass, queryPointer, mergeMaps, dumpMaps ) where -- standard libraries import Char (toUpper, toLower, isSpace) import List (find) import Maybe (fromMaybe) -- Compiler Toolkit import Common (Position, Pos(posOf), nopos, builtinPos) import Errors (interr) import Idents (Ident, identToLexeme, onlyPosIdent) import Data.FiniteMap (FiniteMap, emptyFM, addToFM, lookupFM, plusFM, fmToList, listToFM) -- 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 = FiniteMap (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 = FiniteMap 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) the set of delayed code fragaments, ie, pieces of Haskell code that, -- finally, have to be appended at the CHS module together with the hook -- that created them (the latter allows avoid duplication of foreign -- export declarations), and -- (4) a map associating C pointer types with their Haskell representation -- -- access to the attributes of the C structure tree is via the `CT' monad of -- which we use an instance here -- data GBState = GBState { lib :: String, -- dynamic library prefix :: String, -- prefix frags :: [(CHSHook, CHSFrag)], -- delayed code (with hooks) ptrmap :: PointerMap, -- pointer representation objmap :: HsObjectMap -- generated Haskell objects } type GB a = CT GBState a initialGBState :: GBState initialGBState = GBState { lib = "", prefix = "", frags = [], ptrmap = emptyFM, objmap = emptyFM } -- set the dynamic library and library prefix -- setContext :: (Maybe String) -> (Maybe String) -> GB () setContext lib prefix = transCT $ \state -> (state {lib = fromMaybe "" lib, prefix = fromMaybe "" prefix}, ()) -- get the dynamic library -- getLibrary :: GB String getLibrary = readCT lib -- get the prefix string -- getPrefix :: GB String getPrefix = readCT prefix -- add code to the delayed fragments (the code is made to start at a new line) -- -- * currently only code belonging to call hooks can be delayed -- -- * if code for the same call hook (ie, same C function) is delayed -- repeatedly only the first entry is stored; it is checked that the hooks -- specify the same flags (ie, produce the same delayed code) -- delayCode :: CHSHook -> String -> GB () delayCode hook str = do frags <- readCT frags frags' <- delay hook frags transCT (\state -> (state {frags = frags'}, ())) where newEntry = (hook, (CHSVerb ("\n" ++ str) (posOf hook))) -- delay hook@(CHSCall isFun isUns ide oalias _) frags = case find (\(hook', _) -> hook' == hook) frags of Just (CHSCall isFun' isUns' ide' _ _, _) | isFun == isFun' && isUns == isUns' && ide == ide' -> return frags | otherwise -> err (posOf ide) (posOf ide') Nothing -> return $ frags ++ [newEntry] delay _ _ = interr "GBMonad.delayCode: Illegal delay!" -- err = incompatibleCallHooksErr -- get the complete list of delayed fragments -- getDelayedCode :: GB [CHSFrag] getDelayedCode = readCT (map snd . frags) -- add an entry to the pointer map -- ptrMapsTo :: (Bool, Ident) -> HsPtrRep -> GB () (isStar, cName) `ptrMapsTo` hsRepr = transCT (\state -> (state { ptrmap = addToFM (ptrmap state) (isStar, cName) hsRepr }, ())) -- query the pointer map -- queryPtr :: (Bool, Ident) -> GB (Maybe HsPtrRep) queryPtr pcName = do fm <- readCT ptrmap return $ lookupFM fm pcName -- add an entry to the Haskell object map -- objIs :: Ident -> HsObject -> GB () hsName `objIs` obj = transCT (\state -> (state { objmap = addToFM (objmap state) hsName obj }, ())) -- query the Haskell object map -- queryObj :: Ident -> GB (Maybe HsObject) queryObj hsName = do fm <- readCT objmap return $ lookupFM fm hsName -- 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 = plusFM readPtrMap (ptrmap state), objmap = plusFM readObjMap (objmap state) }, ())) where (ptrAssoc, objAssoc) = read str readPtrMap = listToFM [((isStar, onlyPosIdent nopos ide), repr) | ((isStar, ide), repr) <- ptrAssoc] readObjMap = listToFM [(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) <- fmToList ptrFM], [(identToLexeme ide, obj) | (ide, obj) <- fmToList 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."] --- NEW FILE: CInfo.hs --- -- C->Haskell Compiler: information about the C implementation -- -- Author : Manuel M T Chakravarty -- Created: 5 February 01 -- -- Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:41 $ -- -- 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 CForeign -- 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 --- NEW FILE: GenBind.hs --- -- C->Haskell Compiler: binding generator -- -- Author : Manuel M T Chakravarty -- Created: 17 August 99 -- -- Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:41 $ -- -- 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. -- [...1992 lines suppressed...] 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))] |
