From 667731f8923dd85e962244ed4d75e8ab6a41fe41 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Thu, 5 Apr 2007 17:37:45 +0000 Subject: [PATCH] Fix the case output ambiguity --- fco2/AST.hs | 12 ++++- fco2/Makefile | 3 +- fco2/Parse.hs | 69 ++++++++++++++++++----------- fco2/ParseState.hs | 15 ++++--- fco2/Types.hs | 59 ++++++++++++++++++++++++ fco2/testcases/ats1-q7.occ | 3 ++ fco2/testcases/broken5.occ | 8 ++++ fco2/testcases/broken6.occ | 8 ++++ fco2/testcases/inout.occ | 5 +-- fco2/testcases/output-ambiguity.occ | 12 +++++ 10 files changed, 155 insertions(+), 39 deletions(-) create mode 100644 fco2/Types.hs create mode 100644 fco2/testcases/broken5.occ create mode 100644 fco2/testcases/broken6.occ create mode 100644 fco2/testcases/output-ambiguity.occ diff --git a/fco2/AST.hs b/fco2/AST.hs index aced1e6..b02df22 100644 --- a/fco2/AST.hs +++ b/fco2/AST.hs @@ -16,8 +16,15 @@ data NameType = data Name = Name { nameMeta :: Meta, nameType :: NameType, - nameName :: String, - nameOrigName :: String + nameName :: String + } + deriving (Show, Eq, Typeable, Data) + +data NameDef = NameDef { + ndMeta :: Meta, + ndName :: String, + ndOrigName :: String, + ndType :: SpecType } deriving (Show, Eq, Typeable, Data) @@ -37,6 +44,7 @@ data Type = | Port Type | Val Type | Infer -- for where the type is not given but can be worked out (e.g. "x IS y:") + | NoType -- for where we need a Type, but none exists (e.g. PROCs scoping in) deriving (Show, Eq, Typeable, Data) data ConversionMode = diff --git a/fco2/Makefile b/fco2/Makefile index 54b4323..37ff39d 100644 --- a/fco2/Makefile +++ b/fco2/Makefile @@ -10,7 +10,8 @@ sources = \ Metadata.hs \ Parse.hs \ ParseState.hs \ - PrettyShow.hs + PrettyShow.hs \ + Types.hs $(targets): $(sources) ghc -fglasgow-exts -o fco --make Main diff --git a/fco2/Parse.hs b/fco2/Parse.hs index 6628a5b..14bc411 100644 --- a/fco2/Parse.hs +++ b/fco2/Parse.hs @@ -15,6 +15,7 @@ import Metadata import ParseState import Errors import Indentation +import Types --{{{ setup stuff for Parsec type OccParser = GenParser Char ParseState @@ -276,38 +277,43 @@ sepBy1NE item sep findName :: A.Name -> OccParser A.Name findName thisN = do st <- getState - origN <- case lookup (A.nameName thisN) (localNames st) of + origN <- case lookup (A.nameName thisN) (psLocalNames st) of Nothing -> fail $ "name " ++ A.nameName thisN ++ " not defined" Just n -> return n if A.nameType thisN /= A.nameType origN then fail $ "expected " ++ show (A.nameType thisN) ++ " (" ++ A.nameName origN ++ " is " ++ show (A.nameType origN) ++ ")" - else return $ thisN { A.nameName = A.nameName origN, - A.nameOrigName = A.nameName thisN } + else return $ thisN { A.nameName = A.nameName origN } -scopeIn :: A.Name -> OccParser A.Name -scopeIn n@(A.Name m nt s os) +scopeIn :: A.Name -> A.SpecType -> OccParser A.Name +scopeIn n@(A.Name m nt s) t = do st <- getState - let s' = s ++ "_" ++ (show $ nameCounter st) - let n' = n { A.nameName = s', A.nameOrigName = s } + let s' = s ++ "_" ++ (show $ psNameCounter st) + let n' = n { A.nameName = s' } + let nd = A.NameDef { + A.ndMeta = m, + A.ndName = s', + A.ndOrigName = s, + A.ndType = t + } setState $ st { - nameCounter = (nameCounter st) + 1, - localNames = (s, n') : (localNames st), - names = (s', n') : (names st) + psNameCounter = (psNameCounter st) + 1, + psLocalNames = (s, n') : (psLocalNames st), + psNames = (s', nd) : (psNames st) } return n' scopeOut :: A.Name -> OccParser () -scopeOut n@(A.Name m nt s os) +scopeOut n@(A.Name m nt s) = do st <- getState - let lns' = case localNames st of + let lns' = case psLocalNames st of (s, _):ns -> ns otherwise -> dieInternal "scopeOut trying to scope out the wrong name" - setState $ st { localNames = lns' } + setState $ st { psLocalNames = lns' } -- FIXME: Do these with generics? (going carefully to avoid nested code blocks) scopeInRep :: A.Replicator -> OccParser A.Replicator scopeInRep r@(A.For m n b c) - = do n' <- scopeIn n + = do n' <- scopeIn n (A.Declaration m A.Int) return $ A.For m n' b c scopeOutRep :: A.Replicator -> OccParser () @@ -315,16 +321,19 @@ scopeOutRep r@(A.For m n b c) = scopeOut n scopeInSpec :: A.Specification -> OccParser A.Specification scopeInSpec s@(n, st) - = do n' <- scopeIn n + = do n' <- scopeIn n st return (n', st) scopeOutSpec :: A.Specification -> OccParser () scopeOutSpec s@(n, st) = scopeOut n +scopeInFormal :: (A.Type, A.Name) -> OccParser (A.Type, A.Name) +scopeInFormal (t, n) + = do n' <- scopeIn n (A.Declaration (A.nameMeta n) t) + return (t, n') + scopeInFormals :: A.Formals -> OccParser A.Formals -scopeInFormals fs - = do ns' <- mapM scopeIn (map snd fs) - return $ zip (map fst fs) ns' +scopeInFormals fs = mapM scopeInFormal fs scopeOutFormals :: A.Formals -> OccParser () scopeOutFormals fs @@ -344,7 +353,7 @@ anyName :: A.NameType -> OccParser A.Name anyName nt = do m <- md s <- identifier - return $ A.Name m nt s s + return $ A.Name m nt s show nt name :: A.NameType -> OccParser A.Name @@ -823,7 +832,7 @@ process = try assignment <|> try inputProcess <|> try caseInput - <|> try output + <|> output <|> do { m <- md; sSKIP; eol; return $ A.Skip m } <|> do { m <- md; sSTOP; eol; return $ A.Stop m } <|> seqProcess @@ -904,13 +913,10 @@ variant "variant" --}}} --{{{ output (!) --- XXX This can't tell at parse time in "c ! x; y" whether x is a variable or a tag... --- ... so this now wants "c ! CASE x" if it's a tag, to match input. --- FIXME: We'll be able to deal with this once state is added. output :: OccParser A.Process output = channelOutput - <|> do { m <- md; p <- port; sBang; e <- expression; eol; return $ A.Output m p [A.OutExpression m e] } + <|> do { m <- md; p <- try port; sBang; e <- expression; eol; return $ A.Output m p [A.OutExpression m e] } "output" channelOutput :: OccParser A.Process @@ -918,9 +924,18 @@ channelOutput = do m <- md c <- try channel sBang - (try (do { sCASE; t <- tagName; sSemi; os <- sepBy1 outputItem sSemi; eol; return $ A.OutputCase m c t os }) - <|> do { sCASE; t <- tagName; eol; return $ A.OutputCase m c t [] } - <|> do { os <- sepBy1 outputItem sSemi; eol; return $ A.Output m c os }) + -- This is an ambiguity in the occam grammar; you can't tell in "a ! b" + -- whether b is a variable or a tag, without knowing the type of a. + st <- getState + isCase <- case typeOfChannel st c of + Just t -> return $ isCaseProtocolType st t + Nothing -> fail $ "cannot figure out the type of " ++ show c + if isCase + then + (try (do { t <- tagName; sSemi; os <- sepBy1 outputItem sSemi; eol; return $ A.OutputCase m c t os }) + <|> do { t <- tagName; eol; return $ A.OutputCase m c t [] }) + else + do { os <- sepBy1 outputItem sSemi; eol; return $ A.Output m c os } "channelOutput" outputItem :: OccParser A.OutputItem diff --git a/fco2/ParseState.hs b/fco2/ParseState.hs index 0b9e2c8..4486b9c 100644 --- a/fco2/ParseState.hs +++ b/fco2/ParseState.hs @@ -7,16 +7,19 @@ import Data.Generics import qualified AST as A data ParseState = ParseState { - localNames :: [(String, A.Name)], - names :: [(String, A.Name)], - nameCounter :: Int + psLocalNames :: [(String, A.Name)], + psNames :: [(String, A.NameDef)], + psNameCounter :: Int } deriving (Show, Eq, Typeable, Data) emptyState :: ParseState emptyState = ParseState { - localNames = [], - names = [], - nameCounter = 0 + psLocalNames = [], + psNames = [], + psNameCounter = 0 } +psLookupName :: ParseState -> A.Name -> Maybe A.NameDef +psLookupName ps n = lookup (A.nameName n) (psNames ps) + diff --git a/fco2/Types.hs b/fco2/Types.hs new file mode 100644 index 0000000..a04ebac --- /dev/null +++ b/fco2/Types.hs @@ -0,0 +1,59 @@ +module Types where + +import qualified AST as A +import ParseState + +-- I'm pretty sure this is in the standard library, but I can't find it! +perhapsM :: Maybe a -> (a -> Maybe b) -> Maybe b +perhapsM m f + = case m of + Just v -> f v + _ -> Nothing + +perhaps :: Maybe a -> (a -> b) -> Maybe b +perhaps m f = m `perhapsM` (Just . f) + +specTypeOfName :: ParseState -> A.Name -> Maybe A.SpecType +specTypeOfName ps n + = (psLookupName ps n) `perhaps` A.ndType + +typeOfName :: ParseState -> A.Name -> Maybe A.Type +typeOfName ps n + = case specTypeOfName ps n of + Just (A.Declaration m t) -> Just t + Just (A.Is m t v) -> typeOfVariable ps v + Just (A.ValIs m t e) -> typeOfExpression ps e `perhaps` A.Val + Just (A.IsChannel m t c) -> typeOfChannel ps c + Just (A.IsChannelArray m t (c:_)) -> typeOfChannel ps c `perhaps` A.ArrayUnsized + Just (A.Retypes m t v) -> Just t + Just (A.Reshapes m t v) -> Just t + Just (A.ValRetypes m t v) -> Just (A.Val t) + Just (A.ValReshapes m t v) -> Just (A.Val t) + _ -> Nothing + +-- FIXME: This should fail if the subscript is invalid... +subscriptType :: A.Type -> Maybe A.Type +subscriptType (A.Array e t) = Just t +subscriptType (A.ArrayUnsized t) = Just t +subscriptType _ = Nothing + +typeOfChannel :: ParseState -> A.Channel -> Maybe A.Type +typeOfChannel ps (A.Channel m n) = typeOfName ps n +typeOfChannel ps (A.SubscriptedChannel m s c) + = case typeOfChannel ps c of + Just t -> subscriptType t + _ -> Nothing + +typeOfVariable :: ParseState -> A.Variable -> Maybe A.Type +typeOfVariable ps v = Nothing + +typeOfExpression :: ParseState -> A.Expression -> Maybe A.Type +typeOfExpression ps e = Nothing + +isCaseProtocolType :: ParseState -> A.Type -> Bool +isCaseProtocolType ps (A.Chan (A.UserProtocol pr)) + = case specTypeOfName ps pr of + Just (A.ProtocolCase _ _) -> True + _ -> False +isCaseProtocolType ps _ = False + diff --git a/fco2/testcases/ats1-q7.occ b/fco2/testcases/ats1-q7.occ index c8588b8..e824a75 100644 --- a/fco2/testcases/ats1-q7.occ +++ b/fco2/testcases/ats1-q7.occ @@ -17,6 +17,9 @@ PROC copy.string ([]BYTE dest, VAL []BYTE src) PROC make.string ([]BYTE dest, VAL INT len) STOP : +PROC erase.screen (CHAN OF BYTE out) + STOP +: --}}} --{{{ Constants diff --git a/fco2/testcases/broken5.occ b/fco2/testcases/broken5.occ new file mode 100644 index 0000000..123f0e6 --- /dev/null +++ b/fco2/testcases/broken5.occ @@ -0,0 +1,8 @@ +PROTOCOL PROTO + CASE + foo +: +PROC P () + CHAN OF INT c: + c ! foo +: diff --git a/fco2/testcases/broken6.occ b/fco2/testcases/broken6.occ new file mode 100644 index 0000000..03dc8fe --- /dev/null +++ b/fco2/testcases/broken6.occ @@ -0,0 +1,8 @@ +PROTOCOL PROTO + CASE + foo +: +PROC P () + CHAN OF PROTO c: + c ! 42 +: diff --git a/fco2/testcases/inout.occ b/fco2/testcases/inout.occ index 99bef04..351a70e 100644 --- a/fco2/testcases/inout.occ +++ b/fco2/testcases/inout.occ @@ -29,8 +29,7 @@ PROC foo () c ! x + 1 cc ! x + 1; y + 1 - -- FIXME: This is the bodged syntax - ccc ! CASE none - ccc ! CASE one; x + 1 + ccc ! none + ccc ! one; x + 1 p ! x + 1 : diff --git a/fco2/testcases/output-ambiguity.occ b/fco2/testcases/output-ambiguity.occ new file mode 100644 index 0000000..91e1834 --- /dev/null +++ b/fco2/testcases/output-ambiguity.occ @@ -0,0 +1,12 @@ +PROTOCOL PROTO + CASE + foo +: +VAL INT foo IS 42: +PROC P () + CHAN OF PROTO c1: + CHAN OF INT c2: + SEQ + c1 ! foo + c2 ! foo +: