Fix the case output ambiguity

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 =

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

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

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)
+

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
+

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

fco2/testcases/broken5.occ

@@ -0,0 +1,8 @@
+PROTOCOL PROTO
+  CASE
+    foo
+:
+PROC P ()
+  CHAN OF INT c:
+  c ! foo
+:

fco2/testcases/broken6.occ

@@ -0,0 +1,8 @@
+PROTOCOL PROTO
+  CASE
+    foo
+:
+PROC P ()
+  CHAN OF PROTO c:
+  c ! 42
+:

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
 :

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
+: