Menu
▾
▴
[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/c C.hs,1.1.1.1,1.2 CAST.hs,1.1.1.1,1.2 CAttrs.hs,1.1.1.1,1.2 CLexer.hs,1.1.1.1,1.2 CParser.hs,1.1.1.1,1.2
|
From: Duncan C. <dun...@us...> - 2004-11-13 17:27:08
|
Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/c2hs/c Modified Files: C.hs CAST.hs CAttrs.hs CLexer.hs CParser.hs Log Message: add Axel's --precomp patches with a binary serialisation framework derived from the one used in ghc. This required makeing Position a proper data type. Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module. Index: C.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c/C.hs,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -d -r1.1.1.1 -r1.2 --- C.hs 13 Nov 2004 16:42:21 -0000 1.1.1.1 +++ C.hs 13 Nov 2004 17:26:51 -0000 1.2 @@ -35,10 +35,6 @@ -- stuff from `Common' (reexported) -- Pos(posOf), - -- - -- reexported from `FiniteMaps' - -- - FiniteMap, -- -- structure tree -- @@ -70,8 +66,7 @@ csuffix, hsuffix, isuffix) where -import Common (Position, Pos(posOf)) -import FiniteMaps (FiniteMap) +import Common (Position(Position), Pos(posOf)) import Idents (Ident, lexemeToIdent) import Attributes (Attrs, Attr(..)) @@ -114,7 +109,7 @@ -- parse -- traceInfoParse - rawHeader <- parseC contents (fname, 1, 1) + rawHeader <- parseC contents (Position fname 1 1) let header = attrC rawHeader -- name analysis Index: CParser.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c/CParser.hs,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -d -r1.1.1.1 -r1.2 --- CParser.hs 13 Nov 2004 16:42:28 -0000 1.1.1.1 +++ CParser.hs 13 Nov 2004 17:26:52 -0000 1.2 @@ -85,7 +85,7 @@ import Maybe (catMaybes) import Common (Position, Pos(..), nopos) -import Sets (Set, listToSet, joinSet, elemSet) +import Data.Set (Set, mkSet, union, elementOf) import Utils (Tag(tag)) import UNames (Name, NameSupply, names) import Idents (Ident) @@ -281,7 +281,7 @@ nameSupply <- getNameSupply let name = (head . names) nameSupply at = newAttrs pos name - predefTypeIds = listToSet . map fst $ builtinTypeNames + predefTypeIds = mkSet . map fst $ builtinTypeNames decls <- parseCExtDeclList [] predefTypeIds tokens return (CHeader decls at) where @@ -304,7 +304,7 @@ -- raise the errors first, in case any of them is fatal -- mapM raise errs - let tdefNames' = tdefNames `joinSet` (listToSet $ getTDefNames decl) + let tdefNames' = tdefNames `union` (mkSet $ getTDefNames decl) parseCExtDeclList (decl:decls) tdefNames' toks' -- extract all identifiers turned into `typedef-name's @@ -330,7 +330,7 @@ -- morphTypeNames :: Set Ident -> CToken -> CToken morphTypeNames tides (CTokIdent pos ide) - | ide `elemSet` tides = CTokTypeName pos ide + | ide `elementOf` tides = CTokTypeName pos ide morphTypeNames tides tok = tok -- parse external C declaration (K&R A10) Index: CAttrs.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c/CAttrs.hs,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -d -r1.1.1.1 -r1.2 --- CAttrs.hs 13 Nov 2004 16:42:22 -0000 1.1.1.1 +++ CAttrs.hs 13 Nov 2004 17:26:51 -0000 1.2 @@ -79,6 +79,7 @@ newAttrTable, freezeAttrTable, softenAttrTable) import NameSpaces (NameSpace, nameSpace, enterNewRange, leaveRange, defLocal, defGlobal, find, nameSpaceToList) +import Binary (Binary(..), putByte, getByte) import CAST @@ -364,7 +365,7 @@ -- object tables (internal use only) -- --------------------------------- --- the object name spavce +-- the object name space -- type CObjNS = NameSpace CObj @@ -399,3 +400,95 @@ -- 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) Index: CAST.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c/CAST.hs,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -d -r1.1.1.1 -r1.2 --- CAST.hs 13 Nov 2004 16:42:30 -0000 1.1.1.1 +++ CAST.hs 13 Nov 2004 17:26:51 -0000 1.2 @@ -50,6 +50,7 @@ import Common (Position, Pos(posOf), nopos) import Idents (Ident) import Attributes (Attrs) +import Binary (Binary(..), putByte, getByte) -- a complete C header file (K&R A10) (EXPORTED) @@ -582,3 +583,583 @@ (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 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) = do + putByte bh 2 + put_ bh af + put_ bh ag + put_ bh ah + 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 + return (CArrDeclr af ag ah) + 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 + 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) + +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 Index: CLexer.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c/CLexer.hs,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -d -r1.1.1.1 -r1.2 --- CLexer.hs 13 Nov 2004 16:42:27 -0000 1.1.1.1 +++ CLexer.hs 13 Nov 2004 17:26:52 -0000 1.2 @@ -69,7 +69,7 @@ import Monad (liftM) import Numeric (readDec, readOct, readHex) -import Common (Position, Pos(posOf), incPos, retPos) +import Common (Position(Position), Pos(posOf), incPos, retPos) import Utils (Tag(tag)) import Errors (Error) import UNames (NameSupply, Name, names) @@ -526,7 +526,7 @@ int = digitNZ +> digit`star` epsilon fname = char '"' +> infname`star` char '"' -- - adjustPos str (fname, row, _) = (fname', row', 0) + adjustPos str (Position fname row _) = (Position fname' row' 0) where str' = dropWhite . drop 1 $ str (rowStr, str'') = span isDigit str' |
