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

Added a type-class for retrieving the (AST) type of things

Browse Source 
This patch hides all the old typeOfExpression, typeOfName, typeOfVariable, etc, and unifies them into a single type-class with an "astTypeOf" function.  The type-class is currently named Typed, but that can easily be changed (it's only explicitly referred to in the Types module).  The patch is essentially the type-class with a giant find-and-replace on the other modules.
This commit is contained in:
Neil Brown 2008-05-17 11:41:52 +00:00
parent 3daf82d318
commit 89c25e3f6c
16 changed files with 147 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
backends/BackendPasses.hs
View File

@ -107,7 +107,7 @@ declareSizesArray = doGeneric `ext1M` doStructured
retypesSizes :: Meta -> A.Name -> [A.Dimension] -> A.Type -> A.Variable -> PassM A.Specification retypesSizes :: Meta -> A.Name -> [A.Dimension] -> A.Type -> A.Variable -> PassM A.Specification
retypesSizes m n_sizes ds elemT v@(A.Variable _ nSrc) retypesSizes m n_sizes ds elemT v@(A.Variable _ nSrc)
= do biDest <- bytesInType (A.Array ds elemT) = do biDest <- bytesInType (A.Array ds elemT)
tSrc <- typeOfVariable v tSrc <- astTypeOf v
biSrc <- bytesInType tSrc biSrc <- bytesInType tSrc
-- Figure out the size of the source. -- Figure out the size of the source.
@ -158,10 +158,10 @@ declareSizesArray = doGeneric `ext1M` doStructured
varSrcSizes <- case innerV of varSrcSizes <- case innerV of
A.Variable _ srcN -> return (A.Variable m $ append_sizes srcN) A.Variable _ srcN -> return (A.Variable m $ append_sizes srcN)
A.SubscriptedVariable _ (A.SubscriptField _ fieldName) recordV -> A.SubscriptedVariable _ (A.SubscriptField _ fieldName) recordV ->
do A.Record recordName <- typeOfVariable recordV do A.Record recordName <- astTypeOf recordV
return (A.Variable m $ A.Name m A.VariableName $ A.nameName recordName ++ A.nameName fieldName ++ "_sizes") return (A.Variable m $ A.Name m A.VariableName $ A.nameName recordName ++ A.nameName fieldName ++ "_sizes")
-- Get the dimensions of the source variable: -- Get the dimensions of the source variable:
(A.Array srcDs _) <- typeOfVariable innerV (A.Array srcDs _) <- astTypeOf innerV
-- Calculate the correct subscript into the source _sizes variable to get to the dimensions for the destination: -- Calculate the correct subscript into the source _sizes variable to get to the dimensions for the destination:
let sizeDiff = length srcDs - length ds let sizeDiff = length srcDs - length ds
subSrcSizeVar = A.SubscriptedVariable m (A.SubscriptFromFor m (makeConstant m sizeDiff) (makeConstant m $ length ds)) varSrcSizes subSrcSizeVar = A.SubscriptedVariable m (A.SubscriptFromFor m (makeConstant m sizeDiff) (makeConstant m $ length ds)) varSrcSizes
@ -296,7 +296,7 @@ addSizesActualParameters = doGeneric `extM` doProcess
transformActualVariable :: A.Actual -> A.Variable -> PassM [A.Actual] transformActualVariable :: A.Actual -> A.Variable -> PassM [A.Actual]
transformActualVariable a v@(A.Variable m n) transformActualVariable a v@(A.Variable m n)
= do t <- typeOfVariable v = do t <- astTypeOf v
case t of case t of
A.Array ds _ -> A.Array ds _ ->
return [a, A.ActualVariable a_sizes] return [a, A.ActualVariable a_sizes]
@ -320,7 +320,7 @@ simplifySlices = doGeneric `extM` doVariable
return (A.SubscriptedVariable m (A.SubscriptFromFor m' (makeConstant m' 0) for') v') return (A.SubscriptedVariable m (A.SubscriptFromFor m' (makeConstant m' 0) for') v')
doVariable (A.SubscriptedVariable m (A.SubscriptFrom m' from) v) doVariable (A.SubscriptedVariable m (A.SubscriptFrom m' from) v)
= do v' <- doGeneric v = do v' <- doGeneric v
A.Array (d:_) _ <- typeOfVariable v' A.Array (d:_) _ <- astTypeOf v'
limit <- case d of limit <- case d of
A.Dimension n -> return n A.Dimension n -> return n
A.UnknownDimension -> return $ A.SizeVariable m' v' A.UnknownDimension -> return $ A.SizeVariable m' v'

44
backends/GenerateC.hs
View File

@ -258,7 +258,7 @@ genRightB = tell ["}"]
-- | Map an operation over every item of an occam array. -- | Map an operation over every item of an occam array.
cgenOverArray :: Meta -> A.Variable -> (SubscripterFunction -> Maybe (CGen ())) -> CGen () cgenOverArray :: Meta -> A.Variable -> (SubscripterFunction -> Maybe (CGen ())) -> CGen ()
cgenOverArray m var func cgenOverArray m var func
= do A.Array ds _ <- typeOfVariable var = do A.Array ds _ <- astTypeOf var
specs <- sequence [csmLift $ makeNonceVariable "i" m A.Int A.VariableName A.Original | _ <- ds] specs <- sequence [csmLift $ makeNonceVariable "i" m A.Int A.VariableName A.Original | _ <- ds]
let indices = [A.Variable m n | A.Specification _ n _ <- specs] let indices = [A.Variable m n | A.Specification _ n _ <- specs]
@ -457,10 +457,10 @@ cgenCheckedConversion m fromT toT exp
cgenConversion :: Meta -> A.ConversionMode -> A.Type -> A.Expression -> CGen () cgenConversion :: Meta -> A.ConversionMode -> A.Type -> A.Expression -> CGen ()
cgenConversion m A.DefaultConversion toT e cgenConversion m A.DefaultConversion toT e
= do fromT <- typeOfExpression e = do fromT <- astTypeOf e
call genCheckedConversion m fromT toT (call genExpression e) call genCheckedConversion m fromT toT (call genExpression e)
cgenConversion m cm toT e cgenConversion m cm toT e
= do fromT <- typeOfExpression e = do fromT <- astTypeOf e
case (isSafeConversion fromT toT, isRealType fromT, isRealType toT) of case (isSafeConversion fromT toT, isRealType fromT, isRealType toT) of
(True, _, _) -> (True, _, _) ->
-- A safe conversion -- no need for a check. -- A safe conversion -- no need for a check.
@ -583,7 +583,7 @@ cgenUnfoldedExpression e = call genExpression e
-- | Generate a variable inside a record literal. -- | Generate a variable inside a record literal.
cgenUnfoldedVariable :: Meta -> A.Variable -> CGen () cgenUnfoldedVariable :: Meta -> A.Variable -> CGen ()
cgenUnfoldedVariable m var cgenUnfoldedVariable m var
= do t <- typeOfVariable var = do t <- astTypeOf var
case t of case t of
A.Array ds _ -> A.Array ds _ ->
do genLeftB do genLeftB
@ -720,7 +720,7 @@ cgenVariable' checkValid v
-- If we are dealing with an array element, treat it as if it had the original abbreviation mode, -- If we are dealing with an array element, treat it as if it had the original abbreviation mode,
-- regardless of the abbreviation mode of the array: -- regardless of the abbreviation mode of the array:
(_, Just t') -> return (A.Original, t') (_, Just t') -> return (A.Original, t')
(am,Nothing) -> do t <- typeOfName n (am,Nothing) -> do t <- astTypeOf n
return (am, t) return (am, t)
let ind' = case (am, t, indirectedType t) of let ind' = case (am, t, indirectedType t) of
-- For types that are referred to by pointer (such as records) -- For types that are referred to by pointer (such as records)
@ -738,7 +738,7 @@ cgenVariable' checkValid v
_ -> ind _ -> ind
return (genName n, ind') return (genName n, ind')
inner ind (A.DerefVariable _ v) mt inner ind (A.DerefVariable _ v) mt
= do (A.Mobile t) <- typeOfVariable v = do (A.Mobile t) <- astTypeOf v
case t of case t of
A.Array {} -> inner ind v mt A.Array {} -> inner ind v mt
A.Record {} -> inner ind v mt A.Record {} -> inner ind v mt
@ -749,16 +749,16 @@ cgenVariable' checkValid v
inner ind sv@(A.SubscriptedVariable m (A.Subscript _ subCheck _) v) mt inner ind sv@(A.SubscriptedVariable m (A.Subscript _ subCheck _) v) mt
= do (es, v, t') <- collectSubs sv = do (es, v, t') <- collectSubs sv
t <- if checkValid t <- if checkValid
then typeOfVariable sv then astTypeOf sv
else return t' else return t'
A.Array ds _ <- typeOfVariable v A.Array ds _ <- astTypeOf v
(cg, n) <- inner ind v (Just t) (cg, n) <- inner ind v (Just t)
let check = if checkValid then subCheck else A.NoCheck let check = if checkValid then subCheck else A.NoCheck
return ((if (length ds /= length es) then tell ["&"] else return ()) >> cg return ((if (length ds /= length es) then tell ["&"] else return ()) >> cg
>> call genArraySubscript check v (map (\e -> (findMeta e, call genExpression e)) es), n) >> call genArraySubscript check v (map (\e -> (findMeta e, call genExpression e)) es), n)
inner ind sv@(A.SubscriptedVariable _ (A.SubscriptField m n) v) mt inner ind sv@(A.SubscriptedVariable _ (A.SubscriptField m n) v) mt
= do (cg, ind') <- inner ind v mt = do (cg, ind') <- inner ind v mt
t <- typeOfVariable sv t <- astTypeOf sv
let outerInd :: Int let outerInd :: Int
outerInd = if indirectedType t then -1 else 0 outerInd = if indirectedType t then -1 else 0
return (addPrefix (addPrefix cg ind' >> tell ["->"] >> genName n) outerInd, 0) return (addPrefix (addPrefix cg ind' >> tell ["->"] >> genName n) outerInd, 0)
@ -795,7 +795,7 @@ cgenVariable' checkValid v
= do (es', v', t') <- collectSubs v = do (es', v', t') <- collectSubs v
t <- trivialSubscriptType m t' t <- trivialSubscriptType m t'
return (es' ++ [e], v', t) return (es' ++ [e], v', t)
collectSubs v = do t <- typeOfVariable v collectSubs v = do t <- astTypeOf v
return ([], v, t) return ([], v, t)
@ -809,7 +809,7 @@ cgenDirectedVariable var _ = var
cgenArraySubscript :: A.SubscriptCheck -> A.Variable -> [(Meta, CGen ())] -> CGen () cgenArraySubscript :: A.SubscriptCheck -> A.Variable -> [(Meta, CGen ())] -> CGen ()
cgenArraySubscript check v es cgenArraySubscript check v es
= do t <- typeOfVariable v = do t <- astTypeOf v
let numDims = case t of A.Array ds _ -> length ds let numDims = case t of A.Array ds _ -> length ds
tell ["["] tell ["["]
sequence_ $ intersperse (tell ["+"]) $ genPlainSub (genDynamicDim v) es [0..(numDims - 1)] sequence_ $ intersperse (tell ["+"]) $ genPlainSub (genDynamicDim v) es [0..(numDims - 1)]
@ -867,7 +867,7 @@ cgenExpression (A.SizeExpr m e)
= do call genExpression e = do call genExpression e
call genSizeSuffix "0" call genSizeSuffix "0"
cgenExpression (A.SizeVariable m v) cgenExpression (A.SizeVariable m v)
= do t <- typeOfVariable v = do t <- astTypeOf v
case t of case t of
A.Array (d:_) _ -> A.Array (d:_) _ ->
case d of case d of
@ -919,7 +919,7 @@ cgenSimpleMonadic s e
cgenFuncMonadic :: Meta -> String -> A.Expression -> CGen () cgenFuncMonadic :: Meta -> String -> A.Expression -> CGen ()
cgenFuncMonadic m s e cgenFuncMonadic m s e
= do t <- typeOfExpression e = do t <- astTypeOf e
call genTypeSymbol s t call genTypeSymbol s t
tell [" ("] tell [" ("]
call genExpression e call genExpression e
@ -943,7 +943,7 @@ cgenSimpleDyadic s e f
cgenFuncDyadic :: Meta -> String -> A.Expression -> A.Expression -> CGen () cgenFuncDyadic :: Meta -> String -> A.Expression -> A.Expression -> CGen ()
cgenFuncDyadic m s e f cgenFuncDyadic m s e f
= do t <- typeOfExpression e = do t <- astTypeOf e
call genTypeSymbol s t call genTypeSymbol s t
tell [" ("] tell [" ("]
call genExpression e call genExpression e
@ -985,7 +985,7 @@ cgenListConcat _ _ = call genMissing "C backend does not yet support lists"
cgenInputItem :: A.Variable -> A.InputItem -> CGen () cgenInputItem :: A.Variable -> A.InputItem -> CGen ()
cgenInputItem c (A.InCounted m cv av) cgenInputItem c (A.InCounted m cv av)
= do call genInputItem c (A.InVariable m cv) = do call genInputItem c (A.InVariable m cv)
t <- typeOfVariable av t <- astTypeOf av
tell ["ChanIn(wptr,"] tell ["ChanIn(wptr,"]
call genVariable c call genVariable c
tell [","] tell [","]
@ -997,7 +997,7 @@ cgenInputItem c (A.InCounted m cv av)
call genBytesIn m subT (Right av) call genBytesIn m subT (Right av)
tell [");"] tell [");"]
cgenInputItem c (A.InVariable m v) cgenInputItem c (A.InVariable m v)
= do t <- typeOfVariable v = do t <- astTypeOf v
let rhs = call genVariableAM v A.Abbrev let rhs = call genVariableAM v A.Abbrev
case t of case t of
A.Int -> A.Int ->
@ -1018,7 +1018,7 @@ cgenInputItem c (A.InVariable m v)
cgenOutputItem :: A.Variable -> A.OutputItem -> CGen () cgenOutputItem :: A.Variable -> A.OutputItem -> CGen ()
cgenOutputItem c (A.OutCounted m ce ae) cgenOutputItem c (A.OutCounted m ce ae)
= do call genOutputItem c (A.OutExpression m ce) = do call genOutputItem c (A.OutExpression m ce)
t <- typeOfExpression ae t <- astTypeOf ae
case ae of case ae of
A.ExprVariable m v -> A.ExprVariable m v ->
do tell ["ChanOut(wptr,"] do tell ["ChanOut(wptr,"]
@ -1032,7 +1032,7 @@ cgenOutputItem c (A.OutCounted m ce ae)
call genBytesIn m subT (Right v) call genBytesIn m subT (Right v)
tell [");"] tell [");"]
cgenOutputItem c (A.OutExpression m e) cgenOutputItem c (A.OutExpression m e)
= do t <- typeOfExpression e = do t <- astTypeOf e
case (t, e) of case (t, e) of
(A.Int, _) -> (A.Int, _) ->
do tell ["ChanOutInt(wptr,"] do tell ["ChanOutInt(wptr,"]
@ -1101,7 +1101,7 @@ cgenReplicatorLoop _ = cgenMissing "ForEach loops not yet supported in the C bac
cgenVariableAM :: A.Variable -> A.AbbrevMode -> CGen () cgenVariableAM :: A.Variable -> A.AbbrevMode -> CGen ()
cgenVariableAM v am cgenVariableAM v am
= do when (am == A.Abbrev) $ = do when (am == A.Abbrev) $
do t <- typeOfVariable v do t <- astTypeOf v
case (indirectedType t, t) of case (indirectedType t, t) of
(True, _) -> return () (True, _) -> return ()
(False, A.Array {}) -> return () (False, A.Array {}) -> return ()
@ -1302,7 +1302,7 @@ cintroduceSpec (A.Specification _ n (A.ProtocolCase _ ts))
cintroduceSpec (A.Specification _ n st@(A.Proc _ _ _ _)) cintroduceSpec (A.Specification _ n st@(A.Proc _ _ _ _))
= genProcSpec n st False = genProcSpec n st False
cintroduceSpec (A.Specification _ n (A.Retypes m am t v)) cintroduceSpec (A.Specification _ n (A.Retypes m am t v))
= do origT <- typeOfVariable v = do origT <- astTypeOf v
let rhs = call genVariableAM v A.Abbrev let rhs = call genVariableAM v A.Abbrev
call genDecl am t n call genDecl am t n
tell ["="] tell ["="]
@ -1472,7 +1472,7 @@ cgenProcess p = case p of
--{{{ assignment --{{{ assignment
cgenAssign :: Meta -> [A.Variable] -> A.ExpressionList -> CGen () cgenAssign :: Meta -> [A.Variable] -> A.ExpressionList -> CGen ()
cgenAssign m [v] (A.ExpressionList _ [e]) cgenAssign m [v] (A.ExpressionList _ [e])
= do t <- typeOfVariable v = do t <- astTypeOf v
f <- fget getScalarType f <- fget getScalarType
case f t of case f t of
Just _ -> doAssign v e Just _ -> doAssign v e
@ -1522,7 +1522,7 @@ cgenOutput c ois = sequence_ $ map (call genOutputItem c) ois
cgenOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen () cgenOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen ()
cgenOutputCase c tag ois cgenOutputCase c tag ois
= do t <- typeOfVariable c = do t <- astTypeOf c
let proto = case t of A.Chan _ _ (A.UserProtocol n) -> n let proto = case t of A.Chan _ _ (A.UserProtocol n) -> n
tell ["ChanOutInt(wptr,"] tell ["ChanOutInt(wptr,"]
call genVariable c call genVariable c

26
backends/GenerateCPPCSP.hs
View File

@ -184,7 +184,7 @@ cppgenStop m s
-- | Generates code from a channel 'A.Variable' that will be of type Chanin\<\> -- | Generates code from a channel 'A.Variable' that will be of type Chanin\<\>
genCPPCSPChannelInput :: A.Variable -> CGen() genCPPCSPChannelInput :: A.Variable -> CGen()
genCPPCSPChannelInput var genCPPCSPChannelInput var
= do t <- typeOfVariable var = do t <- astTypeOf var
case t of case t of
(A.Chan A.DirInput _ _) -> call genVariable var (A.Chan A.DirInput _ _) -> call genVariable var
(A.Chan A.DirUnknown _ _) -> do call genVariable var (A.Chan A.DirUnknown _ _) -> do call genVariable var
@ -194,7 +194,7 @@ genCPPCSPChannelInput var
-- | Generates code from a channel 'A.Variable' that will be of type Chanout\<\> -- | Generates code from a channel 'A.Variable' that will be of type Chanout\<\>
genCPPCSPChannelOutput :: A.Variable -> CGen() genCPPCSPChannelOutput :: A.Variable -> CGen()
genCPPCSPChannelOutput var genCPPCSPChannelOutput var
= do t <- typeOfVariable var = do t <- astTypeOf var
case t of case t of
(A.Chan A.DirOutput _ _) -> call genVariable var (A.Chan A.DirOutput _ _) -> call genVariable var
(A.Chan A.DirUnknown _ _) -> do call genVariable var (A.Chan A.DirUnknown _ _) -> do call genVariable var
@ -207,7 +207,7 @@ genCPPCSPChannelOutput var
--the remainder is taken to trim the timer back down to something that will be useful in an int --the remainder is taken to trim the timer back down to something that will be useful in an int
cppgenTimerRead :: A.Variable -> A.Variable -> CGen () cppgenTimerRead :: A.Variable -> A.Variable -> CGen ()
cppgenTimerRead c v = do cppgenTimerRead c v = do
tt <- typeOfVariable c tt <- astTypeOf c
case tt of case tt of
A.Timer A.RainTimer -> A.Timer A.RainTimer ->
do tell ["csp::CurrentTime (&"] do tell ["csp::CurrentTime (&"]
@ -291,13 +291,13 @@ cppgenInputItem c dest
recvBytes av ( recvBytes av (
do call genVariable cv do call genVariable cv
tell ["*"] tell ["*"]
t <- typeOfVariable av t <- astTypeOf av
subT <- trivialSubscriptType m t subT <- trivialSubscriptType m t
call genBytesIn m subT (Right av) call genBytesIn m subT (Right av)
) )
(A.InVariable m v) -> (A.InVariable m v) ->
do ct <- typeOfVariable c do ct <- astTypeOf c
t <- typeOfVariable v t <- astTypeOf v
case (byteArrayChan ct,t) of case (byteArrayChan ct,t) of
(True,_)-> recvBytes v (call genBytesIn m t (Right v)) (True,_)-> recvBytes v (call genBytesIn m t (Right v))
(False,A.Array {}) -> do tell ["tockRecvArray("] (False,A.Array {}) -> do tell ["tockRecvArray("]
@ -325,8 +325,8 @@ cppgenOutputItem chan item
= case item of = case item of
(A.OutCounted m (A.ExprVariable _ cv) (A.ExprVariable _ av)) -> (sendBytes cv) >> (sendBytes av) (A.OutCounted m (A.ExprVariable _ cv) (A.ExprVariable _ av)) -> (sendBytes cv) >> (sendBytes av)
(A.OutExpression _ (A.ExprVariable _ sv)) -> (A.OutExpression _ (A.ExprVariable _ sv)) ->
do t <- typeOfVariable chan do t <- astTypeOf chan
tsv <- typeOfVariable sv tsv <- astTypeOf sv
case (byteArrayChan t,tsv) of case (byteArrayChan t,tsv) of
(True,_) -> sendBytes sv (True,_) -> sendBytes sv
(False,A.Array {}) -> do tell ["tockSendArray("] (False,A.Array {}) -> do tell ["tockSendArray("]
@ -353,11 +353,11 @@ byteArrayChan (A.Chan _ _ (A.Counted _ _)) = True
byteArrayChan _ = False byteArrayChan _ = False
genPoint :: A.Variable -> CGen() genPoint :: A.Variable -> CGen()
genPoint v = do t <- typeOfVariable v genPoint v = do t <- astTypeOf v
when (not $ isPoint t) $ tell ["&"] when (not $ isPoint t) $ tell ["&"]
call genVariable v call genVariable v
genNonPoint :: A.Variable -> CGen() genNonPoint :: A.Variable -> CGen()
genNonPoint v = do t <- typeOfVariable v genNonPoint v = do t <- astTypeOf v
when (isPoint t) $ tell ["*"] when (isPoint t) $ tell ["*"]
call genVariable v call genVariable v
isPoint :: A.Type -> Bool isPoint :: A.Type -> Bool
@ -373,7 +373,7 @@ infixComma [] = return ()
cppgenOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen () cppgenOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen ()
cppgenOutputCase c tag ois cppgenOutputCase c tag ois
= do t <- typeOfVariable c = do t <- astTypeOf c
let proto = case t of A.Chan _ _ (A.UserProtocol n) -> n let proto = case t of A.Chan _ _ (A.UserProtocol n) -> n
tell ["tockSendInt("] tell ["tockSendInt("]
genCPPCSPChannelOutput c genCPPCSPChannelOutput c
@ -717,7 +717,7 @@ cppgenListConcat a b
cppgenReplicatorLoop :: A.Replicator -> CGen () cppgenReplicatorLoop :: A.Replicator -> CGen ()
cppgenReplicatorLoop rep@(A.For {}) = cgenReplicatorLoop rep cppgenReplicatorLoop rep@(A.For {}) = cgenReplicatorLoop rep
cppgenReplicatorLoop (A.ForEach m n (A.ExprVariable _ v)) cppgenReplicatorLoop (A.ForEach m n (A.ExprVariable _ v))
= do t <- typeOfVariable v = do t <- astTypeOf v
call genType t call genType t
tell ["::iterator "] tell ["::iterator "]
genName n genName n
@ -750,7 +750,7 @@ cppgenUnfoldedExpression e = call genExpression e
-- | Changed to remove array size: -- | Changed to remove array size:
cppgenUnfoldedVariable :: Meta -> A.Variable -> CGen () cppgenUnfoldedVariable :: Meta -> A.Variable -> CGen ()
cppgenUnfoldedVariable m var cppgenUnfoldedVariable m var
= do t <- typeOfVariable var = do t <- astTypeOf var
case t of case t of
A.Record _ -> A.Record _ ->
do genLeftB do genLeftB

2
checks/ArrayUsageCheck.hs
View File

@ -82,7 +82,7 @@ checkArrayUsage (m,p) = mapM_ (checkIndexes m) $ Map.toList $
checkIndexes :: Meta -> (String,ParItems ([A.Expression],[A.Expression])) -> m () checkIndexes :: Meta -> (String,ParItems ([A.Expression],[A.Expression])) -> m ()
checkIndexes m (arrName, indexes) checkIndexes m (arrName, indexes)
= do userArrName <- getRealName (A.Name undefined undefined arrName) = do userArrName <- getRealName (A.Name undefined undefined arrName)
arrType <- typeOfName (A.Name undefined undefined arrName) arrType <- astTypeOf (A.Name undefined undefined arrName)
arrLength <- case arrType of arrLength <- case arrType of
A.Array (A.Dimension d:_) _ -> return d A.Array (A.Dimension d:_) _ -> return d
-- Unknown dimension, use the maximum value for a (assumed 32-bit for INT) integer: -- Unknown dimension, use the maximum value for a (assumed 32-bit for INT) integer:

10
common/EvalConstants.hs
View File

@ -45,7 +45,7 @@ import Utils
constantFold :: (CSMR m, Die m) => A.Expression -> m (A.Expression, Bool, ErrorReport) constantFold :: (CSMR m, Die m) => A.Expression -> m (A.Expression, Bool, ErrorReport)
constantFold e constantFold e
= do ps <- getCompState = do ps <- getCompState
t <- typeOfExpression e t <- astTypeOf e
case runEvaluator ps (evalExpression e) of case runEvaluator ps (evalExpression e) of
Left err -> return (e, False, err) Left err -> return (e, False, err)
Right val -> Right val ->
@ -152,7 +152,7 @@ evalExpression (A.MostNeg _ A.Int32) = return $ OccInt32 minBound
evalExpression (A.MostPos _ A.Int64) = return $ OccInt64 maxBound evalExpression (A.MostPos _ A.Int64) = return $ OccInt64 maxBound
evalExpression (A.MostNeg _ A.Int64) = return $ OccInt64 minBound evalExpression (A.MostNeg _ A.Int64) = return $ OccInt64 minBound
evalExpression (A.SizeExpr m e) evalExpression (A.SizeExpr m e)
= do t <- typeOfExpression e >>= underlyingType m = do t <- astTypeOf e >>= underlyingType m
case t of case t of
A.Array (A.Dimension n:_) _ -> evalExpression n A.Array (A.Dimension n:_) _ -> evalExpression n
_ -> _ ->
@ -161,7 +161,7 @@ evalExpression (A.SizeExpr m e)
OccArray vs -> return $ OccInt (fromIntegral $ length vs) OccArray vs -> return $ OccInt (fromIntegral $ length vs)
_ -> throwError (Just m, "size of non-constant expression " ++ show e ++ " used") _ -> throwError (Just m, "size of non-constant expression " ++ show e ++ " used")
evalExpression (A.SizeVariable m v) evalExpression (A.SizeVariable m v)
= do t <- typeOfVariable v >>= underlyingType m = do t <- astTypeOf v >>= underlyingType m
case t of case t of
A.Array (A.Dimension n:_) _ -> evalExpression n A.Array (A.Dimension n:_) _ -> evalExpression n
_ -> throwError (Just m, "size of non-fixed-size variable " ++ show v ++ " used") _ -> throwError (Just m, "size of non-fixed-size variable " ++ show v ++ " used")
@ -171,7 +171,7 @@ evalExpression (A.True _) = return $ OccBool True
evalExpression (A.False _) = return $ OccBool False evalExpression (A.False _) = return $ OccBool False
evalExpression (A.SubscriptedExpr _ sub e) = evalExpression e >>= evalSubscript sub evalExpression (A.SubscriptedExpr _ sub e) = evalExpression e >>= evalSubscript sub
evalExpression (A.BytesInExpr m e) evalExpression (A.BytesInExpr m e)
= do b <- typeOfExpression e >>= underlyingType m >>= bytesInType = do b <- astTypeOf e >>= underlyingType m >>= bytesInType
case b of case b of
BIJust n -> evalExpression n BIJust n -> evalExpression n
_ -> throwError (Just m, "BYTESIN non-constant-size expression " ++ show e ++ " used") _ -> throwError (Just m, "BYTESIN non-constant-size expression " ++ show e ++ " used")
@ -341,7 +341,7 @@ renderLiteral m t v
return (t', A.ArrayElemArray aes) return (t', A.ArrayElemArray aes)
renderArrayElem t v renderArrayElem t v
= do e <- renderValue m t v = do e <- renderValue m t v
t' <- typeOfExpression e t' <- astTypeOf e
return (t', A.ArrayElemExpr e) return (t', A.ArrayElemExpr e)
renderRecord :: [OccValue] -> m (A.Type, A.LiteralRepr) renderRecord :: [OccValue] -> m (A.Type, A.LiteralRepr)

20
common/Types.hs
View File

@ -19,7 +19,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- | Type inference and checking. -- | Type inference and checking.
module Types module Types
( (
specTypeOfName, typeOfSpec, abbrevModeOfName, typeOfName, typeOfExpression, typeOfVariable, underlyingType, stripArrayType, abbrevModeOfVariable, abbrevModeOfSpec specTypeOfName, typeOfSpec, abbrevModeOfName, underlyingType, stripArrayType, abbrevModeOfVariable, abbrevModeOfSpec
, isRealType, isIntegerType, isNumericType, isCaseableType, isScalarType, isDataType, isCommunicableType, isSequenceType , isRealType, isIntegerType, isNumericType, isCaseableType, isScalarType, isDataType, isCommunicableType, isSequenceType
, resolveUserType, isSafeConversion, isPreciseConversion, isImplicitConversionRain , resolveUserType, isSafeConversion, isPreciseConversion, isImplicitConversionRain
, returnTypesOfFunction , returnTypesOfFunction
@ -31,7 +31,8 @@ module Types
, recordFields, protocolItems , recordFields, protocolItems
, leastGeneralSharedTypeRain , leastGeneralSharedTypeRain
, Typed(..)
) where ) where
import Control.Monad.State import Control.Monad.State
@ -53,6 +54,12 @@ import ShowCode
import TypeSizes import TypeSizes
import Utils import Utils
class Typed a where
astTypeOf :: (CSMR m, Die m) => a -> m A.Type
instance Typed A.Type where
astTypeOf = return
-- | Gets the 'A.SpecType' for a given 'A.Name' from the recorded types in the 'CompState'. Dies with an error if the name is unknown. -- | Gets the 'A.SpecType' for a given 'A.Name' from the recorded types in the 'CompState'. Dies with an error if the name is unknown.
specTypeOfName :: (CSMR m, Die m) => A.Name -> m A.SpecType specTypeOfName :: (CSMR m, Die m) => A.Name -> m A.SpecType
specTypeOfName n specTypeOfName n
@ -63,6 +70,9 @@ abbrevModeOfName :: (CSMR m, Die m) => A.Name -> m A.AbbrevMode
abbrevModeOfName n abbrevModeOfName n
= liftM A.ndAbbrevMode (lookupNameOrError n $ dieP (A.nameMeta n) $ "Could not find abbreviation mode in abbrevModeOfName for: " ++ (show $ A.nameName n)) = liftM A.ndAbbrevMode (lookupNameOrError n $ dieP (A.nameMeta n) $ "Could not find abbreviation mode in abbrevModeOfName for: " ++ (show $ A.nameName n))
instance Typed A.Name where
astTypeOf = typeOfName
-- | Gets the 'A.Type' for a given 'A.Name' by looking at its definition in the 'CompState'. Dies with an error if the name is unknown. -- | Gets the 'A.Type' for a given 'A.Name' by looking at its definition in the 'CompState'. Dies with an error if the name is unknown.
typeOfName :: (CSMR m, Die m) => A.Name -> m A.Type typeOfName :: (CSMR m, Die m) => A.Name -> m A.Type
typeOfName n typeOfName n
@ -166,6 +176,9 @@ trivialSubscriptType _ (A.Array [d] t) = return t
trivialSubscriptType _ (A.Array (d:ds) t) = return $ A.Array ds t trivialSubscriptType _ (A.Array (d:ds) t) = return $ A.Array ds t
trivialSubscriptType m t = diePC m $ formatCode "not plain array type: %" t trivialSubscriptType m t = diePC m $ formatCode "not plain array type: %" t
instance Typed A.Variable where
astTypeOf = typeOfVariable
-- | Gets the 'A.Type' of a 'A.Variable' by looking at the types recorded in the 'CompState'. -- | Gets the 'A.Type' of a 'A.Variable' by looking at the types recorded in the 'CompState'.
typeOfVariable :: (CSMR m, Die m) => A.Variable -> m A.Type typeOfVariable :: (CSMR m, Die m) => A.Variable -> m A.Type
typeOfVariable (A.Variable m n) = typeOfName n typeOfVariable (A.Variable m n) = typeOfName n
@ -199,6 +212,9 @@ dyadicIsBoolean A.MoreEq = True
dyadicIsBoolean A.After = True dyadicIsBoolean A.After = True
dyadicIsBoolean _ = False dyadicIsBoolean _ = False
instance Typed A.Expression where
astTypeOf = typeOfExpression
-- | Gets the 'A.Type' of an 'A.Expression'. This function assumes that the expression has already been type-checked. -- | Gets the 'A.Type' of an 'A.Expression'. This function assumes that the expression has already been type-checked.
typeOfExpression :: (CSMR m, Die m) => A.Expression -> m A.Type typeOfExpression :: (CSMR m, Die m) => A.Expression -> m A.Type
typeOfExpression e typeOfExpression e

2
frontends/OccamPasses.hs
View File

@ -67,7 +67,7 @@ fixConstructorTypes = applyDepthM doExpression
where where
doExpression :: A.Expression -> PassM A.Expression doExpression :: A.Expression -> PassM A.Expression
doExpression (A.ExprConstr m (A.RepConstr m' _ rep expr)) doExpression (A.ExprConstr m (A.RepConstr m' _ rep expr))
= do t <- typeOfExpression expr = do t <- astTypeOf expr
let count = countReplicator rep let count = countReplicator rep
t' = A.Array [A.Dimension count] t t' = A.Array [A.Dimension count] t
return $ A.ExprConstr m $ A.RepConstr m' t' rep expr return $ A.ExprConstr m $ A.RepConstr m' t' rep expr

90
frontends/OccamTypes.hs
View File

@ -162,7 +162,7 @@ checkList m rawT
-- | Check the type of an expression. -- | Check the type of an expression.
checkExpressionType :: A.Type -> A.Expression -> PassM () checkExpressionType :: A.Type -> A.Expression -> PassM ()
checkExpressionType et e = typeOfExpression e >>= checkType (findMeta e) et checkExpressionType et e = astTypeOf e >>= checkType (findMeta e) et
-- | Check that an expression is of integer type. -- | Check that an expression is of integer type.
checkExpressionInt :: Check A.Expression checkExpressionInt :: Check A.Expression
@ -275,7 +275,7 @@ classifyOp A.Concat = ListOp
-- | Check a monadic operator. -- | Check a monadic operator.
checkMonadicOp :: A.MonadicOp -> A.Expression -> PassM () checkMonadicOp :: A.MonadicOp -> A.Expression -> PassM ()
checkMonadicOp op e checkMonadicOp op e
= do t <- typeOfExpression e = do t <- astTypeOf e
let m = findMeta e let m = findMeta e
case classifyMOp op of case classifyMOp op of
NumericOp -> checkNumeric m t NumericOp -> checkNumeric m t
@ -285,9 +285,9 @@ checkMonadicOp op e
-- | Check a dyadic operator. -- | Check a dyadic operator.
checkDyadicOp :: A.DyadicOp -> A.Expression -> A.Expression -> PassM () checkDyadicOp :: A.DyadicOp -> A.Expression -> A.Expression -> PassM ()
checkDyadicOp op l r checkDyadicOp op l r
= do lt <- typeOfExpression l = do lt <- astTypeOf l
let lm = findMeta l let lm = findMeta l
rt <- typeOfExpression r rt <- astTypeOf r
let rm = findMeta r let rm = findMeta r
case classifyOp op of case classifyOp op of
NumericOp -> NumericOp ->
@ -338,8 +338,8 @@ checkActuals m n fs as
checkActual :: A.Formal -> A.Actual -> PassM () checkActual :: A.Formal -> A.Actual -> PassM ()
checkActual (A.Formal newAM et _) a checkActual (A.Formal newAM et _) a
= do rt <- case a of = do rt <- case a of
A.ActualVariable v -> typeOfVariable v A.ActualVariable v -> astTypeOf v
A.ActualExpression e -> typeOfExpression e A.ActualExpression e -> astTypeOf e
checkType (findMeta a) et rt checkType (findMeta a) et rt
origAM <- case a of origAM <- case a of
A.ActualVariable v -> abbrevModeOfVariable v A.ActualVariable v -> abbrevModeOfVariable v
@ -393,7 +393,7 @@ checkAllocMobile m rawT me
_ -> ok _ -> ok
case me of case me of
Just e -> Just e ->
do et <- typeOfExpression e do et <- astTypeOf e
checkType (findMeta e) innerT et checkType (findMeta e) innerT et
Nothing -> ok Nothing -> ok
_ -> diePC m $ formatCode "Expected mobile type in allocation; found %" t _ -> diePC m $ formatCode "Expected mobile type in allocation; found %" t
@ -414,7 +414,7 @@ checkWritable v
checkChannel :: A.Direction -> A.Variable -> PassM A.Type checkChannel :: A.Direction -> A.Variable -> PassM A.Type
checkChannel wantDir c checkChannel wantDir c
= do -- Check it's a channel. = do -- Check it's a channel.
t <- typeOfVariable c >>= resolveUserType m t <- astTypeOf c >>= resolveUserType m
case t of case t of
A.Chan dir (A.ChanAttributes ws rs) innerT -> A.Chan dir (A.ChanAttributes ws rs) innerT ->
do -- Check the direction is appropriate do -- Check the direction is appropriate
@ -440,7 +440,7 @@ checkChannel wantDir c
-- Return the type of the timer's value. -- Return the type of the timer's value.
checkTimer :: A.Variable -> PassM A.Type checkTimer :: A.Variable -> PassM A.Type
checkTimer tim checkTimer tim
= do t <- typeOfVariable tim >>= resolveUserType m = do t <- astTypeOf tim >>= resolveUserType m
case t of case t of
A.Timer A.OccamTimer -> return A.Int A.Timer A.OccamTimer -> return A.Int
A.Timer A.RainTimer -> return A.Time A.Timer A.RainTimer -> return A.Time
@ -503,7 +503,7 @@ checkExpressionList ets el
dieP m $ "Wrong number of items in expression list; found " dieP m $ "Wrong number of items in expression list; found "
++ (show $ length es) ++ ", expected " ++ (show $ length es) ++ ", expected "
++ (show $ length ets) ++ (show $ length ets)
sequence_ [do rt <- typeOfExpression e sequence_ [do rt <- astTypeOf e
checkType (findMeta e) et rt checkType (findMeta e) et rt
| (e, et) <- zip es ets] | (e, et) <- zip es ets]
@ -522,7 +522,7 @@ checkReplicator (A.For _ _ start count)
= do checkExpressionInt start = do checkExpressionInt start
checkExpressionInt count checkExpressionInt count
checkReplicator (A.ForEach _ _ e) checkReplicator (A.ForEach _ _ e)
= do t <- typeOfExpression e = do t <- astTypeOf e
checkSequence (findMeta e) t checkSequence (findMeta e) t
-- | Check a 'Structured', applying the given check to each item found inside -- | Check a 'Structured', applying the given check to each item found inside
@ -651,8 +651,8 @@ inferTypes = applyX $ baseX
A.Dyadic m op le re -> A.Dyadic m op le re ->
let -- Both types are the same. let -- Both types are the same.
bothSame bothSame
= do lt <- inferTypes le >>= typeOfExpression = do lt <- inferTypes le >>= astTypeOf
rt <- inferTypes re >>= typeOfExpression rt <- inferTypes re >>= astTypeOf
inTypeContext (Just $ betterType lt rt) $ inTypeContext (Just $ betterType lt rt) $
descend outer descend outer
-- The RHS type is always A.Int. -- The RHS type is always A.Int.
@ -676,7 +676,7 @@ inferTypes = applyX $ baseX
Just t -> unsubscriptType s t >>* Just Just t -> unsubscriptType s t >>* Just
Nothing -> return Nothing Nothing -> return Nothing
e' <- inTypeContext ctx' $ inferTypes e e' <- inTypeContext ctx' $ inferTypes e
t <- typeOfExpression e' t <- astTypeOf e'
s' <- inferTypes s >>= fixSubscript t s' <- inferTypes s >>= fixSubscript t
return $ A.SubscriptedExpr m s' e' return $ A.SubscriptedExpr m s' e'
A.BytesInExpr _ _ -> noTypeContext $ descend outer A.BytesInExpr _ _ -> noTypeContext $ descend outer
@ -751,7 +751,7 @@ inferTypes = applyX $ baseX
t' <- inferTypes t t' <- inferTypes t
v' <- inTypeContext (Just t') $ inferTypes v v' <- inTypeContext (Just t') $ inferTypes v
t'' <- case t' of t'' <- case t' of
A.Infer -> typeOfVariable v' A.Infer -> astTypeOf v'
_ -> return t' _ -> return t'
return $ A.Is m am' t'' v' return $ A.Is m am' t'' v'
A.IsExpr m am t e -> A.IsExpr m am t e ->
@ -759,7 +759,7 @@ inferTypes = applyX $ baseX
t' <- inferTypes t t' <- inferTypes t
e' <- inTypeContext (Just t') $ inferTypes e e' <- inTypeContext (Just t') $ inferTypes e
t'' <- case t' of t'' <- case t' of
A.Infer -> typeOfExpression e' A.Infer -> astTypeOf e'
_ -> return t' _ -> return t'
return $ A.IsExpr m am' t'' e' return $ A.IsExpr m am' t'' e'
A.IsChannelArray m t vs -> A.IsChannelArray m t vs ->
@ -770,7 +770,7 @@ inferTypes = applyX $ baseX
let dim = makeDimension m $ length vs' let dim = makeDimension m $ length vs'
t'' <- case (t', vs') of t'' <- case (t', vs') of
(A.Infer, (v:_)) -> (A.Infer, (v:_)) ->
do elemT <- typeOfVariable v do elemT <- astTypeOf v
return $ addDimensions [dim] elemT return $ addDimensions [dim] elemT
(A.Infer, []) -> (A.Infer, []) ->
dieP m "Cannot infer type of empty channel array" dieP m "Cannot infer type of empty channel array"
@ -807,7 +807,7 @@ inferTypes = applyX $ baseX
= case p of = case p of
A.Assign m vs el -> A.Assign m vs el ->
do vs' <- inferTypes vs do vs' <- inferTypes vs
ts <- mapM typeOfVariable vs' ts <- mapM astTypeOf vs'
el' <- doExpressionList ts el el' <- doExpressionList ts el
return $ A.Assign m vs' el' return $ A.Assign m vs' el'
A.Output m v ois -> A.Output m v ois ->
@ -834,7 +834,7 @@ inferTypes = applyX $ baseX
A.If _ _ -> inTypeContext (Just A.Bool) $ descend p A.If _ _ -> inTypeContext (Just A.Bool) $ descend p
A.Case m e so -> A.Case m e so ->
do e' <- inferTypes e do e' <- inferTypes e
t <- typeOfExpression e' t <- astTypeOf e'
so' <- inTypeContext (Just t) $ inferTypes so so' <- inTypeContext (Just t) $ inferTypes so
return $ A.Case m e' so' return $ A.Case m e' so'
A.While _ _ _ -> inTypeContext (Just A.Bool) $ descend p A.While _ _ _ -> inTypeContext (Just A.Bool) $ descend p
@ -876,7 +876,7 @@ inferTypes = applyX $ baseX
doVariable :: ExplicitTrans A.Variable doVariable :: ExplicitTrans A.Variable
doVariable descend (A.SubscriptedVariable m s v) doVariable descend (A.SubscriptedVariable m s v)
= do v' <- inferTypes v = do v' <- inferTypes v
t <- typeOfVariable v' t <- astTypeOf v'
s' <- inferTypes s >>= fixSubscript t s' <- inferTypes s >>= fixSubscript t
return $ A.SubscriptedVariable m s' v' return $ A.SubscriptedVariable m s' v'
doVariable descend v = descend v doVariable descend v = descend v
@ -961,7 +961,7 @@ inferTypes = applyX $ baseX
-- An expression: descend into it with the right context. -- An expression: descend into it with the right context.
doArrayElem wantT (A.ArrayElemExpr e) doArrayElem wantT (A.ArrayElemExpr e)
= do e' <- inTypeContext (Just wantT) $ doExpression descend e = do e' <- inTypeContext (Just wantT) $ doExpression descend e
t <- typeOfExpression e' t <- astTypeOf e'
checkType (findMeta e') wantT t checkType (findMeta e') wantT t
return (t, A.ArrayElemExpr e') return (t, A.ArrayElemExpr e')
@ -1019,15 +1019,15 @@ checkVariables = checkDepthM doVariable
where where
doVariable :: Check A.Variable doVariable :: Check A.Variable
doVariable (A.SubscriptedVariable m s v) doVariable (A.SubscriptedVariable m s v)
= do t <- typeOfVariable v = do t <- astTypeOf v
checkSubscript m s t checkSubscript m s t
doVariable (A.DirectedVariable m _ v) doVariable (A.DirectedVariable m _ v)
= do t <- typeOfVariable v >>= resolveUserType m = do t <- astTypeOf v >>= resolveUserType m
case t of case t of
A.Chan _ _ _ -> ok A.Chan _ _ _ -> ok
_ -> dieP m $ "Direction applied to non-channel variable" _ -> dieP m $ "Direction applied to non-channel variable"
doVariable (A.DerefVariable m v) doVariable (A.DerefVariable m v)
= do t <- typeOfVariable v >>= resolveUserType m = do t <- astTypeOf v >>= resolveUserType m
case t of case t of
A.Mobile _ -> ok A.Mobile _ -> ok
_ -> dieP m $ "Dereference applied to non-mobile variable" _ -> dieP m $ "Dereference applied to non-mobile variable"
@ -1046,13 +1046,13 @@ checkExpressions = checkDepthM doExpression
doExpression (A.MostNeg m t) = checkNumeric m t doExpression (A.MostNeg m t) = checkNumeric m t
doExpression (A.SizeType m t) = checkSequence m t doExpression (A.SizeType m t) = checkSequence m t
doExpression (A.SizeExpr m e) doExpression (A.SizeExpr m e)
= do t <- typeOfExpression e = do t <- astTypeOf e
checkSequence m t checkSequence m t
doExpression (A.SizeVariable m v) doExpression (A.SizeVariable m v)
= do t <- typeOfVariable v = do t <- astTypeOf v
checkSequence m t checkSequence m t
doExpression (A.Conversion m _ t e) doExpression (A.Conversion m _ t e)
= do et <- typeOfExpression e = do et <- astTypeOf e
checkScalar m t >> checkScalar (findMeta e) et checkScalar m t >> checkScalar (findMeta e) et
doExpression (A.Literal m t lr) = doLiteralRepr t lr doExpression (A.Literal m t lr) = doLiteralRepr t lr
doExpression (A.FunctionCall m n es) doExpression (A.FunctionCall m n es)
@ -1062,7 +1062,7 @@ checkExpressions = checkDepthM doExpression
doExpression (A.IntrinsicFunctionCall m s es) doExpression (A.IntrinsicFunctionCall m s es)
= checkIntrinsicFunctionCall m s es = checkIntrinsicFunctionCall m s es
doExpression (A.SubscriptedExpr m s e) doExpression (A.SubscriptedExpr m s e)
= do t <- typeOfExpression e = do t <- astTypeOf e
checkSubscript m s t checkSubscript m s t
doExpression (A.OffsetOf m rawT n) doExpression (A.OffsetOf m rawT n)
= do t <- resolveUserType m rawT = do t <- resolveUserType m rawT
@ -1098,13 +1098,13 @@ checkSpecTypes = checkDepthM doSpecType
doSpecType (A.Place _ e) = checkExpressionInt e doSpecType (A.Place _ e) = checkExpressionInt e
doSpecType (A.Declaration _ _) = ok doSpecType (A.Declaration _ _) = ok
doSpecType (A.Is m am t v) doSpecType (A.Is m am t v)
= do tv <- typeOfVariable v = do tv <- astTypeOf v
checkType (findMeta v) t tv checkType (findMeta v) t tv
when (am /= A.Abbrev) $ unexpectedAM m when (am /= A.Abbrev) $ unexpectedAM m
amv <- abbrevModeOfVariable v amv <- abbrevModeOfVariable v
checkAbbrev m amv am checkAbbrev m amv am
doSpecType (A.IsExpr m am t e) doSpecType (A.IsExpr m am t e)
= do te <- typeOfExpression e = do te <- astTypeOf e
checkType (findMeta e) t te checkType (findMeta e) t te
when (am /= A.ValAbbrev) $ unexpectedAM m when (am /= A.ValAbbrev) $ unexpectedAM m
checkAbbrev m A.ValAbbrev am checkAbbrev m A.ValAbbrev am
@ -1112,7 +1112,7 @@ checkSpecTypes = checkDepthM doSpecType
= do t <- resolveUserType m rawT = do t <- resolveUserType m rawT
case t of case t of
A.Array [d] et@(A.Chan _ _ _) -> A.Array [d] et@(A.Chan _ _ _) ->
do sequence_ [do rt <- typeOfVariable c do sequence_ [do rt <- astTypeOf c
checkType (findMeta c) et rt checkType (findMeta c) et rt
am <- abbrevModeOfVariable c am <- abbrevModeOfVariable c
checkAbbrev m am A.Abbrev checkAbbrev m am A.Abbrev
@ -1158,10 +1158,10 @@ checkSpecTypes = checkDepthM doSpecType
-- FIXME: Need to know the name of the function to do this -- FIXME: Need to know the name of the function to do this
doFunctionBody rs (Right p) = dieP m "Cannot check function process body" doFunctionBody rs (Right p) = dieP m "Cannot check function process body"
doSpecType (A.Retypes m _ t v) doSpecType (A.Retypes m _ t v)
= do fromT <- typeOfVariable v = do fromT <- astTypeOf v
checkRetypes m fromT t checkRetypes m fromT t
doSpecType (A.RetypesExpr m _ t e) doSpecType (A.RetypesExpr m _ t e)
= do fromT <- typeOfExpression e = do fromT <- astTypeOf e
checkRetypes m fromT t checkRetypes m fromT t
unexpectedAM :: Check Meta unexpectedAM :: Check Meta
@ -1177,7 +1177,7 @@ checkProcesses = checkDepthM doProcess
doProcess (A.Assign m vs el) doProcess (A.Assign m vs el)
-- We ignore dimensions here because we do the check at runtime. -- We ignore dimensions here because we do the check at runtime.
-- (That is, [2]INT := []INT is legal.) -- (That is, [2]INT := []INT is legal.)
= do vts <- sequence [typeOfVariable v >>* removeFixedDimensions = do vts <- sequence [astTypeOf v >>* removeFixedDimensions
| v <- vs] | v <- vs]
mapM_ checkWritable vs mapM_ checkWritable vs
checkExpressionList vts el checkExpressionList vts el
@ -1185,7 +1185,7 @@ checkProcesses = checkDepthM doProcess
doProcess (A.Output m v ois) = doOutput m v ois doProcess (A.Output m v ois) = doOutput m v ois
doProcess (A.OutputCase m v tag ois) = doOutputCase m v tag ois doProcess (A.OutputCase m v tag ois) = doOutputCase m v tag ois
doProcess (A.ClearMobile _ v) doProcess (A.ClearMobile _ v)
= do t <- typeOfVariable v = do t <- astTypeOf v
case t of case t of
A.Mobile _ -> ok A.Mobile _ -> ok
_ -> diePC (findMeta v) $ formatCode "Expected mobile type; found %" t _ -> diePC (findMeta v) $ formatCode "Expected mobile type; found %" t
@ -1195,7 +1195,7 @@ checkProcesses = checkDepthM doProcess
doProcess (A.Seq _ s) = checkStructured (\p -> ok) s doProcess (A.Seq _ s) = checkStructured (\p -> ok) s
doProcess (A.If _ s) = checkStructured doChoice s doProcess (A.If _ s) = checkStructured doChoice s
doProcess (A.Case _ e s) doProcess (A.Case _ e s)
= do t <- typeOfExpression e = do t <- astTypeOf e
checkCaseable (findMeta e) t checkCaseable (findMeta e) t
checkStructured (doOption t) s checkStructured (doOption t) s
doProcess (A.While _ e _) = checkExpressionBool e doProcess (A.While _ e _) = checkExpressionBool e
@ -1242,25 +1242,25 @@ checkProcesses = checkDepthM doProcess
doInputItem t ii doInputItem t ii
doInput c (A.InputTimerAfter m e) doInput c (A.InputTimerAfter m e)
= do t <- checkTimer c = do t <- checkTimer c
et <- typeOfExpression e et <- astTypeOf e
checkType (findMeta e) t et checkType (findMeta e) t et
doInput c (A.InputTimerFor m e) doInput c (A.InputTimerFor m e)
= do t <- checkTimer c = do t <- checkTimer c
et <- typeOfExpression e et <- astTypeOf e
checkType (findMeta e) t et checkType (findMeta e) t et
doInputItem :: A.Type -> A.InputItem -> PassM () doInputItem :: A.Type -> A.InputItem -> PassM ()
doInputItem (A.Counted wantCT wantAT) (A.InCounted m cv av) doInputItem (A.Counted wantCT wantAT) (A.InCounted m cv av)
= do ct <- typeOfVariable cv = do ct <- astTypeOf cv
checkType (findMeta cv) wantCT ct checkType (findMeta cv) wantCT ct
checkWritable cv checkWritable cv
at <- typeOfVariable av at <- astTypeOf av
checkType (findMeta cv) wantAT at checkType (findMeta cv) wantAT at
checkWritable av checkWritable av
doInputItem t@(A.Counted _ _) (A.InVariable m v) doInputItem t@(A.Counted _ _) (A.InVariable m v)
= diePC m $ formatCode "Expected counted item of type %; found %" t v = diePC m $ formatCode "Expected counted item of type %; found %" t v
doInputItem wantT (A.InVariable _ v) doInputItem wantT (A.InVariable _ v)
= do t <- typeOfVariable v = do t <- astTypeOf v
case wantT of case wantT of
A.Any -> checkCommunicable (findMeta v) t A.Any -> checkCommunicable (findMeta v) t
_ -> checkType (findMeta v) wantT t _ -> checkType (findMeta v) wantT t
@ -1268,7 +1268,7 @@ checkProcesses = checkDepthM doProcess
doOption :: A.Type -> A.Option -> PassM () doOption :: A.Type -> A.Option -> PassM ()
doOption et (A.Option _ es _) doOption et (A.Option _ es _)
= sequence_ [do rt <- typeOfExpression e = sequence_ [do rt <- astTypeOf e
checkType (findMeta e) et rt checkType (findMeta e) et rt
| e <- es] | e <- es]
doOption _ (A.Else _ _) = ok doOption _ (A.Else _ _) = ok
@ -1285,14 +1285,14 @@ checkProcesses = checkDepthM doProcess
doOutputItem :: A.Type -> A.OutputItem -> PassM () doOutputItem :: A.Type -> A.OutputItem -> PassM ()
doOutputItem (A.Counted wantCT wantAT) (A.OutCounted m ce ae) doOutputItem (A.Counted wantCT wantAT) (A.OutCounted m ce ae)
= do ct <- typeOfExpression ce = do ct <- astTypeOf ce
checkType (findMeta ce) wantCT ct checkType (findMeta ce) wantCT ct
at <- typeOfExpression ae at <- astTypeOf ae
checkType (findMeta ae) wantAT at checkType (findMeta ae) wantAT at
doOutputItem t@(A.Counted _ _) (A.OutExpression m e) doOutputItem t@(A.Counted _ _) (A.OutExpression m e)
= diePC m $ formatCode "Expected counted item of type %; found %" t e = diePC m $ formatCode "Expected counted item of type %; found %" t e
doOutputItem wantT (A.OutExpression _ e) doOutputItem wantT (A.OutExpression _ e)
= do t <- typeOfExpression e = do t <- astTypeOf e
case wantT of case wantT of
A.Any -> checkCommunicable (findMeta e) t A.Any -> checkCommunicable (findMeta e) t
_ -> checkType (findMeta e) wantT t _ -> checkType (findMeta e) wantT t

2
frontends/RainPasses.hs
View File

@ -265,7 +265,7 @@ pullUpForEach = doGeneric `ext1M` doStructured
doStructured (A.Rep m (A.ForEach m' loopVar loopExp) s) doStructured (A.Rep m (A.ForEach m' loopVar loopExp) s)
= do (extra, loopExp') <- case loopExp of = do (extra, loopExp') <- case loopExp of
A.ExprVariable {} -> return (id, loopExp) A.ExprVariable {} -> return (id, loopExp)
_ -> do t <- typeOfExpression loopExp _ -> do t <- astTypeOf loopExp
spec@(A.Specification _ n _) <- makeNonceIsExpr spec@(A.Specification _ n _) <- makeNonceIsExpr
"loop_expr" m' t loopExp "loop_expr" m' t loopExp
return (A.Spec m' spec, A.ExprVariable m' (A.Variable m' n)) return (A.Spec m' spec, A.ExprVariable m' (A.Variable m' n))

42
frontends/RainTypes.hs
View File

@ -38,7 +38,7 @@ recordInfNameTypes = everywhereM (mkM recordInfNameTypes')
where where
recordInfNameTypes' :: A.Replicator -> PassM A.Replicator recordInfNameTypes' :: A.Replicator -> PassM A.Replicator
recordInfNameTypes' input@(A.ForEach m n e) recordInfNameTypes' input@(A.ForEach m n e)
= do arrType <- typeOfExpression e = do arrType <- astTypeOf e
innerT <- case arrType of innerT <- case arrType of
A.List t -> return t A.List t -> return t
_ -> diePC m $ formatCode "Cannot do a foreach loop over a non-list type: %" arrType _ -> diePC m $ formatCode "Cannot do a foreach loop over a non-list type: %" arrType
@ -94,7 +94,7 @@ annotateListLiteralTypes = applyDepthM doExpression
where where
doExpression :: A.Expression -> PassM A.Expression doExpression :: A.Expression -> PassM A.Expression
doExpression (A.Literal m _ (A.ListLiteral m' es)) doExpression (A.Literal m _ (A.ListLiteral m' es))
= do ts <- mapM typeOfExpression es = do ts <- mapM astTypeOf es
sharedT <- case (ts, leastGeneralSharedTypeRain ts) of sharedT <- case (ts, leastGeneralSharedTypeRain ts) of
(_, Just t) -> return t (_, Just t) -> return t
([], Nothing) -> return A.Any ([], Nothing) -> return A.Any
@ -105,8 +105,8 @@ annotateListLiteralTypes = applyDepthM doExpression
es' <- mapM (coerceIfNecessary sharedT) (zip ts es) es' <- mapM (coerceIfNecessary sharedT) (zip ts es)
return $ A.Literal m (A.List sharedT) $ A.ListLiteral m' es' return $ A.Literal m (A.List sharedT) $ A.ListLiteral m' es'
doExpression (A.ExprConstr m (A.RangeConstr m' t b e)) doExpression (A.ExprConstr m (A.RangeConstr m' t b e))
= do bt <- typeOfExpression b = do bt <- astTypeOf b
et <- typeOfExpression e et <- astTypeOf e
sharedT <- case leastGeneralSharedTypeRain [bt, et] of sharedT <- case leastGeneralSharedTypeRain [bt, et] of
Just t -> return t Just t -> return t
Nothing -> diePC m' Nothing -> diePC m'
@ -161,7 +161,7 @@ matchParamPass = everywhereM ((mkM matchParamPassProc) `extM` matchParamPassFunc
--Checks the type of a parameter (A.Actual), and inserts a cast if it is safe to do so --Checks the type of a parameter (A.Actual), and inserts a cast if it is safe to do so
doParam :: Meta -> String -> (Int,A.Formal, A.Actual) -> PassM A.Actual doParam :: Meta -> String -> (Int,A.Formal, A.Actual) -> PassM A.Actual
doParam m n (index, A.Formal formalAbbrev formalType formalName, A.ActualVariable v) doParam m n (index, A.Formal formalAbbrev formalType formalName, A.ActualVariable v)
= do actualType <- typeOfVariable v = do actualType <- astTypeOf v
if (actualType == formalType) if (actualType == formalType)
then return $ A.ActualVariable v then return $ A.ActualVariable v
else (liftM A.ActualExpression) $ doCast index formalType actualType (A.ExprVariable (findMeta v) v ) else (liftM A.ActualExpression) $ doCast index formalType actualType (A.ExprVariable (findMeta v) v )
@ -171,7 +171,7 @@ matchParamPass = everywhereM ((mkM matchParamPassProc) `extM` matchParamPassFunc
--Checks the type of a parameter (A.Expression), and inserts a cast if it is safe to do so --Checks the type of a parameter (A.Expression), and inserts a cast if it is safe to do so
doExpParam :: Meta -> String -> (Int, A.Formal, A.Expression) -> PassM A.Expression doExpParam :: Meta -> String -> (Int, A.Formal, A.Expression) -> PassM A.Expression
doExpParam m n (index, A.Formal formalAbbrev formalType formalName, e) doExpParam m n (index, A.Formal formalAbbrev formalType formalName, e)
= do actualType <- typeOfExpression e = do actualType <- astTypeOf e
if (actualType == formalType) if (actualType == formalType)
then return e then return e
else doCast index formalType actualType e else doCast index formalType actualType e
@ -210,8 +210,8 @@ checkExpressionTypes = applyDepthM checkExpression
checkExpression :: A.Expression -> PassM A.Expression checkExpression :: A.Expression -> PassM A.Expression
checkExpression e@(A.Dyadic m op lhs rhs) checkExpression e@(A.Dyadic m op lhs rhs)
= do tlhs <- typeOfExpression lhs = do tlhs <- astTypeOf lhs
trhs <- typeOfExpression rhs trhs <- astTypeOf rhs
if (tlhs == A.Time || trhs == A.Time) if (tlhs == A.Time || trhs == A.Time)
-- Expressions with times can have asymmetric types, -- Expressions with times can have asymmetric types,
-- so we handle them specially: -- so we handle them specially:
@ -242,7 +242,7 @@ checkExpressionTypes = applyDepthM checkExpression
else --The operands are not equal, and are not integers, and neither of them is a time type. Therefore this must be an error: else --The operands are not equal, and are not integers, and neither of them is a time type. Therefore this must be an error:
diePC m $ formatCode "Mis-matched types; no operator applies to types: % and %" tlhs trhs diePC m $ formatCode "Mis-matched types; no operator applies to types: % and %" tlhs trhs
checkExpression e@(A.Monadic m op rhs) checkExpression e@(A.Monadic m op rhs)
= do trhs <- typeOfExpression rhs = do trhs <- astTypeOf rhs
if (op == A.MonadicMinus) if (op == A.MonadicMinus)
then case trhs of then case trhs of
A.Byte -> return $ A.Monadic m op $ convert A.Int16 trhs rhs A.Byte -> return $ A.Monadic m op $ convert A.Int16 trhs rhs
@ -257,7 +257,7 @@ checkExpressionTypes = applyDepthM checkExpression
_ -> diePC m $ formatCode "Cannot apply unary not to non-boolean type: %" trhs _ -> diePC m $ formatCode "Cannot apply unary not to non-boolean type: %" trhs
else dieP m $ "Invalid Rain operator: \"" ++ show op ++ "\"" else dieP m $ "Invalid Rain operator: \"" ++ show op ++ "\""
checkExpression e@(A.Conversion m cm dest rhs) checkExpression e@(A.Conversion m cm dest rhs)
= do src <- typeOfExpression rhs = do src <- astTypeOf rhs
if (src == dest) if (src == dest)
then return e then return e
else if isImplicitConversionRain src dest else if isImplicitConversionRain src dest
@ -306,8 +306,8 @@ checkAssignmentTypes = applyDepthM checkAssignment
where where
checkAssignment :: A.Process -> PassM A.Process checkAssignment :: A.Process -> PassM A.Process
checkAssignment ass@(A.Assign m [v] (A.ExpressionList m' [e])) checkAssignment ass@(A.Assign m [v] (A.ExpressionList m' [e]))
= do trhs <- typeOfExpression e = do trhs <- astTypeOf e
tlhs <- typeOfVariable v tlhs <- astTypeOf v
am <- abbrevModeOfVariable v am <- abbrevModeOfVariable v
when (am == A.ValAbbrev) $ when (am == A.ValAbbrev) $
diePC m $ formatCode "Cannot assign to a constant variable: %" v diePC m $ formatCode "Cannot assign to a constant variable: %" v
@ -324,7 +324,7 @@ checkConditionalTypes = applyDepthM2 checkWhile checkIf
where where
checkWhile :: A.Process -> PassM A.Process checkWhile :: A.Process -> PassM A.Process
checkWhile w@(A.While m exp _) checkWhile w@(A.While m exp _)
= do t <- typeOfExpression exp = do t <- astTypeOf exp
if (t == A.Bool) if (t == A.Bool)
then return w then return w
else dieP m "Expression in while conditional must be of boolean type" else dieP m "Expression in while conditional must be of boolean type"
@ -332,7 +332,7 @@ checkConditionalTypes = applyDepthM2 checkWhile checkIf
checkIf :: A.Choice -> PassM A.Choice checkIf :: A.Choice -> PassM A.Choice
checkIf c@(A.Choice m exp _) checkIf c@(A.Choice m exp _)
= do t <- typeOfExpression exp = do t <- astTypeOf exp
if (t == A.Bool) if (t == A.Bool)
then return c then return c
else dieP m "Expression in if conditional must be of boolean type" else dieP m "Expression in if conditional must be of boolean type"
@ -343,8 +343,8 @@ checkCommTypes = applyDepthM2 checkInputOutput checkAltInput
where where
checkInput :: A.Variable -> A.Variable -> Meta -> a -> PassM a checkInput :: A.Variable -> A.Variable -> Meta -> a -> PassM a
checkInput chanVar destVar m p checkInput chanVar destVar m p
= do chanType <- typeOfVariable chanVar = do chanType <- astTypeOf chanVar
destType <- typeOfVariable destVar destType <- astTypeOf destVar
case chanType of case chanType of
A.Chan dir _ innerType -> A.Chan dir _ innerType ->
if (dir == A.DirOutput) if (dir == A.DirOutput)
@ -358,17 +358,17 @@ checkCommTypes = applyDepthM2 checkInputOutput checkAltInput
checkWait :: A.InputMode -> PassM () checkWait :: A.InputMode -> PassM ()
checkWait (A.InputTimerFor m exp) checkWait (A.InputTimerFor m exp)
= do t <- typeOfExpression exp = do t <- astTypeOf exp
when (t /= A.Time) $ when (t /= A.Time) $
diePC m $ formatCode "Tried to wait for something that was not of time type: %" diePC m $ formatCode "Tried to wait for something that was not of time type: %"
t t
checkWait (A.InputTimerAfter m exp) checkWait (A.InputTimerAfter m exp)
= do t <- typeOfExpression exp = do t <- astTypeOf exp
when (t /= A.Time) $ when (t /= A.Time) $
diePC m $ formatCode "Tried to wait for something that was not of time type: %" diePC m $ formatCode "Tried to wait for something that was not of time type: %"
t t
checkWait (A.InputTimerRead m (A.InVariable _ v)) checkWait (A.InputTimerRead m (A.InVariable _ v))
= do t <- typeOfVariable v = do t <- astTypeOf v
when (t /= A.Time) $ when (t /= A.Time) $
diePC m $ formatCode "Tried to wait for something that was not of time type: %" diePC m $ formatCode "Tried to wait for something that was not of time type: %"
t t
@ -387,8 +387,8 @@ checkCommTypes = applyDepthM2 checkInputOutput checkAltInput
= do checkWait im = do checkWait im
return p return p
checkInputOutput p@(A.Output m chanVar [A.OutExpression m' srcExp]) checkInputOutput p@(A.Output m chanVar [A.OutExpression m' srcExp])
= do chanType <- typeOfVariable chanVar = do chanType <- astTypeOf chanVar
srcType <- typeOfExpression srcExp srcType <- astTypeOf srcExp
case chanType of case chanType of
A.Chan dir _ innerType -> A.Chan dir _ innerType ->
if (dir == A.DirInput) if (dir == A.DirInput)

4
frontends/RainTypesTest.hs
View File

@ -442,14 +442,14 @@ checkExpressionTest = TestList
check t e check t e
= do eot <- errorOrType = do eot <- errorOrType
case eot of case eot of
Left err -> assertFailure ("checkExpressionTest " ++ show n ++ " typeOfExpression failed") Left err -> assertFailure ("checkExpressionTest " ++ show n ++ " astTypeOf failed")
Right t' -> do assertEqual ("checkExpressionTest " ++ show n) t t' Right t' -> do assertEqual ("checkExpressionTest " ++ show n) t t'
--Now feed it through again, to make sure it isn't changed: --Now feed it through again, to make sure it isn't changed:
if (e /= act) then pass' (10000 + n) t (mkPattern e) e else return () if (e /= act) then pass' (10000 + n) t (mkPattern e) e else return ()
where where
errorOrType :: IO (Either ErrorReport A.Type) errorOrType :: IO (Either ErrorReport A.Type)
errorOrType errorOrType
= (flip runPassM (typeOfExpression e) (execState state emptyState)) = (flip runPassM (astTypeOf e) (execState state emptyState))
>>* \(x,_,_) -> x >>* \(x,_,_) -> x

2
pass/Properties.hs
View File

@ -306,7 +306,7 @@ findAssignVars _ = []
filterArrayAndRecord :: (CSMR m, Die m) => A.Variable -> m Bool filterArrayAndRecord :: (CSMR m, Die m) => A.Variable -> m Bool
filterArrayAndRecord v filterArrayAndRecord v
= do t <- typeOfVariable v = do t <- astTypeOf v
return $ case t of return $ case t of
A.Array {} -> True A.Array {} -> True
A.Record {} -> True A.Record {} -> True

2
transformations/SimplifyComms.hs
View File

@ -69,7 +69,7 @@ outExprs = doGeneric `extM` doProcess
return (A.ExprVariable m $ A.Variable m nm, spec) return (A.ExprVariable m $ A.Variable m nm, spec)
abbrevExpr :: Meta -> A.Expression -> PassM (A.Name, A.Structured A.Process -> A.Structured A.Process) abbrevExpr :: Meta -> A.Expression -> PassM (A.Name, A.Structured A.Process -> A.Structured A.Process)
abbrevExpr m e = do t <- typeOfExpression e abbrevExpr m e = do t <- astTypeOf e
specification@(A.Specification _ nm _) <- defineNonce m "output_var" (A.IsExpr m A.ValAbbrev t e) A.VariableName A.ValAbbrev specification@(A.Specification _ nm _) <- defineNonce m "output_var" (A.IsExpr m A.ValAbbrev t e) A.VariableName A.ValAbbrev
return (nm, A.Spec m specification) return (nm, A.Spec m specification)

16
transformations/SimplifyExprs.hs
View File

@ -111,7 +111,7 @@ removeAfter = doGeneric `extM` doExpression
doExpression (A.Dyadic m A.After a b) doExpression (A.Dyadic m A.After a b)
= do a' <- removeAfter a = do a' <- removeAfter a
b' <- removeAfter b b' <- removeAfter b
t <- typeOfExpression a' t <- astTypeOf a'
case t of case t of
A.Byte -> do let one = A.Literal m t $ A.IntLiteral m "1" A.Byte -> do let one = A.Literal m t $ A.IntLiteral m "1"
oneTwoSeven = A.Literal m t $ A.IntLiteral m "127" oneTwoSeven = A.Literal m t $ A.IntLiteral m "127"
@ -130,7 +130,7 @@ expandArrayLiterals = doGeneric `extM` doArrayElem
doArrayElem :: A.ArrayElem -> PassM A.ArrayElem doArrayElem :: A.ArrayElem -> PassM A.ArrayElem
doArrayElem ae@(A.ArrayElemExpr e) doArrayElem ae@(A.ArrayElemExpr e)
= do e' <- expandArrayLiterals e = do e' <- expandArrayLiterals e
t <- typeOfExpression e' t <- astTypeOf e'
case t of case t of
A.Array ds _ -> expand ds e A.Array ds _ -> expand ds e
_ -> doGeneric ae _ -> doGeneric ae
@ -181,7 +181,7 @@ pullRepCounts = doGeneric `extM` doProcess
return $ A.ProcThen m p' s' return $ A.ProcThen m p' s'
pullRepCountSeq (A.Several m ss) = mapM pullRepCountSeq ss >>* A.Several m pullRepCountSeq (A.Several m ss) = mapM pullRepCountSeq ss >>* A.Several m
pullRepCountSeq (A.Rep m (A.For m' n from for) s) pullRepCountSeq (A.Rep m (A.For m' n from for) s)
= do t <- typeOfExpression for = do t <- astTypeOf for
spec@(A.Specification _ nonceName _) <- makeNonceIsExpr "rep_for" m' t for spec@(A.Specification _ nonceName _) <- makeNonceIsExpr "rep_for" m' t for
s' <- pullRepCountSeq s s' <- pullRepCountSeq s
return $ A.Spec m spec $ A.Rep m (A.For m' n from (A.ExprVariable m' $ A.Variable m' nonceName)) s' return $ A.Spec m spec $ A.Rep m (A.For m' n from (A.ExprVariable m' $ A.Variable m' nonceName)) s'
@ -319,7 +319,7 @@ pullUp pullUpArraysInsideRecords
-- Convert RetypesExpr into Retypes of a variable. -- Convert RetypesExpr into Retypes of a variable.
doSpecification (A.Specification m n (A.RetypesExpr m' am toT e)) doSpecification (A.Specification m n (A.RetypesExpr m' am toT e))
= do e' <- doExpression e = do e' <- doExpression e
fromT <- typeOfExpression e' fromT <- astTypeOf e'
spec@(A.Specification _ n' _) <- makeNonceIsExpr "retypes_expr" m' fromT e' spec@(A.Specification _ n' _) <- makeNonceIsExpr "retypes_expr" m' fromT e'
addPulled $ (m', Left spec) addPulled $ (m', Left spec)
return $ A.Specification m n (A.Retypes m' am toT (A.Variable m' n')) return $ A.Specification m n (A.Retypes m' am toT (A.Variable m' n'))
@ -339,7 +339,7 @@ pullUp pullUpArraysInsideRecords
doExpression :: A.Expression -> PassM A.Expression doExpression :: A.Expression -> PassM A.Expression
doExpression e doExpression e
= do e' <- doExpression' e = do e' <- doExpression' e
t <- typeOfExpression e' t <- astTypeOf e'
case t of case t of
A.Array _ _ -> A.Array _ _ ->
case e' of case e' of
@ -360,7 +360,7 @@ pullUp pullUpArraysInsideRecords
doVariable :: A.Variable -> PassM A.Variable doVariable :: A.Variable -> PassM A.Variable
doVariable v@(A.SubscriptedVariable m _ _) doVariable v@(A.SubscriptedVariable m _ _)
= do v' <- doGeneric v = do v' <- doGeneric v
t <- typeOfVariable v' t <- astTypeOf v'
case t of case t of
A.Array _ _ -> A.Array _ _ ->
do origAM <- abbrevModeOfVariable v' do origAM <- abbrevModeOfVariable v'
@ -375,7 +375,7 @@ pullUp pullUpArraysInsideRecords
convertFuncCall :: Meta -> A.Name -> [A.Expression] -> PassM [A.Variable] convertFuncCall :: Meta -> A.Name -> [A.Expression] -> PassM [A.Variable]
convertFuncCall m n es convertFuncCall m n es
= do es' <- pullUpRecur es = do es' <- pullUpRecur es
ets <- sequence [typeOfExpression e | e <- es'] ets <- sequence [astTypeOf e | e <- es']
ps <- get ps <- get
rts <- Map.lookup (A.nameName n) (csFunctionReturns ps) rts <- Map.lookup (A.nameName n) (csFunctionReturns ps)
@ -398,7 +398,7 @@ pullUp pullUpArraysInsideRecords
doExpression' (A.SubscriptedExpr m s e) doExpression' (A.SubscriptedExpr m s e)
= do e' <- pullUpRecur e = do e' <- pullUpRecur e
s' <- pullUpRecur s s' <- pullUpRecur s
t <- typeOfExpression e' t <- astTypeOf e'
spec@(A.Specification _ n _) <- makeNonceIsExpr "subscripted_expr" m t e' spec@(A.Specification _ n _) <- makeNonceIsExpr "subscripted_expr" m t e'
addPulled $ (m, Left spec) addPulled $ (m, Left spec)
return $ A.ExprVariable m (A.SubscriptedVariable m s' (A.Variable m n)) return $ A.ExprVariable m (A.SubscriptedVariable m s' (A.Variable m n))

4
transformations/SimplifyProcs.hs
View File

@ -81,7 +81,7 @@ removeParAssign = doGeneric `extM` doProcess
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es)) doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es))
= do ts <- mapM typeOfVariable vs = do ts <- mapM astTypeOf vs
specs <- sequence [makeNonceVariable "assign_temp" m t A.VariableName A.Original | t <- ts] specs <- sequence [makeNonceVariable "assign_temp" m t A.VariableName A.Original | t <- ts]
let temps = [A.Variable m n | A.Specification _ n _ <- specs] let temps = [A.Variable m n | A.Specification _ n _ <- specs]
let first = [A.Assign m [v] (A.ExpressionList m [e]) | (v, e) <- zip temps es] let first = [A.Assign m [v] (A.ExpressionList m [e]) | (v, e) <- zip temps es]
@ -98,7 +98,7 @@ flattenAssign = doGeneric `extM` doProcess `ext1M` doStructured
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess (A.Assign m [v] (A.ExpressionList m' [e])) doProcess (A.Assign m [v] (A.ExpressionList m' [e]))
= do t <- typeOfVariable v = do t <- astTypeOf v
assign m t v m' e assign m t v m' e
doProcess p = doGeneric p doProcess p = doGeneric p

2
transformations/Unnest.hs
View File

@ -131,7 +131,7 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
-- Don't bother with constants -- they get pulled up anyway. -- Don't bother with constants -- they get pulled up anyway.
freeNames <- filterM (liftM not . isConstantName) freeNames'' freeNames <- filterM (liftM not . isConstantName) freeNames''
types <- mapM typeOfName freeNames types <- mapM astTypeOf freeNames
origAMs <- mapM abbrevModeOfName freeNames origAMs <- mapM abbrevModeOfName freeNames
let ams = map makeAbbrevAM origAMs let ams = map makeAbbrevAM origAMs