Index: base/syntax/Parsers.hs =================================================================== RCS file: /home/chakcvs/hipar/base/syntax/Parsers.hs,v retrieving revision 1.22 diff -u -r1.22 Parsers.hs --- base/syntax/Parsers.hs 9 Feb 2001 02:36:10 -0000 1.22 +++ base/syntax/Parsers.hs 15 May 2004 08:23:19 -0000 @@ -1,11 +1,11 @@ -- Compiler Toolkit: Self-optimizing LL(1) parser combinators -- --- Author : Manuel M. T. Chakravarty +-- Author : Manuel M T Chakravarty -- Created: 27 February 99 -- -- Version $Revision: 1.22 $ from $Date: 2001/02/09 02:36:10 $ -- --- Copyright (c) [1999..2000] Manuel M. T. Chakravarty +-- Copyright (c) [1999..2004] 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 @@ -398,6 +398,11 @@ -- apply a parser to a token sequence (EXPORTED) -- +-- * The token mapping is applied to every token just before consumption. It +-- is useful if a processing phase needs to be put between scanner and +-- lexer, where only the tokens actually consumed are to be processed (and +-- the rest returned in their original form). +-- -- * Trailing tokens are returned in the third component of the result (the -- longest match is found). -- @@ -405,7 +410,12 @@ -- returned pair) is undefined in case of an error (this changes when error -- correction is added). -- -execParser :: Token t => Parser a t r -> a -> [t] -> (r, [Error], [t]) +execParser :: Token t + => Parser a t r -- parser specification + -> a -- initial state + -> (t -> t) -- token mapping + -> [t] -- token stream + -> (r, [Error], [t]) -- result with errors and rest tokens -- -- * Regarding the case cascade in the second equation, note that laziness is -- not our friend here. The root of the parse tree will be constructed at @@ -413,25 +423,27 @@ -- with following stages here (and then there are the error messages, which -- also spoil pipelining). -- -execParser (Parser (Action m con) c) a [] = -- eof +execParser (Parser (Action m con) c) a _ [] = -- eof case c of Empty x _ -> (con (snd . m $ a) errtoken x, [], []) _ -> (errresult, [makeError FatalErr nopos eofErr], []) -execParser (Parser (Action m con) c) a ts = -- eat one token - case m a of -- execute meta action - (a', x') -> case cont c a' ts of -- process next input token +execParser (Parser (Action m con) c) a f ts = -- eat one token + case m a of -- execute meta action + (a', x') -> case cont c a' f ts of -- process next input token -- !!! (t, (x, errs, ts')) -> ((((con $! x') $ t) $!x), errs, ts') (t, (x, errs, ts')) -> ((((con $ x') $ t) $ x), errs, ts') where - cont :: Token t => Cont a t r -> a -> [t] -> (t, (r, [Error], [t])) - cont Done _ (t:_) = makeErr (posOf t) trailErr - cont (Alts alts) a (t:ts) = case lookupFM alts t of - Nothing -> makeErr (posOf t) (illErr t) - Just p -> (t, execParser p a ts) - cont (Empty x p) a ts = + cont :: Token t + => Cont a t r -> a -> (t -> t) -> [t] -> (t, (r, [Error], [t])) + cont Done _ f (t:_) = makeErr (posOf (f t)) trailErr + cont (Alts alts) a f (t:ts) = let t' = f t + in case lookupFM alts t' of + Nothing -> makeErr (posOf t') (illErr t') + Just p -> (t', execParser p a f ts) + cont (Empty x p) a f ts = case p of Parser _ Done -> (errtoken, (x, [], ts)) - _ -> (errtoken, (execParser p a ts)) + _ -> (errtoken, (execParser p a f ts)) makeErr pos err = (errtoken, (errresult, [makeError FatalErr pos err], [])) Index: c2hs/c/CParser.hs =================================================================== RCS file: /home/chakcvs/hipar/c2hs/c/CParser.hs,v retrieving revision 1.20 diff -u -r1.20 CParser.hs --- c2hs/c/CParser.hs 12 Feb 2003 09:41:02 -0000 1.20 +++ c2hs/c/CParser.hs 15 May 2004 08:24:33 -0000 @@ -5,7 +5,7 @@ -- -- Version $Revision: 1.20 $ from $Date: 2003/02/12 09:41:02 $ -- --- Copyright (c) [1999..2002] Manuel M T Chakravarty +-- 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 @@ -82,6 +82,7 @@ import Maybe (catMaybes) import Common (Position, Pos(..), nopos) +import Sets (Set, listToSet, joinSet, elemSet) import Utils (Tag(tag)) import UNames (Name, NameSupply, names) import Idents (Ident) @@ -277,32 +278,31 @@ nameSupply <- getNameSupply let name = (head . names) nameSupply at = newAttrs pos name - predefTypeIds = map fst builtinTypeNames - decls <- parseCExtDeclList (morphTypeNames predefTypeIds tokens) + predefTypeIds = listToSet . map fst $ builtinTypeNames + decls <- parseCExtDeclList [] predefTypeIds tokens return (CHeader decls at) where -- the set contains all identifiers that were turned into a -- typedef-name by a `typedef' declaration -- - parseCExtDeclList :: [CToken] -> CST s [CExtDecl] - parseCExtDeclList [] = return [] - parseCExtDeclList toks = + parseCExtDeclList :: [CExtDecl] -- accumulator (reverse order!) + -> Set Ident -- typedef'd identifiers + -> [CToken] -- token stream + -> CST s [CExtDecl] + parseCExtDeclList decls _ [] = return (reverse decls) + parseCExtDeclList decls tdefNames toks = do nameSupply <- getNameSupply let ns = names nameSupply - (decl, errs, toks') = execParser parseCExtDecl ns toks - mapM raise errs + tokMorpher = morphTypeNames tdefNames + -- changes token type of typedef'd idents + (decl, errs, toks') = execParser parseCExtDecl ns tokMorpher toks -- -- raise the errors first, in case any of them is fatal -- - let tdefNames = getTDefNames decl - morphedToks = if null tdefNames then toks' -- as `toks'' is *long* - else morphTypeNames tdefNames toks' - if null morphedToks - then return [decl] - else do - decls <- parseCExtDeclList morphedToks - return (decl:decls) + mapM raise errs + let tdefNames' = tdefNames `joinSet` (listToSet $ getTDefNames decl) + parseCExtDeclList (decl:decls) tdefNames' toks' -- extract all identifiers turned into `typedef-name's -- @@ -320,16 +320,13 @@ declrToOptIdent (CArrDeclr declr _ _) = declrToOptIdent declr declrToOptIdent (CFunDeclr declr _ _ _) = declrToOptIdent declr - -- convert all identifier tokens mentioned in the first arguments into - -- typedef-name tokens + -- token converter that changes any identifier tokens whose identifier is + -- contained in the first set into a typedef-name token -- - morphTypeNames :: [Ident] -> [CToken] -> [CToken] - morphTypeNames _ [] = [] - morphTypeNames tides (tok@(CTokIdent pos ide):toks) - | ide `elem` tides = CTokTypeName pos ide : morphTypeNames tides toks - | otherwise = tok : morphTypeNames tides toks - morphTypeNames tides (tok :toks) - = tok : morphTypeNames tides toks + morphTypeNames :: Set Ident -> CToken -> CToken + morphTypeNames tides (CTokIdent pos ide) + | ide `elemSet` tides = CTokTypeName pos ide + morphTypeNames tides tok = tok -- parse external C declaration (K&R A10) --