1 | // $Source$ |
---|
2 | // $Revision: 1201 $ |
---|
3 | // $Date: 2003-08-13 22:59:18 +0000 (Wed, 13 Aug 2003) $ |
---|
4 | |
---|
5 | $use "rfpc"; |
---|
6 | $use "rfp_list"; |
---|
7 | $use "rfp_helper"; |
---|
8 | $use "rfp_check"; |
---|
9 | $use "rfp_as2as"; |
---|
10 | $use "rfp_format"; |
---|
11 | $use "rfp_vars"; |
---|
12 | $use "rfp_const"; |
---|
13 | $use "rfp_clashes"; |
---|
14 | |
---|
15 | $use StdIO; |
---|
16 | $use Table; |
---|
17 | $use Box; |
---|
18 | $use Arithm; |
---|
19 | $use Access; |
---|
20 | $use Compare; |
---|
21 | $use Convert; |
---|
22 | $use Class; |
---|
23 | $use Apply; |
---|
24 | $use Dos; |
---|
25 | |
---|
26 | |
---|
27 | /* |
---|
28 | * Table for storing object names. |
---|
29 | */ |
---|
30 | $table Objects; |
---|
31 | |
---|
32 | /* |
---|
33 | * Table for storing parameters of referenced functions. |
---|
34 | */ |
---|
35 | $table Stub-Funcs; |
---|
36 | |
---|
37 | /* |
---|
38 | * Box for storing function out format |
---|
39 | */ |
---|
40 | $box Out-Format; |
---|
41 | |
---|
42 | /* |
---|
43 | * Box for storing names for function result variables |
---|
44 | */ |
---|
45 | $box Res-Vars; |
---|
46 | |
---|
47 | /* |
---|
48 | * Following table is used by Gener-Label function for obtaining unical (for |
---|
49 | * certain function) label name. |
---|
50 | * e.Key ::= e.QualifiedName (parameter given to Gener-Label) |
---|
51 | * e.Val ::= [Int] (last index used with such e.QualifiedName) |
---|
52 | */ |
---|
53 | $table Labels; |
---|
54 | |
---|
55 | /* |
---|
56 | * Table for storing variables used in place of preprocessor-generated ones. |
---|
57 | */ |
---|
58 | $table Prep-Vars; |
---|
59 | |
---|
60 | |
---|
61 | $func Compile (e.targets) (e.headers) e.Items = e.Compiled-Items (INTERFACE e.headers); |
---|
62 | |
---|
63 | $func Comp-Func-Stubs = e.asail-funcs; |
---|
64 | |
---|
65 | $func Comp-Func s.tag t.name e.params-and-body = e.compiled-func; |
---|
66 | |
---|
67 | $func Set-Drops (e.declared-exprs) e.comp-func = (e.declared-exprs) e.result-func; |
---|
68 | |
---|
69 | $func Comp-Sentence e.Sentence = e.asail-sentence; |
---|
70 | |
---|
71 | $func Save-Snt-State = ; |
---|
72 | |
---|
73 | $func Recall-Snt-State = ; |
---|
74 | |
---|
75 | $func Pop-Snt-State = ; |
---|
76 | |
---|
77 | $func Extract-Calls e.Re = (e.last-Re) e.calls; |
---|
78 | |
---|
79 | $func Get-Clash-Sequence (e.last-Re) e.Snt = (e.clashes) e.rest-of-the-Sentence; |
---|
80 | |
---|
81 | $func? Without-Calls? e.Re = ; |
---|
82 | |
---|
83 | $func Comp-Clashes (e.clashes) s.tail? (v.fails) e.Sentence = e.asail-sentence; |
---|
84 | |
---|
85 | $func Gener-Label e.QualifiedName = t.label; |
---|
86 | |
---|
87 | $func Add-To-Label t.label e.name = t.label; |
---|
88 | |
---|
89 | $func Comp-Calls e.Re = e.calls; |
---|
90 | |
---|
91 | $func Prepare-Vars e.vars = e.vars; |
---|
92 | |
---|
93 | $func Prepare-Res e.Reult-exprs = e.Result-exprs; |
---|
94 | |
---|
95 | $func Comp-Assigns e.assignments = e.asail-assignments; |
---|
96 | |
---|
97 | $func Comp-Format (e.last-Re) e.He = e.assignments; |
---|
98 | |
---|
99 | |
---|
100 | |
---|
101 | ************ Get AS-Items and targets, and pass it to Compile ************ |
---|
102 | |
---|
103 | /* |
---|
104 | * Ящик для объявлений статических функций, констант и объектов. Все они |
---|
105 | * выписываются в самом начале тела модуля. |
---|
106 | */ |
---|
107 | $box Declarations; |
---|
108 | |
---|
109 | RFP-Compile e.Items = |
---|
110 | { <Lookup &RFP-Options ITEMS>;; } :: e.targets, |
---|
111 | <RFP-Clear-Table &Stub-Funcs>, |
---|
112 | <Store &Declarations /*empty*/>, |
---|
113 | <Init-Consts>, |
---|
114 | <Compile (e.targets) () e.Items> :: e.Items t.Interface, |
---|
115 | <Comp-Func-Stubs> :: e.stub-funcs, |
---|
116 | t.Interface (MODULE <? &Declarations> <Comp-Consts> e.Items e.stub-funcs); |
---|
117 | |
---|
118 | |
---|
119 | |
---|
120 | ****************** Choose needed items and compile them ****************** |
---|
121 | |
---|
122 | Compile (e.targets) (e.headers) e.Items, { |
---|
123 | e.Items : e t.item e.rest, |
---|
124 | { |
---|
125 | e.targets : v = |
---|
126 | e.targets : e t.name e, |
---|
127 | t.item : (t t t t.name e);; |
---|
128 | }, |
---|
129 | t.item : { |
---|
130 | (IMPORT e) = () /*empty*/; |
---|
131 | (s.link s.tag t.pragma t.name (e.in) (e.out) e.body), FUNC FUNC? : e s.tag e = |
---|
132 | { |
---|
133 | s.link : EXPORT = (DECL-FUNC EXPORT t.name); |
---|
134 | <Put &Declarations (DECL-FUNC LOCAL t.name)> = /*empty*/; |
---|
135 | } :: e.decl, |
---|
136 | { |
---|
137 | e.body : (BRANCH t.p e.branch) = |
---|
138 | <Comp-Func s.tag t.name <Del-Pragmas (e.in) (e.out) e.branch>>;; |
---|
139 | } :: e.comp-func, |
---|
140 | (e.decl) e.comp-func; |
---|
141 | (s.link CONST t.pragma t.name e.expr) = |
---|
142 | (CONSTEXPR s.link t.name (e.expr) e.expr) :: t.const, |
---|
143 | { |
---|
144 | s.link : EXPORT = (t.const) /*empty*/; |
---|
145 | <Put &Declarations t.const> = () /*empty*/; |
---|
146 | }; |
---|
147 | (EXPORT s.tag t.pragma t.name) = ((DECL-OBJ EXPORT s.tag t.name)) /*empty*/; |
---|
148 | (LOCAL s.tag t.pragma t.name) = |
---|
149 | <Put &Declarations (DECL-OBJ LOCAL s.tag t.name)>, |
---|
150 | () /*empty*/; |
---|
151 | } :: (e.decl) e.item = |
---|
152 | e.item <Compile (e.targets) (e.headers e.decl) e.rest>; |
---|
153 | /*<Comp-Func-Stubs>*/ (INTERFACE e.headers); |
---|
154 | }; |
---|
155 | |
---|
156 | |
---|
157 | |
---|
158 | $func Gener-Stub e = e; |
---|
159 | |
---|
160 | /* |
---|
161 | * For each referenced function generate a stub one with format e = e. |
---|
162 | */ |
---|
163 | Comp-Func-Stubs = <Map &Gener-Stub (<Domain &Stub-Funcs>)>; |
---|
164 | |
---|
165 | Gener-Stub (t.name) = |
---|
166 | <Lookup &Stub-Funcs t.name> : t.stub-name s.tag (e.Fin) (e.Fout), |
---|
167 | <Put &Declarations (DECL-FUNC LOCAL t.stub-name)>, |
---|
168 | <Gener-Vars (e.Fin) "stub"> :: e.He, |
---|
169 | <Comp-Func s.tag t.stub-name ((EVAR ("arg" 1))) ((EVAR)) |
---|
170 | (LEFT e.He) (RESULT (CALL t.name e.He))>; |
---|
171 | |
---|
172 | |
---|
173 | |
---|
174 | Comp-Func s.tag t.name (e.in) (e.out) e.Sentence = |
---|
175 | <RFP-Clear-Table &Labels>, |
---|
176 | <RFP-Clear-Table &Prep-Vars>, |
---|
177 | <Init-Vars>, |
---|
178 | <Vars <Gener-Vars (e.out) "res">> :: e.res-vars, |
---|
179 | <Vars-Decl e.res-vars> : e, |
---|
180 | <Store &Res-Vars e.res-vars>, |
---|
181 | <Store &Out-Format <Format-Exp e.out>>, |
---|
182 | <Prepare-Res (e.in)> : (e.arg), |
---|
183 | <Vars e.arg> :: e.arg-vars, |
---|
184 | <Map &Set-Var- (Instantiated? True) (e.arg-vars)> : e, |
---|
185 | s.tag : { |
---|
186 | FUNC = FATAL; |
---|
187 | FUNC? = RETFAIL; |
---|
188 | } :: t.retfail, |
---|
189 | (FUNC t.name (<Vars-Print e.arg-vars>) (<Vars-Print e.res-vars>) |
---|
190 | <Comp-Sentence Tail ((t.retfail)) (e.arg) e.Sentence> |
---|
191 | ) :: e.comp-func, |
---|
192 | * <Set-Drops () <Gener-Var-Names e.comp-func>> :: t e.comp-func, |
---|
193 | <Gener-Var-Names e.comp-func> :: e.comp-func, |
---|
194 | //! <Post-Comp (e.res-vars) e.comp-func> :: t e.result, |
---|
195 | //! e.result; |
---|
196 | e.comp-func; |
---|
197 | // :: (e.func-decl) e.func-body, |
---|
198 | // () <Domain &Declarations> $iter { |
---|
199 | // e.vars : (t.var) e.rest-vars, |
---|
200 | // (e.var-decls (DECL t.var)) e.rest-vars; |
---|
201 | // } :: (e.var-decls) e.vars, |
---|
202 | // e.vars : /*empty*/, |
---|
203 | // (e.func-decl e.var-decls e.func-body); |
---|
204 | |
---|
205 | Set-Drops (e.declared) e.comp-func = |
---|
206 | e.comp-func () (e.declared) $iter { |
---|
207 | e.comp-func : t.first e.rest, { |
---|
208 | t.first : \{ |
---|
209 | (EXPR t.var e) = (DROP t.var) (t.first) t.var Init; |
---|
210 | (DEREF t.var e) = (DROP t.var) (t.first) t.var Init; |
---|
211 | (SUBEXPR t.var e) = (DROP t.var) (t.first) t.var Init; |
---|
212 | (DECL Expr t.var) = (DROP t.var) () t.var Decl; |
---|
213 | (DECL "int" t.var) = /*empty*/ () t.var Decl; |
---|
214 | } :: e.drop (e.constr) t.var s.init, |
---|
215 | { |
---|
216 | e.declared : e1 t.var s.old-init e2, s.old-init : { |
---|
217 | Init, { |
---|
218 | t.var : (VAR ("const" e)) = |
---|
219 | e.rest (e.result-func) (e.declared); |
---|
220 | e.rest (e.result-func e.drop e.constr) (e.declared); |
---|
221 | }; |
---|
222 | Decl, s.init : { |
---|
223 | Decl = |
---|
224 | e.rest (e.result-func) (e.declared); |
---|
225 | Init = |
---|
226 | t.first : (s.method t.var e.args), |
---|
227 | e.rest (e.result-func (ASSIGN t.var (s.method e.args))) |
---|
228 | (e1 e2 t.var s.init); |
---|
229 | /* |
---|
230 | * FIXME: if s.method is EXPR, it shouldn't be written. |
---|
231 | */ |
---|
232 | }; |
---|
233 | }; |
---|
234 | e.rest (e.result-func t.first) (e.declared t.var s.init); |
---|
235 | }; |
---|
236 | t.first : (LABEL (t.label) e.expr) = |
---|
237 | <Set-Drops (e.declared) e.expr> :: (e.declared) e.expr, |
---|
238 | e.rest (e.result-func (LABEL (t.label) e.expr)) (e.declared); |
---|
239 | t.first : (e.expr) = |
---|
240 | <Set-Drops (e.declared) e.expr> :: t e.expr, |
---|
241 | e.rest (e.result-func (e.expr)) (e.declared); |
---|
242 | t.first : s.symbol = |
---|
243 | e.rest (e.result-func s.symbol) (e.declared); |
---|
244 | }; |
---|
245 | } :: e.comp-func (e.result-func) (e.declared), |
---|
246 | e.comp-func : /*empty*/ = |
---|
247 | (e.declared) e.result-func; |
---|
248 | |
---|
249 | |
---|
250 | Comp-Sentence s.tail? (v.fails) (e.last-Re) e.Sentence, e.Sentence : { |
---|
251 | |
---|
252 | /*empty*/ = /*empty*/; |
---|
253 | |
---|
254 | /* |
---|
255 | * In case of Re look if we should do a tailcall. If not, then compile |
---|
256 | * function calls from the Re and assign results to the out parameters or |
---|
257 | * use them in compilation of the rest of the sentence. |
---|
258 | */ |
---|
259 | (RESULT e.Re) e.Snt = |
---|
260 | { |
---|
261 | /* |
---|
262 | * If the Re is the last action in the sentence then we can do |
---|
263 | * tailcall if one of the following is true: |
---|
264 | * - Re is a call of non-failable function; |
---|
265 | * - Re is a call of a failable function, current function is |
---|
266 | * failable, and the failures stack is empty. |
---|
267 | * In both cases out format of the called function should coincide |
---|
268 | * with those of compiled one. |
---|
269 | * FIXME: really we can do tailcall if all the parameters of |
---|
270 | * compiled function that won't get their values from the call can |
---|
271 | * be assigned from other sources. Some support from runtime is |
---|
272 | * needed though. |
---|
273 | */ |
---|
274 | e.Snt : /*empty*/, s.tail? : Tail, e.Re : (CALL t.name e.arg), |
---|
275 | { <In-Table? &Fun? t.name> = v.fails : (RETFAIL);; }, |
---|
276 | <Lookup-Func t.name> :: s.linkage s.tag t.pragma (e.Fin) (e.Fout), |
---|
277 | <Subformat? (e.Fout) (<? &Out-Format>)> = |
---|
278 | <Extract-Calls e.arg> :: (e.last-Re) e.calls, |
---|
279 | <Prepare-Res <Split-Re (e.Fin) e.last-Re>> :: e.splited-Re, |
---|
280 | <Comp-Calls <R 0 v.fails> e.calls> |
---|
281 | (TAILCALL t.name (e.splited-Re) (<? &Res-Vars>)); |
---|
282 | |
---|
283 | <Extract-Calls e.Re> :: (e.last-Re) e.calls, |
---|
284 | <Comp-Calls <R 0 v.fails> e.calls> :: e.comp-calls, |
---|
285 | { |
---|
286 | e.Snt : /*empty*/, s.tail? : Tail = |
---|
287 | <Split-Re (<? &Out-Format>) e.last-Re> :: e.splited-Re, |
---|
288 | <Prepare-Res e.splited-Re> :: e.splited-Re, |
---|
289 | e.comp-calls <Comp-Assigns <Zip (<? &Res-Vars>) (e.splited-Re)>>; |
---|
290 | |
---|
291 | e.comp-calls <Comp-Sentence s.tail? (v.fails) (e.last-Re) e.Snt>; |
---|
292 | }; |
---|
293 | }; |
---|
294 | |
---|
295 | /* |
---|
296 | * In case of He compile assignments from last Re and then (with new state |
---|
297 | * of variables) proceed with the rest of the sentence. |
---|
298 | */ |
---|
299 | (FORMAT e.He) e.Snt = |
---|
300 | <Comp-Format (e.last-Re) e.He> |
---|
301 | <Comp-Sentence s.tail? (v.fails) () e.Snt>; |
---|
302 | |
---|
303 | /* |
---|
304 | * In case of Pe get from the begining of the sentence a maximum possible |
---|
305 | * sequence of clashes and compile it. New values of variables from the |
---|
306 | * clashes use in the compilation of the rest of the sentence. |
---|
307 | */ |
---|
308 | (s.dir e.Pattern) e.Snt, s.dir : \{ LEFT; RIGHT; } = |
---|
309 | <Get-Clash-Sequence (e.last-Re) e.Sentence> :: (e.clashes) e.Sentence, |
---|
310 | <Comp-Clashes (e.clashes) s.tail? (v.fails) e.Sentence>; |
---|
311 | |
---|
312 | (s.block) e, BLOCK BLOCK? : e s.block e = <WriteLN! &StdErr "Empty block?">, $fail; |
---|
313 | |
---|
314 | /* |
---|
315 | * In case of a block first see if its results are needed for something |
---|
316 | * after the block and determine whether the block is a source. Then |
---|
317 | * compile each branch in turn. |
---|
318 | */ |
---|
319 | (s.block e.branches) e.Snt, |
---|
320 | s.block : \{ |
---|
321 | BLOCK = (FATAL); |
---|
322 | BLOCK?; |
---|
323 | } :: e.fatal? = |
---|
324 | /* |
---|
325 | * If the block initializes an $iter then extract from the $iter the He |
---|
326 | * for placing it in the end of each branch. |
---|
327 | * Then look if the block is used by a pattern or format expression. |
---|
328 | * If so, we should declare variables from that expression before |
---|
329 | * entering any branch -- those should be visible after the block. |
---|
330 | * Pattern or format expression is placed in the end of each branch. |
---|
331 | * But if a branch computes to $error, the expression shouldn't be |
---|
332 | * used, so protect it with (Comp If-not-error). |
---|
333 | * If next after the block is (Comp Error) then block results should be |
---|
334 | * used as values for $error, so place (Comp Error) in the end of each |
---|
335 | * branch. |
---|
336 | * If next after the block is (Comp If-not-error) then our block is in |
---|
337 | * the end of a branch of an outer block and has next pattern or format |
---|
338 | * inherited from there. In that case we should place all the sentence |
---|
339 | * rest in the end of each branch because the block can be inside the |
---|
340 | * $error already. |
---|
341 | */ |
---|
342 | { |
---|
343 | e.Snt : (ITER t.body t.format t.cond) e.rest = |
---|
344 | t.format (Comp Iter t.body t.format t.cond) e.rest; |
---|
345 | e.Snt; |
---|
346 | } :: e.Snt, |
---|
347 | e.Snt : { |
---|
348 | t.first e.rest, t.first : \{ |
---|
349 | (LEFT e.pattern) = e.pattern; |
---|
350 | (RIGHT e.pattern) = e.pattern; |
---|
351 | (FORMAT e.format) = e.format; |
---|
352 | } :: e.expr = |
---|
353 | <Prepare-Vars <Vars e.expr>> :: e.vars, |
---|
354 | (e.vars) ((Comp If-not-error) t.first) |
---|
355 | ((Comp Source)) e.rest; |
---|
356 | (Comp Error) e.rest = |
---|
357 | () ((Comp Error)) () /*empty*/; |
---|
358 | (Comp If-not-error) e.rest = |
---|
359 | () (e.Snt) () /*empty*/; |
---|
360 | e = () () () e.Snt; |
---|
361 | } :: (e.out-vars) (e.next-terms) (e.source?) e.Snt, |
---|
362 | /* |
---|
363 | * The block is a source if after it goes pattern or format expression |
---|
364 | * (in that case e.source? isn't empty) or e.Snt isn't empty. |
---|
365 | * Branches in the block are tail sentences if the current sentence is |
---|
366 | * tail and the block isn't a source. |
---|
367 | */ |
---|
368 | { |
---|
369 | \{ e.source? : v; e.Snt : v; } = ((Comp Source) <R 0 v.fails>) Notail; |
---|
370 | s.tail? : Tail = () Tail; |
---|
371 | () Notail; |
---|
372 | } :: (e.source?) s.tail-branch?, |
---|
373 | /* |
---|
374 | * In case our block is a source we should mark the position in the |
---|
375 | * failures stack, so that we can jump to it after CUTALL. And if our |
---|
376 | * block isn't failable we should add (FATAL) to the end of the stack. |
---|
377 | */ |
---|
378 | v.fails e.source? e.fatal? :: v.branch-fails, |
---|
379 | /* |
---|
380 | * Before compile the branches mark all out-vars as declared. |
---|
381 | */ |
---|
382 | <Vars-Decl e.out-vars> :: e.decls, |
---|
383 | /* |
---|
384 | * We put all compiled branches in a block, so positive return from a |
---|
385 | * branch is a break from that block. |
---|
386 | * Each branch in its turn is placed in its own block, so for a $fail |
---|
387 | * to the next branch we should just break from that inner block. |
---|
388 | * Each branch is compiled with the current sentence state and the |
---|
389 | * state is recalled after that. When all branches are compiled the |
---|
390 | * state is popped out from the stack. |
---|
391 | * If last branch fails then the whole block fails, and return from the |
---|
392 | * last branch is return from the block. So the last branch isn't |
---|
393 | * placed in a block and is processed with the failures stack that was |
---|
394 | * before entering the block. Note: this trick helps us find more |
---|
395 | * tailcalls. If the call of a failable function is on the last branch |
---|
396 | * of the block and the failures stack is empty we can do tailcall. |
---|
397 | * When the last branch is compiled with the block's stack, all we |
---|
398 | * should do is to check it. |
---|
399 | */ |
---|
400 | <Gener-Label "block"> :: t.label, |
---|
401 | <Save-Snt-State>, |
---|
402 | (e.branches) /*e.comp-branches*/ $iter { |
---|
403 | e.branches : (BRANCH e.branch) e.rest-br = |
---|
404 | <Add-To-Label t.label "branch"> :: t.br-label, |
---|
405 | <Comp-Sentence |
---|
406 | s.tail-branch? |
---|
407 | (v.branch-fails ((BREAK t.br-label))) |
---|
408 | (e.last-Re) |
---|
409 | e.branch e.next-terms |
---|
410 | > :: e.comp-br, |
---|
411 | <Recall-Snt-State>, |
---|
412 | (e.rest-br) e.comp-branches (LABEL (t.br-label) e.comp-br (BREAK t.label)); |
---|
413 | } :: (e.branches) e.comp-branches, |
---|
414 | e.branches : (BRANCH e.branch) = |
---|
415 | <Comp-Sentence |
---|
416 | s.tail-branch? (v.branch-fails) (e.last-Re) e.branch e.next-terms |
---|
417 | > :: e.last-branch, |
---|
418 | <Pop-Snt-State>, |
---|
419 | <Map &Set-Var- (Instantiated? True) (e.out-vars)> : e, |
---|
420 | e.decls (LABEL (t.label) e.comp-branches e.last-branch) |
---|
421 | <Comp-Sentence s.tail? (v.fails) () e.Snt>; |
---|
422 | |
---|
423 | /* |
---|
424 | * In case of $iter first of all compile initial assignment to the hard |
---|
425 | * expression. |
---|
426 | */ |
---|
427 | (ITER t.body t.format t.cond) e.Snt = |
---|
428 | <Comp-Sentence s.tail? (v.fails) (e.last-Re) |
---|
429 | t.format (Comp Iter t.body t.format t.cond) e.Snt |
---|
430 | >; |
---|
431 | |
---|
432 | /* |
---|
433 | * Then compile $iter condition and body both with the current state of the |
---|
434 | * sentence. |
---|
435 | * e.Snt can contain (Comp Error) and (protected from errors) pattern or |
---|
436 | * format which comes from an outer block, so compile it together with the |
---|
437 | * condition. |
---|
438 | * If condition fails we should compute the body, so put the compiled |
---|
439 | * condition in a block and place a break from it to the failures stack. |
---|
440 | */ |
---|
441 | (Comp Iter (BRANCH e.body) t.format (BRANCH e.condition)) e.Snt = |
---|
442 | <Gener-Label "iter"> :: t.label, |
---|
443 | <Gener-Label "exit_iter"> :: t.exit, |
---|
444 | <Save-Snt-State>, |
---|
445 | <Comp-Sentence s.tail? (v.fails ((BREAK t.label))) () e.condition e.Snt> |
---|
446 | :: e.comp-condition, |
---|
447 | <Pop-Snt-State>, |
---|
448 | <Comp-Sentence Notail (v.fails) () e.body t.format> :: e.comp-body, |
---|
449 | (FOR (/*cont-label*/) (t.exit) () () |
---|
450 | (LABEL (t.label) e.comp-condition (BREAK t.exit)) e.comp-body |
---|
451 | ); |
---|
452 | |
---|
453 | /* |
---|
454 | * In case of $trap/$with at first compile try-sentence. All $fails from |
---|
455 | * it should become errors. |
---|
456 | * Then recall the state of the sentence and compile catching of an error |
---|
457 | * with a variable err. |
---|
458 | * e.Snt can contain (Comp Error) and (protected from errors) pattern or |
---|
459 | * format which comes from an outer block, so compile it together with both |
---|
460 | * sentences. |
---|
461 | */ |
---|
462 | (TRY (BRANCH e.try) e.catch) e.Snt = |
---|
463 | <Save-Snt-State>, |
---|
464 | <Comp-Sentence Notail ((FATAL)) () e.try e.Snt> :: e.comp-try, |
---|
465 | <Pop-Snt-State>, |
---|
466 | <Gener-Err-Var> :: t.var, |
---|
467 | <Set-Var (Instantiated? True) t.var>, |
---|
468 | <Comp-Sentence s.tail? (v.fails) (t.var) e.catch e.Snt> :: e.comp-catch, |
---|
469 | (TRY e.comp-try) (CATCH-ERROR e.comp-catch); |
---|
470 | |
---|
471 | /* |
---|
472 | * In case of \? add Stake to the failures stack. Add last fail after it |
---|
473 | * for <R 0 v.fails> continue to work. |
---|
474 | */ |
---|
475 | (STAKE) e.Snt = |
---|
476 | <Comp-Sentence s.tail? (v.fails (Comp Stake) <R 0 v.fails>) () e.Snt>; |
---|
477 | |
---|
478 | /* |
---|
479 | * In case of \! forget all failure catchers after last \?. |
---|
480 | * If there is no Stake then we are inside negation or error (we assume the |
---|
481 | * program is correct). So the right failure catcher is in the bottom of |
---|
482 | * the stack. |
---|
483 | */ |
---|
484 | (CUT) e.Snt = |
---|
485 | { |
---|
486 | v.fails : $r v.earlier-fails (Comp Stake) e = v.earlier-fails; |
---|
487 | <L 0 v.fails>; |
---|
488 | } :: v.fails, |
---|
489 | <Comp-Sentence s.tail? (v.fails) () e.Snt>; |
---|
490 | |
---|
491 | /* |
---|
492 | * In case of = clear the failures stack up to the closest source. |
---|
493 | */ |
---|
494 | (CUTALL) e.Snt = |
---|
495 | { |
---|
496 | v.fails : $r v.earlier-fails (Comp Source) e = v.earlier-fails; |
---|
497 | <L 0 v.fails>; |
---|
498 | } :: v.fails, |
---|
499 | <Comp-Sentence s.tail? (v.fails) () e.Snt>; |
---|
500 | |
---|
501 | /* |
---|
502 | * In case of = in the Refal-6 sense (non-transparent hedge for the fails), |
---|
503 | * $fail(k) should become $error(Fname "Unexpected fail"), so clear the |
---|
504 | * failures stack and put that value in it. |
---|
505 | */ |
---|
506 | NOFAIL e.Snt = |
---|
507 | <Comp-Sentence s.tail? ((FATAL)) (e.last-Re) e.Snt>; |
---|
508 | |
---|
509 | /* |
---|
510 | * In case of $fail return last failure catcher. |
---|
511 | */ |
---|
512 | (FAIL) e.Snt = |
---|
513 | v.fails : e (e.last-fail), |
---|
514 | e.last-fail; |
---|
515 | |
---|
516 | /* |
---|
517 | * In case of # we should proceed with the rest if the source is computed |
---|
518 | * to $fail. |
---|
519 | * We could compile the rest of the sentence and place it in the |
---|
520 | * failures stack. But then the compiled sentence would be copied as many |
---|
521 | * times as there are $fail's to the upper level in the source. So we |
---|
522 | * place compiled source in the block and put the break to exit from it in |
---|
523 | * the stack. |
---|
524 | * When compiling the source mark it as Notail as usual. |
---|
525 | * If the source isn't computed to $fail we should proceed with the last |
---|
526 | * failure catcher. |
---|
527 | */ |
---|
528 | (NOT (BRANCH e.branch)) e.Snt = |
---|
529 | <Gener-Label "negation"> :: t.label, |
---|
530 | v.fails : e (e.last-fail), |
---|
531 | // <Save-Snt-State>, |
---|
532 | <Comp-Sentence Notail (((BREAK t.label))) () e.branch> e.last-fail |
---|
533 | :: e.comp-negation, |
---|
534 | // <Pop-Snt-State>, |
---|
535 | (LABEL (t.label) e.comp-negation) <Comp-Sentence s.tail? (v.fails) () e.Snt>; |
---|
536 | |
---|
537 | /* |
---|
538 | * In case of $error all fails become $error(Fname "Unexpected fail"). So |
---|
539 | * place that value in the failures stack and then compile the computation |
---|
540 | * of the rest of the sentence and the last Re which should be the value of |
---|
541 | * $error. |
---|
542 | */ |
---|
543 | (ERROR) e.Snt = |
---|
544 | <Comp-Sentence Notail ((FATAL)) () e.Snt (Comp Error)>; |
---|
545 | |
---|
546 | (Comp Error) e.Snt = |
---|
547 | <Prepare-Res (e.last-Re)> : (e.Re), |
---|
548 | (ERROR e.Re); |
---|
549 | |
---|
550 | /* |
---|
551 | * Protection mark to be used between source and tail. If there is $error |
---|
552 | * construction somewhere in the source then the tail shouldn't be |
---|
553 | * computed, but instead the source value should be used for throwing. |
---|
554 | */ |
---|
555 | (Comp If-not-error) e.Snt = |
---|
556 | { |
---|
557 | e.Snt : e (Comp Error) = |
---|
558 | <Comp-Sentence s.tail? (v.fails) (e.last-Re) (Comp Error)>; |
---|
559 | <Comp-Sentence s.tail? (v.fails) (e.last-Re) e.Snt>; |
---|
560 | }; |
---|
561 | |
---|
562 | // (Comp Fatal) = FATAL; |
---|
563 | |
---|
564 | // (Comp Retfail) = RETFAIL; |
---|
565 | |
---|
566 | }; |
---|
567 | |
---|
568 | |
---|
569 | |
---|
570 | ********** Sentence state stack and functions for work with it. ********** |
---|
571 | |
---|
572 | $box Snt-State; |
---|
573 | |
---|
574 | /* |
---|
575 | * Put current state in the stack. |
---|
576 | */ |
---|
577 | Save-Snt-State = <Put &Snt-State <Vars-Copy-State>>; |
---|
578 | |
---|
579 | /* |
---|
580 | * Set current state to that at the top of the stack. |
---|
581 | */ |
---|
582 | Recall-Snt-State = <Vars-Set-State <R 0 <? &Snt-State>>>; |
---|
583 | |
---|
584 | /* |
---|
585 | * Pop the top from the stack and set current state to it. |
---|
586 | */ |
---|
587 | Pop-Snt-State = |
---|
588 | <Recall-Snt-State>, |
---|
589 | <Store &Snt-State <Middle 0 1 <? &Snt-State>>>; |
---|
590 | |
---|
591 | |
---|
592 | |
---|
593 | ********************** Function calls compilation. *********************** |
---|
594 | |
---|
595 | /* |
---|
596 | * $func Extract-Calls e.Re = (e.last-Re) e.calls; |
---|
597 | * |
---|
598 | * |
---|
599 | * |
---|
600 | */ |
---|
601 | Extract-Calls { |
---|
602 | (CALL t.name e.arg) e.rest = |
---|
603 | <Lookup-Func t.name> :: s.linkage s.tag t.pragma (e.Fin) (e.Fout), |
---|
604 | <Extract-Calls e.arg> :: (e.last-Re) e.calls, |
---|
605 | <Prepare-Res <Split-Re (e.Fin) e.last-Re>> :: e.splited-Re, |
---|
606 | <RFP-Extract-Qualifiers t.name> :: t e.prefix, |
---|
607 | <Gener-Subst-Vars (e.Fout) e.prefix> :: e.Re, |
---|
608 | <Vars e.Re> :: e.vars, |
---|
609 | <Map &Set-Var- (Instantiated? True) (e.vars)> : e, |
---|
610 | { |
---|
611 | s.tag : FUNC? = (Failable (CALL t.name (e.splited-Re) (e.vars))); |
---|
612 | (CALL t.name (e.splited-Re) (e.vars)); |
---|
613 | } :: t.call, |
---|
614 | <Extract-Calls e.rest> :: (e.rest-Re) e.rest-calls, |
---|
615 | (e.Re e.rest-Re) e.calls <Vars-Decl e.vars> t.call e.rest-calls; |
---|
616 | (PAREN e.Re) e.rest = |
---|
617 | <Extract-Calls e.Re> :: (e.last-Re) e.calls, |
---|
618 | <Extract-Calls e.rest> :: (e.rest-Re) e.rest-calls, |
---|
619 | ((PAREN e.last-Re) e.rest-Re) e.calls e.rest-calls; |
---|
620 | t.Rt e.Re = |
---|
621 | <Extract-Calls e.Re> :: (e.last-Re) e.calls, |
---|
622 | (t.Rt e.last-Re) e.calls; |
---|
623 | /*empty*/ = () /*empty*/; |
---|
624 | }; |
---|
625 | |
---|
626 | |
---|
627 | Comp-Calls (e.fail) e.calls, e.calls : { |
---|
628 | (Failable t.call) e.rest = |
---|
629 | (IF ((NOT t.call)) e.fail) <Comp-Calls (e.fail) e.rest>; |
---|
630 | t.call e.rest = |
---|
631 | t.call <Comp-Calls (e.fail) e.rest>; |
---|
632 | /*empty*/ = /*empty*/; |
---|
633 | }; |
---|
634 | |
---|
635 | |
---|
636 | |
---|
637 | ********** Preparation of vars and REs for following processing ********** |
---|
638 | *********** Compilation of static parts of result expressions ************ |
---|
639 | |
---|
640 | $func Static-Expr? s.create? e.Re = static? e.Re; |
---|
641 | |
---|
642 | $func Static-Term? t.Rt = static? t.Rt; |
---|
643 | |
---|
644 | $func Find-Ref-Funcs expr = expr; |
---|
645 | |
---|
646 | $func Stub-Name t.name = t.stub-name; |
---|
647 | |
---|
648 | |
---|
649 | /* |
---|
650 | * Extract static parts from each Re. |
---|
651 | * Also get the right names for variables generated during the preprocessing |
---|
652 | * stage, if those are in the expr. |
---|
653 | */ |
---|
654 | Prepare-Res { |
---|
655 | (e.Re) e.rest = <Static-Expr? Create e.Re> :: s e.Re, (e.Re) <Prepare-Res e.rest>; |
---|
656 | /*empty*/ = /*empty*/; |
---|
657 | }; |
---|
658 | |
---|
659 | /* |
---|
660 | * Find all the longest static parts in the upper level of Re. Create STATIC |
---|
661 | * form in place of each one. |
---|
662 | * Return a tag pointing whether the whole expression is static and expression |
---|
663 | * with static parts replaced by STATIC forms. Dynamic parts are returned |
---|
664 | * unchanged. |
---|
665 | */ |
---|
666 | Static-Expr? { |
---|
667 | s.create? t.Rt e.Re = |
---|
668 | <Static-Term? t.Rt> : { |
---|
669 | Static t.st-Rt = |
---|
670 | { |
---|
671 | e.Re : e1 t2 e3, <Static-Term? t2> : Dynamic t.dyn-Rt = |
---|
672 | <Static-Expr? Create e3> :: s e3, |
---|
673 | Dynamic |
---|
674 | <Create-Static <Find-Ref-Funcs t.st-Rt e1>> t.dyn-Rt e3; |
---|
675 | { |
---|
676 | s.create? : Create = |
---|
677 | Static |
---|
678 | <Create-Static <Find-Ref-Funcs t.st-Rt e.Re>>; |
---|
679 | Static <Find-Ref-Funcs t.st-Rt e.Re>; |
---|
680 | }; |
---|
681 | }; |
---|
682 | Dynamic t.dyn-Rt = |
---|
683 | <Static-Expr? Create e.Re> :: s e.Re, |
---|
684 | Dynamic t.dyn-Rt e.Re; |
---|
685 | }; |
---|
686 | s.create? /*empty*/ = Static; |
---|
687 | }; |
---|
688 | |
---|
689 | |
---|
690 | /* |
---|
691 | * The same as Static-Expr? but for terms. |
---|
692 | */ |
---|
693 | Static-Term? { |
---|
694 | symbol = Static symbol; |
---|
695 | (PAREN e.Re) = <Static-Expr? Not-Create e.Re> :: static? e.Re, static? (PAREN e.Re); |
---|
696 | (REF t.name) = Static (REF t.name); |
---|
697 | t.var = <Prepare-Vars t.var> : t.prep-var, Dynamic t.prep-var; |
---|
698 | }; |
---|
699 | |
---|
700 | |
---|
701 | Prepare-Vars { |
---|
702 | (s.var-tag (e.prefix s.n)) e.rest, <Int? s.n> = |
---|
703 | { |
---|
704 | <Lookup &Prep-Vars e.prefix s.n>; |
---|
705 | <Gener-Vars ((s.var-tag)) e.prefix> :: e.var, |
---|
706 | <Bind &Prep-Vars (e.prefix s.n) (e.var)>, |
---|
707 | e.var; |
---|
708 | } :: e.var, |
---|
709 | e.var <Prepare-Vars e.rest>; |
---|
710 | t.var e.rest = t.var <Prepare-Vars e.rest>; |
---|
711 | /*empty*/ = /*empty*/; |
---|
712 | }; |
---|
713 | |
---|
714 | |
---|
715 | $func Ref-Func? e = e; |
---|
716 | |
---|
717 | Find-Ref-Funcs expr = <Map &Ref-Func? (expr)>; |
---|
718 | |
---|
719 | Ref-Func? { |
---|
720 | (REF t.name) = |
---|
721 | { |
---|
722 | <Lookup-Func t.name> : { |
---|
723 | t t t ((EVAR)) ((EVAR)) = (FUNC t.name); |
---|
724 | s.linkage s.tag t.pragma (e.Fin) (e.Fout) = |
---|
725 | { |
---|
726 | <Lookup &Stub-Funcs t.name> : t.stub-name e = |
---|
727 | (FUNC t.stub-name); |
---|
728 | <Stub-Name t.name> :: t.stub-name, |
---|
729 | <Bind &Stub-Funcs (t.name) |
---|
730 | (t.stub-name s.tag (e.Fin) (e.Fout))>, |
---|
731 | (FUNC t.stub-name); |
---|
732 | }; |
---|
733 | }; |
---|
734 | (REF t.name); |
---|
735 | }; |
---|
736 | term = term; |
---|
737 | }; |
---|
738 | |
---|
739 | |
---|
740 | /* |
---|
741 | * Генерируем уникальные внутри модуля имена для функций-заглушек. |
---|
742 | */ |
---|
743 | Stub-Name (e.qualifiers s.name) = |
---|
744 | <To-Chars s.name> : { |
---|
745 | e1 '_' s.n, <Int? s.n> = e1 '_' <"+" s.n 1>; |
---|
746 | e1 = e1 '_' 0; |
---|
747 | } :: e.name, |
---|
748 | (e.qualifiers <To-Word e.name>) :: t.name, |
---|
749 | { |
---|
750 | <Lookup-Func t.name> : e = <Stub-Name t.name>; |
---|
751 | t.name; |
---|
752 | }; |
---|
753 | |
---|
754 | |
---|
755 | |
---|
756 | ***************** Compilation of assignment to variables ***************** |
---|
757 | |
---|
758 | $func Comp-Assign-to-Var e = e; |
---|
759 | |
---|
760 | Comp-Assign-to-Var (t.var (e.Re)) = |
---|
761 | { |
---|
762 | t.var : e.Re = /*empty*/; |
---|
763 | <Set-Var (Instantiated? True) t.var>, $fail; |
---|
764 | <Substitutable-Var? e.Re> = <Gener-Var-Assign t.var e.Re>; |
---|
765 | <Get-Var Decl t.var> : s = (ASSIGN <Vars-Print t.var> e.Re); |
---|
766 | <Vars-Decl t.var> : e, (EXPR <Vars-Print t.var> e.Re); |
---|
767 | }; |
---|
768 | |
---|
769 | Comp-Assigns e.assigns = <Map &Comp-Assign-to-Var (e.assigns)>; |
---|
770 | |
---|
771 | |
---|
772 | |
---|
773 | ************************** FORMAT compilation. *************************** |
---|
774 | |
---|
775 | $box Aux-Index; |
---|
776 | |
---|
777 | $func Gener-Aux-Var = t.new-aux-var; |
---|
778 | |
---|
779 | Gener-Aux-Var = |
---|
780 | <? &Aux-Index> : s.n, |
---|
781 | <Store &Aux-Index <"+" s.n 1>>, |
---|
782 | (VAR ("aux" s.n)); |
---|
783 | |
---|
784 | |
---|
785 | $func Create-Aux-Vars (e.vars) e.splited-Re = e.assigns; |
---|
786 | |
---|
787 | |
---|
788 | Comp-Format (e.last-Re) e.He = |
---|
789 | <Prepare-Vars <Vars e.He>> :: e.vars, |
---|
790 | <Prepare-Res <Split-Re (<Format-Exp e.He>) e.last-Re>> :: e.splited-Re, |
---|
791 | <Store &Aux-Index 1>, |
---|
792 | <Create-Aux-Vars (e.vars) e.splited-Re> :: e.assigns, |
---|
793 | <Comp-Assigns e.assigns>; |
---|
794 | |
---|
795 | /* |
---|
796 | * Итак, e.vars -- все переменные, входящие в форматное выражение. Каждая |
---|
797 | * переменная может входить в форматное выражение только один раз, поэтому |
---|
798 | * повторяющихся среди них нет. |
---|
799 | * e.splited-Re -- набор результатных выражений. На каждую переменную из |
---|
800 | * e.vars по выражению, которое должно быть ей присвоено. |
---|
801 | * |
---|
802 | * Если переменная t.var_i используется в выражении e.Re_j, и i /= j, то |
---|
803 | * переменной t.var_j значение должно быть присвоено раньше, чем перeменной |
---|
804 | * t.var_i. Если же, по аналогичным соображениям, t.var_i должна получить |
---|
805 | * значение раньше t.var_j, необходимо завести вспомогательную переменную. |
---|
806 | * |
---|
807 | * Пример: |
---|
808 | * |
---|
809 | * t1 (t1 t2) (t1 t3) :: t2 t1 t3 |
---|
810 | * |
---|
811 | * t3 = (t1 + t3)(); |
---|
812 | * aux_1 = t1; |
---|
813 | * t1 = (t1 + t2)() |
---|
814 | * t2 = aux_1; |
---|
815 | * |
---|
816 | * В общем случае вспомогательная переменная требуется, если двум переменным |
---|
817 | * необходимы старые значения друг друга (возможно, не напрямую, а через |
---|
818 | * промежуточные переменные). |
---|
819 | * |
---|
820 | * Вместо того, чтобы искать и анализировать такие циклы, будем действовать по |
---|
821 | * методу "наибольшей пользы". А именно: |
---|
822 | * |
---|
823 | * - Для каждой переменной выпишем все другие переменные, которым требуется |
---|
824 | * её старое значение, а также отдельно те, старые значения которых |
---|
825 | * требуются ей. |
---|
826 | * |
---|
827 | * - Всем переменным, от старых значений которых ничего не зависит, можно |
---|
828 | * смело присвоить новые значения. При этом они исчезают из списков |
---|
829 | * зависимостей оставшихся переменных. |
---|
830 | * |
---|
831 | * - Все переменные, новые значения которых ни от чего не зависят, можно |
---|
832 | * отложить, чтобы присвоить им значения тогда, когда будет удобно. Т.е. |
---|
833 | * тогда, когда списки зависящих от них переменных опустеют. |
---|
834 | * |
---|
835 | * - Чтобы означить оставшиеся, нужны вспомогательные переменные. Выберем |
---|
836 | * одну из переменных, с максимальным списком тех, от которых она зависит, |
---|
837 | * и положим её значение во вспомогательную переменную. Так как мы сразу |
---|
838 | * уменьшили кол-во зависимостей у максимального кол-ва переменных, |
---|
839 | * локально мы добились наибольшей пользы, хотя не исключено, что глобально |
---|
840 | * такой метод и не даст наименьшего кол-ва вспомогательных переменных. |
---|
841 | * Кроме того, мы не пытаемся выбрать наилучшую переменную из нескольких с |
---|
842 | * максимальным списком зависимостей. |
---|
843 | * |
---|
844 | * - Повторяем всё это до тех пор, пока у каждой переменной не опустеет |
---|
845 | * список зависящих от неё. |
---|
846 | * |
---|
847 | * |
---|
848 | * Для нашего примера: |
---|
849 | * |
---|
850 | * t1 (t1 t2) (t1 t3) :: t2 t1 t3 |
---|
851 | * |
---|
852 | * t1 -- (t2 t3) (t2) |
---|
853 | * t2 -- (t1) (t1) |
---|
854 | * t3 -- () (t1) |
---|
855 | * |
---|
856 | * |
---|
857 | * Для каждой переменной var_i найдём все j /= i, такие что в Re_j встречается |
---|
858 | * var_i -- provide[i], и а также все j /= i, такие что var_j нужна для |
---|
859 | * подсчёта var_i, т.е. встречается в Re_i. |
---|
860 | * |
---|
861 | * Res-vars <- <Map &Vars (Res)> |
---|
862 | * for var_i in vars |
---|
863 | * provide[i] <- |
---|
864 | * for vars-Re_j in Res-vars, j /= i |
---|
865 | * vars-Re_j : e var_i e = j |
---|
866 | * require[i] <- <Res-vars[i] `*` vars[^i]> : e var_j e, j |
---|
867 | * |
---|
868 | * Res-vars = map Vars Res |
---|
869 | * provide, require = |
---|
870 | * { [ j | vars-Re_j <- Res-vars, j /= i, var_i `in` vars-Re_j ] |
---|
871 | * , [ j | var_j <- Res-vars[i] `*` vars, i /= j] |
---|
872 | * | var_i <- vars |
---|
873 | * } |
---|
874 | * |
---|
875 | */ |
---|
876 | |
---|
877 | $func CAV e.vars (e.assigns) (e.delayed) = e.assigns; |
---|
878 | |
---|
879 | $func Get-Vars e = e; |
---|
880 | Get-Vars (e.Re) = (<Vars e.Re>); |
---|
881 | |
---|
882 | Create-Aux-Vars (e.vars) e.splited-Re = |
---|
883 | <Zip (<Map &Get-Vars (e.splited-Re)>) (e.vars)> :: e.list, |
---|
884 | <Box> :: s.box, |
---|
885 | <Box> :: s.provide-i, |
---|
886 | <Box> :: s.require-i, |
---|
887 | { |
---|
888 | e.vars : e1 t.var-i e2, |
---|
889 | { |
---|
890 | e.list : e ((e.vars-Re) t.var-j) e, |
---|
891 | \{ |
---|
892 | t.var-i : t.var-j = <Put s.require-i <And (e1 e2) e.vars-Re>>; |
---|
893 | e.vars-Re : e t.var-i e = <Put s.provide-i t.var-j>; |
---|
894 | }, |
---|
895 | $fail; |
---|
896 | <L <Length e1> e.splited-Re> :: t.Re-i, |
---|
897 | <Put s.box (t.var-i t.Re-i (<? s.provide-i>) (<? s.require-i>))>, |
---|
898 | <Store s.provide-i /*empty*/>, |
---|
899 | <Store s.require-i /*empty*/>; |
---|
900 | }, |
---|
901 | $fail;; |
---|
902 | }, |
---|
903 | <CAV <? s.box> (/*assigns*/) (/*delayed*/)>; |
---|
904 | |
---|
905 | |
---|
906 | /* |
---|
907 | * Если есть переменная, у которой список provide пуст, её можно посчитать. |
---|
908 | * Это выражается в том, что она (вместе с присваиваемым значением) добавляется |
---|
909 | * в список assigns, убирается из списка vars, а также из всех списков provide |
---|
910 | * и delayed. В списках require её не было. |
---|
911 | * |
---|
912 | * CAV Res vars provide require assigns delayed = |
---|
913 | * { i | var_i <- vars, provide_i == [] } -> // Здесь неверно! На переменные |
---|
914 | * из delayed тоже надо смотреть. |
---|
915 | * vars = vars - var_i |
---|
916 | * provide = [ provide_j - i | provide_j <- provide ] |
---|
917 | * assigns = assigns++[(var_i, Res[i])] |
---|
918 | * delayed = [ (var_j, provide_j - i) | (var_j, provide_j) <- delayed ] |
---|
919 | * CAV Res vars provide require assigns delayed |
---|
920 | */ |
---|
921 | |
---|
922 | $func Assign-Empty-Provides e.vars = e.assigns (e.vars); |
---|
923 | |
---|
924 | Assign-Empty-Provides { |
---|
925 | e1 (t.var-i t.Re-i (/*empty provide_i*/) (e.require-i)) e2 = |
---|
926 | <Box> :: s.vars, |
---|
927 | { |
---|
928 | e1 e2 : e (t.var-j t.Re-j (e.provide-j) (e.require-j)) e, |
---|
929 | <Put s.vars (t.var-j t.Re-j (<Sub (e.provide-j) t.var-i>) (e.require-j))>, |
---|
930 | $fail;; |
---|
931 | }, |
---|
932 | (t.var-i t.Re-i) <Assign-Empty-Provides <? s.vars>>; |
---|
933 | e.vars = /*empty*/ (e.vars); |
---|
934 | }; |
---|
935 | |
---|
936 | |
---|
937 | /* |
---|
938 | * Если есть переменная, у которой список require пуст, кладём её в delayed. |
---|
939 | * Она будет посчитана, когда у неё опустеет список provide, т.е. когда не |
---|
940 | * останется переменных, у которых она в списке require. |
---|
941 | */ |
---|
942 | $func Delay-Empty-Requires e.vars = e.delayed (e.vars); |
---|
943 | |
---|
944 | Delay-Empty-Requires { |
---|
945 | e1 t.var e2, t.var : (t.var-i t.Re-i (e.provide-i) (/*empty require_i*/)) = |
---|
946 | <Delay-Empty-Requires e2> :: e.delayed (e.vars), |
---|
947 | t.var e.delayed (e1 e.vars); |
---|
948 | e.vars = /*empty*/ (e.vars); |
---|
949 | }; |
---|
950 | |
---|
951 | |
---|
952 | /* |
---|
953 | * Выбор переменной (из двух) с более длинным списком требуемых ей значений. |
---|
954 | */ |
---|
955 | $func Max-Require e = e; |
---|
956 | |
---|
957 | Max-Require t.arg1 t.arg2 = |
---|
958 | t.arg1 : (t.var1 t.Re1 t.provide1 (e.require1)), |
---|
959 | t.arg2 : (t.var2 t.Re2 t.provide2 (e.require2)), |
---|
960 | { |
---|
961 | <"<" (<Length e.require1>) (<Length e.require2>)> = t.arg2; |
---|
962 | t.arg1; |
---|
963 | }; |
---|
964 | |
---|
965 | |
---|
966 | /* |
---|
967 | * Подставить вспомогательную переменную вместо исходной во всех результатных выражениях. |
---|
968 | * Присваивание к исходной переменной убрать (оно к этому моменту уже выполнено). |
---|
969 | * Убрать переменную из списков зависимостей. |
---|
970 | */ |
---|
971 | $func Subst-Aux-Var e = e; |
---|
972 | |
---|
973 | Subst-Aux-Var t.var t.aux (t.v t.Re (e.provide) (e.require)), { |
---|
974 | t.var : t.v = /*empty*/; |
---|
975 | ( |
---|
976 | t.v |
---|
977 | <Subst (t.var) ((t.aux)) t.Re> |
---|
978 | (<Sub (e.provide) t.var>) |
---|
979 | (<Sub (e.require) t.var>) |
---|
980 | ); |
---|
981 | }; |
---|
982 | |
---|
983 | |
---|
984 | /* |
---|
985 | * Извлечь присваивание из всей информации о переменной. |
---|
986 | */ |
---|
987 | $func Extract-Assigns e = e; |
---|
988 | Extract-Assigns (t.var t.Re e) = (t.var t.Re); |
---|
989 | |
---|
990 | |
---|
991 | /* |
---|
992 | * Основной цикл обработки присваиваний. |
---|
993 | * |
---|
994 | * 1) Из всех переменных (в том числе и отложенных), от которых больше ничего |
---|
995 | * не зависит, сделать присваивания. |
---|
996 | * 2) Все переменные, которые больше ни от чего не зависят, отложить. |
---|
997 | * 3) Если осталось хотя бы две неотложенных переменных, выбирать из них ту, |
---|
998 | * которая зависит от наибольшего числа переменных, подставить везде вместо |
---|
999 | * неё вспомогательную, перейти к пункту 1. |
---|
1000 | */ |
---|
1001 | CAV e.vars (e.assigns) (e.delayed) = |
---|
1002 | <Assign-Empty-Provides e.vars> :: e.new-assigns (e.vars), |
---|
1003 | e.assigns e.new-assigns <Assign-Empty-Provides e.delayed> :: e.assigns (e.delayed), |
---|
1004 | e.delayed <Delay-Empty-Requires e.vars> :: e.delayed (e.vars), |
---|
1005 | { |
---|
1006 | e.vars : t t e = |
---|
1007 | <Foldr1 &Max-Require (e.vars)> : (t.var t.Re e), |
---|
1008 | <Gener-Aux-Var> :: t.aux, |
---|
1009 | e.assigns (t.aux (t.var)) (t.var t.Re) :: e.assigns, |
---|
1010 | <Map &Subst-Aux-Var t.var t.aux (e.vars)> :: e.vars, |
---|
1011 | <Map &Subst-Aux-Var t.var t.aux (e.delayed)> :: e.delayed, |
---|
1012 | <CAV e.vars (e.assigns) (e.delayed)>; |
---|
1013 | e.assigns <Map &Extract-Assigns (e.vars e.delayed)>; |
---|
1014 | }; |
---|
1015 | |
---|
1016 | |
---|
1017 | |
---|
1018 | |
---|
1019 | ****************** Компиляция сопоставления с образцом ******************* |
---|
1020 | |
---|
1021 | Get-Clash-Sequence (e.last-Re) t.Pattern e.Snt = |
---|
1022 | (/*e.clashes*/) (RESULT e.last-Re) t.Pattern e.Snt $iter { |
---|
1023 | e.Snt : (RESULT e.Re) (s.dir e.Pe) e.rest = |
---|
1024 | /* |
---|
1025 | * Компилируем все константные выражения и заводим в табличке все |
---|
1026 | * незаведённые переменные. У старых переменных очищается память |
---|
1027 | * на предмет клешей, в которых они раньше использовались. |
---|
1028 | */ |
---|
1029 | <Prepare-Res (e.Re) (e.Pe)> : (e.R1) (e.P1), |
---|
1030 | <Map &Set-Var- (Clashes /*empty*/) (<Vars e.R1 e.P1>)> : e, |
---|
1031 | (e.clashes (e.R1) (s.dir e.P1)) e.rest; |
---|
1032 | } :: (e.clashes) e.Snt, |
---|
1033 | # \{ |
---|
1034 | e.Snt : \{ |
---|
1035 | (RESULT e.Re) (LEFT e) e = e.Re; |
---|
1036 | (RESULT e.Re) (RIGHT e) e = e.Re; |
---|
1037 | } :: e.Re, |
---|
1038 | <Without-Calls? e.Re>; |
---|
1039 | } = |
---|
1040 | (e.clashes) e.Snt; |
---|
1041 | |
---|
1042 | Without-Calls? e.Re = |
---|
1043 | e.Re $iter { |
---|
1044 | e.Re : t.Rt e.rest = |
---|
1045 | t.Rt : { |
---|
1046 | (CALL e) = $fail; |
---|
1047 | (BLOCK e) = $fail; |
---|
1048 | (PAREN e.Re1) = <Without-Calls? e.Re1>; |
---|
1049 | t.symbol-or-var = /*empty*/; |
---|
1050 | }, |
---|
1051 | e.rest; |
---|
1052 | } :: e.Re, |
---|
1053 | e.Re : /*empty*/; |
---|
1054 | |
---|
1055 | $func CC s.tail? (v.fails) t.end-cycle e.Snt = e.asail-Snt; |
---|
1056 | |
---|
1057 | Comp-Clashes (e.clashes) s.tail? (v.fails) e.Sentence = |
---|
1058 | <Init-Clashes e.clashes>, |
---|
1059 | <CC s.tail? (v.fails) <R 0 v.fails> e.Sentence>; |
---|
1060 | |
---|
1061 | $func CC-Known-Lengths t.fail e.idxs = e.conds; |
---|
1062 | |
---|
1063 | $func CC-Compute-Length t.fail t.end-cycle t.idx = e; |
---|
1064 | |
---|
1065 | $func CC-Unknown-Lengths t.fail e.idxs = e.conds; |
---|
1066 | |
---|
1067 | $func CC-Deref t.fail e.actions = e.actions; |
---|
1068 | |
---|
1069 | $func CC-Eqs t.fail (e.assigns) e.eqs = e.actions; |
---|
1070 | |
---|
1071 | CC s.tail? (v.fails) t.end-cycle e.Snt, { |
---|
1072 | <Domain &Known-Lengths> : v.clashes = |
---|
1073 | <CC-Known-Lengths t.end-cycle v.clashes> |
---|
1074 | <CC s.tail? (v.fails) t.end-cycle e.Snt>; |
---|
1075 | <Domain &Compute-Length> : (t.clash) e = |
---|
1076 | <CC-Compute-Length <R 0 v.fails> t.end-cycle t.clash> |
---|
1077 | <CC s.tail? (v.fails) t.end-cycle e.Snt>; |
---|
1078 | <Domain &Unknown-Lengths> : e.clashes = |
---|
1079 | <CC-Unknown-Lengths t.end-cycle e.clashes> :: e.conds, |
---|
1080 | /* |
---|
1081 | * Когда мы добрались до сюда, все условия на длины на текущем уровне |
---|
1082 | * выписаны. Невыполнение любого из оставшихся условий (на |
---|
1083 | * соответствие типов, равенство, длины внутри скобок) ведёт не к |
---|
1084 | * прекращению текущего цикла, а переход к его следующей итерации. |
---|
1085 | * Поэтому в качестве t.end-cycle везде дальше подставляется текущий |
---|
1086 | * откат. |
---|
1087 | */ |
---|
1088 | <Update-Hard-Parts> : { |
---|
1089 | v.actions = |
---|
1090 | e.conds <CC-Deref <R 0 v.fails> v.actions> |
---|
1091 | <CC s.tail? (v.fails) <R 0 v.fails> e.Snt>; |
---|
1092 | /*empty*/ = |
---|
1093 | e.conds <CC-Eqs <R 0 v.fails> () <? &Eqs>> :: e.actions, |
---|
1094 | <Store &Eqs /*empty*/>, |
---|
1095 | { |
---|
1096 | <Compose-Source> :: e.assign = |
---|
1097 | e.actions <CC-Eqs <R 0 v.fails> () e.assign> |
---|
1098 | <CC s.tail? (v.fails) <R 0 v.fails> e.Snt>; |
---|
1099 | { |
---|
1100 | <Get-Cycle> :: s.split (e.left) (e.right) (e.len) |
---|
1101 | t.var t.l-var t.r-var = |
---|
1102 | { |
---|
1103 | e.left : 0, e.right : 0 = /*empty*/ t.var; |
---|
1104 | <Gener-Vars ((VAR)) "subexpr_" t.var> : t.sub-var, |
---|
1105 | (SUBEXPR t.sub-var t.var (e.left) |
---|
1106 | ((INFIX "-" (e.len) (e.left e.right)))) |
---|
1107 | t.sub-var; |
---|
1108 | } :: e.subexpr t.var, |
---|
1109 | { |
---|
1110 | s.split : RSPLIT = |
---|
1111 | t.r-var t.l-var DEC-ITER; |
---|
1112 | t.l-var t.r-var INC-ITER; |
---|
1113 | } :: t.l-var t.r-var s.iter-op, |
---|
1114 | <Gener-Label "continue"> :: t.cont-label, |
---|
1115 | <Gener-Label "exit"> :: t.break-label, |
---|
1116 | e.actions e.subexpr |
---|
1117 | (s.split t.var (<Get-Var Min t.l-var>) t.l-var t.r-var) |
---|
1118 | (FOR (t.cont-label) (t.break-label) () ((s.iter-op t.var)) |
---|
1119 | (IF ((NOT (CHECK-ITER t.var))) <Concat <R 0 v.fails>>) |
---|
1120 | <CC s.tail? (v.fails ((CONTINUE t.cont-label))) |
---|
1121 | <R 0 v.fails> e.Snt> |
---|
1122 | (BREAK t.break-label) |
---|
1123 | ); |
---|
1124 | e.actions <Comp-Sentence s.tail? (v.fails) () e.Snt>; |
---|
1125 | }; |
---|
1126 | }; |
---|
1127 | }; |
---|
1128 | }; |
---|
1129 | |
---|
1130 | CC-Known-Lengths (e.fail) e.idxs, { |
---|
1131 | e.idxs : (t.idx) e.rest = |
---|
1132 | <Put &Checked-Lengths t.idx>, |
---|
1133 | <Lookup &Known-Lengths t.idx> : (e.len-Re) (e.len-Pe), |
---|
1134 | (IF ((INFIX "!=" (e.len-Re) (e.len-Pe))) e.fail) |
---|
1135 | <CC-Known-Lengths (e.fail) e.rest>; |
---|
1136 | <RFP-Clear-Table &Known-Lengths>; |
---|
1137 | }; |
---|
1138 | |
---|
1139 | CC-Compute-Length (e.fail) (e.end-cycle) t.idx = |
---|
1140 | <Lookup &Compute-Length t.idx> : t.var s.mult (e.minuend) (e.subtrahend), |
---|
1141 | <Create-Int-Var ("len") Aux e.minuend> :: t.m-var e.m-assign, |
---|
1142 | <Create-Int-Var ("len") Aux e.subtrahend> :: t.s-var e.s-assign, |
---|
1143 | <Get-Var Min t.var> :: e.min, |
---|
1144 | ((INFIX "<" (t.m-var) |
---|
1145 | ((INFIX "+" (t.s-var) |
---|
1146 | ((INFIX "*" (e.min) (s.mult))) |
---|
1147 | )) )) :: e.min-cond, |
---|
1148 | <Get-Var Max t.var> : { |
---|
1149 | /*empty*/; |
---|
1150 | e.max = |
---|
1151 | ((INFIX ">" (t.m-var) |
---|
1152 | ((INFIX "+" (t.s-var) |
---|
1153 | ((INFIX "*" (e.max) (s.mult))) |
---|
1154 | )) )); |
---|
1155 | } :: e.max-cond, |
---|
1156 | (INFIX "%" ((INFIX "-" (t.m-var) (t.s-var))) (s.mult)) :: e.div-cond, |
---|
1157 | <Create-Int-Var ("len_") t.var |
---|
1158 | (INFIX "/" ((INFIX "-" (t.m-var) (t.s-var))) (s.mult)) |
---|
1159 | > :: t.len-var e.len-assign, |
---|
1160 | <Set-Var (Length t.len-var) t.var>, |
---|
1161 | <Unbind &Compute-Length t.idx>, |
---|
1162 | <Put &Checked-Lengths t.idx>, |
---|
1163 | <Get-Var Clashes t.var> :: e.clashes, |
---|
1164 | <Map &Reclassify-Clash (<Sub (e.clashes) <? &Checked-Lengths>>)> : e, |
---|
1165 | e.m-assign e.s-assign |
---|
1166 | (IF ((INFIX "||" e.min-cond e.max-cond)) e.end-cycle) |
---|
1167 | (IF (e.div-cond) e.fail) |
---|
1168 | e.len-assign; |
---|
1169 | |
---|
1170 | $func Get-Min e = e; |
---|
1171 | |
---|
1172 | $func? Get-Max e = e; |
---|
1173 | |
---|
1174 | CC-Unknown-Lengths (e.fail) e.idxs, { |
---|
1175 | e.idxs : (t.idx) e.rest = |
---|
1176 | <Lookup &Unknown-Lengths t.idx> : (e.len-Re) (e.len-Pe) (e.vars-Re) (e.vars-Pe), |
---|
1177 | { |
---|
1178 | <Get-Max e.vars-Re> :: e.max = |
---|
1179 | <Get-Min e.vars-Pe> :: e.min, |
---|
1180 | ((INFIX "<" (e.len-Re e.max) (e.len-Pe e.min))); |
---|
1181 | /*empty*/; |
---|
1182 | } :: e.cond1, |
---|
1183 | { |
---|
1184 | <Get-Max e.vars-Pe> :: e.max = |
---|
1185 | <Get-Min e.vars-Re> :: e.min, |
---|
1186 | ((INFIX ">" (e.len-Re e.min) (e.len-Pe e.max))); |
---|
1187 | /*empty*/; |
---|
1188 | } :: e.cond2, |
---|
1189 | { |
---|
1190 | e.cond1 : /*empty*/, e.cond2 : /*empty*/ = /*empty*/; |
---|
1191 | (IF ((INFIX "||" e.cond1 e.cond2)) e.fail); |
---|
1192 | } :: e.cond, |
---|
1193 | e.cond |
---|
1194 | <CC-Unknown-Lengths (e.fail) e.rest>; |
---|
1195 | <RFP-Clear-Table &Unknown-Lengths>; |
---|
1196 | }; |
---|
1197 | |
---|
1198 | Get-Min |
---|
1199 | { |
---|
1200 | t.var e.vars = <Get-Var Min t.var> <Get-Min e.vars>; |
---|
1201 | /*empty*/ = /*empty*/; |
---|
1202 | }; |
---|
1203 | |
---|
1204 | Get-Max |
---|
1205 | { |
---|
1206 | t.var e.vars = <Get-Var Max t.var> : v.max, v.max <Get-Max e.vars>; |
---|
1207 | /*empty*/ = /*empty*/; |
---|
1208 | }; |
---|
1209 | |
---|
1210 | $func Pos (e.Re) s.dir e.pos = e.pos; |
---|
1211 | |
---|
1212 | Pos { |
---|
1213 | (e.Re) RIGHT e.pos = (INFIX "-" ((LENGTH e.Re)) (1) (e.pos)); |
---|
1214 | (e.Re) LEFT e.pos = e.pos; |
---|
1215 | }; |
---|
1216 | |
---|
1217 | /* |
---|
1218 | * Информацию о проверках и заведении переменных, необходимых для создания |
---|
1219 | * клешей из содержимого скобок, кодируем на ASAIL. |
---|
1220 | */ |
---|
1221 | CC-Deref (e.fail) e.actions, e.actions : { |
---|
1222 | (SYMBOL? e.Re (s.dir e.pos)) e.rest = |
---|
1223 | (IF ((SYMBOL? e.Re (<Pos (e.Re) s.dir e.pos>))) e.fail) |
---|
1224 | <CC-Deref (e.fail) e.rest>; |
---|
1225 | (DEREF t.var e.Re (s.dir e.pos)) e.rest = |
---|
1226 | (DEREF t.var e.Re (<Pos (e.Re) s.dir e.pos>)) |
---|
1227 | <CC-Deref (e.fail) e.rest>; |
---|
1228 | /*empty*/ = /*empty*/; |
---|
1229 | }; |
---|
1230 | |
---|
1231 | CC-Eqs (e.fail) (e.assigns) e.eqs, { |
---|
1232 | e.eqs : ((e.Re) (s.dir e.pos) t.Pt (e.len)) e.rest = |
---|
1233 | { |
---|
1234 | e.Re : t, |
---|
1235 | <Get-Known-Length e.Re> : e.len (), // FIXME: здесь надо использовать |
---|
1236 | // калькулятор |
---|
1237 | s.dir e.pos : \{ |
---|
1238 | LEFT 0; |
---|
1239 | RIGHT e.len; |
---|
1240 | } = |
---|
1241 | e.Re;; |
---|
1242 | } :: e.Re-term, |
---|
1243 | { |
---|
1244 | e.len : 1 = TERM-EQ; // FIXME: здесь надо использовать |
---|
1245 | // калькулятор |
---|
1246 | EQ; |
---|
1247 | } :: s.eq, |
---|
1248 | <Pos (e.Re) s.dir e.pos> :: e.pos, |
---|
1249 | { |
---|
1250 | \{ |
---|
1251 | <Get-Var Instantiated? t.Pt> : True = t.Pt (e.Re); |
---|
1252 | t.Pt : \{ |
---|
1253 | (REF e); |
---|
1254 | (STATIC e); |
---|
1255 | }, { |
---|
1256 | <Var? e.Re-term> = e.Re-term (t.Pt); |
---|
1257 | t.Pt (e.Re); |
---|
1258 | }; |
---|
1259 | } :: el (er), |
---|
1260 | (IF ((NOT (s.eq el (er) (e.pos)))) e.fail) :: t.cond, |
---|
1261 | { |
---|
1262 | /* |
---|
1263 | * Мы предполагаем, что во всех пришедших e.eqs все e.Re |
---|
1264 | * уже были определены ранее. |
---|
1265 | */ |
---|
1266 | e.assigns : $r e1 (s.op t.Pt e.def) e2 = |
---|
1267 | <CC-Eqs (e.fail) (e1 (s.op t.Pt e.def) t.cond e2) e.rest>; |
---|
1268 | t.cond <CC-Eqs (e.fail) (e.assigns) e.rest>; |
---|
1269 | }; |
---|
1270 | <Set-Var (Instantiated? True) t.Pt>, |
---|
1271 | { |
---|
1272 | t.Pt : (SVAR e) = |
---|
1273 | (IF |
---|
1274 | ((NOT (SYMBOL? e.Re (<Pos (e.Re) s.dir e.pos>)))) |
---|
1275 | e.fail |
---|
1276 | );; |
---|
1277 | } :: e.cond, |
---|
1278 | { |
---|
1279 | <Get-Var Decl t.Pt> : s = |
---|
1280 | e.cond <CC-Eqs (e.fail) (e.assigns |
---|
1281 | (ASSIGN t.Pt (SUBEXPR e.Re (e.pos) (e.len)))) |
---|
1282 | e.rest>; |
---|
1283 | <Vars-Decl t.Pt> : e, |
---|
1284 | e.cond <CC-Eqs (e.fail) (e.assigns |
---|
1285 | (SUBEXPR t.Pt e.Re (e.pos) (e.len))) e.rest>; |
---|
1286 | }; |
---|
1287 | }; |
---|
1288 | e.assigns e.eqs; |
---|
1289 | }; |
---|
1290 | |
---|
1291 | |
---|
1292 | |
---|
1293 | |
---|
1294 | Gener-Label e.QualifiedName = |
---|
1295 | { |
---|
1296 | <Lookup &Labels e.QualifiedName> : s.num, |
---|
1297 | <"+" s.num 1>; |
---|
1298 | 1; |
---|
1299 | } :: s.num, |
---|
1300 | <Bind &Labels (e.QualifiedName) (s.num)>, |
---|
1301 | (e.QualifiedName s.num); |
---|
1302 | |
---|
1303 | Add-To-Label (e.label) e.name = <Gener-Label e.label "_" e.name>; |
---|
1304 | |
---|
1305 | |
---|
1306 | |
---|
1307 | |
---|
1308 | Lookup-Func t.Fname, \{ |
---|
1309 | <Lookup &Fun t.Fname>; |
---|
1310 | <Lookup &Fun? t.Fname>; |
---|
1311 | } : s.linkage s.tag t.pragma (e.Fin) (e.Fout) = |
---|
1312 | s.linkage s.tag t.pragma (e.Fin) (e.Fout); |
---|
1313 | |
---|