Track the types of all defined names properly

fco2/AST.hs

@@ -13,7 +13,11 @@ data NameType =
   | ProcName | ProtocolName | TagName | TimerName | VariableName
   deriving (Show, Eq, Typeable, Data)
 
-data Name = Name Meta NameType String
+data Name = Name {
+    nameMeta :: Meta,
+    nameType :: NameType,
+    nameName :: String
+  }
   deriving (Show, Eq, Typeable, Data)
 
 data Type =

fco2/Errors.hs

@@ -3,6 +3,7 @@ module Errors where
 import Data.Generics
 import Control.Monad.Error
 
+import qualified AST as A
 import Metadata
 
 data OccError = OccError {
@@ -19,8 +20,12 @@ die s = error $ "\n\nError:\n" ++ s
 dieInternal :: Monad m => String -> m a
 dieInternal s = die $ "Internal error: " ++ s
 
-dieP :: Monad m => Meta -> String -> m a
-dieP m s = case findSourcePos m of
-             Just (OccSourcePos f l c) -> die $ f ++ ":" ++ (show l) ++ ":" ++ (show c) ++ ": " ++ s
-             Nothing -> die s
+formatPos :: Meta -> String
+formatPos m
+    = case findSourcePos m of
+        Just o -> show o
+        Nothing -> "?"
+
+dieP :: Monad m => Meta -> String -> m a
+dieP m s = die $ formatPos m ++ ": " ++ s
 

fco2/Metadata.hs

@@ -8,7 +8,10 @@ import Data.List
 type Meta = [Metadatum]
 
 data OccSourcePos = OccSourcePos String Int Int
-  deriving (Show, Eq, Typeable, Data)
+  deriving (Eq, Typeable, Data)
+
+instance Show OccSourcePos where
+  show (OccSourcePos file line col) = file ++ ":" ++ show line ++ ":" ++ show col
 
 data Metadatum =
   MdSourcePos OccSourcePos

fco2/Parse.hs

@@ -261,16 +261,28 @@ handleSpecs specs inner specMarker
            v <- inner
            mapM scopeOutSpec ss'
            return $ foldl (\e s -> specMarker m s e) v ss'
+
+-- Like sepBy1, but not eager: it won't consume the separator unless it finds
+-- another item after it.
+sepBy1NE :: OccParser a -> OccParser b -> OccParser [a]
+sepBy1NE item sep
+    =  do i <- item
+          rest <- option [] $ try (do sep
+                                      sepBy1NE item sep)
+          return $ i : rest
 --}}}
 
 --{{{ name scoping
 findName :: A.Name -> OccParser A.Name
-findName n@(A.Name m nt s)
+findName thisN
     =  do st <- getState
-          let s' = case lookup s (localNames st) of
-                     Nothing -> die $ "Name " ++ s ++ " is not defined"
-                     Just (NameInfo _ n) -> n
-          return $ A.Name m nt s'
+          ni <- case lookup (A.nameName thisN) (localNames st) of
+                  Nothing -> fail $ "name " ++ A.nameName thisN ++ " not defined"
+                  Just ni -> return ni
+          let origN = originalDef ni
+          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 }
 
 scopeIn :: A.Name -> OccParser A.Name
 scopeIn n@(A.Name m nt s)
@@ -491,10 +503,10 @@ expressionList
 
 expression :: OccParser A.Expression
 expression
-    =   try (do { m <- md; o <- monadicOperator; v <- operand; return $ A.Monadic m o v })
+    =   do { m <- md; o <- monadicOperator; v <- operand; return $ A.Monadic m o v }
     <|> do { m <- md; sMOSTPOS; t <- dataType; return $ A.MostPos m t }
     <|> do { m <- md; sMOSTNEG; t <- dataType; return $ A.MostNeg m t }
-    <|> do { m <- md; sSIZE; t <- dataType; return $ A.Size m t }
+    <|> sizeExpr
     <|> do { m <- md; sTRUE; return $ A.True m }
     <|> do { m <- md; sFALSE; return $ A.False m }
     <|> try (do { m <- md; l <- operand; o <- dyadicOperator; r <- operand; return $ A.Dyadic m o l r })
@@ -502,6 +514,14 @@ expression
     <|> operand
     <?> "expression"
 
+sizeExpr :: OccParser A.Expression
+sizeExpr
+    =  do m <- md
+          sSIZE
+          (try (do { t <- dataType; return $ A.Size m t })
+           <|> do { v <- operand; return $ A.Monadic m A.MonadicSize v })
+    <?> "sizeExpr"
+
 booleanExpr :: OccParser A.Expression
 booleanExpr
     -- FIXME: Check the type is BOOL
@@ -513,7 +533,6 @@ monadicOperator
     =   do { reservedOp "-" <|> sMINUS; return A.MonadicSubtr }
     <|> do { reservedOp "~" <|> sBITNOT; return A.MonadicBitNot }
     <|> do { sNOT; return A.MonadicNot }
-    <|> do { sSIZE; return A.MonadicSize }
     <?> "monadicOperator"
 
 dyadicOperator :: OccParser A.DyadicOp
@@ -605,6 +624,28 @@ channel'
     =   try (do { m <- md; n <- channelName; return $ A.Channel m n })
     <|> try (maybeSliced channel A.SubscriptedChannel)
     <?> "channel'"
+
+timer :: OccParser A.Channel
+timer
+    =   maybeSubscripted "timer" timer' A.SubscriptedChannel
+    <?> "timer"
+
+timer' :: OccParser A.Channel
+timer'
+    =   try (do { m <- md; n <- timerName; return $ A.Channel m n })
+    <|> try (maybeSliced timer A.SubscriptedChannel)
+    <?> "timer'"
+
+port :: OccParser A.Channel
+port
+    =   maybeSubscripted "port" port' A.SubscriptedChannel
+    <?> "port"
+
+port' :: OccParser A.Channel
+port'
+    =   try (do { m <- md; n <- portName; return $ A.Channel m n })
+    <|> try (maybeSliced port A.SubscriptedChannel)
+    <?> "port'"
 --}}}
 --{{{ protocols
 protocol :: OccParser A.Type
@@ -703,6 +744,12 @@ definition
               <|> do { sRESHAPES; v <- variable; sColon; eol; return (n, A.ValReshapes m s v) } }
     <?> "definition"
 
+dataSpecifier :: OccParser A.Type
+dataSpecifier
+    =   try dataType
+    <|> try (do { sLeft; sRight; s <- dataSpecifier; return $ A.ArrayUnsized s })
+    <?> "dataSpecifier"
+
 specifier :: OccParser A.Type
 specifier
     =   try dataType
@@ -710,31 +757,32 @@ specifier
     <|> try timerType
     <|> try portType
     <|> try (do { sLeft; sRight; s <- specifier; return $ A.ArrayUnsized s })
-    <|> do { sLeft; e <- expression; sRight; s <- specifier; return $ A.Array e s }
     <?> "specifier"
 
 --{{{ PROCs and FUNCTIONs
--- This is rather different from the grammar, since I had some difficulty
--- getting Parsec to parse it as a list of lists of arguments.
 formalList :: OccParser A.Formals
 formalList
-    =   do { m <- md; sLeftR; fs <- sepBy formalArg sComma; sRightR; return $ markTypes m fs }
+    =  do m <- md
+          sLeftR
+          fs <- sepBy formalArgSet sComma
+          sRightR
+          return $ concat fs
     <?> "formalList"
-    where
-      formalArg :: OccParser (Maybe A.Type, A.Name)
-      formalArg =   try (do { sVAL; s <- specifier; n <- newVariableName; return $ (Just (A.Val s), n) })
-                <|> try (do { s <- specifier; n <- newVariableName <|> newChannelName; return $ (Just s, n) })
-                <|> try (do { n <- newVariableName <|> newChannelName; return $ (Nothing, n) })
 
-      markTypes :: Meta -> [(Maybe A.Type, A.Name)] -> A.Formals
-      markTypes _ [] = []
-      markTypes _ ((Nothing, _):_) = die "Formal list must start with a type"
-      markTypes m ((Just ft, fn):is) = markRest m ft [fn] is
+formalArgSet :: OccParser A.Formals
+formalArgSet
+    =   try (do t <- formalVariableType
+                ns <- sepBy1NE newVariableName sComma
+                return [(t, n) | n <- ns])
+    <|> do t <- specifier
+           ns <- sepBy1NE newChannelName sComma
+           return [(t, n) | n <- ns]
+    <?> "formalArgSet"
 
-      markRest :: Meta -> A.Type -> [A.Name] -> [(Maybe A.Type, A.Name)] -> A.Formals
-      markRest m lt ns [] = [(lt, n) | n <- ns]
-      markRest m lt ns ((Nothing, n):is) = markRest m lt (ns ++ [n]) is
-      markRest m lt ns ((Just t, n):is) = (markRest m lt ns []) ++ (markRest m t [n] is)
+formalVariableType :: OccParser A.Type
+    =   try (do { sVAL; s <- dataSpecifier; return $ A.Val s })
+    <|> dataSpecifier
+    <?> "formalVariableType"
 
 functionHeader :: OccParser (A.Name, A.Formals)
 functionHeader
@@ -810,13 +858,27 @@ inputProcess
 
 input :: OccParser (A.Channel, A.InputMode)
 input
+    =   channelInput
+    <|> timerInput
+    <|> do { m <- md; p <- port; sQuest; v <- variable; eol; return (p, A.InputSimple m [A.InVariable m v]) }
+    <?> "input"
+
+channelInput :: OccParser (A.Channel, A.InputMode)
     =   do  m <- md
             c <- channel
             sQuest
             (do { sCASE; tl <- taggedList; eol; return (c, A.InputCase m (A.OnlyV m (tl (A.Skip m)))) }
              <|> do { sAFTER; e <- expression; eol; return (c, A.InputAfter m e) }
              <|> do { is <- sepBy1 inputItem sSemi; eol; return (c, A.InputSimple m is) })
-    <?> "input"
+    <?> "channelInput"
+
+timerInput :: OccParser (A.Channel, A.InputMode)
+    =   do  m <- md
+            c <- timer
+            sQuest
+            (do { v <- variable; eol; return (c, A.InputSimple m [A.InVariable m v]) }
+             <|> do { sAFTER; e <- expression; eol; return (c, A.InputAfter m e) })
+    <?> "timerInput"
 
 taggedList :: OccParser (A.Process -> A.Variant)
 taggedList

fco2/testcases/args.occ

@@ -0,0 +1,11 @@
+PROC O (VAL []BYTE s)
+  SKIP
+:
+
+PROC P (INT a, b, c, BYTE d, CHAN OF INT p, q, r, CHAN OF BYTE s, []INT z, []CHAN OF INT zs, VAL INT va, vb, vc, VAL BYTE vd)
+  SKIP
+:
+
+PROC Q ()
+  SKIP
+:

fco2/testcases/broken1.occ

@@ -0,0 +1,3 @@
+PROC foo ()
+  FISH
+:

fco2/testcases/broken2.occ

@@ -0,0 +1,3 @@
+PROC foo ()
+  unknown.proc ()
+:

fco2/testcases/broken3.occ

@@ -0,0 +1,4 @@
+PROC foo ()
+  SKIP
+  SKIP
+:

fco2/testcases/broken4.occ

@@ -0,0 +1,4 @@
+PROC foo ()
+  INT x:
+  x ()
+:

fco2/testcases/commstime-mini.occ

@@ -0,0 +1,169 @@
+-- A standalone occam 2 version of the stock commstime benchmark.
+
+--{{{  PROC out.string (VAL []BYTE s, VAL INT width, CHAN OF BYTE out)
+PROC out.string (VAL []BYTE s, VAL INT width, CHAN OF BYTE out)
+  SEQ
+    SEQ i = 0 FOR SIZE s
+      out ! s[i]
+    SEQ j = 0 FOR width - (SIZE s)
+      out ! ' '
+:
+--}}}
+
+--{{{  PROC out.int (VAL INT n, VAL INT width, CHAN OF BYTE out)
+PROC out.int (VAL INT n, VAL INT width, CHAN OF BYTE out)
+  BYTE sign:
+  INT val, i:
+  [12]BYTE s:
+  SEQ
+    val, i := n, 0
+    IF
+      n < 0
+        SEQ
+          sign := '-'
+          val := -val
+      TRUE
+        sign := ' '
+    WHILE n > 10
+      SEQ
+        s[i] := '0' + (BYTE (n \ 10))
+        i := i + 1
+        n := n / 10
+    s[i] := '0' + (BYTE n)
+    s[i + 1] := sign
+    i := i + 2
+    SEQ j = 0 FOR width - i
+      out ! ' '
+    WHILE i > 0
+      SEQ
+        i := i - 1
+        out ! s[i]
+:
+--}}}
+
+--{{{  PROC id (CHAN OF INT in, out)
+PROC id (CHAN OF INT in, out)
+  WHILE TRUE
+    INT n:
+    SEQ
+      in ? n
+      out ! n
+:
+--}}}
+
+--{{{  PROC prefix (VAL INT n, CHAN OF INT in, out)
+PROC prefix (VAL INT n, CHAN OF INT in, out)
+  SEQ
+    out ! n
+    id (in, out)
+:
+--}}}
+
+--{{{  PROC delta (CHAN OF INT in, out.0, out.1)
+PROC delta (CHAN OF INT in, out.0, out.1)
+  WHILE TRUE
+    INT n:
+    SEQ
+      in ? n
+      PAR
+        out.0 ! n
+        out.1 ! n
+:
+--}}}
+
+--{{{  PROC seq.delta (CHAN OF INT in, out.0, out.1)
+PROC seq.delta (CHAN OF INT in, out.0, out.1)
+  WHILE TRUE
+    INT n:
+    SEQ
+      in ? n
+      out.0 ! n
+      out.1 ! n
+:
+--}}}
+
+--{{{  PROC succ (CHAN OF INT in, out)
+PROC succ (CHAN OF INT in, out)
+  WHILE TRUE
+    INT n:
+    SEQ
+      in ? n
+      out ! n + 1
+:
+--}}}
+
+--{{{  PROC consume (VAL INT n.loops, CHAN OF INT in, CHAN OF BYTE out)
+PROC consume (VAL INT n.loops, CHAN OF INT in, CHAN OF BYTE out)
+  TIMER tim:
+  INT t0, t1:
+  INT value:
+  SEQ
+    --{{{  warm-up loop
+    VAL INT warm.up IS 16:
+    SEQ i = 0 FOR warm.up
+      in ? value
+    --}}}
+    WHILE TRUE
+      SEQ
+        tim ? t0
+        --{{{  bench-mark loop
+        SEQ i = 0 FOR n.loops
+          in ? value
+        --}}}
+        tim ? t1
+        --{{{  report
+        VAL INT microsecs IS t1 MINUS t0:
+        VAL INT64 nanosecs IS 1000 * (INT64 microsecs):
+        SEQ
+          out.string ("Last value received = ", 0, out)
+          out.int (value, 0, out)
+          out.string ("*c*n", 0, out)
+          out.string ("Time = ", 0, out)
+          out.int (microsecs, 0, out)
+          out.string (" microsecs*c*n", 0, out)
+          out.string ("Time per loop = ", 0, out)
+          out.int (INT (nanosecs/(INT64 n.loops)), 0, out)
+          out.string (" nanosecs*c*n", 0, out)
+          out.string ("Context switch = ", 0, out)
+          out.int (INT ((nanosecs/(INT64 n.loops))/4), 0, out)
+          out.string (" nanosecs*c*n*n", 0, out)
+        --}}}
+:
+--}}}
+
+--{{{  PROC comms.time (CHAN OF BYTE keyboard, screen, error)
+PROC comms.time (CHAN OF BYTE keyboard, screen, error)
+
+  BOOL use.seq.delta:
+
+  SEQ
+
+    --{{{  announce
+    SEQ
+      out.string ("*c*nCommstime in occam ...*c*n*n", 0, screen)
+      out.string ("Using the SEQ-output version of the delta process*c*n", 0, screen)
+      out.string ("yields a more accurate measure of context-switch time*c*n*n", 0, screen)
+      out.string ("Using the PAR-output version carries an extra overhead*c*n", 0, screen)
+      out.string ("of one process startup/shutdown per Commstime loop*c*n*n", 0, screen)
+      out.string ("By comparing **loop** times between the SEQ and PAR versions,*c*n", 0, screen)
+      out.string ("the process startup/shutdown overhead may be deduced*c*n*n", 0, screen)
+    --}}}
+
+    --ask.bool ("Sequential delta ", use.seq.delta, keyboard, screen)
+    use.seq.delta := TRUE
+    out.string ("*nCommstime starting ...*c*n*n", 0, screen)
+
+    CHAN OF INT a, b, c, d:
+    PAR
+      prefix (0, b, a)
+      IF
+        use.seq.delta
+          seq.delta (a, c, d)    -- the one defined above
+        TRUE
+          delta (a, c, d)        -- the one that does a parallel output
+      succ (c, b)
+      consume (1000000, d, screen)
+
+:
+--}}}
+

fco2/testcases/tables.occ

@@ -0,0 +1,6 @@
+PROC main ()
+  VAL INT n IS 3:
+  VAL []BYTE s IS "hello world":
+  SKIP
+:
+

fco2/testcases/tags.occ

@@ -0,0 +1,25 @@
+PROTOCOL FOO
+  CASE
+    tag.a; INT
+    tag.b; REAL32; REAL32
+    tag.c
+:
+
+PROTOCOL BAR
+  CASE
+    tag.x
+    tag.y
+    tag.z
+:
+
+PROC foo (CHAN OF FOO foo, CHAN OF BAR bar)
+  SEQ
+    -- FIXME: This is the bodgy FCO syntax for now
+    foo ! CASE tag.a; 42
+    foo ! CASE tag.b; 1.2; 3.4
+    foo ! CASE tag.c
+    bar ! CASE tag.x
+    bar ! CASE tag.y
+    bar ! CASE tag.z
+:
+