diff --git a/Makefile.am b/Makefile.am
index b14854d..569e8f2 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -181,6 +181,7 @@ tocktest_SOURCES += frontends/RainPassesTest.hs
tocktest_SOURCES += frontends/RainTypesTest.hs
tocktest_SOURCES += frontends/StructureOccamTest.hs
tocktest_SOURCES += transformations/PassTest.hs
+tocktest_SOURCES += transformations/SimplifyAbbrevsTest.hs
pregen_sources = data/AST.hs
pregen_sources += pregen/PregenUtils.hs
diff --git a/TestMain.hs b/TestMain.hs
index 9d0fab8..f7335c3 100644
--- a/TestMain.hs
+++ b/TestMain.hs
@@ -44,6 +44,8 @@ with this program. If not, see .
--
-- * "RainTypesTest"
--
+-- * "SimplifyAbbrevsTest"
+--
-- * "StructureOccamTest"
--
-- * "UsageCheckTest"
@@ -70,6 +72,7 @@ import qualified PassTest (tests)
import qualified PreprocessOccamTest (tests)
import qualified RainPassesTest (tests)
import qualified RainTypesTest (ioTests)
+import qualified SimplifyAbbrevsTest (tests)
import qualified StructureOccamTest (tests)
import qualified UsageCheckTest (tests)
import TestUtils
@@ -187,6 +190,7 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options
,noqc PreprocessOccamTest.tests
,noqc RainPassesTest.tests
,noqcButIO RainTypesTest.ioTests
+ ,noqc SimplifyAbbrevsTest.tests
,noqc StructureOccamTest.tests
,noqc UsageCheckTest.tests
]
diff --git a/testcases/initial.occ b/testcases/initial.occ
index 7f73e0a..3a42233 100644
--- a/testcases/initial.occ
+++ b/testcases/initial.occ
@@ -1,6 +1,6 @@
PROC P ()
INITIAL INT x IS 1234:
- INITIAL []BYTE cs IS "hello, world":
+ INITIAL [12]BYTE cs IS "hello, world":
SEQ
SEQ i = 0 FOR SIZE cs
cs[i] := 'A'
diff --git a/transformations/SimplifyAbbrevs.hs b/transformations/SimplifyAbbrevs.hs
index f438f56..4a0c92b 100644
--- a/transformations/SimplifyAbbrevs.hs
+++ b/transformations/SimplifyAbbrevs.hs
@@ -17,12 +17,21 @@ with this program. If not, see .
-}
-- | Simplify abbreviations.
-module SimplifyAbbrevs (simplifyAbbrevs) where
+module SimplifyAbbrevs (
+ simplifyAbbrevs
+ , removeInitial
+ , removeResult
+ ) where
+
+import Data.Generics
import qualified AST as A
+import CompState
+import Metadata
import Pass
import qualified Properties as Prop
import Traversal
+import Utils
simplifyAbbrevs :: [Pass]
simplifyAbbrevs =
@@ -36,8 +45,116 @@ removeInitial
= pass "Remove INITIAL abbreviations"
[]
[Prop.initialRemoved]
- -- FIXME: Implement this
- return
+ (applyDepthSM doStructured)
+ where
+ doStructured :: Data t => A.Structured t -> PassM (A.Structured t)
+ doStructured (A.Spec m spec s) = doSpec m spec s
+ doStructured s = return s
+
+ -- FIXME: When we add mobile support, we'll need to make a decision between
+ -- ValAbbrev and Abbrev based on whether the type in question is mobile.
+
+ doSpec :: forall t. Data t =>
+ Meta -> A.Specification
+ -> A.Structured t -> PassM (A.Structured t)
+ doSpec m spec@(A.Specification m' n st) inner
+ = case st of
+ -- INITIAL abbreviation
+ --
+ -- INITIAL INT foo IS bar:
+ -- inner
+ -- ->
+ -- INT foo:
+ -- PROCTHEN
+ -- foo := bar
+ -- inner
+ A.IsExpr m'' A.InitialAbbrev t e ->
+ return $ declareAssign n t e inner
+
+ -- INITIAL retyping
+ --
+ -- INITIAL INT foo RETYPES bar:
+ -- inner
+ -- ->
+ -- VAL INT temp RETYPES bar:
+ -- INT foo:
+ -- PROCTHEN
+ -- foo := temp
+ -- inner
+ A.RetypesExpr m'' A.InitialAbbrev t e ->
+ do temp <- defineNonce m' "initial_retypes_expr" st A.ValAbbrev
+ let e = A.ExprVariable m' (specVar temp)
+ return $ A.Spec m temp $
+ declareAssign n t e inner
+
+ -- PROC -- look for INITIAL formals
+ --
+ -- PROC foo (INITIAL INT bar)
+ -- process
+ -- :
+ -- inner
+ -- ->
+ -- PROC foo (VAL INT temp)
+ -- SEQ
+ -- INT bar:
+ -- PROCTHEN
+ -- bar := temp
+ -- process
+ -- :
+ -- inner
+ A.Proc m'' sm fs p ->
+ do -- Find the INITIAL formals, and note their positions.
+ let (positions, fromFS)
+ = unzip [(i, f)
+ | (i, f@(A.Formal A.InitialAbbrev _ _))
+ <- zip [0 ..] fs]
+
+ -- Define names for new formals.
+ temps <- sequence [defineNonce m'
+ "initial_formal"
+ (A.Declaration m' t)
+ A.ValAbbrev
+ | A.Formal _ t _ <- fromFS]
+
+ -- Replace the old formals with new ValAbbrevs.
+ let fs' = foldl (\fs (A.Specification _ n _,
+ A.Formal _ t _,
+ pos) ->
+ replaceAt pos
+ (A.Formal A.ValAbbrev t n)
+ fs
+ )
+ fs (zip3 temps fromFS positions)
+
+ -- Wrap the inner process to declare the old names as
+ -- variables and copy the right values into them.
+ -- (We reverse the list so the first formal is outermost.)
+ let p' = foldl (\p (temp, A.Formal _ t n) ->
+ let e = A.ExprVariable m' (specVar temp) in
+ A.Seq m' (declareAssign n t e $
+ A.Only m' p))
+ p (reverse $ zip temps fromFS)
+
+ let spec' = A.Specification m' n (A.Proc m'' sm fs' p')
+ return $ A.Spec m spec' inner
+
+ _ -> leave
+ where
+ leave :: PassM (A.Structured t)
+ leave = return $ A.Spec m spec inner
+
+ declareAssign :: Data s =>
+ A.Name -> A.Type -> A.Expression
+ -> A.Structured s -> A.Structured s
+ declareAssign n t e s
+ = A.Spec m (A.Specification m' n $ A.Declaration m' t) $
+ A.ProcThen m' (A.Assign m'
+ [A.Variable m' n]
+ (A.ExpressionList m' [e])) $
+ s
+
+ specVar :: A.Specification -> A.Variable
+ specVar (A.Specification m n _) = A.Variable m n
-- | Rewrite 'ResultAbbrev' into just 'Abbrev'.
removeResult :: Pass
diff --git a/transformations/SimplifyAbbrevsTest.hs b/transformations/SimplifyAbbrevsTest.hs
new file mode 100644
index 0000000..9e21979
--- /dev/null
+++ b/transformations/SimplifyAbbrevsTest.hs
@@ -0,0 +1,164 @@
+{-
+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 .
+-}
+
+-- | Tests for 'SimplifyAbbrevs'.
+module SimplifyAbbrevsTest (tests) where
+
+import Control.Monad.State
+import Data.Generics
+import Test.HUnit hiding (State)
+
+import CompState
+import qualified AST as A
+import Metadata
+import Pattern
+import SimplifyAbbrevs
+import TagAST
+import TestUtils
+import TreeUtils
+
+m :: Meta
+m = emptyMeta
+
+setupState :: State CompState ()
+setupState
+ = return ()
+
+testRemoveInitial :: Test
+testRemoveInitial = TestLabel "testRemoveInitial" $ TestList
+ [ -- Nothing to do
+ ok 0 inner
+ inner
+
+ -- INITIAL abbreviation
+ , ok 10 (spec foo (A.IsExpr m A.InitialAbbrev A.Int exp)
+ inner)
+ (mDeclareAssign foo A.Int exp inner)
+
+ -- INITIAL retyping
+ , ok 20 (spec foo (A.RetypesExpr m A.InitialAbbrev A.Int exp)
+ inner)
+ (mSpec mTemp (A.RetypesExpr m A.InitialAbbrev A.Int exp)
+ (mDeclareAssign foo A.Int mTempE inner))
+
+ -- INITIAL formal
+ , ok 30 (spec foo (A.Proc m
+ A.PlainSpec
+ [A.Formal A.InitialAbbrev A.Int bar]
+ skip)
+ inner)
+ (mSpec foo (mProc A.PlainSpec
+ [mFormal' A.ValAbbrev A.Int mTemp]
+ (mSeq
+ (mDeclareAssign bar A.Int mTempE
+ (A.Only m skip))))
+ inner)
+
+ -- Two INITIAL formals and a regular VAL formal
+ , ok 40 (spec foo (A.Proc m
+ A.PlainSpec
+ [ A.Formal A.InitialAbbrev A.Int bar
+ , A.Formal A.ValAbbrev A.Int baz
+ , A.Formal A.InitialAbbrev A.Int quux
+ ]
+ skip)
+ inner)
+ (mSpec foo (mProc A.PlainSpec
+ [ mFormal' A.ValAbbrev A.Int mTemp
+ , mFormal' A.ValAbbrev A.Int baz
+ , mFormal' A.ValAbbrev A.Int mTemp2
+ ]
+ (mSeq
+ (mDeclareAssign bar A.Int mTempE
+ (mOnlyP
+ (mSeq
+ (mDeclareAssign quux A.Int mTempE2
+ (A.Only m skip)))))))
+ inner)
+ ]
+ where
+ ok :: (Data a, Data b) => Int -> a -> b -> Test
+ ok n inp exp = TestCase $ testPass ("testRemoveInitial" ++ show n)
+ exp removeInitial inp setupState
+
+ skip = A.Skip m
+ inner = A.Only m skip
+ spec n st s = A.Spec m (A.Specification m n st) s
+ mSpec :: (Data a, Data b, Data c) => a -> b -> c -> Pattern
+ mSpec n st s = mSpecP (tag3 A.Specification m n st) s
+ foo = simpleName "foo"
+ bar = simpleName "bar"
+ barV = A.Variable m bar
+ baz = simpleName "baz"
+ quux = simpleName "quux"
+ exp = A.ExprVariable m barV
+ mTemp :: Pattern
+ mTemp = Named "temp" DontCare
+ mTempV :: Pattern
+ mTempV = mVariable mTemp
+ mTempE :: Pattern
+ mTempE = mExprVariable mTempV
+ mTemp2 :: Pattern
+ mTemp2 = Named "temp2" DontCare
+ mTempV2 :: Pattern
+ mTempV2 = mVariable mTemp2
+ mTempE2 :: Pattern
+ mTempE2 = mExprVariable mTempV2
+ mAssign :: (Data a, Data b) => a -> b -> Pattern
+ mAssign v e = tag3 A.Assign m [v] (tag2 A.ExpressionList m [e])
+
+ mDeclareAssign :: (Data a, Data b, Data c, Data d) =>
+ a -> b -> c -> d -> Pattern
+ mDeclareAssign n t e s
+ = mSpec n (mDeclaration t) $
+ mProcThenP (mAssign (mVariable n) e) $
+ s
+
+testRemoveResult :: Test
+testRemoveResult = TestLabel "testRemoveResult" $ TestList
+ [ -- Nothing to do
+ ok 0 inner
+ inner
+
+ -- RESULT abbreviation
+ , ok 10 (spec foo (A.Is m A.ResultAbbrev A.Int barV) inner)
+ (spec foo (A.Is m A.Abbrev A.Int barV) inner)
+
+ -- RESULT retyping
+ , ok 20 (spec foo (A.Retypes m A.ResultAbbrev A.Int barV) inner)
+ (spec foo (A.Retypes m A.Abbrev A.Int barV) inner)
+
+ -- RESULT formal
+ , ok 30 (A.Formal A.ResultAbbrev A.Int foo)
+ (A.Formal A.Abbrev A.Int foo)
+ ]
+ where
+ ok :: (Data a, Data b) => Int -> a -> b -> Test
+ ok n inp exp = TestCase $ testPass ("testRemoveResult" ++ show n)
+ exp removeResult inp setupState
+
+ inner = A.Only m (A.Skip m)
+ spec n st s = A.Spec m (A.Specification m n st) s
+ foo = simpleName "foo"
+ barV = A.Variable m $ simpleName "bar"
+
+tests :: Test
+tests = TestLabel "SimplifyAbbrevsTest" $ TestList
+ [ testRemoveInitial
+ , testRemoveResult
+ ]