suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Turned *EXTERNAL pragmas into specifications in the occam parser

Browse Source 
There was a bug where things scoped in via pragmas were never scoped out again, which was screwing up the local names stack.  I then realised/decided that pragmas were really specifications, and decided to put them there in the parser.

The rest of this patch is just some rewiring to allow the special name munging involved in pragmas (they have already got a munged version of their name) and to stop the scoped in pragmas appearing in the AST.
This commit is contained in:
Neil Brown 2009-04-03 21:06:24 +00:00
parent 4a36d578c0
commit f755458545
1 changed files with 52 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
frontends/ParseOccam.hs
View File

@ -358,7 +358,6 @@ maybeIndentedList :: Meta -> String -> OccParser t -> OccParser [t]
maybeIndentedList m msg inner maybeIndentedList m msg inner
= do try indent = do try indent
vs <- many1 inner vs <- many1 inner
optional $ many1 pragma
outdent outdent
return vs return vs
<|> do warnP m WarnParserOddity msg <|> do warnP m WarnParserOddity msg
@ -372,7 +371,8 @@ handleSpecs specs inner specMarker
v <- inner v <- inner
mapM scopeOutSpec (reverse ss') mapM scopeOutSpec (reverse ss')
after after
return $ foldl (\e s -> specMarker m s e) v ss' return $ foldl (\e s -> specMarker m s e) v
[s | (s,(_,_,(_,A.NameUser))) <- zip ss' ss]
-- | Run several different parsers with a separator between them. -- | Run several different parsers with a separator between them.
-- If you give it [a, b, c] and s, it'll parse [a, s, b, s, c] then -- If you give it [a, b, c] and s, it'll parse [a, s, b, s, c] then
@ -403,17 +403,16 @@ findName thisN thisNT
then dieP (A.nameMeta thisN) $ "expected " ++ show thisNT ++ " (" ++ A.nameName origN ++ " is " ++ show origNT ++ ")" then dieP (A.nameMeta thisN) $ "expected " ++ show thisNT ++ " (" ++ A.nameName origN ++ " is " ++ show origNT ++ ")"
else return $ thisN { A.nameName = A.nameName origN } else return $ thisN { A.nameName = A.nameName origN }
scopeIn :: A.Name -> NameType -> A.SpecType -> A.AbbrevMode -> OccParser A.Name scopeIn :: A.Name -> NameType -> A.SpecType -> A.AbbrevMode -> (Maybe A.Name, A.NameSource) -> OccParser A.Name
scopeIn n@(A.Name m s) nt specType am scopeIn n@(A.Name m s) nt specType am (munged, ns)
= do s' <- makeUniqueName m s = do n' <- maybe (makeUniqueName m s >>* A.Name m) return munged
let n' = n { A.nameName = s' }
let nd = A.NameDef { let nd = A.NameDef {
A.ndMeta = m, A.ndMeta = m,
A.ndName = s', A.ndName = A.nameName n',
A.ndOrigName = s, A.ndOrigName = s,
A.ndSpecType = specType, A.ndSpecType = specType,
A.ndAbbrevMode = am, A.ndAbbrevMode = am,
A.ndNameSource = A.NameUser, A.ndNameSource = ns,
A.ndPlacement = A.Unplaced A.ndPlacement = A.Unplaced
} }
defineName n' nd defineName n' nd
@ -433,22 +432,25 @@ scopeOut n@(A.Name m _)
scopeInRep :: A.Name -> OccParser A.Name scopeInRep :: A.Name -> OccParser A.Name
scopeInRep n scopeInRep n
= scopeIn n VariableName (A.Declaration (A.nameMeta n) A.Int) A.ValAbbrev = scopeIn n VariableName (A.Declaration (A.nameMeta n) A.Int) A.ValAbbrev normalName
scopeOutRep :: A.Name -> OccParser () scopeOutRep :: A.Name -> OccParser ()
scopeOutRep n = scopeOut n scopeOutRep n = scopeOut n
-- | A specification, along with the 'NameType' of the name it defines. -- | A specification, along with the 'NameType' of the name it defines.
type NameSpec = (A.Specification, NameType) type NameSpec = (A.Specification, NameType, (Maybe A.Name, A.NameSource))
normalName :: (Maybe A.Name, A.NameSource)
normalName = (Nothing, A.NameUser)
scopeInSpec :: NameSpec -> OccParser A.Specification scopeInSpec :: NameSpec -> OccParser A.Specification
scopeInSpec (spec@(A.Specification m n st), nt) scopeInSpec (spec@(A.Specification m n st), nt, ns)
-- If it's recursive, the spec has already been defined: -- If it's recursive, the spec has already been defined:
| isRecursive st | isRecursive st
= do modifyName n $ \nd -> nd {A.ndSpecType = st} = do modifyName n $ \nd -> nd {A.ndSpecType = st}
return spec return spec
| otherwise | otherwise
= do n' <- scopeIn n nt st (abbrevModeOfSpec st) = do n' <- scopeIn n nt st (abbrevModeOfSpec st) ns
return $ A.Specification m n' st return $ A.Specification m n' st
where where
isRecursive (A.Function _ (_, A.Recursive) _ _ _) = True isRecursive (A.Function _ (_, A.Recursive) _ _ _) = True
@ -464,7 +466,7 @@ type NameFormal = (A.Formal, NameType)
scopeInFormal :: NameFormal -> OccParser A.Formal scopeInFormal :: NameFormal -> OccParser A.Formal
scopeInFormal (A.Formal am t n, nt) scopeInFormal (A.Formal am t n, nt)
= do n' <- scopeIn n nt (A.Declaration (A.nameMeta n) t) am = do n' <- scopeIn n nt (A.Declaration (A.nameMeta n) t) am normalName
return (A.Formal am t n') return (A.Formal am t n')
scopeInFormals :: [NameFormal] -> OccParser [A.Formal] scopeInFormals :: [NameFormal] -> OccParser [A.Formal]
@ -1032,9 +1034,10 @@ specification :: OccParser ([NameSpec], OccParser ())
specification specification
= do m <- md = do m <- md
(ns, d, nt) <- declaration (ns, d, nt) <- declaration
return ([(A.Specification m n d, nt) | n <- ns], return ()) return ([(A.Specification m n d, nt, normalName) | n <- ns], return ())
<|> do { a <- abbreviation; return ([a], return ()) } <|> do { a <- abbreviation; return ([a], return ()) }
<|> do { d <- definition; return ([d], return ()) } <|> do { d <- definition; return ([d], return ()) }
<|> do { n <- pragma ; return (maybeToList n, return ()) }
<?> "specification" <?> "specification"
declaration :: OccParser ([A.Name], A.SpecType, NameType) declaration :: OccParser ([A.Name], A.SpecType, NameType)
@ -1081,7 +1084,7 @@ valAbbrev
e <- expression e <- expression
sColon sColon
eol eol
return (A.Specification m n $ A.Is m am t (A.ActualExpression e), VariableName) return (A.Specification m n $ A.Is m am t (A.ActualExpression e), VariableName, normalName)
<?> "abbreviation by value" <?> "abbreviation by value"
refAbbrevMode :: OccParser A.AbbrevMode refAbbrevMode :: OccParser A.AbbrevMode
@ -1101,7 +1104,7 @@ refAbbrev oldVar nt
sColon sColon
eol eol
t' <- direct t t' <- direct t
return (A.Specification m n $ A.Is m am t' $ A.ActualVariable v, nt) return (A.Specification m n $ A.Is m am t' $ A.ActualVariable v, nt, normalName)
<?> "abbreviation by reference" <?> "abbreviation by reference"
chanArrayAbbrev :: OccParser NameSpec chanArrayAbbrev :: OccParser NameSpec
@ -1116,7 +1119,7 @@ chanArrayAbbrev
sColon sColon
eol eol
t' <- direct t t' <- direct t
return (A.Specification m n $ A.Is m A.Abbrev t' $ A.ActualChannelArray cs, ChannelName) return (A.Specification m n $ A.Is m A.Abbrev t' $ A.ActualChannelArray cs, ChannelName, normalName)
<?> "channel array abbreviation" <?> "channel array abbreviation"
specMode :: OccParser a -> OccParser (A.SpecMode, a) specMode :: OccParser a -> OccParser (A.SpecMode, a)
@ -1141,9 +1144,9 @@ definition
sDATA sDATA
sTYPE sTYPE
do { n <- tryVX newDataTypeName sIS; t <- dataType; sColon; eol; do { n <- tryVX newDataTypeName sIS; t <- dataType; sColon; eol;
return (A.Specification m n (A.DataType m t), DataTypeName) } return (A.Specification m n (A.DataType m t), DataTypeName, normalName) }
<|> do { n <- newRecordName; eol; indent; rec <- structuredType; outdent; sColon; eol; <|> do { n <- newRecordName; eol; indent; rec <- structuredType; outdent; sColon; eol;
return (A.Specification m n rec, RecordName) } return (A.Specification m n rec, RecordName, normalName) }
<|> do m <- md <|> do m <- md
rm <- tryVX (recMode sCHAN) sTYPE >>* fst rm <- tryVX (recMode sCHAN) sTYPE >>* fst
n <- newChanBundleName n <- newChanBundleName
@ -1155,19 +1158,19 @@ definition
indent indent
n' <- if rm == A.Recursive n' <- if rm == A.Recursive
then scopeIn n ChanBundleName then scopeIn n ChanBundleName
(A.ChanBundleType m rm []) A.Original (A.ChanBundleType m rm []) A.Original normalName
else return n else return n
fs <- many1 chanInBundle fs <- many1 chanInBundle
outdent outdent
outdent outdent
sColon sColon
eol eol
return (A.Specification m n' $ A.ChanBundleType m rm fs, ChanBundleName) return (A.Specification m n' $ A.ChanBundleType m rm fs, ChanBundleName, normalName)
<|> do m <- md <|> do m <- md
sPROTOCOL sPROTOCOL
n <- newProtocolName n <- newProtocolName
do { sIS; p <- sequentialProtocol; sColon; eol; return (A.Specification m n $ A.Protocol m p, ProtocolName) } do { sIS; p <- sequentialProtocol; sColon; eol; return (A.Specification m n $ A.Protocol m p, ProtocolName, normalName) }
<|> do { eol; indent; sCASE; eol; ps <- maybeIndentedList m "empty CASE protocol" taggedProtocol; outdent; sColon; eol; return (A.Specification m n $ A.ProtocolCase m ps, ProtocolName) } <|> do { eol; indent; sCASE; eol; ps <- maybeIndentedList m "empty CASE protocol" taggedProtocol; outdent; sColon; eol; return (A.Specification m n $ A.ProtocolCase m ps, ProtocolName, normalName) }
<|> do m <- md <|> do m <- md
(sm, (rm, _)) <- specMode $ recMode sPROC (sm, (rm, _)) <- specMode $ recMode sPROC
n <- newProcName n <- newProcName
@ -1176,7 +1179,7 @@ definition
indent indent
n' <- if rm == A.Recursive n' <- if rm == A.Recursive
then scopeIn n ProcName then scopeIn n ProcName
(A.Proc m (sm, rm) (map fst fs) (A.Skip m)) A.Original (A.Proc m (sm, rm) (map fst fs) (A.Skip m)) A.Original normalName
else return n else return n
fs' <- scopeInFormals fs fs' <- scopeInFormals fs
p <- process p <- process
@ -1184,7 +1187,7 @@ definition
outdent outdent
sColon sColon
eol eol
return (A.Specification m n' $ A.Proc m (sm, rm) fs' p, ProcName) return (A.Specification m n' $ A.Proc m (sm, rm) fs' p, ProcName, normalName)
<|> do m <- md <|> do m <- md
(rs, (sm, (rm, _))) <- tryVV (sepBy1 dataType sComma) (specMode $ recMode sFUNCTION) (rs, (sm, (rm, _))) <- tryVV (sepBy1 dataType sComma) (specMode $ recMode sFUNCTION)
n <- newFunctionName n <- newFunctionName
@ -1193,16 +1196,16 @@ definition
= do n' <- if rm == A.Recursive = do n' <- if rm == A.Recursive
then scopeIn n FunctionName then scopeIn n FunctionName
(A.Function m (sm, rm) rs (map fst fs) (Left $ A.Several m [])) (A.Function m (sm, rm) rs (map fst fs) (Left $ A.Several m []))
A.Original A.Original normalName
else return n else return n
fs' <- scopeInFormals fs fs' <- scopeInFormals fs
x <- body x <- body
scopeOutFormals fs' scopeOutFormals fs'
return (x, fs', n') return (x, fs', n')
do { sIS; (el, fs', n') <- addScope expressionList; sColon; eol; do { sIS; (el, fs', n') <- addScope expressionList; sColon; eol;
return (A.Specification m n' $ A.Function m (sm, rm) rs fs' (Left $ A.Only m el), FunctionName) } return (A.Specification m n' $ A.Function m (sm, rm) rs fs' (Left $ A.Only m el), FunctionName, normalName) }
<|> do { eol; indent; (vp, fs', n') <- addScope valueProcess; outdent; sColon; eol; <|> do { eol; indent; (vp, fs', n') <- addScope valueProcess; outdent; sColon; eol;
return (A.Specification m n' $ A.Function m (sm, rm) rs fs' (Left vp), FunctionName) } return (A.Specification m n' $ A.Function m (sm, rm) rs fs' (Left vp), FunctionName, normalName) }
<|> retypesAbbrev <|> retypesAbbrev
<?> "definition" <?> "definition"
where where
@ -1222,19 +1225,19 @@ retypesAbbrev
v <- variable v <- variable
sColon sColon
eol eol
return (A.Specification m n $ A.Retypes m am s v, VariableName) return (A.Specification m n $ A.Retypes m am s v, VariableName, normalName)
<|> do m <- md <|> do m <- md
(s, n) <- tryVVX channelSpecifier newChannelName retypesReshapes (s, n) <- tryVVX channelSpecifier newChannelName retypesReshapes
c <- directedChannel c <- directedChannel
sColon sColon
eol eol
return (A.Specification m n $ A.Retypes m A.Abbrev s c, ChannelName) return (A.Specification m n $ A.Retypes m A.Abbrev s c, ChannelName, normalName)
<|> do m <- md <|> do m <- md
(am, s, n) <- tryVVVX valAbbrevMode dataSpecifier newVariableName retypesReshapes (am, s, n) <- tryVVVX valAbbrevMode dataSpecifier newVariableName retypesReshapes
e <- expression e <- expression
sColon sColon
eol eol
return (A.Specification m n $ A.RetypesExpr m am s e, VariableName) return (A.Specification m n $ A.RetypesExpr m am s e, VariableName, normalName)
<?> "RETYPES/RESHAPES abbreviation" <?> "RETYPES/RESHAPES abbreviation"
where where
retypesReshapes :: OccParser () retypesReshapes :: OccParser ()
@ -1373,7 +1376,7 @@ structuredTypeField
--}}} --}}}
--}}} --}}}
--{{{ pragmas --{{{ pragmas
pragma :: OccParser () pragma :: OccParser (Maybe NameSpec)
pragma = do m <- getPosition >>* sourcePosToMeta pragma = do m <- getPosition >>* sourcePosToMeta
Pragma rawP <- genToken isPragma Pragma rawP <- genToken isPragma
let prag :: Maybe (Int, String) let prag :: Maybe (Int, String)
@ -1397,6 +1400,7 @@ pragma = do m <- getPosition >>* sourcePosToMeta
modify $ \st -> st {csNameAttr = Map.insertWith Set.union modify $ \st -> st {csNameAttr = Map.insertWith Set.union
n (Set.singleton NameShared) (csNameAttr st)}) n (Set.singleton NameShared) (csNameAttr st)})
vars vars
return Nothing
1 -> do 1 -> do
vars <- sepBy1 identifier sComma vars <- sepBy1 identifier sComma
mapM_ (\var -> mapM_ (\var ->
@ -1407,6 +1411,7 @@ pragma = do m <- getPosition >>* sourcePosToMeta
modify $ \st -> st {csNameAttr = Map.insertWith Set.union modify $ \st -> st {csNameAttr = Map.insertWith Set.union
n (Set.singleton NameAliasesPermitted) (csNameAttr st)}) n (Set.singleton NameAliasesPermitted) (csNameAttr st)})
vars vars
return Nothing
pragmaType | pragmaType == 2 || pragmaType == 3 -> do pragmaType | pragmaType == 2 || pragmaType == 3 -> do
m <- md m <- md
(n, nt, origN, fs, sp) <- (n, nt, origN, fs, sp) <-
@ -1430,27 +1435,28 @@ pragma = do m <- getPosition >>* sourcePosToMeta
n <- newFunctionName n <- newFunctionName
return (n, FunctionName, origN, fs, A.Function m (A.PlainSpec, A.PlainRec) ts fs return (n, FunctionName, origN, fs, A.Function m (A.PlainSpec, A.PlainRec) ts fs
$ Right (A.Skip m)) $ Right (A.Skip m))
let nd = A.NameDef m (A.nameName n) (A.nameName origN) let ext = if pragmaType == 2 then ExternalOldStyle else ExternalOccam
sp A.Original A.NamePredefined A.Unplaced
ext = if pragmaType == 2 then ExternalOldStyle else ExternalOccam
modify $ \st -> st modify $ \st -> st
{ csNames = Map.insert (A.nameName n) nd (csNames st) { csExternals = (A.nameName n, (ext, fs)) : csExternals st
, csLocalNames = (A.nameName origN, (n, nt)) : csLocalNames st
, csExternals = (A.nameName n, (ext, fs)) : csExternals st
} }
case (prag, mprod) of return $ Just (A.Specification m origN sp, nt, (Just n, A.NamePredefined))
ns <- case (prag, mprod) of
(Just (_, pragStr), Just prod) -> do (Just (_, pragStr), Just prod) -> do
let column = metaColumn m + fromMaybe 0 (findIndex (=='\"') rawP) let column = metaColumn m + fromMaybe 0 (findIndex (=='\"') rawP)
toks <- runLexer' (fromMaybe "<unknown(pragma)>" $ metaFile m toks <- runLexer' (fromMaybe "<unknown(pragma)>" $ metaFile m
, metaLine m, column) pragStr , metaLine m, column) pragStr
cs <- getCompState cs <- getCompState
case runParser (prod >> getState) cs "" toks of case runParser (do {n <- prod; s <- getState; return (n, s)}) cs "" toks of
Left err -> warnP m WarnUnknownPreprocessorDirective $ Left err -> do warnP m WarnUnknownPreprocessorDirective $
"Unknown PRAGMA (parse failed): " ++ show err "Unknown PRAGMA (parse failed): " ++ show err
Right st -> setState st return Nothing
_ -> warnP m WarnUnknownPreprocessorDirective $ Right (n, st) -> do setState st
"Unknown PRAGMA type: " ++ show rawP return n
_ -> do warnP m WarnUnknownPreprocessorDirective $
"Unknown PRAGMA type: " ++ show rawP
return Nothing
eol eol
return ns
where where
isPragma (Token _ p@(Pragma {})) = Just p isPragma (Token _ p@(Pragma {})) = Just p
isPragma _ = Nothing isPragma _ = Nothing
@ -1479,7 +1485,6 @@ process
<|> intrinsicProc <|> intrinsicProc
<|> handleSpecs (allocation <|> specification <|> claimSpec) process <|> handleSpecs (allocation <|> specification <|> claimSpec) process
(\m s p -> A.Seq m (A.Spec m s (A.Only m p))) (\m s p -> A.Seq m (A.Spec m s (A.Only m p)))
<|> (tryXV pragma process)
<?> "process" <?> "process"
claimSpec :: OccParser ([NameSpec], OccParser ()) claimSpec :: OccParser ([NameSpec], OccParser ())
@ -1489,7 +1494,7 @@ claimSpec
n <- getName v >>= getOrigName n <- getName v >>= getOrigName
eol eol
indent indent
return ([(A.Specification m (A.Name m n) $ A.Is m A.Abbrev A.Infer $ A.ActualClaim v, ChannelName)], outdent) return ([(A.Specification m (A.Name m n) $ A.Is m A.Abbrev A.Infer $ A.ActualClaim v, ChannelName, normalName)], outdent)
where where
getName :: A.Variable -> OccParser A.Name getName :: A.Variable -> OccParser A.Name
getName (A.Variable _ n) = return n getName (A.Variable _ n) = return n
@ -1887,7 +1892,6 @@ topLevelItem :: OccParser A.AST
topLevelItem topLevelItem
= handleSpecs (allocation <|> specification) topLevelItem = handleSpecs (allocation <|> specification) topLevelItem
(\m s inner -> A.Spec m s inner) (\m s inner -> A.Spec m s inner)
<|> (pragma >> topLevelItem)
<|> do m <- md <|> do m <- md
eof eof
-- Stash the current locals so that we can either restore them -- Stash the current locals so that we can either restore them