Convert the C backend to the new CIF API (mostly).
Most of this is mechanical: changing function names, and carrying the "wptr" argument around. I've made the code for computing Expressions from Structureds a bit more generic too. The only complex bit is the handling of PAR processes, which I'm not very happy with at the moment; they used to use the normal C calling convention, but now you need to pack the arguments into the workspace. I'm handling this at the moment by generating wrapper functions that do the unpacking, but it would be better in the future to make the wrapper PROCs that we already generate have the right interface. This won't work for programs that use any of the top-level channels yet, since there are no handlers for them.
This commit is contained in:
Adam Sampson
parent
87a1c39411
commit
2f7539bcdb
|
|
@ -160,16 +160,20 @@ cgenTopLevel s
|
|||
cs <- get
|
||||
(tlpName, chans) <- tlpInterface
|
||||
|
||||
tell ["extern int " ++ nameString n ++ "_stack_size;\n"
|
||||
| n <- tlpName : (Set.toList $ csParProcs cs)]
|
||||
sequence_ $ map (call genForwardDeclaration)
|
||||
(listify (const True :: A.Specification -> Bool) s)
|
||||
|
||||
tell ["/* ", show $ csParProcs cs, " */\n"]
|
||||
sequence_ [do tell ["extern int " ++ nameString n ++ "_wrapper_stack_size;\n"]
|
||||
cgenProcWrapper n
|
||||
| n <- tlpName : (Set.toList $ csParProcs cs)]
|
||||
|
||||
sequence_ $ map (call genForwardDeclaration) (listify (const True :: A.Specification -> Bool) s)
|
||||
call genStructured s (\m _ -> tell ["\n#error Invalid top-level item: ", show m])
|
||||
|
||||
tell ["void tock_main (Workspace wptr) {\n\
|
||||
\ Workspace tlp = ProcAlloc (wptr, ", show $ length chans, ", "]
|
||||
genName tlpName
|
||||
tell ["_stack_size);\n"]
|
||||
tell ["_wrapper_stack_size);\n"]
|
||||
sequence_ [do tell [" ProcParam (wptr, tlp, " ++ show i ++ ", "]
|
||||
call genTLPChannel c
|
||||
tell [");\n"]
|
||||
|
|
@ -180,7 +184,7 @@ cgenTopLevel s
|
|||
\ LightProcBarrierInit (wptr, &bar, 1);\n\
|
||||
\ LightProcStart (wptr, &bar, tlp, (Process) "]
|
||||
genName tlpName
|
||||
tell [");\n\
|
||||
tell ["_wrapper);\n\
|
||||
\ LightProcBarrierWait (wptr, &bar);\n\
|
||||
\ Shutdown (wptr);\n\
|
||||
\}\n\
|
||||
|
|
@ -280,7 +284,7 @@ cgetScalarType A.Int32 = Just "int32_t"
|
|||
cgetScalarType A.Int64 = Just "int64_t"
|
||||
cgetScalarType A.Real32 = Just "float"
|
||||
cgetScalarType A.Real64 = Just "double"
|
||||
cgetScalarType A.Timer = Just "Time"
|
||||
cgetScalarType A.Timer = Just "Time" -- Not used in the C backend.
|
||||
cgetScalarType A.Time = Just "Time"
|
||||
cgetScalarType _ = Nothing
|
||||
|
||||
|
|
@ -888,7 +892,7 @@ cgenInputItem :: A.Variable -> A.InputItem -> CGen ()
|
|||
cgenInputItem c (A.InCounted m cv av)
|
||||
= do call genInputItem c (A.InVariable m cv)
|
||||
t <- typeOfVariable av
|
||||
tell ["ChanIn("]
|
||||
tell ["ChanIn(wptr,"]
|
||||
call genVariable c
|
||||
tell [","]
|
||||
fst $ abbrevVariable A.Abbrev t av
|
||||
|
|
@ -903,13 +907,13 @@ cgenInputItem c (A.InVariable m v)
|
|||
let rhs = fst $ abbrevVariable A.Abbrev t v
|
||||
case t of
|
||||
A.Int ->
|
||||
do tell ["ChanInInt("]
|
||||
do tell ["ChanInInt(wptr,"]
|
||||
call genVariable c
|
||||
tell [","]
|
||||
rhs
|
||||
tell [");"]
|
||||
_ ->
|
||||
do tell ["ChanIn("]
|
||||
do tell ["ChanIn(wptr,"]
|
||||
call genVariable c
|
||||
tell [","]
|
||||
rhs
|
||||
|
|
@ -923,7 +927,7 @@ cgenOutputItem c (A.OutCounted m ce ae)
|
|||
t <- typeOfExpression ae
|
||||
case ae of
|
||||
A.ExprVariable m v ->
|
||||
do tell ["ChanOut("]
|
||||
do tell ["ChanOut(wptr,"]
|
||||
call genVariable c
|
||||
tell [","]
|
||||
fst $ abbrevVariable A.Abbrev t v
|
||||
|
|
@ -937,13 +941,13 @@ cgenOutputItem c (A.OutExpression m e)
|
|||
= do t <- typeOfExpression e
|
||||
case (t, e) of
|
||||
(A.Int, _) ->
|
||||
do tell ["ChanOutInt("]
|
||||
do tell ["ChanOutInt(wptr,"]
|
||||
call genVariable c
|
||||
tell [","]
|
||||
call genExpression e
|
||||
tell [");"]
|
||||
(_, A.ExprVariable _ v) ->
|
||||
do tell ["ChanOut("]
|
||||
do tell ["ChanOut(wptr,"]
|
||||
call genVariable c
|
||||
tell [","]
|
||||
fst $ abbrevVariable A.Abbrev t v
|
||||
|
|
@ -1166,6 +1170,7 @@ cgenDeclaration (A.Array ds t) n True
|
|||
tell ["int "]
|
||||
genName n
|
||||
tell ["_sizes[",show $ length ds,"];"]
|
||||
cgenDeclaration A.Timer _ _ = return ()
|
||||
cgenDeclaration t n _
|
||||
= do call genType t
|
||||
tell [" "]
|
||||
|
|
@ -1201,7 +1206,7 @@ cgenArraySizesLiteral n (A.Array ds _)
|
|||
-- | Initialise an item being declared.
|
||||
cdeclareInit :: Meta -> A.Type -> A.Variable -> Maybe A.Expression -> Maybe (CGen ())
|
||||
cdeclareInit _ (A.Chan A.DirUnknown _ _) var _
|
||||
= Just $ do tell ["ChanInit("]
|
||||
= Just $ do tell ["ChanInit(wptr,"]
|
||||
call genVariableUnchecked var
|
||||
tell [");"]
|
||||
cdeclareInit m t@(A.Array ds t') var _
|
||||
|
|
@ -1327,7 +1332,7 @@ cintroduceSpec (A.Specification _ n (A.Proc _ sm fs p))
|
|||
= do call genSpecMode sm
|
||||
tell ["void "]
|
||||
genName n
|
||||
tell [" (Process *me"]
|
||||
tell [" (Workspace wptr"]
|
||||
call genFormals fs
|
||||
tell [") {\n"]
|
||||
call genProcess p
|
||||
|
|
@ -1365,13 +1370,12 @@ cgenRecordTypeSpec n b fs
|
|||
genName n
|
||||
tell [";"]
|
||||
|
||||
|
||||
cgenForwardDeclaration :: A.Specification -> CGen ()
|
||||
cgenForwardDeclaration (A.Specification _ n (A.Proc _ sm fs _))
|
||||
= do call genSpecMode sm
|
||||
tell ["void "]
|
||||
genName n
|
||||
tell [" (Process *me"]
|
||||
tell [" (Workspace wptr"]
|
||||
call genFormals fs
|
||||
tell [");"]
|
||||
cgenForwardDeclaration (A.Specification _ n (A.RecordType _ b fs))
|
||||
|
|
@ -1401,43 +1405,88 @@ cgenActuals :: [A.Actual] -> CGen ()
|
|||
cgenActuals as = prefixComma (map (call genActual) as)
|
||||
|
||||
cgenActual :: A.Actual -> CGen ()
|
||||
cgenActual actual
|
||||
= case actual of
|
||||
A.ActualExpression t e ->
|
||||
case (t, e) of
|
||||
(A.Array _ _, A.ExprVariable _ v) ->
|
||||
do call genVariable v
|
||||
tell [","]
|
||||
call genVariable v
|
||||
tell ["_sizes"]
|
||||
_ -> call genExpression e
|
||||
A.ActualVariable am t v ->
|
||||
case t of
|
||||
A.Array _ _ ->
|
||||
do call genVariable v
|
||||
tell [","]
|
||||
call genVariable v
|
||||
tell ["_sizes"]
|
||||
_ -> fst $ abbrevVariable am t v
|
||||
|
||||
numCArgs :: [A.Actual] -> Int
|
||||
numCArgs [] = 0
|
||||
numCArgs (A.ActualVariable _ (A.Array _ _) _:fs) = 2 + numCArgs fs
|
||||
numCArgs (A.ActualExpression (A.Array _ _) _:fs) = 2 + numCArgs fs
|
||||
numCArgs (_:fs) = 1 + numCArgs fs
|
||||
cgenActual actual = seqComma $ realActuals actual
|
||||
|
||||
cgenFormals :: [A.Formal] -> CGen ()
|
||||
cgenFormals fs = prefixComma (map (call genFormal) fs)
|
||||
|
||||
cgenFormal :: A.Formal -> CGen ()
|
||||
cgenFormal (A.Formal am t n)
|
||||
cgenFormal f = seqComma [t >> tell [" "] >> n | (t, n) <- realFormals f]
|
||||
|
||||
-- | Return generators for all the real actuals corresponding to a single
|
||||
-- actual.
|
||||
realActuals :: A.Actual -> [CGen ()]
|
||||
realActuals (A.ActualExpression t e)
|
||||
= case (t, e) of
|
||||
(A.Array _ _, A.ExprVariable _ v) ->
|
||||
[call genVariable v,
|
||||
call genVariable v >> tell ["_sizes"]]
|
||||
_ -> [call genExpression e]
|
||||
realActuals (A.ActualVariable am t v)
|
||||
= case t of
|
||||
A.Array _ _ ->
|
||||
[call genVariable v,
|
||||
call genVariable v >> tell ["_sizes"]]
|
||||
_ -> [fst $ abbrevVariable am t v]
|
||||
|
||||
-- | Return (type, name) generator pairs for all the real formals corresponding
|
||||
-- to a single formal.
|
||||
realFormals :: A.Formal -> [(CGen (), CGen ())]
|
||||
realFormals (A.Formal am t n)
|
||||
= case t of
|
||||
A.Array _ t' ->
|
||||
do call genDecl am t n
|
||||
tell [", const int *"]
|
||||
genName n
|
||||
tell ["_sizes"]
|
||||
_ -> call genDecl am t n
|
||||
[(mainType, mainName),
|
||||
(tell ["const int *"], genName n >> tell ["_sizes"])]
|
||||
_ -> [(mainType, mainName)]
|
||||
where
|
||||
mainType = cgenDeclType am t
|
||||
mainName = genName n
|
||||
|
||||
-- | Generate a wrapper function for a PAR subprocess.
|
||||
cgenProcWrapper :: A.Name -> CGen ()
|
||||
cgenProcWrapper n
|
||||
= do st <- specTypeOfName n
|
||||
let fs = case st of A.Proc _ _ fs _ -> fs
|
||||
let rfs = concatMap realFormals fs
|
||||
|
||||
tell ["static void "]
|
||||
genName n
|
||||
tell ["_wrapper (Workspace wptr) {\n"]
|
||||
|
||||
sequence_ [unpackParam num rf | (num, rf) <- zip [0..] rfs]
|
||||
genName n
|
||||
tell [" (wptr"]
|
||||
prefixComma [n | (_, n) <- rfs]
|
||||
tell [");\n"]
|
||||
|
||||
tell ["}\n"]
|
||||
where
|
||||
unpackParam :: Int -> (CGen (), CGen ()) -> CGen ()
|
||||
unpackParam num (t, n)
|
||||
= do t
|
||||
tell [" "]
|
||||
n
|
||||
tell [" = ProcGetParam (wptr, " ++ show num ++ ", "]
|
||||
t
|
||||
tell [");\n"]
|
||||
|
||||
-- | Generate a ProcAlloc for a PAR subprocess, returning a nonce for the
|
||||
-- workspace pointer and the name of the function to call.
|
||||
cgenProcAlloc :: A.Name -> [A.Actual] -> CGen (String, CGen ())
|
||||
cgenProcAlloc n as
|
||||
= do let ras = concatMap realActuals as
|
||||
|
||||
ws <- makeNonce "workspace"
|
||||
tell ["Workspace ", ws, " = ProcAlloc (wptr, ", show $ length ras, ", "]
|
||||
genName n
|
||||
tell ["_wrapper_stack_size);\n"]
|
||||
|
||||
sequence_ [do tell ["ProcParam (wptr, ", ws, ", ", show num, ", "]
|
||||
ra
|
||||
tell [");\n"]
|
||||
| (num, ra) <- zip [(0 :: Int)..] ras]
|
||||
|
||||
return (ws, genName n >> tell ["_wrapper"])
|
||||
--}}}
|
||||
|
||||
--{{{ processes
|
||||
|
|
@ -1447,7 +1496,7 @@ cgenProcess p = case p of
|
|||
A.Input m c im -> call genInput c im
|
||||
A.Output m c ois -> call genOutput c ois
|
||||
A.OutputCase m c t ois -> call genOutputCase c t ois
|
||||
A.GetTime m v -> call genGetTime m v
|
||||
A.GetTime m v -> call genGetTime v
|
||||
A.Wait m wm e -> call genWait wm e
|
||||
A.Skip m -> tell ["/* skip */\n"]
|
||||
A.Stop m -> call genStop m "STOP process"
|
||||
|
|
@ -1494,31 +1543,23 @@ cgenInput c im
|
|||
_ -> call genMissing $ "genInput " ++ show im
|
||||
|
||||
cgenTimerRead :: A.Variable -> A.Variable -> CGen ()
|
||||
cgenTimerRead c v
|
||||
= do tell ["ProcTime (&"]
|
||||
call genVariable c
|
||||
tell [");\n"]
|
||||
call genVariable v
|
||||
tell [" = "]
|
||||
call genVariable c
|
||||
tell [";\n"]
|
||||
cgenTimerRead _ v = cgenGetTime v
|
||||
|
||||
cgenTimerWait :: A.Expression -> CGen ()
|
||||
cgenTimerWait e
|
||||
= do tell ["ProcTimeAfter("]
|
||||
= do tell ["TimerWait(wptr,"]
|
||||
call genExpression e
|
||||
tell [");"]
|
||||
|
||||
cgenGetTime :: Meta -> A.Variable -> CGen ()
|
||||
cgenGetTime m v
|
||||
= do tell ["ProcTime(&"]
|
||||
call genVariable v
|
||||
tell [");"]
|
||||
cgenGetTime :: A.Variable -> CGen ()
|
||||
cgenGetTime v
|
||||
= do call genVariable v
|
||||
tell [" = TimerRead(wptr);"]
|
||||
|
||||
cgenWait :: A.WaitMode -> A.Expression -> CGen ()
|
||||
cgenWait A.WaitUntil e = call genTimerWait e
|
||||
cgenWait A.WaitFor e
|
||||
= do tell ["ProcAfter("]
|
||||
= do tell ["TimerDelay(wptr,"]
|
||||
call genExpression e
|
||||
tell [");"]
|
||||
|
||||
|
|
@ -1531,7 +1572,7 @@ cgenOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen ()
|
|||
cgenOutputCase c tag ois
|
||||
= do t <- typeOfVariable c
|
||||
let proto = case t of A.Chan _ _ (A.UserProtocol n) -> n
|
||||
tell ["ChanOutInt("]
|
||||
tell ["ChanOutInt(wptr,"]
|
||||
call genVariable c
|
||||
tell [","]
|
||||
genName tag
|
||||
|
|
@ -1545,7 +1586,7 @@ cgenStop :: Meta -> String -> CGen ()
|
|||
cgenStop m s
|
||||
= do tell ["occam_stop("]
|
||||
genMeta m
|
||||
tell [",\"", s, "\");"]
|
||||
tell [",1,\"", s, "\");"]
|
||||
--}}}
|
||||
--{{{ seq
|
||||
cgenSeq :: A.Structured A.Process -> CGen ()
|
||||
|
|
@ -1616,66 +1657,46 @@ cgenWhile e p
|
|||
tell ["}"]
|
||||
--}}}
|
||||
--{{{ par
|
||||
-- FIXME: The ParMode is now ignored (as it is in occ21), so PRI PAR behaves
|
||||
-- the same as PAR.
|
||||
cgenPar :: A.ParMode -> A.Structured A.Process -> CGen ()
|
||||
cgenPar pm s
|
||||
= do (size, _, _) <- constantFold $ addOne (sizeOfStructured s)
|
||||
pids <- makeNonce "pids"
|
||||
pris <- makeNonce "priorities"
|
||||
index <- makeNonce "i"
|
||||
when (pm == A.PriPar) $
|
||||
do tell ["int ", pris, "["]
|
||||
call genExpression size
|
||||
tell ["];\n"]
|
||||
tell ["Process *", pids, "["]
|
||||
call genExpression size
|
||||
tell ["];\n"]
|
||||
tell ["int ", index, " = 0;\n"]
|
||||
call genStructured s (createP pids pris index)
|
||||
tell [pids, "[", index, "] = NULL;\n"]
|
||||
tell ["if(",pids,"[0] != NULL){"] -- CIF seems to deadlock when you give ProcParList a list
|
||||
-- beginning with NULL (i.e. with no processes)
|
||||
case pm of
|
||||
A.PriPar -> tell ["ProcPriParList (", pids, ", ", pris, ");\n"]
|
||||
_ -> tell ["ProcParList (", pids, ");\n"]
|
||||
tell ["}"]
|
||||
tell [index, " = 0;\n"]
|
||||
call genStructured s (freeP pids index)
|
||||
where
|
||||
createP pids pris index _ p
|
||||
= do when (pm == A.PriPar) $
|
||||
tell [pris, "[", index, "] = ", index, ";\n"]
|
||||
tell [pids, "[", index, "++] = "]
|
||||
genProcAlloc p
|
||||
tell [";\n"]
|
||||
freeP pids index _ _
|
||||
= do tell ["ProcAllocClean (", pids, "[", index, "++]);\n"]
|
||||
= do (count, _, _) <- constantFold $ countStructured s
|
||||
|
||||
genProcAlloc :: A.Process -> CGen ()
|
||||
genProcAlloc (A.ProcCall m n as)
|
||||
= do tell ["ProcAlloc ("]
|
||||
genName n
|
||||
let stackSize = nameString n ++ "_stack_size"
|
||||
tell [", ", stackSize, ", ", show $ numCArgs as]
|
||||
call genActuals as
|
||||
tell [")"]
|
||||
genProcAlloc p = call genMissing $ "genProcAlloc " ++ show p
|
||||
bar <- makeNonce "par_barrier"
|
||||
tell ["LightProcBarrier ", bar, ";\n"]
|
||||
tell ["LightProcBarrierInit (wptr, &", bar, ", "]
|
||||
call genExpression count
|
||||
tell [");\n"]
|
||||
|
||||
call genStructured s (startP bar)
|
||||
|
||||
tell ["LightProcBarrierWait (wptr, &", bar, ");\n"]
|
||||
|
||||
where
|
||||
startP :: String -> Meta -> A.Process -> CGen ()
|
||||
startP bar _ (A.ProcCall _ n as)
|
||||
= do (ws, func) <- cgenProcAlloc n as
|
||||
tell ["LightProcStart (wptr, &", bar, ", ", ws, ", "]
|
||||
func
|
||||
tell [");\n"]
|
||||
--}}}
|
||||
--{{{ alt
|
||||
cgenAlt :: Bool -> A.Structured A.Alternative -> CGen ()
|
||||
cgenAlt isPri s
|
||||
= do tell ["AltStart ();\n"]
|
||||
= do tell ["Alt (wptr);\n"]
|
||||
tell ["{\n"]
|
||||
genAltEnable s
|
||||
tell ["}\n"]
|
||||
-- Like occ21, this is always a PRI ALT, so we can use it for both.
|
||||
tell ["AltWait ();\n"]
|
||||
tell ["AltWait (wptr);\n"]
|
||||
id <- makeNonce "alt_id"
|
||||
tell ["int ", id, " = 0;\n"]
|
||||
tell ["{\n"]
|
||||
genAltDisable id s
|
||||
tell ["}\n"]
|
||||
fired <- makeNonce "alt_fired"
|
||||
tell ["int ", fired, " = AltEnd ();\n"]
|
||||
tell ["int ", fired, " = AltEnd (wptr);\n"]
|
||||
tell [id, " = 0;\n"]
|
||||
label <- makeNonce "alt_end"
|
||||
tell ["{\n"]
|
||||
|
|
@ -1690,10 +1711,10 @@ cgenAlt isPri s
|
|||
= case alt of
|
||||
A.Alternative _ c im _ -> doIn c im
|
||||
A.AlternativeCond _ e c im _ -> withIf e $ doIn c im
|
||||
A.AlternativeSkip _ e _ -> withIf e $ tell ["AltEnableSkip ();\n"]
|
||||
A.AlternativeSkip _ e _ -> withIf e $ tell ["AltEnableSkip (wptr);\n"]
|
||||
--transformWaitFor should have removed all A.WaitFor guards (transforming them into A.WaitUntil):
|
||||
A.AlternativeWait _ A.WaitUntil e _ ->
|
||||
do tell ["AltEnableTimer ( "]
|
||||
do tell ["AltEnableTimer (wptr,"]
|
||||
call genExpression e
|
||||
tell [" );\n"]
|
||||
|
||||
|
|
@ -1701,11 +1722,11 @@ cgenAlt isPri s
|
|||
= do case im of
|
||||
A.InputTimerRead _ _ -> call genMissing "timer read in ALT"
|
||||
A.InputTimerAfter _ time ->
|
||||
do tell ["AltEnableTimer ("]
|
||||
do tell ["AltEnableTimer (wptr,"]
|
||||
call genExpression time
|
||||
tell [");\n"]
|
||||
_ ->
|
||||
do tell ["AltEnableChannel ("]
|
||||
do tell ["AltEnableChannel (wptr,"]
|
||||
call genVariable c
|
||||
tell [");\n"]
|
||||
|
||||
|
|
@ -1716,20 +1737,20 @@ cgenAlt isPri s
|
|||
= case alt of
|
||||
A.Alternative _ c im _ -> doIn c im
|
||||
A.AlternativeCond _ e c im _ -> withIf e $ doIn c im
|
||||
A.AlternativeSkip _ e _ -> withIf e $ tell ["AltDisableSkip (", id, "++);\n"]
|
||||
A.AlternativeSkip _ e _ -> withIf e $ tell ["AltDisableSkip (wptr,", id, "++);\n"]
|
||||
A.AlternativeWait _ A.WaitUntil e _ ->
|
||||
do tell ["AltDisableTimer (", id, "++, "]
|
||||
do tell ["AltDisableTimer (wptr,", id, "++, "]
|
||||
call genExpression e
|
||||
tell [");\n"]
|
||||
doIn c im
|
||||
= do case im of
|
||||
A.InputTimerRead _ _ -> call genMissing "timer read in ALT"
|
||||
A.InputTimerAfter _ time ->
|
||||
do tell ["AltDisableTimer (", id, "++, "]
|
||||
do tell ["AltDisableTimer (wptr,", id, "++, "]
|
||||
call genExpression time
|
||||
tell [");\n"]
|
||||
_ ->
|
||||
do tell ["AltDisableChannel (", id, "++, "]
|
||||
do tell ["AltDisableChannel (wptr,", id, "++, "]
|
||||
call genVariable c
|
||||
tell [");\n"]
|
||||
|
||||
|
|
@ -1767,7 +1788,7 @@ withIf cond body
|
|||
cgenProcCall :: A.Name -> [A.Actual] -> CGen ()
|
||||
cgenProcCall n as
|
||||
= do genName n
|
||||
tell [" (me"]
|
||||
tell [" (wptr"]
|
||||
call genActuals as
|
||||
tell [");\n"]
|
||||
--}}}
|
||||
|
|
|
|||
|
|
@ -122,7 +122,7 @@ data GenOps = GenOps {
|
|||
genFuncDyadic :: Meta -> String -> A.Expression -> A.Expression -> CGen (),
|
||||
genFuncMonadic :: Meta -> String -> A.Expression -> CGen (),
|
||||
-- | Gets the current time into the given variable
|
||||
genGetTime :: Meta -> A.Variable -> CGen (),
|
||||
genGetTime :: A.Variable -> CGen (),
|
||||
-- | Generates an IF statement (which can have replicators, specifications and such things inside it).
|
||||
genIf :: Meta -> A.Structured A.Choice -> CGen (),
|
||||
genInput :: A.Variable -> A.InputMode -> CGen (),
|
||||
|
|
|
|||
|
|
@ -248,8 +248,8 @@ cppgenTimerRead c v
|
|||
call genVariable c
|
||||
tell ["),4294967296.0);\n"]
|
||||
|
||||
cppgenGetTime :: Meta -> A.Variable -> CGen ()
|
||||
cppgenGetTime m v
|
||||
cppgenGetTime :: A.Variable -> CGen ()
|
||||
cppgenGetTime v
|
||||
= do tell ["csp::CurrentTime(&"]
|
||||
call genVariable v
|
||||
tell [");"]
|
||||
|
|
|
|||
|
|
@ -285,7 +285,7 @@ testGenType = TestList
|
|||
|
||||
testStop :: Test
|
||||
testStop =
|
||||
testBoth "Stop" "occam_stop(\"foo:4:9\",\"bar\");" "throw StopException(\"foo:4:9\" \"bar\");" (tcall2 genStop (Meta (Just "foo") 4 9) "bar")
|
||||
testBoth "Stop" "occam_stop(\"foo:4:9\",1,\"bar\");" "throw StopException(\"foo:4:9\" \"bar\");" (tcall2 genStop (Meta (Just "foo") 4 9) "bar")
|
||||
|
||||
testArraySizes :: Test
|
||||
testArraySizes = TestList
|
||||
|
|
@ -487,16 +487,16 @@ testDeclareInitFree = TestLabel "testDeclareInitFree" $ TestList
|
|||
,testAllSameInit 10 ("foo=3;","") A.Int (intLiteral 3)
|
||||
|
||||
-- Channel types:
|
||||
,testAll 1 ("ChanInit((&foo));","") ("","") $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int
|
||||
,testAll 1 ("ChanInit(wptr,(&foo));","") ("","") $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int
|
||||
,testAllSame 2 ("","") $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int
|
||||
|
||||
-- Plain arrays:
|
||||
,testAllSame 3 ("","") $ A.Array [A.Dimension 4] A.Int
|
||||
|
||||
-- Channel arrays:
|
||||
,testAll 4 ("tock_init_chan_array(foo_storage,foo,4);^ChanInit(foo[0]);^","") ("tockInitChanArray(foo_storage,foo_actual,4);","") $ A.Array [A.Dimension 4] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int
|
||||
,testAll 4 ("tock_init_chan_array(foo_storage,foo,4);^ChanInit(wptr,foo[0]);^","") ("tockInitChanArray(foo_storage,foo_actual,4);","") $ A.Array [A.Dimension 4] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int
|
||||
-- The subscripting on this test is incomplete; it should probably be fixed at some point:
|
||||
,testAll 5 ("tock_init_chan_array(foo_storage,foo,4*5*6);^ChanInit(foo[0*foo_sizes[1]*foo_sizes[2]]);^","") ("tockInitChanArray(foo_storage,foo_actual,4*5*6);","") $
|
||||
,testAll 5 ("tock_init_chan_array(foo_storage,foo,4*5*6);^ChanInit(wptr,foo[0*foo_sizes[1]*foo_sizes[2]]);^","") ("tockInitChanArray(foo_storage,foo_actual,4*5*6);","") $
|
||||
A.Array [A.Dimension 4,A.Dimension 5,A.Dimension 6] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int
|
||||
,testAllSame 6 ("","") $ A.Array [A.Dimension 4] $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int
|
||||
|
||||
|
|
@ -889,7 +889,7 @@ testCase = TestList
|
|||
over = local $ \ops -> ops {genExpression = override1 dollar, genProcess = override1 at, genStop = override2 caret, genSpec = override2 hash}
|
||||
|
||||
testGetTime :: Test
|
||||
testGetTime = testBoth "testGetTime 0" "ProcTime(&@);" "csp::CurrentTime(&@);" (over (tcall2 genGetTime emptyMeta undefined))
|
||||
testGetTime = testBoth "testGetTime 0" "@ = TimerRead(wptr);" "csp::CurrentTime(&@);" (over (tcall genGetTime undefined))
|
||||
where
|
||||
over :: Override
|
||||
over = local $ \ops -> ops {genVariable = override1 at}
|
||||
|
|
@ -897,8 +897,8 @@ testGetTime = testBoth "testGetTime 0" "ProcTime(&@);" "csp::CurrentTime(&@);" (
|
|||
testWait :: Test
|
||||
testWait = TestList
|
||||
[
|
||||
testBoth "testWait 0" "ProcTimeAfter($);" "csp::SleepUntil($);" (over (tcall2 genWait A.WaitUntil undefined))
|
||||
,testBoth "testWait 1" "ProcAfter($);" "csp::SleepFor($);" (over (tcall2 genWait A.WaitFor undefined))
|
||||
testBoth "testWait 0" "TimerWait(wptr,$);" "csp::SleepUntil($);" (over (tcall2 genWait A.WaitUntil undefined))
|
||||
,testBoth "testWait 1" "TimerDelay(wptr,$);" "csp::SleepFor($);" (over (tcall2 genWait A.WaitFor undefined))
|
||||
]
|
||||
where
|
||||
over :: Override
|
||||
|
|
@ -936,43 +936,43 @@ testInput = TestList
|
|||
,testBothSame "testInput 2" "^^^" (overInputItemCase (tcall2 genInput undefined $ A.InputSimple undefined [undefined, undefined, undefined]))
|
||||
|
||||
-- Reading an integer (special case in the C backend):
|
||||
,testInputItem 100 "ChanInInt(#,&x);" "#>>x;" (A.InVariable emptyMeta $ variable "x") A.Int
|
||||
,testInputItem 100 "ChanInInt(wptr,#,&x);" "#>>x;" (A.InVariable emptyMeta $ variable "x") A.Int
|
||||
-- Reading a other plain types:
|
||||
,testInputItem 101 "ChanIn(#,&x,^(Int8));" "#>>x;" (A.InVariable emptyMeta $ variable "x") A.Int8
|
||||
,testInputItem 102 ("ChanIn(#,(&x),^(" ++ show (A.Record foo) ++ "));") "#>>*(&x);" (A.InVariable emptyMeta $ variable "x") (A.Record foo)
|
||||
,testInputItem 101 "ChanIn(wptr,#,&x,^(Int8));" "#>>x;" (A.InVariable emptyMeta $ variable "x") A.Int8
|
||||
,testInputItem 102 ("ChanIn(wptr,#,(&x),^(" ++ show (A.Record foo) ++ "));") "#>>*(&x);" (A.InVariable emptyMeta $ variable "x") (A.Record foo)
|
||||
-- Reading into a fixed size array:
|
||||
,testInputItem 103 "ChanIn(#,x,^(Array [Dimension 8] Int));" "tockRecvArray(#,x);" (A.InVariable emptyMeta $ variable "x") $ A.Array [A.Dimension 8] A.Int
|
||||
,testInputItem 103 "ChanIn(wptr,#,x,^(Array [Dimension 8] Int));" "tockRecvArray(#,x);" (A.InVariable emptyMeta $ variable "x") $ A.Array [A.Dimension 8] A.Int
|
||||
|
||||
-- Reading into subscripted variables:
|
||||
,testInputItem 110 "ChanInInt(#,&xs$);" "#>>xs$;" (A.InVariable emptyMeta $ sub0 $ variable "xs") A.Int
|
||||
,testInputItem 110 "ChanInInt(wptr,#,&xs$);" "#>>xs$;" (A.InVariable emptyMeta $ sub0 $ variable "xs") A.Int
|
||||
-- Reading a other plain types:
|
||||
,testInputItem 111 "ChanIn(#,&xs$,^(Int8));" "#>>xs$;" (A.InVariable emptyMeta $ sub0 $ variable "xs") A.Int8
|
||||
,testInputItem 112 ("ChanIn(#,(&xs$),^(" ++ show (A.Record foo) ++ "));") "#>>*(&xs$);" (A.InVariable emptyMeta $ sub0 $ variable "xs") (A.Record foo)
|
||||
,testInputItem 111 "ChanIn(wptr,#,&xs$,^(Int8));" "#>>xs$;" (A.InVariable emptyMeta $ sub0 $ variable "xs") A.Int8
|
||||
,testInputItem 112 ("ChanIn(wptr,#,(&xs$),^(" ++ show (A.Record foo) ++ "));") "#>>*(&xs$);" (A.InVariable emptyMeta $ sub0 $ variable "xs") (A.Record foo)
|
||||
|
||||
-- A counted array of Int:
|
||||
,testInputItem 200 "ChanInInt(#,&x);ChanIn(#,xs,x*^(Int));"
|
||||
,testInputItem 200 "ChanInInt(wptr,#,&x);ChanIn(wptr,#,xs,x*^(Int));"
|
||||
"tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int),xs));"
|
||||
(A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int A.Int)
|
||||
-- A counted array, counted by Int8:
|
||||
,testInputItem 201 "ChanIn(#,&x,^(Int8));ChanIn(#,xs,x*^(Int));"
|
||||
,testInputItem 201 "ChanIn(wptr,#,&x,^(Int8));ChanIn(wptr,#,xs,x*^(Int));"
|
||||
"tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int8),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int),xs));"
|
||||
(A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int8 A.Int)
|
||||
|
||||
-- TODO reading in a counted/fixed-size array into an array of arrays (or will that have already been sliced?)
|
||||
|
||||
-- inputs as part of protocols/any:
|
||||
,testInputItemProt 300 "ChanInInt(#,&x);" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int),&x));"
|
||||
,testInputItemProt 300 "ChanInInt(wptr,#,&x);" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int),&x));"
|
||||
(A.InVariable emptyMeta $ variable "x") A.Int
|
||||
,testInputItemProt 301 "ChanIn(#,&x,^(Int8));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int8),&x));"
|
||||
,testInputItemProt 301 "ChanIn(wptr,#,&x,^(Int8));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int8),&x));"
|
||||
(A.InVariable emptyMeta $ variable "x") A.Int8
|
||||
,testInputItemProt 302 ("ChanIn(#,(&x),^(" ++ show (A.Record foo) ++ "));") ("tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(" ++ show (A.Record foo) ++ "),(&x)));")
|
||||
,testInputItemProt 302 ("ChanIn(wptr,#,(&x),^(" ++ show (A.Record foo) ++ "));") ("tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(" ++ show (A.Record foo) ++ "),(&x)));")
|
||||
(A.InVariable emptyMeta $ variable "x") (A.Record foo)
|
||||
,testInputItemProt 303 "ChanIn(#,x,^(Array [Dimension 8] Int));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Array [Dimension 8] Int),x));"
|
||||
,testInputItemProt 303 "ChanIn(wptr,#,x,^(Array [Dimension 8] Int));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Array [Dimension 8] Int),x));"
|
||||
(A.InVariable emptyMeta $ variable "x") $ A.Array [A.Dimension 8] A.Int
|
||||
,testInputItemProt 400 "ChanInInt(#,&x);ChanIn(#,xs,x*^(Int));"
|
||||
,testInputItemProt 400 "ChanInInt(wptr,#,&x);ChanIn(wptr,#,xs,x*^(Int));"
|
||||
"tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int),xs));"
|
||||
(A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int A.Int)
|
||||
,testInputItemProt 401 "ChanIn(#,&x,^(Int8));ChanIn(#,xs,x*^(Int8));"
|
||||
,testInputItemProt 401 "ChanIn(wptr,#,&x,^(Int8));ChanIn(wptr,#,xs,x*^(Int8));"
|
||||
"tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int8),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int8),xs));"
|
||||
(A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int8 A.Int8)
|
||||
|
||||
|
|
@ -1020,46 +1020,46 @@ testOutput = TestList
|
|||
,testBothSame "testOutput 1" "^" (overOutputItem (tcall2 genOutput undefined [undefined]))
|
||||
,testBothSame "testOutput 2" "^^^" (overOutputItem (tcall2 genOutput undefined [undefined,undefined,undefined]))
|
||||
|
||||
,testBothS "testOutput 100" "ChanOutInt((&c),bar_foo);^" "tockSendInt((&c)->writer(),bar_foo);^" (overOutput (tcall3 genOutputCase (A.Variable emptyMeta chan) bar [])) state
|
||||
,testBothS "testOutput 101" "ChanOutInt(cOut,bar_foo);^" "tockSendInt(cOut,bar_foo);^" (overOutput (tcall3 genOutputCase (A.Variable emptyMeta chanOut) bar [])) state
|
||||
,testBothS "testOutput 100" "ChanOutInt(wptr,(&c),bar_foo);^" "tockSendInt((&c)->writer(),bar_foo);^" (overOutput (tcall3 genOutputCase (A.Variable emptyMeta chan) bar [])) state
|
||||
,testBothS "testOutput 101" "ChanOutInt(wptr,cOut,bar_foo);^" "tockSendInt(cOut,bar_foo);^" (overOutput (tcall3 genOutputCase (A.Variable emptyMeta chanOut) bar [])) state
|
||||
|
||||
--Integers are a special case in the C backend:
|
||||
,testOutputItem 201 "ChanOutInt(#,x);" "#<<x;" (A.OutExpression emptyMeta $ exprVariable "x") A.Int
|
||||
,testOutputItem 201 "ChanOutInt(wptr,#,x);" "#<<x;" (A.OutExpression emptyMeta $ exprVariable "x") A.Int
|
||||
--A plain type on the channel of the right type:
|
||||
,testOutputItem 202 "ChanOut(#,&x,^);" "#<<x;" (A.OutExpression emptyMeta $ exprVariable "x") A.Int64
|
||||
,testOutputItem 202 "ChanOut(wptr,#,&x,^);" "#<<x;" (A.OutExpression emptyMeta $ exprVariable "x") A.Int64
|
||||
--A record type on the channel of the right type (because records are always referenced by pointer):
|
||||
,testOutputItem 203 "ChanOut(#,(&x),^);" "#<<*(&x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Record foo)
|
||||
,testOutputItem 203 "ChanOut(wptr,#,(&x),^);" "#<<*(&x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Record foo)
|
||||
--A fixed size array on the channel of the right type:
|
||||
,testOutputItem 204 "ChanOut(#,x,^);" "tockSendArray(#,x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [A.Dimension 6] A.Int)
|
||||
,testOutputItem 205 "ChanOut(#,x,^);" "tockSendArray(#,x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [A.Dimension 6, A.Dimension 7, A.Dimension 8] A.Int)
|
||||
,testOutputItem 204 "ChanOut(wptr,#,x,^);" "tockSendArray(#,x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [A.Dimension 6] A.Int)
|
||||
,testOutputItem 205 "ChanOut(wptr,#,x,^);" "tockSendArray(#,x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [A.Dimension 6, A.Dimension 7, A.Dimension 8] A.Int)
|
||||
|
||||
--A counted array:
|
||||
,testOutputItem 206 "ChanOutInt(#,x);ChanOut(#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
,testOutputItem 206 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int A.Int)
|
||||
--A counted array of arrays:
|
||||
,testOutputItem 207 "ChanOutInt(#,x);ChanOut(#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
,testOutputItem 207 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int (A.Array [A.Dimension 5] A.Int))
|
||||
,testOutputItem 208 "ChanOutInt(#,x);ChanOut(#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
,testOutputItem 208 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int (A.Array [A.Dimension 4,A.Dimension 5] A.Int))
|
||||
|
||||
-- Test counted arrays that do not have Int as the count type:
|
||||
,testOutputItem 209 "ChanOut(#,&x,^);ChanOut(#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
,testOutputItem 209 "ChanOut(wptr,#,&x,^);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int8 A.Int8)
|
||||
|
||||
|
||||
--TODO add a pass that makes sure all outputs are variables. Including count for counted items
|
||||
|
||||
--Test sending things that are part of protocols (this will require different code in the C++ backend)
|
||||
,testOutputItemProt 301 "ChanOutInt(#,x);" "#<<tockSendableArrayOfBytes(&x);" (A.OutExpression emptyMeta $ exprVariable "x") A.Int
|
||||
,testOutputItemProt 302 "ChanOut(#,&x,^);" "#<<tockSendableArrayOfBytes(&x);" (A.OutExpression emptyMeta $ exprVariable "x") A.Int64
|
||||
,testOutputItemProt 303 "ChanOut(#,(&x),^);" "#<<tockSendableArrayOfBytes((&x));" (A.OutExpression emptyMeta $ exprVariable "x") (A.Record foo)
|
||||
,testOutputItemProt 304 "ChanOut(#,x,^);" "#<<tockSendableArrayOfBytes(x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [A.Dimension 6] A.Int)
|
||||
,testOutputItemProt 305 "ChanOut(#,x,^);" "#<<tockSendableArrayOfBytes(x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [A.Dimension 6, A.Dimension 7, A.Dimension 8] A.Int)
|
||||
,testOutputItemProt 306 "ChanOutInt(#,x);ChanOut(#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
,testOutputItemProt 301 "ChanOutInt(wptr,#,x);" "#<<tockSendableArrayOfBytes(&x);" (A.OutExpression emptyMeta $ exprVariable "x") A.Int
|
||||
,testOutputItemProt 302 "ChanOut(wptr,#,&x,^);" "#<<tockSendableArrayOfBytes(&x);" (A.OutExpression emptyMeta $ exprVariable "x") A.Int64
|
||||
,testOutputItemProt 303 "ChanOut(wptr,#,(&x),^);" "#<<tockSendableArrayOfBytes((&x));" (A.OutExpression emptyMeta $ exprVariable "x") (A.Record foo)
|
||||
,testOutputItemProt 304 "ChanOut(wptr,#,x,^);" "#<<tockSendableArrayOfBytes(x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [A.Dimension 6] A.Int)
|
||||
,testOutputItemProt 305 "ChanOut(wptr,#,x,^);" "#<<tockSendableArrayOfBytes(x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [A.Dimension 6, A.Dimension 7, A.Dimension 8] A.Int)
|
||||
,testOutputItemProt 306 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int A.Int)
|
||||
,testOutputItemProt 307 "ChanOutInt(#,x);ChanOut(#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
,testOutputItemProt 307 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int (A.Array [A.Dimension 5] A.Int))
|
||||
,testOutputItemProt 308 "ChanOutInt(#,x);ChanOut(#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
,testOutputItemProt 308 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
||||
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int (A.Array [A.Dimension 4,A.Dimension 5] A.Int))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ module Types
|
|||
specTypeOfName, typeOfSpec, abbrevModeOfName, typeOfName, typeOfExpression, typeOfVariable, underlyingType, stripArrayType, abbrevModeOfVariable, abbrevModeOfSpec
|
||||
, isRealType, isIntegerType, isCaseableType, resolveUserType, isSafeConversion, isPreciseConversion, isImplicitConversionRain
|
||||
, returnTypesOfFunction
|
||||
, BytesInResult(..), bytesInType, sizeOfReplicator, sizeOfStructured
|
||||
, BytesInResult(..), bytesInType, countReplicator, countStructured, computeStructured
|
||||
|
||||
, makeAbbrevAM, makeConstant, addOne
|
||||
, addDimensions, removeFixedDimensions, trivialSubscriptType, subscriptType, unsubscriptType
|
||||
|
|
@ -261,7 +261,7 @@ typeOfExpression e
|
|||
else typeOfArrayList [A.UnknownDimension] bt
|
||||
A.ExprConstr m (A.RepConstr _ rep e) ->
|
||||
do t <- typeOfExpression e
|
||||
count <- evalIntExpression $ sizeOfReplicator rep
|
||||
count <- evalIntExpression $ countReplicator rep
|
||||
typeOfArrayList [A.Dimension count] t
|
||||
A.AllocMobile _ t _ -> return t
|
||||
--}}}
|
||||
|
|
@ -577,20 +577,24 @@ bytesInType _ = return $ BIUnknown
|
|||
--}}}
|
||||
|
||||
-- | Get the number of items a replicator produces.
|
||||
sizeOfReplicator :: A.Replicator -> A.Expression
|
||||
sizeOfReplicator (A.For _ _ _ count) = count
|
||||
countReplicator :: A.Replicator -> A.Expression
|
||||
countReplicator (A.For _ _ _ count) = count
|
||||
|
||||
-- | Get the number of items in a Structured as an expression.
|
||||
sizeOfStructured :: Data a => A.Structured a -> A.Expression
|
||||
sizeOfStructured (A.Rep m rep s)
|
||||
= A.Dyadic m A.Times (sizeOfReplicator rep) (sizeOfStructured s)
|
||||
sizeOfStructured (A.Spec _ _ s) = sizeOfStructured s
|
||||
sizeOfStructured (A.ProcThen _ _ s) = sizeOfStructured s
|
||||
sizeOfStructured (A.Several m ss)
|
||||
countStructured :: Data a => A.Structured a -> A.Expression
|
||||
countStructured = computeStructured (\m _ -> makeConstant m 1)
|
||||
|
||||
-- | Compute an expression over a Structured.
|
||||
computeStructured :: Data a => (Meta -> a -> A.Expression) -> A.Structured a -> A.Expression
|
||||
computeStructured f (A.Rep m rep s)
|
||||
= A.Dyadic m A.Times (countReplicator rep) (computeStructured f s)
|
||||
computeStructured f (A.Spec _ _ s) = computeStructured f s
|
||||
computeStructured f (A.ProcThen _ _ s) = computeStructured f s
|
||||
computeStructured f (A.Only m x) = f m x
|
||||
computeStructured f (A.Several m ss)
|
||||
= case ss of
|
||||
[] -> makeConstant m 0
|
||||
_ -> foldl1 (A.Dyadic m A.Plus) (map sizeOfStructured ss)
|
||||
sizeOfStructured s = makeConstant (findMeta s) 1
|
||||
_ -> foldl1 (A.Dyadic m A.Plus) (map (computeStructured f) ss)
|
||||
|
||||
-- | Add one to an expression.
|
||||
addOne :: A.Expression -> A.Expression
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user