e457d82f0c
This may seem like an odd change, but it simplifies the logic a lot. I kept having problems with passes not operating on externals (e.g. functions-to-procs, adding array sizes, constant folding in array dimensions) and adding a special case every time to also process the externals was getting silly. Putting the externals in the AST therefore made sense, but I didn't want to just add dummy bodies as this would cause them to throw up errors (e.g. in the type-checking for functions). So I turned the bodies into a Maybe type, and that has worked out well. I also stopped storing the formals in csExternals (since they are now in csNames, and the tree), which streamlined that nicely, and stopped me having to keep them up to date.
165 lines
5.5 KiB
Haskell
165 lines
5.5 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/>.
|
|
-}
|
|
|
|
-- | 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.Is m A.InitialAbbrev A.Int $ A.ActualExpression 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.PlainRec)
|
|
[A.Formal A.InitialAbbrev A.Int bar]
|
|
$ Just skip)
|
|
inner)
|
|
(mSpec foo (mProc (A.PlainSpec, A.PlainRec)
|
|
[mFormal' A.ValAbbrev A.Int mTemp]
|
|
(Just $ 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.PlainRec)
|
|
[ A.Formal A.InitialAbbrev A.Int bar
|
|
, A.Formal A.ValAbbrev A.Int baz
|
|
, A.Formal A.InitialAbbrev A.Int quux
|
|
]
|
|
(Just skip))
|
|
inner)
|
|
(mSpec foo (mProc (A.PlainSpec, A.PlainRec)
|
|
[ mFormal' A.ValAbbrev A.Int mTemp
|
|
, mFormal' A.ValAbbrev A.Int baz
|
|
, mFormal' A.ValAbbrev A.Int mTemp2
|
|
]
|
|
(Just $ 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 $ A.ActualVariable barV) inner)
|
|
(spec foo (A.Is m A.Abbrev A.Int $ A.ActualVariable 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
|
|
]
|