8f767ff0d4
This makes sure that we catch all leftover instances of using SYB to do generic operations that we should be using Polyplate for instead. Most modules should only import Data, and possibly Typeable.
430 lines
14 KiB
Haskell
430 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 -- TODO stop this module using SYB
|
|
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, FindMeta a, Die m) => String -> [a] -> m ()
|
|
checkNull _ [] = return ()
|
|
checkNull s xs = dieP (findMeta $ head xs) $ "Property check " ++ show s ++ " failed: " ++ pshow xs
|
|
|
|
checkNull' :: (Data a, Die m) => String -> [a] -> m ()
|
|
checkNull' _ [] = return ()
|
|
checkNull' s xs = dieP emptyMeta $ "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" checkTODO
|
|
|
|
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
|