From 5cb964092d46b96b693c23e605b97ce8e8e26b40 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Tue, 19 Feb 2008 09:49:05 +0000 Subject: [PATCH] Added a new module full of properties about the AST, most now with associated validity checks --- Makefile.am | 1 + common/Properties.hs | 327 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 328 insertions(+) create mode 100644 common/Properties.hs diff --git a/Makefile.am b/Makefile.am index bbc3faf..9603df9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -119,6 +119,7 @@ tock_SOURCES_hs += common/Pass.hs tock_SOURCES_hs += common/PassList.hs tock_SOURCES_hs += common/Pattern.hs tock_SOURCES_hs += common/PrettyShow.hs +tock_SOURCES_hs += common/Properties.hs tock_SOURCES_hs += common/ShowCode.hs tock_SOURCES_hs += common/TagAST.hs tock_SOURCES_hs += common/TreeUtils.hs diff --git a/common/Properties.hs b/common/Properties.hs new file mode 100644 index 0000000..a24b649 --- /dev/null +++ b/common/Properties.hs @@ -0,0 +1,327 @@ +{- +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 . +-} + +module Properties + ( agg_namesDone + , agg_typesDone + , afterRemoved + , allChansToAnyOrProtocol + , arrayLiteralsExpanded + , assignFlattened + , assignParRemoved + , constantsFolded + , declarationsUnique + , declarationTypesRecorded + , declaredNamesResolved + , eachRangeTransformed + , eachTransformed + , expressionTypesChecked + , freeNamesToArgs + , functionCallsRemoved + , functionsRemoved + , inferredTypesRecorded + , inputCaseRemoved + , intLiteralsInBounds + , mainTagged + , nestedPulled + , noInt + , outExpressionRemoved + , parsIdentified + , parsWrapped + , parUsageChecked + , processTypesChecked + , rainParDeclarationsPulledUp + , rangeTransformed + , 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 = [declarationsUnique, declarationTypesRecorded, inferredTypesRecorded, declaredNamesResolved] + +agg_typesDone :: [Property] +agg_typesDone = [expressionTypesChecked, inferredTypesRecorded, processTypesChecked, typesResolvedInAST, typesResolvedInState] + +-- 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) + +constantsFolded :: Property +constantsFolded = Property "constantsFolded" checkTODO + +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 + +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" 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.Rep _ _ s) = findParProcess s + 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 <- typeOfVariable 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 + +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.AlternativeWait _ A.WaitFor _ _) = 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