62a0873d3d
This is mostly straightforward: modify the parser to allow direction decorators in the right places, and extend the type checker to match. There's some slight awkwardness in that some of the Types functions have to perform the same checks as the type checker (e.g. directing a non-channel), so I've tidied up their error messages a bit. At the backend, I've just added a little pass to strip out all the DirectedVariables, since the other backend passes don't handle them gracefully. From the occam/C point of view this is fine, but I'm not sure if it's going to cause problems for C++.
426 lines
14 KiB
Haskell
426 lines
14 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2007 University of Kent
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation, either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
module Properties
|
|
( agg_namesDone
|
|
, agg_functionsGone
|
|
, agg_typesDone
|
|
, afterRemoved
|
|
, allChansToAnyOrProtocol
|
|
, ambiguitiesResolved
|
|
, arrayConstructorsRemoved
|
|
, arrayConstructorTypesDone
|
|
, arrayLiteralsExpanded
|
|
, arraySizesDeclared
|
|
, assignFlattened
|
|
, assignParRemoved
|
|
, constantsChecked
|
|
, constantsFolded
|
|
, declarationsUnique
|
|
, declarationTypesRecorded
|
|
, declaredNamesResolved
|
|
, directionsRemoved
|
|
, eachRangeTransformed
|
|
, eachTransformed
|
|
, expressionTypesChecked
|
|
, freeNamesToArgs
|
|
, functionCallsRemoved
|
|
, functionsRemoved
|
|
, functionTypesChecked
|
|
, inferredTypesRecorded
|
|
, initialRemoved
|
|
, inputCaseRemoved
|
|
, intLiteralsInBounds
|
|
, listsGivenType
|
|
, mainTagged
|
|
, nestedPulled
|
|
, noInt
|
|
, outExpressionRemoved
|
|
, parsIdentified
|
|
, parsWrapped
|
|
, parUsageChecked
|
|
, processTypesChecked
|
|
, rainParDeclarationsPulledUp
|
|
, rangeTransformed
|
|
, resultRemoved
|
|
, retypesChecked
|
|
, seqInputsFlattened
|
|
, slicesSimplified
|
|
, subscriptsPulledUp
|
|
, typesResolvedInAST
|
|
, typesResolvedInState
|
|
, waitForRemoved
|
|
)
|
|
where
|
|
|
|
import Control.Monad.Writer
|
|
import Data.Generics
|
|
import Data.Int
|
|
import Data.List
|
|
import qualified Data.Map as Map
|
|
import Data.Maybe
|
|
import Data.Word
|
|
import Text.Regex
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Errors
|
|
import Metadata
|
|
import Pass
|
|
import PrettyShow
|
|
import Types
|
|
import Utils
|
|
|
|
agg_namesDone :: [Property]
|
|
agg_namesDone =
|
|
[ declarationTypesRecorded
|
|
, declarationsUnique
|
|
, declaredNamesResolved
|
|
, inferredTypesRecorded
|
|
]
|
|
|
|
agg_typesDone :: [Property]
|
|
agg_typesDone =
|
|
[ constantsChecked
|
|
, constantsFolded
|
|
, expressionTypesChecked
|
|
, functionTypesChecked
|
|
, inferredTypesRecorded
|
|
, processTypesChecked
|
|
, retypesChecked
|
|
, typesResolvedInAST
|
|
, typesResolvedInState
|
|
]
|
|
|
|
agg_functionsGone :: [Property]
|
|
agg_functionsGone =
|
|
[ functionCallsRemoved
|
|
, functionsRemoved
|
|
]
|
|
|
|
-- Mark out all the checks I still need to implement:
|
|
checkTODO :: Monad m => A.AST -> m ()
|
|
checkTODO _ = return ()
|
|
|
|
-- For properties that can't easily be tested (such as properties that are themselves tests anyway!)
|
|
nocheck :: Monad m => A.AST -> m ()
|
|
nocheck _ = return ()
|
|
|
|
getDeclaredNames :: A.AST -> [A.Name]
|
|
getDeclaredNames = everything (++) ([] `mkQ` find)
|
|
where
|
|
find :: A.Specification -> [A.Name]
|
|
find (A.Specification _ n (A.Declaration {})) = [n]
|
|
find _ = []
|
|
|
|
checkNull :: (Data a, Die m) => String -> [a] -> m ()
|
|
checkNull _ [] = return ()
|
|
checkNull s xs = dieP (findMeta xs) $ "Property check " ++ show s ++ " failed: " ++ pshow xs
|
|
|
|
isNonceOrUnique :: String -> Bool
|
|
isNonceOrUnique nm = isJust $ matchRegex (mkRegex ".*_[a-z][0-9]+$") nm
|
|
|
|
declaredNamesResolved :: Property
|
|
declaredNamesResolved = Property "declaredNamesResolved" $
|
|
checkNull "namesResolved" . filter (not . isNonceOrUnique . A.nameName) . getDeclaredNames
|
|
|
|
noInt :: Property
|
|
noInt = Property "noInt" $
|
|
checkNull "noInt" . listify (== A.Int)
|
|
|
|
declarationTypesRecorded :: Property
|
|
declarationTypesRecorded = Property "declarationTypesRecorded" $ \t ->
|
|
do let decls = getDeclaredNames t
|
|
st <- getCompState
|
|
mapM_ (checkName (csNames st)) decls
|
|
where
|
|
checkName :: Die m => Map.Map String A.NameDef -> A.Name -> m ()
|
|
checkName nms n = case Map.lookup (A.nameName n) nms of
|
|
Nothing -> dieP m $ "Type of name " ++ show (A.nameName n) ++ " was not recorded"
|
|
Just nd -> when (A.ndName nd /= A.nameName n) $
|
|
dieP m $ "Name not recorded correctly: " ++ show (A.nameName n)
|
|
where m = A.nameMeta n
|
|
|
|
declarationsUnique :: Property
|
|
declarationsUnique = Property "declarationsUnique" $
|
|
checkDupes . sort . getDeclaredNames
|
|
where
|
|
checkDupes :: Die m => [A.Name] -> m ()
|
|
checkDupes [] = return ()
|
|
checkDupes (n:[]) = return ()
|
|
checkDupes (n:n':ns)
|
|
= do when (A.nameName n == A.nameName n') $
|
|
dieP (A.nameMeta n) $ "Duplicate definition of name (names not uniquified successfully?) " ++ show (A.nameName n) ++ " with: " ++ show (A.nameMeta n')
|
|
checkDupes (n':ns)
|
|
|
|
constantsChecked :: Property
|
|
constantsChecked = Property "constantsChecked" nocheck
|
|
|
|
constantsFolded :: Property
|
|
constantsFolded = Property "constantsFolded" nocheck
|
|
|
|
retypesChecked :: Property
|
|
retypesChecked = Property "retypesChecked" nocheck
|
|
|
|
intLiteralsInBounds :: Property
|
|
intLiteralsInBounds = Property "intLiteralsInBounds" $
|
|
mapM_ check . everything (++) ([] `mkQ` find)
|
|
where
|
|
find :: A.Expression -> [(Meta, A.Type, String)]
|
|
find (A.Literal m t (A.IntLiteral _ s)) = [(m,t,s)]
|
|
find _ = []
|
|
|
|
toPair :: (Monad m, Integral a) => [a] -> m (Integer, Integer)
|
|
toPair [x,y] = return (toInteger x, toInteger y)
|
|
|
|
occToBounds :: Die m => Meta -> A.Type -> m (Integer, Integer)
|
|
occToBounds _ A.Byte = toPair ([minBound, maxBound] :: [Word8])
|
|
occToBounds _ A.UInt16 = toPair ([minBound, maxBound] :: [Word16])
|
|
occToBounds _ A.UInt32 = toPair ([minBound, maxBound] :: [Word32])
|
|
occToBounds _ A.UInt64 = toPair ([minBound, maxBound] :: [Word64])
|
|
occToBounds _ A.Int8 = toPair ([minBound, maxBound] :: [Int8])
|
|
occToBounds _ A.Int16 = toPair ([minBound, maxBound] :: [Int16])
|
|
occToBounds _ A.Int32 = toPair ([minBound, maxBound] :: [Int32])
|
|
occToBounds _ A.Int = toPair ([minBound, maxBound] :: [Int32])
|
|
occToBounds _ A.Int64 = toPair ([minBound, maxBound] :: [Int64])
|
|
occToBounds m t = dieP m $ "Type " ++ show t ++ " is not an integer type"
|
|
|
|
check :: Die m => (Meta, A.Type, String) -> m ()
|
|
check (m, t, s)
|
|
= do (low, high) <- occToBounds m t
|
|
when (n < low) $ dieP m $ "Integer not within lower bound: " ++ s
|
|
when (n > high) $ dieP m $ "Integer not within upper bound: " ++ s
|
|
where
|
|
n :: Integer
|
|
n = read s
|
|
|
|
expressionTypesChecked :: Property
|
|
expressionTypesChecked = Property "expressionTypesChecked" nocheck
|
|
|
|
processTypesChecked :: Property
|
|
processTypesChecked = Property "processTypesChecked" nocheck
|
|
|
|
functionTypesChecked :: Property
|
|
functionTypesChecked = Property "functionTypesChecked" nocheck
|
|
|
|
eachRangeTransformed :: Property
|
|
eachRangeTransformed = Property "eachRangeTransformed" checkTODO
|
|
|
|
eachTransformed :: Property
|
|
eachTransformed = Property "eachTransformed" checkTODO
|
|
|
|
rangeTransformed :: Property
|
|
rangeTransformed = Property "rangeTransformed" checkTODO
|
|
|
|
rainParDeclarationsPulledUp :: Property
|
|
rainParDeclarationsPulledUp = Property "rainParDeclarationsPulledUp" checkTODO
|
|
|
|
inferredTypesRecorded :: Property
|
|
inferredTypesRecorded = Property "inferredTypesRecorded" $
|
|
checkNull "inferredTypesRecorded" . listify findInfer
|
|
where
|
|
findInfer :: A.Type -> Bool
|
|
findInfer A.Infer = True
|
|
findInfer _ = False
|
|
|
|
ambiguitiesResolved :: Property
|
|
ambiguitiesResolved = Property "ambiguitiesResolved" checkTODO
|
|
|
|
findUDT :: A.Type -> Bool
|
|
findUDT (A.UserDataType {}) = True
|
|
findUDT _ = False
|
|
|
|
typesResolvedInAST :: Property
|
|
typesResolvedInAST = Property "typesResolvedInAST" $
|
|
checkNull "typesResolvedInAST" . listify findUDT
|
|
|
|
typesResolvedInState :: Property
|
|
typesResolvedInState = Property "typesResolvedInState" $
|
|
\t -> checkNull "typesResolvedInState" . listify findUDT =<< getCompState
|
|
|
|
checkAllExprVariable :: Die m => [A.Expression] -> m ()
|
|
checkAllExprVariable = mapM_ check
|
|
where
|
|
check :: Die m => A.Expression -> m ()
|
|
check (A.ExprVariable {}) = return ()
|
|
check e = dieP (findMeta e) $ "Found something that was not an expression variable: " ++ pshow e
|
|
|
|
findOutputExprs :: A.OutputItem -> [A.Expression]
|
|
findOutputExprs (A.OutExpression _ e) = [e]
|
|
findOutputExprs (A.OutCounted _ ce ae) = [ce, ae]
|
|
|
|
outExpressionRemoved :: Property
|
|
outExpressionRemoved = Property "outExpressionRemoved" $
|
|
checkAllExprVariable . everything (++) ([] `mkQ` findOutputExprs)
|
|
|
|
findInputCase :: A.InputMode -> Bool
|
|
findInputCase (A.InputCase {}) = True
|
|
findInputCase _ = False
|
|
|
|
inputCaseRemoved :: Property
|
|
inputCaseRemoved = Property "inputCaseRemoved" $
|
|
checkNull "inputCaseRemoved" . listify findInputCase
|
|
|
|
findParAssign :: A.Process -> Bool
|
|
findParAssign (A.Assign _ (_:_:_) _) = True
|
|
findParAssign _ = False
|
|
|
|
assignParRemoved :: Property
|
|
assignParRemoved = Property "assignParRemoved" $
|
|
checkNull "assignParRemoved" . listify findParAssign
|
|
|
|
findParWithProcess :: A.Process -> Bool
|
|
findParWithProcess (A.Par _ _ s) = findParProcess s
|
|
where
|
|
-- We don't use listify here because it would descend into the declarations
|
|
-- of the processes (for the wrapped PARs) and find A.Structured A.Process items
|
|
-- in SEQs in there
|
|
findParProcess :: A.Structured A.Process -> Bool
|
|
findParProcess (A.Only _ (A.ProcCall {})) = False
|
|
findParProcess (A.Only {}) = True
|
|
findParProcess (A.ProcThen _ _ s) = findParProcess s
|
|
findParProcess (A.Spec _ _ s) = findParProcess s
|
|
findParProcess (A.Several _ ss) = or $ map findParProcess ss
|
|
findParWithProcess _ = False
|
|
|
|
parsWrapped :: Property
|
|
parsWrapped = Property "parsWrapped" $
|
|
checkNull "parsWrapped" . listify findParWithProcess
|
|
|
|
findAssignVars :: A.Process -> [A.Variable]
|
|
findAssignVars (A.Assign _ vs _) = vs
|
|
findAssignVars _ = []
|
|
|
|
filterArrayAndRecord :: (CSMR m, Die m) => A.Variable -> m Bool
|
|
filterArrayAndRecord v
|
|
= do t <- astTypeOf v
|
|
return $ case t of
|
|
A.Array {} -> True
|
|
A.Record {} -> True
|
|
_ -> False
|
|
|
|
assignFlattened :: Property
|
|
assignFlattened = Property "assignFlattened" $
|
|
checkNull "assignFlattened" <.< (filterM filterArrayAndRecord . everything (++) ([] `mkQ` findAssignVars))
|
|
|
|
parUsageChecked :: Property
|
|
parUsageChecked = Property "parUsageChecked" nocheck
|
|
|
|
freeNamesToArgs :: Property
|
|
freeNamesToArgs = Property "freeNamesToArgs" checkTODO
|
|
|
|
nestedPulled :: Property
|
|
nestedPulled = Property "nestedPulled" checkTODO
|
|
|
|
findFunctions :: A.SpecType -> Bool
|
|
findFunctions (A.Function {}) = True
|
|
findFunctions _ = False
|
|
|
|
functionsRemoved :: Property
|
|
functionsRemoved = Property "functionsRemoved" $
|
|
checkNull "functionsRemoved" . listify findFunctions
|
|
|
|
afterRemoved :: Property
|
|
afterRemoved = Property "afterRemoved" $
|
|
checkNull "afterRemoved" . listify (== A.After)
|
|
|
|
arrayLiteralsExpanded :: Property
|
|
arrayLiteralsExpanded = Property "arrayLiteralsExpanded" checkTODO
|
|
|
|
arrayConstructorsRemoved :: Property
|
|
arrayConstructorsRemoved = Property "arrayConstructorsRemoved" checkTODO
|
|
|
|
arrayConstructorTypesDone :: Property
|
|
arrayConstructorTypesDone = Property "arrayConstructorTypesDone" checkTODO
|
|
|
|
findFunctionCalls :: A.Expression -> Bool
|
|
findFunctionCalls (A.FunctionCall {}) = True
|
|
findFunctionCalls _ = False
|
|
|
|
findFunctionCallLists :: A.ExpressionList -> Bool
|
|
findFunctionCallLists (A.FunctionCallList {}) = True
|
|
findFunctionCallLists _ = False
|
|
|
|
functionCallsRemoved :: Property
|
|
functionCallsRemoved = Property "functionCallsRemoved" $
|
|
\t -> checkNull "functionCallsRemoved/1" (listify findFunctionCalls t) >> checkNull "functionCallsRemoved/2" (listify findFunctionCallLists t)
|
|
|
|
subscriptsPulledUp :: Property
|
|
subscriptsPulledUp = Property "subscriptsPulledUp" checkTODO
|
|
|
|
parsIdentified :: Property
|
|
parsIdentified = Property "parsIdentified" nocheck
|
|
|
|
findWaitFor :: A.Alternative -> Bool
|
|
findWaitFor (A.Alternative _ _ _ (A.InputTimerFor {}) _) = True
|
|
findWaitFor _ = False
|
|
|
|
waitForRemoved :: Property
|
|
waitForRemoved = Property "waitForRemoved" $
|
|
checkNull "waitForRemoved" . listify findWaitFor
|
|
|
|
|
|
allChansToAnyOrProtocol :: Property
|
|
allChansToAnyOrProtocol = Property "allChansToAnyOrProtocol" checkTODO
|
|
|
|
mainTagged :: Property
|
|
mainTagged = Property "mainTagged" nocheck
|
|
-- We don't check this because not having a main process may be valid in the future
|
|
-- so there's no easy way to check if the main process has been looked for or not
|
|
|
|
seqInputsFlattened :: Property
|
|
seqInputsFlattened = Property "seqInputsFlattened" $ checkNull "seqInputsFlattened" . listify findMultipleInputs
|
|
where
|
|
findMultipleInputs :: A.InputMode -> Bool
|
|
findMultipleInputs (A.InputSimple _ (_:_:_)) = True
|
|
findMultipleInputs _ = False
|
|
|
|
arraySizesDeclared :: Property
|
|
arraySizesDeclared = Property "arraySizesDeclared" nocheck
|
|
|
|
slicesSimplified :: Property
|
|
slicesSimplified = Property "slicesSimplified" $
|
|
checkNull "slicesSimplified" . listify findJustFromOrFor
|
|
where
|
|
findJustFromOrFor :: A.Subscript -> Bool
|
|
findJustFromOrFor (A.SubscriptFrom {}) = True
|
|
findJustFromOrFor (A.SubscriptFor {}) = True
|
|
findJustFromOrFor _ = False
|
|
|
|
listsGivenType :: Property
|
|
listsGivenType = Property "listsGivenType" checkTODO
|
|
|
|
initialRemoved :: Property
|
|
initialRemoved
|
|
= Property "initialRemoved" $
|
|
checkNull "initialRemoved" . listify (== A.InitialAbbrev)
|
|
|
|
resultRemoved :: Property
|
|
resultRemoved
|
|
= Property "resultRemoved" $
|
|
checkNull "resultRemoved" . listify (== A.ResultAbbrev)
|
|
|
|
directionsRemoved :: Property
|
|
directionsRemoved
|
|
= Property "directionsRemoved" $
|
|
checkNull "directionsRemoved" . listify findVariable
|
|
where
|
|
findVariable :: A.Variable -> Bool
|
|
findVariable (A.DirectedVariable {}) = True
|
|
findVariable _ = False
|