c8b724d2be
I also added the import list to all the Data.Generics imports in the tests (as I did for the other modules recently)
1662 lines
70 KiB
Haskell
1662 lines
70 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2008 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/>.
|
|
-}
|
|
|
|
-- | The occam typechecker.
|
|
module OccamTypes (inferTypes, checkTypes, addDirections) where
|
|
|
|
import Control.Monad.Error
|
|
import Control.Monad.Reader
|
|
import Control.Monad.State
|
|
import Data.Function (on)
|
|
import Data.Generics (Data)
|
|
import Data.IORef
|
|
import Data.List
|
|
import qualified Data.Map as Map
|
|
import Data.Maybe
|
|
import qualified Data.Traversable as T
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Errors
|
|
import EvalConstants
|
|
import Intrinsics
|
|
import Metadata
|
|
import Pass
|
|
import qualified Properties as Prop
|
|
import ShowCode
|
|
import Traversal
|
|
import Types
|
|
import Utils
|
|
|
|
-- | A successful check.
|
|
ok :: PassM ()
|
|
ok = return ()
|
|
|
|
--{{{ type checks
|
|
|
|
-- | Are two types the same?
|
|
sameType :: A.Type -> A.Type -> PassM Bool
|
|
sameType (A.Array (A.Dimension e1 : ds1) t1)
|
|
(A.Array (A.Dimension e2 : ds2) t2)
|
|
= do n1 <- evalIntExpression e1
|
|
n2 <- evalIntExpression e2
|
|
same <- sameType (A.Array ds1 t1) (A.Array ds2 t2)
|
|
return $ (n1 == n2) && same
|
|
sameType (A.Array (A.UnknownDimension : ds1) t1)
|
|
(A.Array (A.UnknownDimension : ds2) t2)
|
|
= sameType (A.Array ds1 t1) (A.Array ds2 t2)
|
|
-- We might be dealing with channels of arrays, so we must dig through channels:
|
|
sameType (A.Chan _ ta) (A.Chan _ tb) = sameType ta tb
|
|
sameType (A.ChanEnd dira _ ta) (A.ChanEnd dirb _ tb)
|
|
= liftM (dira == dirb &&) (sameType ta tb)
|
|
sameType (A.Mobile ta) (A.Mobile tb) = sameType ta tb
|
|
-- Resolve user data types:
|
|
sameType ta@(A.UserDataType {}) tb
|
|
= do ta' <- resolveUserType emptyMeta ta
|
|
sameType ta' tb
|
|
sameType ta tb@(A.UserDataType {})
|
|
= do tb' <- resolveUserType emptyMeta tb
|
|
sameType ta tb'
|
|
sameType a b = return $ a == b
|
|
|
|
-- | Check that the second dimension can be used in a context where the first
|
|
-- is expected.
|
|
isValidDimension :: A.Dimension -> A.Dimension -> PassM Bool
|
|
isValidDimension A.UnknownDimension A.UnknownDimension = return True
|
|
isValidDimension A.UnknownDimension (A.Dimension _) = return True
|
|
isValidDimension (A.Dimension e1) (A.Dimension e2)
|
|
= do n1 <- evalIntExpression e1
|
|
n2 <- evalIntExpression e2
|
|
return $ n1 == n2
|
|
isValidDimension _ _ = return False
|
|
|
|
-- | Check that the second second of dimensions can be used in a context where
|
|
-- the first is expected.
|
|
areValidDimensions :: [A.Dimension] -> [A.Dimension] -> PassM Bool
|
|
areValidDimensions [] [] = return True
|
|
areValidDimensions (d1:ds1) (d2:ds2)
|
|
= do valid <- isValidDimension d1 d2
|
|
if valid
|
|
then areValidDimensions ds1 ds2
|
|
else return False
|
|
areValidDimensions _ _ = return False
|
|
|
|
-- | Check that a type we've inferred matches the type we expected.
|
|
checkType :: Meta -> A.Type -> A.Type -> PassM ()
|
|
checkType m et rt
|
|
= case (et, rt) of
|
|
(A.Infer, _) -> ok
|
|
(A.Array ds t, A.Array ds' t') ->
|
|
do valid <- areValidDimensions ds ds'
|
|
if valid
|
|
then checkType m t t'
|
|
else bad
|
|
(A.Mobile t, A.Mobile t') -> checkType m t t'
|
|
_ ->
|
|
do same <- sameType rt et
|
|
when (not same) $ bad
|
|
where
|
|
bad :: PassM ()
|
|
bad = diePC m $ formatCode ("Type mismatch: found %, expected % ("++show (rt,et)++")") rt et
|
|
|
|
-- | Check a type against a predicate.
|
|
checkTypeClass :: (A.Type -> Bool) -> String -> Meta -> A.Type -> PassM ()
|
|
checkTypeClass f adjective m rawT
|
|
= do t <- underlyingType m rawT
|
|
if f t
|
|
then ok
|
|
else diePC m $ formatCode ("Expected " ++ adjective ++ " type; found %") t
|
|
|
|
-- | Check that a type is numeric.
|
|
checkNumeric :: Meta -> A.Type -> PassM ()
|
|
checkNumeric = checkTypeClass isNumericType "numeric"
|
|
|
|
-- | Check that a type is integral.
|
|
checkInteger :: Meta -> A.Type -> PassM ()
|
|
checkInteger = checkTypeClass isIntegerType "integer"
|
|
|
|
-- | Check that a type is case-selectable.
|
|
checkCaseable :: Meta -> A.Type -> PassM ()
|
|
checkCaseable = checkTypeClass isCaseableType "case-selectable"
|
|
|
|
-- | Check that a type is scalar.
|
|
checkScalar :: Meta -> A.Type -> PassM ()
|
|
checkScalar = checkTypeClass isScalarType "scalar"
|
|
|
|
-- | Check that a type is usable as a 'DataType'
|
|
checkDataType :: Meta -> A.Type -> PassM ()
|
|
checkDataType = checkTypeClass isDataType "data"
|
|
|
|
-- | Check that a type is communicable.
|
|
checkCommunicable :: Meta -> A.Type -> PassM ()
|
|
checkCommunicable m (A.Counted ct rawAT)
|
|
= do checkInteger m ct
|
|
at <- resolveUserType m rawAT
|
|
case at of
|
|
A.Array (A.UnknownDimension:ds) t ->
|
|
do checkCommunicable m t
|
|
mapM_ (checkFullDimension m) ds
|
|
_ -> dieP m "Expected array type with unknown first dimension"
|
|
checkCommunicable m A.Any = ok
|
|
checkCommunicable m t = checkTypeClass isCommunicableType "communicable" m t
|
|
|
|
-- | Check that a type is a sequence.
|
|
checkSequence :: Bool -> Meta -> A.Type -> PassM ()
|
|
checkSequence mobileAllowed = checkTypeClass (isSequenceType mobileAllowed) "array or list"
|
|
|
|
-- | Check that a type is an array.
|
|
checkArray :: Meta -> A.Type -> PassM ()
|
|
checkArray m rawT
|
|
= do t <- resolveUserType m rawT
|
|
case t of
|
|
A.Array _ _ -> ok
|
|
_ -> diePC m $ formatCode "Expected array type; found %" t
|
|
|
|
-- | Check that a dimension isn't unknown.
|
|
checkFullDimension :: Meta -> A.Dimension -> PassM ()
|
|
checkFullDimension m A.UnknownDimension
|
|
= dieP m $ "Type contains unknown dimensions"
|
|
checkFullDimension _ _ = ok
|
|
|
|
-- | Check that a type is a list.
|
|
checkList :: Meta -> A.Type -> PassM ()
|
|
checkList m rawT
|
|
= do t <- resolveUserType m rawT
|
|
case t of
|
|
A.List _ -> ok
|
|
_ -> diePC m $ formatCode "Expected list type; found %" t
|
|
|
|
-- | Check the type of an expression.
|
|
checkExpressionType :: A.Type -> A.Expression -> PassM ()
|
|
checkExpressionType et e = astTypeOf e >>= checkType (findMeta e) et
|
|
|
|
-- | Check that an expression is of integer type.
|
|
checkExpressionInt :: Check A.Expression
|
|
checkExpressionInt e = checkExpressionType A.Int e
|
|
|
|
-- | Check that an expression is of boolean type.
|
|
checkExpressionBool :: Check A.Expression
|
|
checkExpressionBool e = checkExpressionType A.Bool e
|
|
|
|
-- | Pick the more specific of a pair of types.
|
|
betterType :: A.Type -> A.Type -> A.Type
|
|
betterType t1 t2
|
|
= case betterType' t1 t2 of
|
|
Left () -> t1
|
|
Right () -> t2
|
|
where
|
|
betterType' :: A.Type -> A.Type -> Either () ()
|
|
betterType' A.Infer t = Right ()
|
|
betterType' t A.Infer = Left ()
|
|
betterType' t@(A.UserDataType _) _ = Left ()
|
|
betterType' _ t@(A.UserDataType _) = Right ()
|
|
betterType' t1@(A.Array ds1 et1) t2@(A.Array ds2 et2)
|
|
| length ds1 == length ds2 = betterType' et1 et2
|
|
| length ds1 < length ds2 = Left ()
|
|
betterType' t _ = Left ()
|
|
|
|
--}}}
|
|
--{{{ more complex checks
|
|
|
|
-- | Check that an array literal's length matches its type.
|
|
checkArraySize :: Meta -> A.Type -> Int -> PassM ()
|
|
checkArraySize m rawT want
|
|
= do t <- resolveUserType m rawT
|
|
case t of
|
|
A.Array (A.UnknownDimension:_) _ -> ok
|
|
A.Array (A.Dimension e:_) _ ->
|
|
do n <- evalIntExpression e
|
|
when (n /= want) $
|
|
dieP m $ "Array literal has wrong number of elements: found " ++ show n ++ ", expected " ++ show want
|
|
_ -> checkArray m t
|
|
|
|
-- | Check that a record field name is valid.
|
|
checkRecordField :: Meta -> A.Type -> A.Name -> PassM ()
|
|
checkRecordField m t n
|
|
= do rfs <- recordFields m t
|
|
let validNames = map fst rfs
|
|
when (not $ n `elem` validNames) $
|
|
diePC m $ formatCode "Invalid field name % in record type %" n t
|
|
|
|
-- | Check a subscript.
|
|
checkSubscript :: Meta -> A.Subscript -> A.Type -> PassM ()
|
|
checkSubscript m s rawT
|
|
= do -- Check the type of the thing being subscripted.
|
|
t <- resolveUserType m rawT
|
|
case s of
|
|
-- A record subscript.
|
|
A.SubscriptField m n ->
|
|
checkRecordField m t n
|
|
-- A sequence subscript.
|
|
A.Subscript _ _ _ -> checkSequence False m t
|
|
-- An array slice.
|
|
_ -> checkArray m t
|
|
|
|
-- Check the subscript itself.
|
|
case s of
|
|
A.Subscript m _ e -> checkExpressionInt e
|
|
A.SubscriptFromFor m _ e f ->
|
|
checkExpressionInt e >> checkExpressionInt f
|
|
A.SubscriptFrom m _ e -> checkExpressionInt e
|
|
A.SubscriptFor m _ e -> checkExpressionInt e
|
|
_ -> ok
|
|
|
|
-- | Check an abbreviation.
|
|
-- Is the second abbrev mode a valid abbreviation of the first?
|
|
checkAbbrev :: Meta -> A.AbbrevMode -> A.AbbrevMode -> PassM ()
|
|
checkAbbrev m orig new
|
|
= case (orig, new) of
|
|
(_, A.Original) -> bad
|
|
(A.ValAbbrev, A.ValAbbrev) -> ok
|
|
(A.ValAbbrev, A.InitialAbbrev) -> ok
|
|
(A.ValAbbrev, _) -> bad
|
|
_ -> ok
|
|
where
|
|
bad :: PassM ()
|
|
bad = dieP m $ "You can't abbreviate " ++ showAM orig ++ " as " ++ showAM new
|
|
|
|
showAM :: A.AbbrevMode -> String
|
|
showAM A.Original = "an original declaration"
|
|
showAM A.Abbrev = "a reference abbreviation"
|
|
showAM A.ValAbbrev = "a VAL abbreviation"
|
|
showAM A.InitialAbbrev = "an INITIAL abbreviation"
|
|
showAM A.ResultAbbrev = "a RESULT abbreviation"
|
|
|
|
-- | Check a list of actuals is the right length for a list of formals.
|
|
checkActualCount :: Meta -> A.Name -> [A.Formal] -> [a] -> PassM ()
|
|
checkActualCount m n fs as
|
|
= do when (length fs /= length as) $
|
|
diePC m $ formatCode ("% called with wrong number of arguments; found " ++ (show $ length as) ++ ", expected " ++ (show $ length fs)) n
|
|
|
|
-- | Check a set of actuals against the formals they're meant to match.
|
|
checkActuals :: Meta -> A.Name -> [A.Formal] -> [A.Actual] -> PassM ()
|
|
checkActuals m n fs as
|
|
= do checkActualCount m n fs as
|
|
sequence_ [checkActual f a
|
|
| (f, a) <- zip fs as]
|
|
|
|
-- | Check an actual against its matching formal.
|
|
checkActual :: A.Formal -> A.Actual -> PassM ()
|
|
checkActual (A.Formal newAM et _) a
|
|
= do rt <- astTypeOf a
|
|
checkType (findMeta a) et rt
|
|
origAM <- case a of
|
|
A.ActualVariable v -> abbrevModeOfVariable v
|
|
A.ActualExpression _ -> return A.ValAbbrev
|
|
A.ActualChannelArray {} -> return A.Abbrev
|
|
A.ActualClaim {} -> return A.Abbrev
|
|
checkAbbrev (findMeta a) origAM newAM
|
|
|
|
-- | Check a function exists.
|
|
checkFunction :: Meta -> A.Name -> PassM ([A.Type], [A.Formal])
|
|
checkFunction m n
|
|
= do st <- lookupNameOrError n (diePC m $ formatCode "Could not find function %" n) >>* A.ndSpecType
|
|
case st of
|
|
A.Function _ _ rs fs _ -> return (rs, fs)
|
|
_ -> diePC m $ formatCode "% is not a function" n
|
|
|
|
-- | Check a 'Proc' exists.
|
|
checkProc :: Meta -> A.Name -> PassM [A.Formal]
|
|
checkProc m n
|
|
= do st <- specTypeOfName n
|
|
case st of
|
|
A.Proc _ _ fs _ -> return fs
|
|
_ -> diePC m $ formatCode "% is not a procedure" n
|
|
|
|
-- | Check a function call.
|
|
checkFunctionCall :: Meta -> A.Name -> [A.Expression] -> PassM [A.Type]
|
|
checkFunctionCall m n es
|
|
= do (rs, fs) <- checkFunction m n
|
|
checkActuals m n fs (map A.ActualExpression es)
|
|
return rs
|
|
|
|
-- | Check an intrinsic function call.
|
|
checkIntrinsicFunctionCall :: Bool -> Meta -> String -> [A.Expression] -> PassM [A.Type]
|
|
checkIntrinsicFunctionCall usedInList m n es
|
|
= case lookup n intrinsicFunctions of
|
|
Just (rs, args) ->
|
|
do when (not usedInList && length rs /= 1) $
|
|
dieP m $ "Function " ++ n ++ " used in an expression returns more than one value"
|
|
let fs = [A.Formal A.ValAbbrev t (A.Name m s)
|
|
| (t, s) <- args]
|
|
checkActuals m (A.Name m n)
|
|
fs (map A.ActualExpression es)
|
|
return rs
|
|
Nothing -> dieP m $ n ++ " is not an intrinsic function"
|
|
|
|
-- | Check a mobile allocation.
|
|
checkAllocMobile :: Meta -> A.Type -> Maybe A.Expression -> PassM ()
|
|
checkAllocMobile m rawT me
|
|
= do t <- resolveUserType m rawT
|
|
case t of
|
|
A.Mobile innerT ->
|
|
do case innerT of
|
|
A.Array ds _ -> ok --mapM_ (checkFullDimension m) ds
|
|
_ -> ok
|
|
case me of
|
|
Just e ->
|
|
do et <- astTypeOf e
|
|
checkType (findMeta e) innerT et
|
|
Nothing -> ok
|
|
_ -> diePC m $ formatCode "Expected mobile type in allocation; found %" t
|
|
|
|
-- | Check that a variable is writable.
|
|
checkWritable :: Check A.Variable
|
|
checkWritable v
|
|
= do am <- abbrevModeOfVariable v
|
|
case am of
|
|
A.ValAbbrev -> dieP (findMeta v) $ "Expected a writable variable"
|
|
_ -> ok
|
|
|
|
-- | Check that is a variable is a channel that can be used in the given
|
|
-- direction.
|
|
-- If the direction passed is 'DirUnknown', no direction or sharedness checks
|
|
-- will be performed.
|
|
-- Return the type carried by the channel.
|
|
checkChannel :: A.Direction -> A.Variable -> PassM A.Type
|
|
checkChannel wantDir c
|
|
= do -- Check it's a channel.
|
|
t <- astTypeOf c >>= resolveUserType m
|
|
case t of
|
|
A.ChanEnd dir sh innerT ->
|
|
do -- Check the direction is appropriate
|
|
when (wantDir /= dir) $ dieP m $ "Channel directions do not match"
|
|
-- Check it's not shared in the direction we're using.
|
|
case sh of
|
|
A.Unshared -> ok
|
|
A.Shared -> dieP m $ "Shared channel must be claimed before use"
|
|
|
|
return innerT
|
|
_ -> diePC m $ formatCode ("Expected channel " ++ exp ++ "; found %") t
|
|
where
|
|
exp = case wantDir of
|
|
A.DirInput -> "input-end"
|
|
A.DirOutput -> "output-end"
|
|
m = findMeta c
|
|
|
|
-- | Check that a variable is a timer.
|
|
-- Return the type of the timer's value.
|
|
checkTimer :: A.Variable -> PassM A.Type
|
|
checkTimer tim
|
|
= do t <- astTypeOf tim >>= resolveUserType m
|
|
case t of
|
|
A.Timer A.OccamTimer -> return A.Int
|
|
A.Timer A.RainTimer -> return A.Time
|
|
_ -> diePC m $ formatCode "Expected timer; found %" t
|
|
where
|
|
m = findMeta tim
|
|
|
|
-- | Return the list of types carried by a protocol.
|
|
-- For a variant protocol, the second argument should be 'Just' the tag.
|
|
-- For a non-variant protocol, the second argument should be 'Nothing'.
|
|
protocolTypes :: Meta -> A.Type -> Maybe A.Name -> PassM [A.Type]
|
|
protocolTypes m t tag
|
|
= case t of
|
|
-- A user-defined protocol.
|
|
A.UserProtocol n ->
|
|
do st <- specTypeOfName n
|
|
case (st, tag) of
|
|
-- A simple protocol.
|
|
(A.Protocol _ ts, Nothing) -> return ts
|
|
(A.Protocol _ _, Just tagName) ->
|
|
diePC m $ formatCode "Tag % specified for non-variant protocol %" tagName n
|
|
-- A variant protocol.
|
|
(A.ProtocolCase _ ntss, Just tagName) ->
|
|
case lookup tagName ntss of
|
|
Just ts -> return ts
|
|
Nothing -> diePC m $ formatCode "Tag % not found in protocol %; expected one of %" tagName n (map fst ntss)
|
|
(A.ProtocolCase _ ntss, Nothing) ->
|
|
diePC m $ formatCode "No tag specified for variant protocol %; expected one of %" n (map fst ntss)
|
|
-- Not actually a protocol.
|
|
_ -> diePC m $ formatCode "% is not a protocol" n
|
|
-- Not a protocol (e.g. CHAN INT); just return it.
|
|
_ -> return [t]
|
|
|
|
-- | Check a protocol communication.
|
|
-- Figure out the types of the items that should be involved in a protocol
|
|
-- communication, and run the supplied check against each item with its type.
|
|
checkProtocol :: Meta -> A.Type -> Maybe A.Name
|
|
-> [t] -> (A.Type -> t -> PassM ()) -> PassM ()
|
|
checkProtocol m t tag items doItem
|
|
= do its <- protocolTypes m t tag
|
|
when (length its /= length items) $
|
|
dieP m $ "Wrong number of items in protocol communication; found "
|
|
++ (show $ length items) ++ ", expected "
|
|
++ (show $ length its)
|
|
sequence_ [doItem it item
|
|
| (it, item) <- zip its items]
|
|
|
|
-- | Check an 'ExpressionList' matches a set of types.
|
|
checkExpressionList :: [A.Type] -> A.ExpressionList -> PassM ()
|
|
checkExpressionList ets el
|
|
= case el of
|
|
A.FunctionCallList m n es ->
|
|
do rs <- checkFunctionCall m n es
|
|
when (length ets /= length rs) $
|
|
diePC m $ formatCode ("Function % has wrong number of return values; found " ++ (show $ length rs) ++ ", expected " ++ (show $ length ets)) n
|
|
sequence_ [checkType m et rt
|
|
| (et, rt) <- zip ets rs]
|
|
A.IntrinsicFunctionCallList m n es ->
|
|
do rs <- checkIntrinsicFunctionCall True m n es
|
|
when (length ets /= length rs) $
|
|
dieP m $ "Intrinsic function " ++ n ++ " has wrong number of return values; found " ++ (show $ length rs) ++ ", expected " ++ (show $ length ets)
|
|
sequence_ [checkType m et rt
|
|
| (et, rt) <- zip ets rs]
|
|
A.ExpressionList m es ->
|
|
do when (length ets /= length es) $
|
|
dieP m $ "Wrong number of items in expression list; found "
|
|
++ (show $ length es) ++ ", expected "
|
|
++ (show $ length ets)
|
|
sequence_ [do rt <- astTypeOf e
|
|
checkType (findMeta e) et rt
|
|
| (e, et) <- zip es ets]
|
|
A.AllocChannelBundle m n
|
|
-> case ets of
|
|
[A.ChanDataType A.DirInput shA nA
|
|
,A.ChanDataType A.DirOutput shB nB]
|
|
| A.nameName nA == A.nameName nB && A.nameName nA == A.nameName n
|
|
-> return ()
|
|
[A.ChanDataType A.DirOutput shA nA
|
|
,A.ChanDataType A.DirInput shB nB]
|
|
| A.nameName nA == A.nameName nB && A.nameName nA == A.nameName n
|
|
-> return ()
|
|
_ -> dieP m $ "Wrong number of arguments, mismatched directions, or mismatched bundle types"
|
|
|
|
|
|
-- | Check a set of names are distinct.
|
|
checkNamesDistinct :: Meta -> [A.Name] -> PassM ()
|
|
checkNamesDistinct m ns
|
|
= when (dupes /= []) $
|
|
diePC m $ formatCode "List contains duplicate names: %" dupes
|
|
where
|
|
dupes :: [A.Name]
|
|
dupes = nub (ns \\ nub ns)
|
|
|
|
-- | Check a 'Structured', applying the given check to each item found inside
|
|
-- it. This assumes that processes and specifications will be checked
|
|
-- elsewhere.
|
|
checkStructured :: Data t => Check t -> Check (A.Structured t)
|
|
checkStructured doInner s = transformOnly checkInner s >> return ()
|
|
where
|
|
checkInner m v
|
|
= do doInner v
|
|
return $ A.Only m v
|
|
|
|
--}}}
|
|
--{{{ retyping checks
|
|
|
|
-- | Check that one type can be retyped to another.
|
|
checkRetypes :: Meta -> A.Type -> A.Type -> PassM ()
|
|
checkRetypes m fromT toT
|
|
= do (fromBI, fromN) <- evalBytesInType fromT
|
|
(toBI, toN) <- evalBytesInType toT
|
|
case (fromBI, toBI, fromN, toN) of
|
|
(_, BIManyFree, _, _) ->
|
|
dieP m "Multiple free dimensions in retype destination type"
|
|
(BIJust _, BIJust _, Just a, Just b) ->
|
|
when (a /= b) $
|
|
dieP m "Sizes do not match in retype"
|
|
(BIJust _, BIOneFree _ _, Just a, Just b) ->
|
|
when (not ((b <= a) && (a `mod` b == 0))) $
|
|
dieP m "Sizes do not match in retype"
|
|
(BIOneFree _ _, BIJust _, Just a, Just b) ->
|
|
when (not ((a <= b) && (b `mod` a == 0))) $
|
|
dieP m "Sizes do not match in retype"
|
|
-- Otherwise we must do a runtime check.
|
|
_ -> return ()
|
|
|
|
-- | Evaluate 'BytesIn' for a type.
|
|
-- If the size isn't known at compile type, return 'Nothing'.
|
|
evalBytesInType :: A.Type -> PassM (BytesInResult, Maybe Int)
|
|
evalBytesInType t
|
|
= do bi <- bytesInType t
|
|
n <- case bi of
|
|
BIJust e -> foldEval e
|
|
BIOneFree e _ -> foldEval e
|
|
_ -> return Nothing
|
|
return (bi, n)
|
|
where
|
|
foldEval :: A.Expression -> PassM (Maybe Int)
|
|
foldEval e
|
|
= do (e', isConst, _) <- constantFold e
|
|
if isConst
|
|
then evalIntExpression e' >>* Just
|
|
else return Nothing
|
|
|
|
--}}}
|
|
--{{{ type context management
|
|
|
|
-- | Run an operation in a given type context.
|
|
inTypeContext :: Maybe A.Type -> PassM a -> PassM a
|
|
inTypeContext ctx body
|
|
= do pushTypeContext (case ctx of
|
|
Just A.Infer -> Nothing
|
|
_ -> ctx)
|
|
v <- body
|
|
popTypeContext
|
|
return v
|
|
|
|
-- | Run an operation in the type context 'Nothing'.
|
|
noTypeContext :: PassM a -> PassM a
|
|
noTypeContext = inTypeContext Nothing
|
|
|
|
-- | Run an operation in the type context that results from subscripting
|
|
-- the current type context.
|
|
-- If the current type context is 'Nothing', the resulting one will be too.
|
|
inSubscriptedContext :: Meta -> PassM a -> PassM a
|
|
inSubscriptedContext m body
|
|
= do ctx <- getTypeContext
|
|
subCtx <- case ctx of
|
|
Just t@(A.Array _ _) ->
|
|
trivialSubscriptType m t >>* Just
|
|
Just t -> diePC m $ formatCode "Attempting to subscript non-array type %" t
|
|
Nothing -> return Nothing
|
|
inTypeContext subCtx body
|
|
|
|
--}}}
|
|
|
|
addDirections :: PassOn2 A.Process A.Alternative
|
|
addDirections = occamOnlyPass "Add direction specifiers to inputs and outputs"
|
|
[] []
|
|
(applyBottomUpM2 doProcess doAlternative)
|
|
where
|
|
doProcess :: Transform A.Process
|
|
doProcess (A.Output m v os)
|
|
= do v' <- makeEnd m A.DirOutput v
|
|
return $ A.Output m v' os
|
|
doProcess (A.OutputCase m v n os)
|
|
= do v' <- makeEnd m A.DirOutput v
|
|
return $ A.OutputCase m v' n os
|
|
doProcess (A.Input m v im@(A.InputSimple {}))
|
|
= do v' <- makeEnd m A.DirInput v
|
|
return $ A.Input m v' im
|
|
doProcess (A.Input m v im@(A.InputCase {}))
|
|
= do v' <- makeEnd m A.DirInput v
|
|
return $ A.Input m v' im
|
|
doProcess p = return p
|
|
|
|
doAlternative :: Transform A.Alternative
|
|
doAlternative (A.Alternative m pre v im p)
|
|
= do v' <- case im of
|
|
A.InputSimple {} -> makeEnd m A.DirInput v
|
|
A.InputCase {} -> makeEnd m A.DirInput v
|
|
_ -> return v
|
|
return $ A.Alternative m pre v' im p
|
|
doAlternative a = return a
|
|
|
|
makeEnd :: Meta -> A.Direction -> Transform A.Variable
|
|
makeEnd m dir v
|
|
= case v of
|
|
A.SubscriptedVariable _ _ innerV
|
|
-> do t <- astTypeOf innerV
|
|
case t of
|
|
A.ChanDataType {} -> return v
|
|
_ -> makeEnd'
|
|
_ -> makeEnd'
|
|
where
|
|
makeEnd' :: PassM A.Variable
|
|
makeEnd'
|
|
= do t <- astTypeOf v
|
|
case t of
|
|
A.ChanEnd {} -> return v
|
|
A.Chan {} -> return $ A.DirectedVariable m dir v
|
|
A.Array _ (A.ChanEnd {}) -> return v
|
|
A.Array _ (A.Chan {}) -> return $ A.DirectedVariable m dir v
|
|
-- If unsure (e.g. Infer), just shove a direction on it to be sure:
|
|
_ -> return $ A.DirectedVariable m dir v
|
|
|
|
scrubMobile :: PassM a -> PassM a
|
|
scrubMobile m
|
|
= do ctx <- getTypeContext
|
|
case ctx of
|
|
(Just (A.Mobile t)) -> inTypeContext (Just t) m
|
|
_ -> m
|
|
|
|
inferAllocMobile :: Meta -> A.Type -> A.Expression -> PassM A.Expression
|
|
inferAllocMobile m (A.Mobile {}) e
|
|
= do t <- astTypeOf e >>= underlyingType m
|
|
case t of
|
|
A.Mobile {} -> return e
|
|
_ -> return $ A.AllocMobile m (A.Mobile t) (Just e)
|
|
inferAllocMobile _ _ e = return e
|
|
|
|
--{{{ inferTypes
|
|
|
|
-- I can't put this in the where clause of inferTypes, so it has to be out
|
|
-- here. It should be the type of ops inside the inferTypes function below.
|
|
type InferTypeOps
|
|
= ExtOpMSP BaseOp
|
|
`ExtOpMP` A.Expression
|
|
`ExtOpMP` A.Dimension
|
|
`ExtOpMP` A.Subscript
|
|
`ExtOpMP` A.Replicator
|
|
`ExtOpMP` A.Alternative
|
|
`ExtOpMP` A.Process
|
|
`ExtOpMP` A.Variable
|
|
`ExtOpMP` A.Variant
|
|
|
|
-- | Infer types.
|
|
inferTypes :: Pass A.AST
|
|
inferTypes = occamOnlyPass "Infer types"
|
|
[]
|
|
[Prop.inferredTypesRecorded]
|
|
recurse
|
|
where
|
|
ops :: InferTypeOps
|
|
ops = baseOp
|
|
`extOpMS` (ops, doStructured)
|
|
`extOpM` doExpression
|
|
`extOpM` doDimension
|
|
`extOpM` doSubscript
|
|
`extOpM` doReplicator
|
|
`extOpM` doAlternative
|
|
`extOpM` doProcess
|
|
`extOpM` doVariable
|
|
`extOpM` doVariant
|
|
|
|
recurse :: RecurseM PassM InferTypeOps
|
|
recurse = makeRecurseM ops
|
|
|
|
descend :: DescendM PassM InferTypeOps
|
|
descend = makeDescendM ops
|
|
|
|
doExpression :: Transform A.Expression
|
|
doExpression outer
|
|
= case outer of
|
|
-- Literals are what we're really looking for here.
|
|
A.Literal m t lr ->
|
|
do t' <- recurse t
|
|
scrubMobile $ do
|
|
ctx <- getTypeContext
|
|
let wantT = case (ctx, t') of
|
|
-- No type specified on the literal,
|
|
-- but there's a context, so use that.
|
|
(Just ct, A.Infer) -> ct
|
|
-- Use the explicit type of the literal, or the
|
|
-- default.
|
|
_ -> t'
|
|
(realT, realLR) <- doLiteral (wantT, lr)
|
|
return $ A.Literal m realT realLR
|
|
|
|
-- Expressions that aren't literals, but that modify the type
|
|
-- context.
|
|
A.SizeExpr _ _ -> noTypeContext $ descend outer
|
|
A.Conversion _ _ _ _ -> noTypeContext $ descend outer
|
|
A.FunctionCall m n es ->
|
|
do (n', es') <- doFunctionCall m (n, es)
|
|
return $ A.FunctionCall m n' es'
|
|
A.IntrinsicFunctionCall _ _ _ -> noTypeContext $ descend outer
|
|
A.SubscriptedExpr m s e ->
|
|
do ctx <- getTypeContext
|
|
e' <- inTypeContext (ctx >>= unsubscriptType s) $ recurse e
|
|
t <- astTypeOf e'
|
|
s' <- recurse s >>= fixSubscript t
|
|
return $ A.SubscriptedExpr m s' e'
|
|
A.BytesInExpr _ _ -> noTypeContext $ descend outer
|
|
-- FIXME: ExprConstr
|
|
-- FIXME: AllocMobile
|
|
|
|
A.ExprVariable m v ->
|
|
do ctx <- getTypeContext >>= (T.sequence . fmap (underlyingType m))
|
|
v' <- recurse v
|
|
t <- astTypeOf v' >>= underlyingType m
|
|
case (ctx, t) of
|
|
(Just (A.Mobile {}), A.Mobile {}) -> return $ A.ExprVariable m v'
|
|
(Just _, A.Mobile {}) -> return $ A.ExprVariable m
|
|
$ A.DerefVariable m v'
|
|
_ -> return $ A.ExprVariable m v'
|
|
-- Other expressions don't modify the type context.
|
|
_ -> descend outer
|
|
|
|
doFunctionCall :: Meta -> Transform (A.Name, [A.Expression])
|
|
doFunctionCall m (n, es) = do
|
|
if isOperator (A.nameName n)
|
|
then
|
|
-- for operators, resolve the function name, based on the type
|
|
do let opDescrip = "\"" ++ (A.nameName n) ++ "\" "
|
|
++ case length es of
|
|
1 -> "unary"
|
|
2 -> "binary"
|
|
n -> show n ++ "-ary"
|
|
|
|
es' <- noTypeContext $ mapM recurse es
|
|
tes <- sequence [underlyingTypeOf m e `catchError` (const $ return A.Infer) | e <- es']
|
|
|
|
cs <- getCompState
|
|
|
|
resolvedOps <- sequence [ do ts' <- mapM (underlyingType m) ts
|
|
return (op, n, ts')
|
|
| (op, n, ts) <- csOperators cs
|
|
]
|
|
|
|
-- The nubBy will ensure that only one definition remains for each
|
|
-- set of type-arguments, and will keep the first definition in the
|
|
-- list (which will be the most recent)
|
|
possibles <- return
|
|
[ ((opFuncName, es'), ts)
|
|
| (raw, opFuncName, ts) <- nubBy opsMatch resolvedOps
|
|
-- Must be right operator:
|
|
, raw == A.nameName n
|
|
-- Must be right arity:
|
|
, length ts == length es
|
|
-- Must have right types:
|
|
, ts `typesEqForOp` tes
|
|
]
|
|
case possibles of
|
|
[] -> diePC m $ formatCode "No matching % operator definition found for types: %" opDescrip tes
|
|
[poss] -> return $ fst poss
|
|
posss -> dieP m $ "Ambigious " ++ opDescrip ++ " operator, matches definitions: "
|
|
++ show (map (transformPair (A.nameMeta . fst) showOccam) posss)
|
|
else
|
|
do (_, fs) <- checkFunction m n
|
|
doActuals m n fs direct es >>* (,) n
|
|
where
|
|
direct = error "Cannot direct channels passed to FUNCTIONs"
|
|
|
|
opsMatch (opA, _, tsA) (opB, _, tsB) = (opA == opB) && (tsA `typesEqForOp` tsB)
|
|
|
|
typesEqForOp :: [A.Type] -> [A.Type] -> Bool
|
|
typesEqForOp tsA tsB = (length tsA == length tsB) && (and $ zipWith typeEqForOp tsA tsB)
|
|
|
|
typeEqForOp :: A.Type -> A.Type -> Bool
|
|
typeEqForOp (A.Array ds t) (A.Array ds' t')
|
|
= (length ds == length ds') && typeEqForOp t t'
|
|
typeEqForOp t t' = t == t'
|
|
|
|
doActuals :: (PolyplateM a InferTypeOps () PassM, Data a) => Meta -> A.Name -> [A.Formal] ->
|
|
(Meta -> A.Direction -> Transform a) -> Transform [a]
|
|
doActuals m n fs applyDir as
|
|
= do checkActualCount m n fs as
|
|
sequence [doActual m applyDir t a | (A.Formal _ t _, a) <- zip fs as]
|
|
|
|
doActual :: (PolyplateM a InferTypeOps () PassM, Data a) => Meta -> (Meta -> A.Direction -> Transform a) -> A.Type -> Transform a
|
|
doActual m applyDir (A.ChanEnd dir _ _) a = recurse a >>= applyDir m dir
|
|
doActual m _ t a = inTypeContext (Just t) $ recurse a
|
|
|
|
|
|
doDimension :: Transform A.Dimension
|
|
doDimension dim = inTypeContext (Just A.Int) $ descend dim
|
|
|
|
doSubscript :: Transform A.Subscript
|
|
doSubscript s = inTypeContext (Just A.Int) $ descend s
|
|
|
|
doExpressionList :: [A.Type] -> Transform A.ExpressionList
|
|
doExpressionList ts el
|
|
= case el of
|
|
A.FunctionCallList m n es ->
|
|
do (n', es') <- doFunctionCall m (n, es)
|
|
return $ A.FunctionCallList m n' es'
|
|
A.ExpressionList m es ->
|
|
do es' <- sequence [inTypeContext (Just t) $ recurse e
|
|
| (t, e) <- zip ts es]
|
|
es'' <- mapM (uncurry $ inferAllocMobile m) $ zip ts es'
|
|
return $ A.ExpressionList m es''
|
|
A.AllocChannelBundle {} -> return el
|
|
|
|
doReplicator :: Transform A.Replicator
|
|
doReplicator rep
|
|
= case rep of
|
|
A.For _ _ _ _ -> inTypeContext (Just A.Int) $ descend rep
|
|
A.ForEach _ _ -> noTypeContext $ descend rep
|
|
|
|
doAlternative :: Transform A.Alternative
|
|
doAlternative (A.Alternative m pre v im p)
|
|
= do pre' <- inTypeContext (Just A.Bool) $ recurse pre
|
|
v' <- recurse v
|
|
im' <- doInputMode v' im
|
|
p' <- recurse p
|
|
return $ A.Alternative m pre' v' im' p'
|
|
doAlternative (A.AlternativeSkip m pre p)
|
|
= do pre' <- inTypeContext (Just A.Bool) $ recurse pre
|
|
p' <- recurse p
|
|
return $ A.AlternativeSkip m pre' p'
|
|
|
|
doInputMode :: A.Variable -> Transform A.InputMode
|
|
doInputMode v (A.InputSimple m iis)
|
|
= do ts <- protocolItems m v >>* either id (const [])
|
|
iis' <- sequence [inTypeContext (Just t) $ recurse ii
|
|
| (t, ii) <- zip ts iis]
|
|
return $ A.InputSimple m iis'
|
|
doInputMode v (A.InputCase m sv)
|
|
= do ct <- astTypeOf v
|
|
inTypeContext (Just ct) (recurse sv) >>* A.InputCase m
|
|
doInputMode _ im = inTypeContext (Just A.Int) $ descend im
|
|
|
|
doVariant :: Transform A.Variant
|
|
doVariant (A.Variant m n iis p)
|
|
= do ctx <- getTypeContext
|
|
ets <- case ctx of
|
|
Just x -> protocolItems m x
|
|
Nothing -> dieP m "Could not deduce protocol"
|
|
case ets of
|
|
Left {} -> dieP m "Simple protocol expected during input CASE"
|
|
Right ps -> case lookup n ps of
|
|
Nothing -> diePC m $ formatCode "Name % is not part of protocol %"
|
|
n (fromJust ctx)
|
|
Just ts -> do iis' <- sequence [inTypeContext (Just t) $ recurse ii
|
|
| (t, ii) <- zip ts iis]
|
|
p' <- recurse p
|
|
return $ A.Variant m n iis' p'
|
|
|
|
doStructured :: ( PolyplateM (A.Structured t) InferTypeOps () PassM
|
|
, PolyplateM (A.Structured t) () InferTypeOps PassM
|
|
, Data t) => Transform (A.Structured t)
|
|
|
|
doStructured (A.Spec mspec s@(A.Specification m n st) body)
|
|
= do (st', wrap) <- runReaderT (doSpecType n st) body
|
|
-- Update the definition of each name after we handle it.
|
|
modifyName n (\nd -> nd { A.ndSpecType = st' })
|
|
wrap (recurse body) >>* A.Spec mspec (A.Specification m n st')
|
|
doStructured s = descend s
|
|
|
|
-- The second parameter is a modifier (wrapper) for the descent into the body
|
|
doSpecType :: ( PolyplateM (A.Structured t) InferTypeOps () PassM
|
|
, PolyplateM (A.Structured t) () InferTypeOps PassM
|
|
, Data t) => A.Name -> A.SpecType -> ReaderT (A.Structured t) PassM
|
|
(A.SpecType, PassM (A.Structured a) -> PassM (A.Structured a))
|
|
doSpecType n st
|
|
= case st of
|
|
A.Place _ _ -> lift $ inTypeContext (Just A.Int) $ descend st >>* addId
|
|
A.Is m am t (A.ActualVariable v) ->
|
|
do am' <- lift $ recurse am
|
|
t' <- lift $ recurse t
|
|
v' <- lift $ inTypeContext (Just t') $ recurse v
|
|
vt <- lift $ astTypeOf v'
|
|
(t'', v'') <- case (t', vt) of
|
|
(A.Infer, A.Chan attr innerT) ->
|
|
do dirs <- ask >>= (lift . findDir n)
|
|
case nub dirs of
|
|
[dir] ->
|
|
do let tEnd = A.ChanEnd dir (dirAttr dir attr) innerT
|
|
return (tEnd, A.DirectedVariable m dir v')
|
|
_ -> return (vt, v') -- no direction, or two
|
|
(A.Infer, _) -> return (vt, v')
|
|
(A.ChanEnd dir _ _, _) -> do v'' <- lift $ makeEnd m dir v'
|
|
return (t', v'')
|
|
(A.Array _ (A.ChanEnd dir _ _), _) ->
|
|
do v'' <- lift $ makeEnd m dir v'
|
|
return (t', v'')
|
|
(A.Chan cattr cinnerT, A.ChanEnd dir _ einnerT)
|
|
-> do cinnerT' <- lift $ recurse cinnerT
|
|
einnerT' <- lift $ recurse einnerT
|
|
if cinnerT' /= einnerT'
|
|
then lift $ diePC m $ formatCode "Inner types of channels do not match in type inference: % %" cinnerT' einnerT'
|
|
else return (vt, v')
|
|
(A.Chan attr innerT, A.Chan {}) ->
|
|
do dirs <- ask >>= (lift . findDir n)
|
|
case nub dirs of
|
|
[dir] ->
|
|
do let tEnd = A.ChanEnd dir (dirAttr dir attr) innerT
|
|
return (tEnd, A.DirectedVariable m dir v')
|
|
_ -> return (t', v') -- no direction, or two
|
|
_ -> return (t', v')
|
|
return $ addId $ A.Is m am' t'' $ A.ActualVariable v''
|
|
A.Is m am t (A.ActualExpression e) -> lift $
|
|
do am' <- recurse am
|
|
t' <- recurse t
|
|
e' <- inTypeContext (Just t') $ recurse e
|
|
t'' <- case t' of
|
|
A.Infer -> astTypeOf e'
|
|
A.Array ds _ | A.UnknownDimension `elem` ds -> astTypeOf e'
|
|
_ -> return t'
|
|
return $ addId $ A.Is m am' t'' (A.ActualExpression e')
|
|
A.Is m am t (A.ActualClaim v) -> lift $
|
|
do am' <- recurse am
|
|
t' <- recurse t
|
|
v' <- inTypeContext (Just t') $ recurse v
|
|
t'' <- case t' of
|
|
A.Infer -> astTypeOf (A.ActualClaim v')
|
|
_ -> return t'
|
|
return $ addId $ A.Is m am' t'' (A.ActualClaim v')
|
|
A.Is m am t (A.ActualChannelArray vs) ->
|
|
-- No expressions in this -- but we may need to infer the type
|
|
-- of the variable if it's something like "cs IS [c]:".
|
|
do t' <- lift $ recurse t
|
|
vs' <- lift $ mapM recurse vs >>= case t' of
|
|
A.Infer -> return
|
|
A.Array _ (A.Chan {}) -> return
|
|
A.Array _ (A.ChanEnd dir _ _) -> mapM (makeEnd m dir)
|
|
_ -> const $ dieP m "Cannot coerce non-channels into channels"
|
|
let dim = makeDimension m $ length vs'
|
|
t'' <- lift $ case (t', vs') of
|
|
(A.Infer, (v:_)) ->
|
|
do elemT <- astTypeOf v
|
|
return $ addDimensions [dim] elemT
|
|
(A.Infer, []) ->
|
|
dieP m "Cannot infer type of empty channel array"
|
|
_ -> return $ applyDimension dim t'
|
|
(t''', f) <- case t'' of
|
|
A.Array ds (A.Chan attr innerT) -> do
|
|
dirs <- ask >>= (lift . findDir n)
|
|
case nub dirs of
|
|
[dir] -> return (A.Array ds $ A.ChanEnd dir (dirAttr dir attr) innerT
|
|
,A.DirectedVariable m dir)
|
|
_ -> return (t'', id)
|
|
_ -> return (t'', id)
|
|
return $ addId $ A.Is m am t''' $ A.ActualChannelArray $ map f vs'
|
|
A.Function m sm ts fs mbody -> lift $
|
|
do sm' <- recurse sm
|
|
ts' <- recurse ts
|
|
fs' <- recurse fs
|
|
sel' <- case mbody of
|
|
Just (Left sel) -> doFuncDef ts sel >>* (Just . Left)
|
|
_ -> return mbody
|
|
mOp <- functionOperator n
|
|
let func = A.Function m sm' ts' fs' sel'
|
|
case mOp of
|
|
Just raw -> do
|
|
ts <- mapM astTypeOf fs
|
|
let before = modify $ \cs -> cs { csOperators = (raw, n, ts) : csOperators cs }
|
|
after = modify $ \cs -> cs { csOperators = tail (csOperators cs)}
|
|
return (func
|
|
,\m -> do before
|
|
x <- m
|
|
after
|
|
return x)
|
|
_ -> return func >>* addId
|
|
A.RetypesExpr _ _ _ _ -> lift $ noTypeContext $ descend st >>* addId
|
|
-- For PROCs that take any channels without direction,
|
|
-- we must determine if we can infer a specific direction
|
|
-- for that channel
|
|
A.Proc m sm fs body -> lift $
|
|
do body' <- recurse body
|
|
fs' <- mapM (processFormal body') fs
|
|
return $ addId $ A.Proc m sm fs' body'
|
|
where
|
|
processFormal body f@(A.Formal am t n)
|
|
= do t' <- recurse t
|
|
case t' of
|
|
A.Chan attr innerT ->
|
|
do dirs <- findDir n body
|
|
case nub dirs of
|
|
[dir] ->
|
|
do let t' = A.ChanEnd dir (dirAttr dir attr) innerT
|
|
f' = A.Formal am t' n
|
|
modifyName n (\nd -> nd {A.ndSpecType =
|
|
A.Declaration m t'})
|
|
return f'
|
|
_ -> return $ A.Formal am t' n -- no direction, or two
|
|
_ -> do modifyName n (\nd -> nd {A.ndSpecType =
|
|
A.Declaration m t'})
|
|
return $ A.Formal am t' n
|
|
_ -> lift $ descend st >>* addId
|
|
where
|
|
addId :: a -> (a, b -> b)
|
|
addId a = (a, id)
|
|
|
|
-- | This is a bit ugly: walk down a Structured to find the single
|
|
-- ExpressionList that must be in there.
|
|
-- (This can go away once we represent all functions in the new Process
|
|
-- form.)
|
|
doFuncDef :: [A.Type] -> Transform (A.Structured A.ExpressionList)
|
|
doFuncDef ts (A.Spec m (A.Specification m' n st) s)
|
|
= do (st', wrap) <- runReaderT (doSpecType n st) s
|
|
modifyName n (\nd -> nd { A.ndSpecType = st' })
|
|
s' <- wrap $ doFuncDef ts s
|
|
return $ A.Spec m (A.Specification m' n st') s'
|
|
doFuncDef ts (A.ProcThen m p s)
|
|
= do p' <- recurse p
|
|
s' <- doFuncDef ts s
|
|
return $ A.ProcThen m p' s'
|
|
doFuncDef ts (A.Only m el)
|
|
= do el' <- doExpressionList ts el
|
|
return $ A.Only m el'
|
|
|
|
-- findDir only really needs to descend operating on Variables
|
|
-- But since this is called by doStructured, that would require doStructured
|
|
-- to have an extra constraint that the Structured supports descent into
|
|
-- Variables. But that constraint, in turn, is not satisfied when we build
|
|
-- our ops using extOpMS. Rather than fix all the constraints, I've decided
|
|
-- to adopt a slightly sneaky approach, and build a set of ops for findDir
|
|
-- with the same type as the one for infer types (thus the constraints
|
|
-- don't change), but where everything apart from the Variable operation
|
|
-- is a call to descend.
|
|
--
|
|
-- Also, to fit with the normal ops, we must do so in the PassM monad.
|
|
-- Normally we would do this pass in a StateT monad, but to slip inside
|
|
-- PassM, I've used an IORef instead.
|
|
findDir :: ( PolyplateM a InferTypeOps () PassM
|
|
, PolyplateM a () InferTypeOps PassM
|
|
) => A.Name -> a -> PassM [A.Direction]
|
|
findDir n x
|
|
= do r <- liftIO $ newIORef []
|
|
makeRecurseM (makeOps r) x
|
|
liftIO $ readIORef r
|
|
where
|
|
makeOps :: IORef [A.Direction] -> InferTypeOps
|
|
makeOps r = ops
|
|
where
|
|
ops :: InferTypeOps
|
|
ops = baseOp
|
|
`extOpMS` (ops, descend)
|
|
`extOpM` descend
|
|
`extOpM` descend
|
|
`extOpM` descend
|
|
`extOpM` descend
|
|
`extOpM` descend
|
|
`extOpM` descend
|
|
`extOpM` (doVariable r)
|
|
`extOpM` descend
|
|
descend :: DescendM PassM InferTypeOps
|
|
descend = makeDescendM ops
|
|
|
|
-- This will cover everything, since we will have inferred the direction
|
|
-- specifiers before applying this function.
|
|
doVariable :: IORef [A.Direction] -> A.Variable -> PassM A.Variable
|
|
doVariable r v@(A.DirectedVariable _ dir (A.Variable _ n')) | n == n'
|
|
= liftIO $ modifyIORef r (dir:) >> return v
|
|
doVariable r v@(A.DirectedVariable _ dir
|
|
(A.SubscriptedVariable _ _ (A.Variable _ n'))) | n == n'
|
|
= liftIO $ modifyIORef r (dir:) >> return v
|
|
doVariable r v = makeDescendM (makeOps r) v
|
|
|
|
doProcess :: Transform A.Process
|
|
doProcess p
|
|
= case p of
|
|
A.Assign m vs el ->
|
|
do vs' <- noTypeContext $ recurse vs
|
|
ts <- mapM astTypeOf vs'
|
|
el' <- doExpressionList ts el
|
|
return $ A.Assign m vs' el'
|
|
A.Output m v ois ->
|
|
do v' <- recurse v
|
|
-- At this point we must resolve the "c ! x" ambiguity:
|
|
-- we definitely know what c is, and we must know what x is
|
|
-- before trying to infer its type.
|
|
tagged <- isTagged v'
|
|
if tagged
|
|
-- Tagged protocol -- convert (wrong) variable to tag.
|
|
then case ois of
|
|
((A.OutExpression _ (A.ExprVariable _ (A.Variable _ wrong))):ois) ->
|
|
do tag <- nameToUnscoped wrong
|
|
ois' <- doOutputItems m v' (Just tag) ois
|
|
return $ A.OutputCase m v' tag ois'
|
|
_ -> diePC m $ formatCode "This channel carries a variant protocol; expected a list starting with a tag, but found %" ois
|
|
-- Regular protocol -- proceed as before.
|
|
else do ois' <- doOutputItems m v' Nothing ois
|
|
return $ A.Output m v' ois'
|
|
A.OutputCase m v tag ois ->
|
|
do v' <- recurse v
|
|
ois' <- doOutputItems m v' (Just tag) ois
|
|
return $ A.OutputCase m v' tag ois'
|
|
A.If _ _ -> inTypeContext (Just A.Bool) $ descend p
|
|
A.Case m e so ->
|
|
do e' <- recurse e
|
|
t <- astTypeOf e'
|
|
so' <- inTypeContext (Just t) $ recurse so
|
|
return $ A.Case m e' so'
|
|
A.While _ _ _ -> inTypeContext (Just A.Bool) $ descend p
|
|
A.Processor _ _ _ -> inTypeContext (Just A.Int) $ descend p
|
|
A.ProcCall m n as ->
|
|
do fs <- checkProc m n
|
|
as' <- doActuals m n fs (\m dir (A.ActualVariable v) -> liftM
|
|
A.ActualVariable $ makeEnd m dir v) as
|
|
return $ A.ProcCall m n as'
|
|
A.IntrinsicProcCall _ _ _ -> noTypeContext $ descend p
|
|
A.Input m v im@(A.InputSimple {})
|
|
-> do v' <- recurse v
|
|
im' <- doInputMode v' im
|
|
return $ A.Input m v' im'
|
|
A.Input m v im@(A.InputCase {})
|
|
-> do v' <- recurse v
|
|
im' <- doInputMode v' im
|
|
return $ A.Input m v' im'
|
|
_ -> descend p
|
|
where
|
|
-- | Does a channel carry a tagged protocol?
|
|
isTagged :: A.Variable -> PassM Bool
|
|
isTagged c
|
|
= do protoT <- checkChannel A.DirOutput c
|
|
case protoT of
|
|
A.UserProtocol n ->
|
|
do st <- specTypeOfName n
|
|
case st of
|
|
A.ProtocolCase _ _ -> return True
|
|
_ -> return False
|
|
_ -> return False
|
|
|
|
doOutputItems :: Meta -> A.Variable -> Maybe A.Name
|
|
-> Transform [A.OutputItem]
|
|
doOutputItems m v tag ois
|
|
= do chanT <- checkChannel A.DirOutput v
|
|
ts <- protocolTypes m chanT tag
|
|
sequence [doOutputItem t oi | (t, oi) <- zip ts ois]
|
|
|
|
doOutputItem :: A.Type -> Transform A.OutputItem
|
|
doOutputItem (A.Counted ct at) (A.OutCounted m ce ae)
|
|
= do ce' <- inTypeContext (Just ct) $ recurse ce
|
|
ae' <- inTypeContext (Just at) $ recurse ae
|
|
return $ A.OutCounted m ce' ae'
|
|
doOutputItem A.Any o = noTypeContext $ recurse o
|
|
doOutputItem t (A.OutExpression m e)
|
|
= inTypeContext (Just t) (recurse e >>= inferAllocMobile m t)
|
|
>>* A.OutExpression m
|
|
|
|
doVariable :: Transform A.Variable
|
|
doVariable (A.SubscriptedVariable m s v)
|
|
= do v' <- recurse v
|
|
t <- astTypeOf v'
|
|
underT <- resolveUserType m t
|
|
s' <- recurse s >>= fixSubscript t
|
|
v'' <- case underT of
|
|
A.Mobile {} -> return $ A.DerefVariable m v'
|
|
_ -> return v'
|
|
return $ A.SubscriptedVariable m s' v''
|
|
doVariable v
|
|
= do v' <- descend v
|
|
ctx <- getTypeContext >>= (T.sequence . fmap (underlyingType (findMeta v)))
|
|
underT <- astTypeOf v' >>= resolveUserType (findMeta v)
|
|
case (ctx, underT) of
|
|
(Just (A.Mobile {}), A.Mobile {}) -> return v'
|
|
(Just _, A.Mobile {}) -> return $ A.DerefVariable (findMeta v) v'
|
|
_ -> return v'
|
|
|
|
-- | Resolve the @v[s]@ ambiguity: this takes the type that @v@ is, and
|
|
-- returns the correct 'Subscript'.
|
|
fixSubscript :: A.Type -> A.Subscript -> PassM A.Subscript
|
|
fixSubscript t s@(A.Subscript m _ (A.ExprVariable _ (A.Variable _ wrong)))
|
|
= do underT <- resolveUserType m t
|
|
case underT of
|
|
A.Record _ ->
|
|
do n <- nameToUnscoped wrong
|
|
return $ A.SubscriptField m n
|
|
A.ChanDataType {} ->
|
|
do n <- nameToUnscoped wrong
|
|
return $ A.SubscriptField m n
|
|
_ -> return s
|
|
fixSubscript _ s = return s
|
|
|
|
-- | Given a name that should really have been a tag, make it one.
|
|
nameToUnscoped :: A.Name -> PassM A.Name
|
|
nameToUnscoped n@(A.Name m _)
|
|
= do nd <- lookupName n
|
|
findUnscopedName (A.Name m (A.ndOrigName nd))
|
|
|
|
-- | Process a 'LiteralRepr', taking the type it's meant to represent or
|
|
-- 'Infer', and returning the type it really is.
|
|
doLiteral :: Transform (A.Type, A.LiteralRepr)
|
|
doLiteral (wantT, lr)
|
|
= case lr of
|
|
A.ArrayListLiteral m aes ->
|
|
do (t, aes') <-
|
|
doArrayElem wantT aes
|
|
lr' <- case aes' of
|
|
A.Several _ ss -> buildTable t ss
|
|
_ -> return $ A.ArrayListLiteral m aes'
|
|
return (t, lr')
|
|
_ ->
|
|
do lr' <- descend lr
|
|
(defT, isT) <-
|
|
case lr' of
|
|
A.RealLiteral _ _ -> return (A.Real32, isRealType)
|
|
A.IntLiteral _ _ -> return (A.Int, isIntegerType)
|
|
A.HexLiteral _ _ -> return (A.Int, isIntegerType)
|
|
A.ByteLiteral _ _ -> return (A.Byte, isIntegerType)
|
|
_ -> dieP m $ "Unexpected LiteralRepr: " ++ show lr'
|
|
underT <- resolveUserType m wantT
|
|
case (wantT, isT underT) of
|
|
(A.Infer, _) -> return (defT, lr')
|
|
(_, True) -> return (wantT, lr')
|
|
(_, False) -> diePC m $ formatCode "Literal of default type % is not valid for type %" defT wantT
|
|
where
|
|
m = findMeta lr
|
|
|
|
doArrayElem :: A.Type -> A.Structured A.Expression -> PassM (A.Type, A.Structured A.Expression)
|
|
doArrayElem wantT (A.Spec m spec body)
|
|
-- A replicator: strip off a subscript and keep going
|
|
= do underT <- resolveUserType m wantT
|
|
subT <- trivialSubscriptType m underT
|
|
dim <- case underT of
|
|
A.Array (dim:_) _ -> return dim
|
|
A.Infer -> return A.UnknownDimension
|
|
_ -> diePC m $ formatCode "Unexpected type in array constructor: %" underT
|
|
(t, body') <- doArrayElem subT body
|
|
specAndBody' <- doStructured $ A.Spec m spec body'
|
|
return (applyDimension dim wantT, specAndBody')
|
|
-- A table: this could be an array or a record.
|
|
doArrayElem wantT (A.Several m aes)
|
|
= do underT <- resolveUserType m wantT
|
|
case underT of
|
|
A.Array _ _ ->
|
|
do subT <- trivialSubscriptType m underT
|
|
(elemT, aes') <- doElems subT aes
|
|
let dim = makeDimension m (length aes)
|
|
return (applyDimension dim wantT,
|
|
A.Several m aes')
|
|
A.Record _ ->
|
|
do nts <- recordFields m underT
|
|
aes <- sequence [doArrayElem t ae >>* snd
|
|
| ((_, t), ae) <- zip nts aes]
|
|
return (wantT, A.Several m aes)
|
|
-- If we don't know, assume it's an array.
|
|
A.Infer ->
|
|
do (elemT, aes') <- doElems A.Infer aes
|
|
when (elemT == A.Infer) $
|
|
dieP m "Cannot infer type of (empty?) array"
|
|
let dims = [makeDimension m (length aes)]
|
|
return (addDimensions dims elemT,
|
|
A.Several m aes')
|
|
_ -> diePC m $ formatCode "Table literal is not valid for type %" wantT
|
|
where
|
|
doElems :: A.Type -> [A.Structured A.Expression] -> PassM (A.Type, [A.Structured A.Expression])
|
|
doElems t aes
|
|
= do ts <- mapM (\ae -> doArrayElem t ae >>* fst) aes
|
|
let bestT = foldl betterType t ts
|
|
aes' <- mapM (\ae -> doArrayElem bestT ae >>* snd) aes
|
|
return (bestT, aes')
|
|
-- An expression: descend into it with the right context.
|
|
doArrayElem wantT (A.Only m e)
|
|
= do e' <- inTypeContext (Just wantT) $ doExpression e
|
|
t <- astTypeOf e'
|
|
checkType (findMeta e') wantT t
|
|
return (t, A.Only m e')
|
|
|
|
-- | Turn a raw table literal into the appropriate combination of
|
|
-- arrays and records.
|
|
buildTable :: A.Type -> [A.Structured A.Expression] -> PassM A.LiteralRepr
|
|
buildTable t aes
|
|
= do underT <- resolveUserType m t
|
|
case underT of
|
|
A.Array _ _ ->
|
|
do elemT <- trivialSubscriptType m t
|
|
aes' <- mapM (buildElem elemT) aes
|
|
return $ A.ArrayListLiteral m $ A.Several m aes'
|
|
A.Record _ ->
|
|
do nts <- recordFields m underT
|
|
aes' <- sequence [buildExpr elemT ae
|
|
| ((_, elemT), ae) <- zip nts aes]
|
|
return $ A.RecordLiteral m aes'
|
|
where
|
|
buildExpr :: A.Type -> A.Structured A.Expression -> PassM A.Expression
|
|
buildExpr t (A.Several _ aes)
|
|
= do lr <- buildTable t aes
|
|
return $ A.Literal m t lr
|
|
buildExpr _ (A.Only _ e) = return e
|
|
|
|
buildElem :: A.Type -> A.Structured A.Expression -> PassM (A.Structured A.Expression)
|
|
buildElem t ae
|
|
= do underT <- resolveUserType m t
|
|
case (underT, ae) of
|
|
(A.Array _ _, A.Several _ aes) ->
|
|
do A.ArrayListLiteral _ aes' <- buildTable t aes
|
|
return aes'
|
|
(A.Record _, A.Several {}) ->
|
|
do e <- buildExpr t ae
|
|
return $ A.Only m e
|
|
(_, A.Only {}) -> return ae
|
|
|
|
--}}}
|
|
--{{{ checkTypes
|
|
|
|
-- | Check the AST for type consistency.
|
|
-- This is actually a series of smaller passes that check particular types
|
|
-- inside the AST, but it doesn't really make sense to split it up.
|
|
checkTypes ::
|
|
(PolyplateSpine t (OneOpQ (PassM ()) A.Variable) () (PassM ())
|
|
,PolyplateSpine t (OneOpQ (PassM ()) A.Expression) () (PassM ())
|
|
,PolyplateSpine t (OneOpQ (PassM ()) A.SpecType) () (PassM ())
|
|
,PolyplateSpine t (OneOpQ (PassM ()) A.Process) () (PassM ())
|
|
) => Pass t
|
|
checkTypes = occamOnlyPass "Check types"
|
|
[Prop.inferredTypesRecorded, Prop.ambiguitiesResolved]
|
|
[Prop.expressionTypesChecked, Prop.processTypesChecked,
|
|
Prop.functionTypesChecked, Prop.retypesChecked]
|
|
(\x -> do
|
|
checkVariables x
|
|
checkExpressions x
|
|
checkSpecTypes x
|
|
checkProcesses x
|
|
return x
|
|
)
|
|
|
|
--{{{ checkVariables
|
|
|
|
checkVariables :: PlainCheckOn A.Variable
|
|
checkVariables = checkDepthM doVariable
|
|
where
|
|
doVariable :: Check A.Variable
|
|
doVariable (A.SubscriptedVariable m s v)
|
|
= do t <- astTypeOf v
|
|
checkSubscript m s t
|
|
doVariable (A.DirectedVariable m dir v)
|
|
= do t <- astTypeOf v >>= resolveUserType m
|
|
case t of
|
|
A.ChanEnd oldDir _ _ -> checkDir oldDir
|
|
A.Chan _ _ -> ok
|
|
A.Array _ (A.ChanEnd oldDir _ _) -> checkDir oldDir
|
|
A.Array _ (A.Chan _ _) -> ok
|
|
_ -> diePC m $ formatCode "Direction specified on non-channel variable of type: %" t
|
|
where
|
|
checkDir oldDir
|
|
= if dir == oldDir
|
|
then ok
|
|
else dieP m "Direction specified does not match existing direction"
|
|
doVariable (A.DerefVariable m v)
|
|
= do t <- astTypeOf v >>= resolveUserType m
|
|
case t of
|
|
A.Mobile _ -> ok
|
|
_ -> diePC m $ formatCode "Dereference applied to non-mobile variable of type %" t
|
|
doVariable _ = ok
|
|
|
|
--}}}
|
|
--{{{ checkExpressions
|
|
|
|
checkExpressions :: PlainCheckOn A.Expression
|
|
checkExpressions = checkDepthM doExpression
|
|
where
|
|
doExpression :: Check A.Expression
|
|
doExpression (A.MostPos m t) = checkNumeric m t
|
|
doExpression (A.MostNeg m t) = checkNumeric m t
|
|
doExpression (A.SizeType m t) = checkSequence True m t
|
|
doExpression (A.SizeExpr m e)
|
|
= do t <- astTypeOf e
|
|
checkSequence True m t
|
|
doExpression (A.Conversion m _ t e)
|
|
= do et <- astTypeOf e
|
|
checkScalar m t >> checkScalar (findMeta e) et
|
|
doExpression (A.Literal m t lr) = doLiteralRepr t lr
|
|
doExpression (A.FunctionCall m n es)
|
|
= do rs <- checkFunctionCall m n es
|
|
when (length rs /= 1) $
|
|
diePC m $ formatCode "Function % used in an expression returns more than one value" n
|
|
doExpression (A.IntrinsicFunctionCall m s es)
|
|
= checkIntrinsicFunctionCall False m s es >> return ()
|
|
doExpression (A.SubscriptedExpr m s e)
|
|
= do t <- astTypeOf e
|
|
checkSubscript m s t
|
|
doExpression (A.OffsetOf m rawT n)
|
|
= do t <- resolveUserType m rawT
|
|
checkRecordField m t n
|
|
doExpression (A.AllocMobile m t me) = checkAllocMobile m t me
|
|
doExpression _ = ok
|
|
|
|
doLiteralRepr :: A.Type -> A.LiteralRepr -> PassM ()
|
|
doLiteralRepr t (A.ArrayListLiteral m aes)
|
|
= doArrayElem m t aes
|
|
doLiteralRepr t (A.RecordLiteral m es)
|
|
= do rfs <- resolveUserType m t >>= recordFields m
|
|
when (length es /= length rfs) $
|
|
dieP m $ "Record literal has wrong number of fields: found " ++ (show $ length es) ++ ", expected " ++ (show $ length rfs)
|
|
sequence_ [checkExpressionType ft fe
|
|
| ((_, ft), fe) <- zip rfs es]
|
|
doLiteralRepr _ _ = ok
|
|
|
|
doArrayElem :: Meta -> A.Type -> A.Structured A.Expression -> PassM ()
|
|
doArrayElem m t (A.Several _ aes)
|
|
= do checkArraySize m t (length aes)
|
|
t' <- subscriptType (A.Subscript m A.NoCheck undefined) t
|
|
sequence_ $ map (doArrayElem m t') aes
|
|
doArrayElem _ t (A.Only _ e) = checkExpressionType t e
|
|
doArrayElem m t (A.Spec _ (A.Specification _ _ (A.Rep _ (A.For _ _ count _))) body)
|
|
= do t' <- subscriptType (A.Subscript m A.NoCheck undefined) t
|
|
doArrayElem m t' body
|
|
--}}}
|
|
--{{{ checkSpecTypes
|
|
|
|
checkSpecTypes :: PlainCheckOn A.SpecType
|
|
checkSpecTypes = checkDepthM doSpecType
|
|
where
|
|
doSpecType :: Check A.SpecType
|
|
doSpecType (A.Place _ e) = checkExpressionInt e
|
|
doSpecType (A.Declaration _ _) = ok
|
|
doSpecType (A.Is m am t (A.ActualVariable v))
|
|
= do tv <- astTypeOf v
|
|
checkType (findMeta v) t tv
|
|
checkRefAM m am
|
|
amv <- abbrevModeOfVariable v
|
|
checkAbbrev m amv am
|
|
doSpecType (A.Is m am t (A.ActualExpression e))
|
|
= do te <- astTypeOf e
|
|
checkType (findMeta e) t te
|
|
checkValAM m am
|
|
checkAbbrev m A.ValAbbrev am
|
|
doSpecType (A.Is m am t (A.ActualClaim v))
|
|
= do tv <- astTypeOf v
|
|
checkAbbrev m A.Abbrev am
|
|
checkType (findMeta v) t tv
|
|
case tv of
|
|
A.ChanEnd _ A.Shared _ -> return ()
|
|
A.ChanDataType _ A.Shared _ -> return ()
|
|
_ -> dieP m "Expected shared channel end in claim"
|
|
doSpecType (A.Is m am rawT (A.ActualChannelArray cs))
|
|
= do t <- resolveUserType m rawT
|
|
checkAbbrev m A.Abbrev am
|
|
let isChan (A.Chan {}) = True
|
|
isChan (A.ChanEnd {}) = True
|
|
isChan _ = False
|
|
case t of
|
|
A.Array [d] et | isChan et ->
|
|
do sequence_ [do rt <- astTypeOf c
|
|
checkType (findMeta c) et rt
|
|
am <- abbrevModeOfVariable c
|
|
checkAbbrev m am A.Abbrev
|
|
| c <- cs]
|
|
case d of
|
|
A.UnknownDimension -> ok
|
|
A.Dimension e ->
|
|
do v <- evalIntExpression e
|
|
when (v /= length cs) $
|
|
dieP m $ "Wrong number of elements in channel array abbreviation: found " ++ (show $ length cs) ++ ", expected " ++ show v
|
|
_ -> dieP m "Expected 1D channel array type"
|
|
doSpecType (A.DataType m t)
|
|
= checkDataType m t
|
|
doSpecType (A.ChanBundleType m _ fts)
|
|
= when (null fts) $ dieP m "Channel bundles cannot be empty"
|
|
doSpecType (A.RecordType m _ nts)
|
|
= do sequence_ [checkDataType (findMeta n) t
|
|
| (n, t) <- nts]
|
|
checkNamesDistinct m (map fst nts)
|
|
doSpecType (A.Protocol m ts)
|
|
= do when (length ts == 0) $
|
|
dieP m "A protocol cannot be empty"
|
|
mapM_ (checkCommunicable m) ts
|
|
doSpecType (A.ProtocolCase m ntss)
|
|
= do sequence_ [mapM_ (checkCommunicable (findMeta n)) ts
|
|
| (n, ts) <- ntss]
|
|
checkNamesDistinct m (map fst ntss)
|
|
doSpecType (A.Proc m _ fs _)
|
|
= sequence_ [when (am == A.Original) $ unexpectedAM m
|
|
| A.Formal am _ n <- fs]
|
|
doSpecType (A.Function m _ rs fs (Just body))
|
|
= do when (length rs == 0) $
|
|
dieP m "A function must have at least one return type"
|
|
sequence_ [do when (am /= A.ValAbbrev) $
|
|
diePC (findMeta n) $ formatCode "Argument % is not a value abbreviation" n
|
|
checkDataType (findMeta n) t
|
|
| A.Formal am t n <- fs]
|
|
-- FIXME: Run this test again after free name removal
|
|
doFunctionBody rs body
|
|
where
|
|
doFunctionBody :: [A.Type]
|
|
-> Either (A.Structured A.ExpressionList) A.Process
|
|
-> PassM ()
|
|
doFunctionBody rs (Left s) = checkStructured (checkExpressionList rs) s
|
|
-- FIXME: Need to know the name of the function to do this
|
|
doFunctionBody rs (Right p) = dieP m "Cannot check function process body"
|
|
doSpecType (A.Function _ _ _ _ Nothing) = return ()
|
|
doSpecType (A.Retypes m am t v)
|
|
= do fromT <- astTypeOf v
|
|
checkRetypes m fromT t
|
|
checkRefAM m am
|
|
amv <- abbrevModeOfVariable v
|
|
checkAbbrev m amv am
|
|
doSpecType (A.RetypesExpr m am t e)
|
|
= do fromT <- astTypeOf e
|
|
checkRetypes m fromT t
|
|
checkValAM m am
|
|
checkAbbrev m A.ValAbbrev am
|
|
doSpecType (A.Rep _ (A.For _ start count step))
|
|
= do checkExpressionInt start
|
|
checkExpressionInt count
|
|
checkExpressionInt step
|
|
doSpecType (A.Rep _ (A.ForEach _ e))
|
|
= do t <- astTypeOf e
|
|
checkSequence False (findMeta e) t
|
|
|
|
|
|
checkValAM :: Meta -> A.AbbrevMode -> PassM ()
|
|
checkValAM m am
|
|
= case am of
|
|
A.ValAbbrev -> ok
|
|
A.InitialAbbrev -> ok
|
|
_ -> unexpectedAM m
|
|
|
|
checkRefAM :: Meta -> A.AbbrevMode -> PassM ()
|
|
checkRefAM m am
|
|
= case am of
|
|
A.Abbrev -> ok
|
|
A.ResultAbbrev -> ok
|
|
_ -> unexpectedAM m
|
|
|
|
unexpectedAM :: Check Meta
|
|
unexpectedAM m = dieP m "Unexpected abbreviation mode"
|
|
|
|
--}}}
|
|
--{{{ checkProcesses
|
|
|
|
checkProcesses :: PlainCheckOn A.Process
|
|
checkProcesses = checkDepthM doProcess
|
|
where
|
|
doProcess :: Check A.Process
|
|
doProcess (A.Assign m vs el)
|
|
-- We ignore dimensions here because we do the check at runtime.
|
|
-- (That is, [2]INT := []INT is legal.)
|
|
= do vts <- sequence [astTypeOf v >>* removeFixedDimensions
|
|
| v <- vs]
|
|
mapM_ checkWritable vs
|
|
checkExpressionList vts el
|
|
doProcess (A.Input _ v im) = doInput v im
|
|
doProcess (A.Output m v ois) = doOutput m v ois
|
|
doProcess (A.OutputCase m v tag ois) = doOutputCase m v tag ois
|
|
doProcess (A.ClearMobile _ v)
|
|
= do t <- astTypeOf v
|
|
case t of
|
|
A.Mobile _ -> ok
|
|
_ -> diePC (findMeta v) $ formatCode "Expected mobile type; found %" t
|
|
checkWritable v
|
|
doProcess (A.Skip _) = ok
|
|
doProcess (A.Stop _) = ok
|
|
doProcess (A.Seq _ s) = checkStructured (\p -> ok) s
|
|
doProcess (A.If _ s) = checkStructured doChoice s
|
|
doProcess (A.Case _ e s)
|
|
= do t <- astTypeOf e
|
|
checkCaseable (findMeta e) t
|
|
checkStructured (doOption t) s
|
|
doProcess (A.While _ e _) = checkExpressionBool e
|
|
doProcess (A.Par _ _ s) = checkStructured (\p -> ok) s
|
|
doProcess (A.Processor _ e _) = checkExpressionInt e
|
|
doProcess (A.Alt _ _ s) = checkStructured doAlternative s
|
|
doProcess (A.ProcCall m n as)
|
|
= do fs <- checkProc m n
|
|
checkActuals m n fs as
|
|
doProcess (A.IntrinsicProcCall m n as)
|
|
= case lookup n intrinsicProcs of
|
|
Just args ->
|
|
do let fs = [A.Formal am t (A.Name m s)
|
|
| (am, t, s) <- args]
|
|
checkActuals m (A.Name m n) fs as
|
|
Nothing -> dieP m $ n ++ " is not an intrinsic procedure"
|
|
|
|
doAlternative :: Check A.Alternative
|
|
doAlternative (A.Alternative m e v im p)
|
|
= do checkExpressionBool e
|
|
case im of
|
|
A.InputTimerRead _ _ ->
|
|
dieP m $ "Timer read not permitted as alternative"
|
|
_ -> doInput v im
|
|
doAlternative (A.AlternativeSkip _ e _)
|
|
= checkExpressionBool e
|
|
|
|
doChoice :: Check A.Choice
|
|
doChoice (A.Choice _ e _) = checkExpressionBool e
|
|
|
|
doInput :: A.Variable -> A.InputMode -> PassM ()
|
|
doInput c (A.InputSimple m iis)
|
|
= do t <- checkChannel A.DirInput c
|
|
checkProtocol m t Nothing iis doInputItem
|
|
doInput c (A.InputCase _ s)
|
|
= do t <- checkChannel A.DirInput c
|
|
checkStructured (doVariant t) s
|
|
where
|
|
doVariant :: A.Type -> A.Variant -> PassM ()
|
|
doVariant t (A.Variant m tag iis _)
|
|
= checkProtocol m t (Just tag) iis doInputItem
|
|
doInput c (A.InputTimerRead m ii)
|
|
= do t <- checkTimer c
|
|
doInputItem t ii
|
|
doInput c (A.InputTimerAfter m e)
|
|
= do t <- checkTimer c
|
|
et <- astTypeOf e
|
|
checkType (findMeta e) t et
|
|
doInput c (A.InputTimerFor m e)
|
|
= do t <- checkTimer c
|
|
et <- astTypeOf e
|
|
checkType (findMeta e) t et
|
|
|
|
doInputItem :: A.Type -> A.InputItem -> PassM ()
|
|
doInputItem (A.Counted wantCT wantAT) (A.InCounted m cv av)
|
|
= do ct <- astTypeOf cv
|
|
checkType (findMeta cv) wantCT ct
|
|
checkWritable cv
|
|
at <- astTypeOf av
|
|
checkType (findMeta cv) wantAT at
|
|
checkWritable av
|
|
doInputItem t@(A.Counted _ _) (A.InVariable m v)
|
|
= diePC m $ formatCode "Expected counted item of type %; found %" t v
|
|
doInputItem wantT (A.InVariable _ v)
|
|
= do t <- astTypeOf v
|
|
case wantT of
|
|
A.Any -> checkCommunicable (findMeta v) t
|
|
_ -> checkType (findMeta v) wantT t
|
|
checkWritable v
|
|
|
|
doOption :: A.Type -> A.Option -> PassM ()
|
|
doOption et (A.Option _ es _)
|
|
= sequence_ [do rt <- astTypeOf e
|
|
checkType (findMeta e) et rt
|
|
| e <- es]
|
|
doOption _ (A.Else _ _) = ok
|
|
|
|
doOutput :: Meta -> A.Variable -> [A.OutputItem] -> PassM ()
|
|
doOutput m c ois
|
|
= do t <- checkChannel A.DirOutput c
|
|
checkProtocol m t Nothing ois doOutputItem
|
|
|
|
doOutputCase :: Meta -> A.Variable -> A.Name -> [A.OutputItem] -> PassM ()
|
|
doOutputCase m c tag ois
|
|
= do t <- checkChannel A.DirOutput c
|
|
checkProtocol m t (Just tag) ois doOutputItem
|
|
|
|
doOutputItem :: A.Type -> A.OutputItem -> PassM ()
|
|
doOutputItem (A.Counted wantCT wantAT) (A.OutCounted m ce ae)
|
|
= do ct <- astTypeOf ce
|
|
checkType (findMeta ce) wantCT ct
|
|
at <- astTypeOf ae
|
|
checkType (findMeta ae) wantAT at
|
|
doOutputItem t@(A.Counted _ _) (A.OutExpression m e)
|
|
= diePC m $ formatCode "Expected counted item of type %; found %" t e
|
|
doOutputItem wantT (A.OutExpression _ e)
|
|
= do t <- astTypeOf e
|
|
case wantT of
|
|
A.Any -> checkCommunicable (findMeta e) t
|
|
_ -> checkType (findMeta e) wantT t
|
|
|
|
--}}}
|
|
|
|
--}}}
|