1%if false  
2  Copyright (c) 2009, ETH Zurich.
3  All rights reserved.
4  
5  This file is distributed under the terms in the attached LICENSE file.
6  If you do not find this file, copies can be found by writing to:
7  ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
8%endif
9
10%include polycode.fmt
11
12%if false
13
14> module Constructs.Conditionals where
15
16> import Data.List
17
18> import Semantics
19> import Constructs
20> import PureExpressions
21> import {-# SOURCE #-} Expressions
22> import Eval
23
24> import IL.FoF.FoF
25> import IL.FoF.Compile
26> import IL.FoF.Run
27
28%endif
29
30\section{Conditionals}
31\label{chap:conditionals}
32
33The |Conditionals| constructs consist of all control-flow operators
34defined in the C language, excepted the @goto@ statement and
35fall-through switches.
36
37\subsection{Smart Constructors}
38
39We provide the DSL designer with all standard C control-flow
40operators. Hence, we define the following combinators: |ifc|, |for|,
41|while|, |doWhile|, |break|, and |continue|.
42
43> ifc :: FoFCode PureExpr -> 
44>        FoFCode PureExpr -> 
45>        FoFCode PureExpr -> 
46>        FoFCode PureExpr
47> ifc cond ifTrue ifFalse = 
48>     inject (If cond ifTrue ifFalse (return Void))
49>
50> for :: FoFCode PureExpr -> 
51>        FoFCode PureExpr -> 
52>        FoFCode PureExpr -> 
53>        FoFCode PureExpr -> 
54>        FoFCode PureExpr
55> for init cond incr loop = 
56>     inject (For init cond incr loop (return Void))
57>
58> while :: FoFCode PureExpr ->
59>          FoFCode PureExpr -> 
60>          FoFCode PureExpr 
61> while cond loop = 
62>     inject (While cond loop (return Void))
63>
64> doWhile :: FoFCode PureExpr -> 
65>            FoFCode PureExpr -> 
66>            FoFCode PureExpr
67> doWhile loop cond = 
68>     inject (DoWhile loop cond (return Void))
69>
70> break :: FoFCode PureExpr
71> break = inject Break
72>
73> continue :: FoFCode PureExpr
74> continue = inject Continue
75
76The |switch| statement is slightly different from the C one: every
77case is automatically terminated by a @break@ statement. Hence, it is
78impossible to \emph{fall through} a case.
79
80> switch :: PureExpr -> 
81>           [(PureExpr, FoFCode PureExpr)] -> 
82>           FoFCode PureExpr -> 
83>           FoFCode PureExpr
84> switch cond cases defaultCase = 
85>     inject (Switch cond cases defaultCase (return Void))
86
87
88\subsection{Compile Instantiation}
89
90The compilation step is mostly standard. Note that we often have to
91compile sub-blocks of code. Therefore, we need to carefully update the
92relevant binding states, so as to ensure the freshness of generated
93names while respecting the scope of locally defined variables.
94
95> compileConditionals (If condi ifTrue ifFalse r) binding =
96>     (FIf compCond compIfTrue compIfFalse cont,
97>      binding2)
98>         where (compCond, binding1) = compileSemtoFoF' condi binding 
99>               (compIfTrue, binding1') = compileSemtoFoF' ifTrue binding1 
100>               (compIfFalse, binding1'') = compileSemtoFoF' ifFalse 
101>                                             (binding1' |-> binding1)
102>               (cont, binding2) = r (binding1'' |-> binding) 
103>
104> compileConditionals (While condW loop r) binding =
105>     (FWhile compCond compLoop cont,
106>      binding3)
107>         where (compCond, binding1) = compileSemtoFoF' condW binding 
108>               (compLoop, binding2) = compileSemtoFoF' loop binding1 
109>               (cont, binding3 ) = r (binding2 |-> binding) 
110>     
111>
112> compileConditionals (DoWhile loop condD r) binding =
113>     (FDoWhile compLoop compCond cont,
114>      binding3)
115>         where (compLoop, binding1) = compileSemtoFoF' loop binding 
116>               (compCond, binding2) = compileSemtoFoF' condD 
117>                                      (binding1 |-> binding)
118>               (cont, binding3 ) = r (binding2 |-> binding)
119>
120> compileConditionals (For init test inc loop r) binding =
121>     (FFor compInit compTest compInc compLoop cont,
122>      binding5)
123>         where (compInit, binding1) = compileSemtoFoF' init binding 
124>               (compTest, binding2) = compileSemtoFoF' test binding1 
125>               (compInc, binding3) = compileSemtoFoF' inc binding2 
126>               (compLoop, binding4) = compileSemtoFoF' loop  
127>                                      (binding1 |-> binding3)
128>               (cont, binding5) = r (binding4 |-> binding) 
129>
130> compileConditionals (Switch test cases defaultC r) binding =
131>     (FSwitch test compCases compDefault cont,
132>      binding3)
133>         where compileCase (compCodes, binding) (i, code) =
134>                   ((i, compCode) : compCodes, 
135>                    (binding1 |-> binding))
136>                   where (compCode, binding1) = compileSemtoFoF' code binding
137>               (compCases, binding1) = 
138>                   foldl' compileCase ([], binding) cases 
139>               (compDefault, binding2) =
140>                   compileSemtoFoF' defaultC (binding1 |-> binding) 
141>               (cont, binding3) = r (binding2 |-> binding)
142>
143> compileConditionals Break binding =
144>     (FClosing $ FBreak, binding)
145>
146> compileConditionals Continue binding =
147>     (FClosing $ FContinue, binding)
148
149
150
151\subsection{Run Instantiation}
152
153The implementation of the interpreter is straightforward. We start by
154dispatching calls to construct-specific functions:
155
156> runConditionals (If a b c r) heap  = 
157>     r $ runIf a b c heap
158> runConditionals (For a b c d r) heap = 
159>     r $ runFor a b c d heap
160> runConditionals (While a b r) heap = 
161>     r $ runWhile a b heap
162> runConditionals (DoWhile a b r) heap = 
163>     r $ runDoWhile a b heap
164> runConditionals (Switch a b c r) heap = 
165>     r $ runSwitch a b c heap
166> runConditionals Break heap = 
167>     error "runAlgebra: Break not yet implemented"
168> runConditionals Continue heap = 
169>     error "runAlgebra: Continue not yet implemented"
170
171Then, we implement the semantics of each of these constructs:
172
173> runIf :: FoFCode PureExpr -> 
174>          FoFCode PureExpr -> 
175>          FoFCode PureExpr -> 
176>          Heap -> Heap
177> runIf test ifTrue ifFalse heap = 
178>     let (vtest, heap1) = run test heap in
179>     let CLInteger _ _ valVtest = symbEval vtest in
180>     if (valVtest /= 0) then
181>        let (_, heap2) = run ifTrue heap1 in
182>        heap2
183>     else
184>        let (_, heap2) = run ifFalse heap1 in
185>        heap2
186>
187> runFor :: FoFCode PureExpr -> 
188>           FoFCode PureExpr ->
189>           FoFCode PureExpr -> 
190>           FoFCode PureExpr -> 
191>           Heap -> Heap
192> runFor init test incr loop heap =
193>     let (_, heap1) = run init heap in
194>     loopWhile heap1
195>         where loopWhile heap =
196>                   let (vtest, heap1) = run test heap in
197>                   let CLInteger _ _ valVtest = symbEval vtest in
198>                   if (valVtest /= 0) then
199>                      let (_, heap2) = run loop heap1 in
200>                      let (_, heap3) = run incr heap2 in
201>                          loopWhile heap3
202>                   else heap1
203>
204> runWhile :: FoFCode PureExpr -> 
205>             FoFCode PureExpr -> 
206>             Heap -> Heap
207> runWhile test loop heap =
208>     let (vtest, heap1) = run test heap in
209>     let (CLInteger _ _ valVtest) = symbEval vtest in
210>     if (valVtest /= 0) then
211>        let (_, heap2) = run loop heap1 in
212>        runWhile test loop heap2
213>     else heap1
214>
215> runDoWhile :: FoFCode PureExpr ->  
216>               FoFCode PureExpr -> 
217>               Heap -> Heap
218> runDoWhile loop test heap =
219>     let (_, heap1) = run loop heap in
220>     let (vtest, heap2) = run test heap1 in
221>     let CLInteger _ _ valVtest = symbEval vtest in
222>     if (valVtest /= 0) then
223>         runDoWhile loop test heap2
224>     else
225>         heap2
226>
227> runSwitch :: PureExpr -> 
228>              [(PureExpr, FoFCode PureExpr)] -> 
229>              FoFCode PureExpr -> 
230>              Heap -> Heap
231> runSwitch test cases defaultCase heap =
232>     let res = symbEval test in
233>         case res `lookup` cases of
234>           Just stmt -> let (_, heap1) = run stmt heap in
235>                        heap1
236>           Nothing -> let (_, heap1) = run defaultCase heap in
237>                      heap1
238
239