source: to-imperative/trunk/compiler/rfp_compile.rf @ 1006

Last change on this file since 1006 was 1006, checked in by orlov, 18 years ago
  • Implemented composition of sources for clashes.
  • Some silly bugs are fixed.
  • Some comments.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 62.6 KB
Line 
1// $Source$
2// $Revision: 1006 $
3// $Date: 2003-07-12 07:37:29 +0000 (Sat, 12 Jul 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 referenced functions.
34 */
35$table Ref-To-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$box Greater-Ineqs;
61$box Less-Ineqs;
62
63$table Static-Exprs;
64
65$func Compile (e.targets) (e.headers) e.Items = e.Compiled-Items (INTERFACE e.headers);
66
67$func Length-of e.Re = e.length;
68
69$func? Hard-Exp? e.expr = ;
70
71$func Comp-Func-Stubs = e.asail-funcs;
72
73$func Comp-Func s.tag t.name e.params-and-body = e.compiled-func;
74
75$func Set-Drops (e.declared-exprs) e.comp-func = (e.declared-exprs) e.result-func;
76
77$func Comp-Sentence e.Sentence = e.asail-sentence;
78
79$func Save-Snt-State = ;
80
81$func Recall-Snt-State = ;
82
83$func Pop-Snt-State = ;
84
85$func Extract-Calls e.Re = (e.last-Re) e.calls;
86
87$func Get-Clash-Sequence (e.last-Re) e.Snt = (e.clashes) e.rest-of-the-Sentence;
88
89$func? Without-Calls? e.Re = ;
90
91//$func Old-Vars e.expr = e.expr;
92
93//$func Find-Known-Lengths e.clashes = (e.known-len-clashes) e.clashes;
94
95//$func? Known-Vars? e.vars = ;
96
97$func Comp-Clashes (e.clashes) s.tail? (v.fails) e.Sentence = e.asail-sentence;
98
99$func? Find-Var-Length e.clashes = e.cond (e.clashes);
100
101$func Update-Ties t.var e.clashes = e.clashes;
102
103$func Known-Length-of e.expr = e.known-length (e.unknown-vars);
104
105$func? Cyclic-Restrictions e.clashes = e.cond (e.clashes);
106
107$func Cyclic-Min t.var = e.min;
108
109$func? Cyclic-Max t.var = e.max;
110
111$func? Get-Source e.clashes = e.cond (e.clashes);
112
113$func Compose-Expr e.expr = e.compose (e.not-instantiated-vars) s.flat?;
114
115$func? Comp-Cyclic e.clashes = e.cond (e.clashes) (e.fail);
116
117$func Get-Subexprs e.vars = e.asail-decls;
118
119$func Unknown-Vars e.expr = e.known-expr (e.unknown-vars);
120
121$func Split-Hard-Left e.expr = e.hard;
122
123$func Split-Hard-Right e.expr = e.hard;
124
125$func Gener-Label e.QualifiedName = t.label;
126
127$func Add-To-Label t.label e.name = t.label;
128
129$func Comp-Calls e.Re = e.calls;
130
131$func Prepare-Vars e.vars = e.vars;
132
133$func Prepare-Res e.Reult-exprs = e.Result-exprs;
134
135$func Comp-Assigns e.assignments = e.asail-assignments;
136
137$func Comp-Format (e.last-Re) e.He = e.assignments;
138
139$func Get-Static-Exprs e.expr = e.expr (e.decls);
140
141$func Get-Static-Var e.expr = e.var (e.decl);
142
143
144
145************ Get AS-Items and targets, and pass it to Compile ************
146
147/*
148 * Ящик для объявлений статических функций, констант и объектов.  Все они
149 * выписываются в самом начале тела модуля.
150 */
151$box Declarations;
152
153RFP-Compile e.Items =
154  { <Lookup &RFP-Options ITEMS>;; } :: e.targets,
155  <Store &Declarations /*empty*/>,
156  <Init-Consts>,
157  <Compile (e.targets) () e.Items> :: e.Items t.Interface,
158  t.Interface (MODULE <? &Declarations> <Comp-Consts> e.Items);
159
160
161
162****************** Choose needed items and compile them ******************
163
164Compile (e.targets) (e.headers) e.Items, {
165  e.Items : e t.item e.rest,
166    {
167      e.targets : v =
168        e.targets : e t.name e,
169        t.item : (t t t t.name e);;
170    },
171    t.item : {
172      (IMPORT e) = () /*empty*/;
173      (s.link s.tag t.pragma t.name (e.in) (e.out) e.body), FUNC FUNC? : e s.tag e =
174        {
175          s.link : EXPORT = (DECL-FUNC EXPORT t.name);
176          <Put &Declarations (DECL-FUNC LOCAL t.name)> = /*empty*/;
177        } :: e.decl,
178        {
179          e.body : (BRANCH t.p e.branch) =
180            <Comp-Func s.tag t.name <Del-Pragmas (e.in) (e.out) e.branch>>;;
181        } :: e.comp-func,
182        (e.decl) e.comp-func;
183      (s.link CONST t.pragma t.name e.expr) =
184        (CONSTEXPR s.link t.name (e.expr) e.expr) :: t.const,
185        {
186          s.link : EXPORT = (t.const) /*empty*/;
187          <Put &Declarations t.const> = () /*empty*/;
188        };
189      (EXPORT s.tag t.pragma t.name) = ((DECL-OBJ EXPORT s.tag t.name)) /*empty*/;
190      (LOCAL  s.tag t.pragma t.name) =
191        <Put &Declarations (DECL-OBJ LOCAL s.tag t.name)>,
192        () /*empty*/;
193    } :: (e.decl) e.item =
194    e.item <Compile (e.targets) (e.headers e.decl) e.rest>;
195  /*<Comp-Func-Stubs>*/ (INTERFACE e.headers);
196};
197
198/*
199 * For each referenced function generate a stub one with format e = e.
200 */
201Comp-Func-Stubs =
202  <Domain &Ref-To-Funcs> () $iter {
203    e.funcs : ((e.QualifiedName)) e.rest,
204      (e.QualifiedName 0) :: t.Fname,
205//      <Bind &Ref-To-Funcs ((e.QualifiedName)) (t.Fname)>,
206//      {
207//        <In-Table? &Fun? (e.QualifiedName)> =
208//          <Bind &Back-Funcs (t.Fname) ()>;;
209//      },
210//      <Bind &Fin (t.Fname) ((EVAR))>,
211//      <Bind &Fout (t.Fname) ((EVAR))>,
212      <Lookup-Func (e.QualifiedName)> :: s.linkage s.tag t.pragma (e.Fin) (e.Fout),
213      <Gener-Vars (e.Fin) "stub"> :: e.He,
214      <Comp-Func s.tag t.Fname ((EVAR ("arg" 1))) ((EVAR ("res" 1)))
215        (LEFT e.He) (RESULT (CALL (e.QualifiedName) e.He))
216      > :: e.asail,
217      e.rest (e.asail-funcs e.asail);
218  } :: e.funcs (e.asail-funcs),
219  e.funcs : /*empty*/ =
220  // Here is place to define expressions - references to stub functions.
221  // Use &Ref-To-Funcs for that.
222  e.asail-funcs;
223
224Comp-Func s.tag t.name (e.in) (e.out) e.Sentence =
225  <RFP-Clear-Table &Labels>,
226  <RFP-Clear-Table &Static-Exprs>,
227  <Store &Greater-Ineqs /*empty*/>,
228  <Store &Less-Ineqs /*empty*/>,
229  <RFP-Clear-Table &Prep-Vars>,
230  <Init-Vars>,
231//!     <Ref-To-Var e.Sentence> :: e.Sentence,
232  <Vars <Gener-Vars (e.out) "res">> :: e.res-vars,
233  <Vars-Decl e.res-vars> : e,
234  <Store &Res-Vars e.res-vars>,
235  <Store &Out-Format <Format-Exp e.out>>,
236  <Prepare-Res (e.in)> : (e.arg),
237  <Vars e.arg> :: e.arg-vars,
238  <Map &Set-Var- (Instantiated? True) (e.arg-vars)> : e,
239  s.tag : {
240    FUNC = FATAL;
241    FUNC? = RETFAIL;
242  } :: t.retfail,
243  (FUNC t.name (<Vars-Print e.arg-vars>) (<Vars-Print e.res-vars>)
244    <Comp-Sentence Tail ((t.retfail)) (e.arg) e.Sentence>
245  ) :: e.comp-func,
246*       <Set-Drops () <Gener-Var-Names e.comp-func>> :: t e.comp-func,
247  <Gener-Var-Names e.comp-func> :: e.comp-func,
248//!     <Post-Comp (e.res-vars) e.comp-func> :: t e.result,
249//!     e.result;
250  e.comp-func;
251//  :: (e.func-decl) e.func-body,
252//  () <Domain &Declarations> $iter {
253//    e.vars : (t.var) e.rest-vars,
254//      (e.var-decls (DECL t.var)) e.rest-vars;
255//  } :: (e.var-decls) e.vars,
256//  e.vars : /*empty*/,
257//  (e.func-decl e.var-decls e.func-body);
258
259Ref-To-Var e.Snt =
260  () e.Snt $iter {
261    e.Snt : t.Statement e.rest, t.Statement : {
262      (REF t.name) = (e.new-Snt /*<New-Vars (VAR REF t.name)>*/) e.rest;
263
264//!                     <Table> :: s.tab,
265//!                     <Bind &Vars-Tab (t.name) (s.tab)>,
266//!                     <Set-Var t.name (Format) (<Format-Exp (REF t.name)>)>,
267//!                     <Set-Var t.name (Declared) (True)>,
268//!                     <Set-Var t.name (Instantiated) (True)>,
269//!                     <Set-Var t.name (Left-compare) ()>,
270//!                     <Set-Var t.name (Right-compare) ()>,
271//!                     <Set-Var t.name (Left-checks) ()>,
272//!                     <Set-Var t.name (Right-checks) ()>,
273//!                     (e.new-Snt (VAR t.name)) e.rest;
274
275      (e.expr) = (e.new-Snt (<Ref-To-Var e.expr>)) e.rest;
276      t = (e.new-Snt t.Statement) e.rest;
277    };
278  } :: (e.new-Snt) e.Snt,
279  e.Snt : /*empty*/ =
280  e.new-Snt;
281
282Set-Drops (e.declared) e.comp-func =
283  e.comp-func () (e.declared) $iter {
284    e.comp-func : t.first e.rest, {
285      t.first : \{
286        (EXPR t.var e) = (DROP t.var) (t.first) t.var Init;
287        (DEREF t.var e) = (DROP t.var) (t.first) t.var Init;
288        (SUBEXPR t.var e) = (DROP t.var) (t.first) t.var Init;
289        (DECL Expr t.var) = (DROP t.var) () t.var Decl;
290        (DECL "int" t.var) = /*empty*/ () t.var Decl;
291      } :: e.drop (e.constr) t.var s.init,
292        {
293          e.declared : e1 t.var s.old-init e2, s.old-init : {
294            Init, {
295              t.var : (VAR ("const" e)) =
296                e.rest (e.result-func) (e.declared);
297              e.rest (e.result-func e.drop e.constr) (e.declared);
298            };
299            Decl, s.init : {
300              Decl =
301                e.rest (e.result-func) (e.declared);
302              Init =
303                t.first : (s.method t.var e.args),
304                e.rest (e.result-func (ASSIGN t.var (s.method e.args)))
305                (e1 e2 t.var s.init);
306                /*
307                 * FIXME: if s.method is EXPR, it shouldn't be written.
308                 */
309            };
310          };
311          e.rest (e.result-func t.first) (e.declared t.var s.init);
312        };
313      t.first : (LABEL (t.label) e.expr) =
314        <Set-Drops (e.declared) e.expr> :: (e.declared) e.expr,
315        e.rest (e.result-func (LABEL (t.label) e.expr)) (e.declared);
316      t.first : (e.expr) =
317        <Set-Drops (e.declared) e.expr> :: t e.expr,
318        e.rest (e.result-func (e.expr)) (e.declared);
319      t.first : s.symbol =
320        e.rest (e.result-func s.symbol) (e.declared);
321    };
322  } :: e.comp-func (e.result-func) (e.declared),
323  e.comp-func : /*empty*/ =
324  (e.declared) e.result-func;
325
326
327Comp-Sentence s.tail? (v.fails) (e.last-Re) e.Sentence, e.Sentence : {
328
329  /*empty*/ = /*empty*/;
330
331  /*
332   * In case of Re look if we should do a tailcall.  If not, then compile
333   * function calls from the Re and assign results to the out parameters or
334   * use them in compilation of the rest of the sentence.
335   */
336  (RESULT e.Re) e.Snt =
337    {
338      /*
339       * If the Re is the last action in the sentence then we can do
340       * tailcall if one of the following is true:
341       *  - Re is a call of non-failable function;
342       *  - Re is a call of a failable function, current function is
343       *  failable, and the failures stack is empty.
344       * In both cases out format of the called function should coincide
345       * with those of compiled one.
346       * FIXME: really we can do tailcall if all the parameters of
347       * compiled function that won't get their values from the call can
348       * be assigned from other sources.  Some support from runtime is
349       * needed though.
350       */
351      e.Snt : /*empty*/, s.tail? : Tail, e.Re : (CALL t.name e.arg),
352        { <In-Table? &Fun? t.name> = v.fails : (RETFAIL);; },
353        <Lookup-Func t.name> :: s.linkage s.tag t.pragma (e.Fin) (e.Fout),
354        <Subformat? (e.Fout) (<? &Out-Format>)> =
355        <Extract-Calls e.arg> :: (e.last-Re) e.calls,
356        <Prepare-Res <Split-Re (e.Fin) e.last-Re>> :: e.splited-Re,
357        <Comp-Calls <R 0 v.fails> e.calls>
358        (TAILCALL t.name (e.splited-Re) (<? &Res-Vars>));
359
360      <Extract-Calls e.Re> :: (e.last-Re) e.calls,
361        <Comp-Calls <R 0 v.fails> e.calls> :: e.comp-calls,
362        {
363          e.Snt : /*empty*/, s.tail? : Tail =
364            <Split-Re (<? &Out-Format>) e.last-Re> :: e.splited-Re,
365            <Prepare-Res e.splited-Re> :: e.splited-Re,
366            e.comp-calls <Comp-Assigns <Zip (<? &Res-Vars>) (e.splited-Re)>>;
367
368          e.comp-calls <Comp-Sentence s.tail? (v.fails) (e.last-Re) e.Snt>;
369        };
370    };
371
372  /*
373   * In case of He compile assignments from last Re and then (with new state
374   * of variables) proceed with the rest of the sentence.
375   */
376  (FORMAT e.He) e.Snt =
377    <Comp-Format (e.last-Re) e.He>
378    <Comp-Sentence s.tail? (v.fails) () e.Snt>;
379
380  /*
381   * In case of Pe get from the begining of the sentence a maximum possible
382   * sequence of clashes and compile it.  New values of variables from the
383   * clashes use in the compilation of the rest of the sentence.
384   */
385  (s.dir e.Pattern) e.Snt, s.dir : \{ LEFT; RIGHT; } =
386    <Get-Clash-Sequence (e.last-Re) e.Sentence> :: (e.clashes) e.Sentence,
387    <Comp-Clashes (e.clashes) s.tail? (v.fails) e.Sentence>;
388
389  (s.block) e, BLOCK BLOCK? : e s.block e = <WriteLN! &StdErr "Empty block?">, $fail;
390
391  /*
392   * In case of a block first see if its results are needed for something
393   * after the block and determine whether the block is a source.  Then
394   * compile each branch in turn.
395   */
396  (s.block e.branches) e.Snt,
397    s.block : \{
398      BLOCK = (FATAL);
399      BLOCK?;
400    } :: e.fatal? =
401    /*
402     * If the block initializes an $iter then extract from the $iter the He
403     * for placing it in the end of each branch.
404     * Then look if the block is used by a pattern or format expression.
405     * If so, we should declare variables from that expression before
406     * entering any branch -- those should be visible after the block.
407     * Pattern or format expression is placed in the end of each branch.
408     * But if a branch computes to $error, the expression shouldn't be
409     * used, so protect it with (Comp If-not-error).
410     * If next after the block is (Comp Error) then block results should be
411     * used as values for $error, so place (Comp Error) in the end of each
412     * branch.
413     * If next after the block is (Comp If-not-error) then our block is in
414     * the end of a branch of an outer block and has next pattern or format
415     * inherited from there.  In that case we should place all the sentence
416     * rest in the end of each branch because the block can be inside the
417     * $error already.
418     */
419    {
420      e.Snt : (ITER t.body t.format t.cond) e.rest =
421        t.format (Comp Iter t.body t.format t.cond) e.rest;
422      e.Snt;
423    } :: e.Snt,
424    e.Snt : {
425      t.first e.rest, t.first : \{
426        (LEFT e.pattern) = e.pattern;
427        (RIGHT e.pattern) = e.pattern;
428        (FORMAT e.format) = e.format;
429      } :: e.expr =
430        <Prepare-Vars <Vars e.expr>> :: e.vars,
431*                               <New-Vars e.vars>,
432        (<Vars-Decl e.vars>) ((Comp If-not-error) t.first)
433        ((Comp Source)) e.rest;
434      (Comp Error) e.rest =
435        () ((Comp Error)) () /*empty*/;
436      (Comp If-not-error) e.rest =
437        () (e.Snt) () /*empty*/;
438      e = () () () e.Snt;
439    } :: (e.decls) (e.next-terms) (e.source?) e.Snt,
440    /*
441     * The block is a source if after it goes pattern or format expression
442     * (in that case e.source? isn't empty) or e.Snt isn't empty.
443     * Branches in the block are tail sentences if the current sentence is
444     * tail and the block isn't a source.
445     */
446    {
447      \{ e.source? : v; e.Snt : v; } = ((Comp Source) <R 0 v.fails>) Notail;
448      s.tail? : Tail = () Tail;
449      () Notail;
450    } :: (e.source?) s.tail-branch?,
451    /*
452     * In case our block is a source we should mark the position in the
453     * failures stack, so that we can jump to it after CUTALL.  And if our
454     * block isn't failable we should add (FATAL) to the end of the stack.
455     */
456    v.fails e.source? e.fatal? :: v.branch-fails,
457    /*
458     * We put all compiled branches in a block, so positive return from a
459     * branch is a break from that block.
460     * Each branch in its turn is placed in its own block, so for a $fail
461     * to the next branch we should just break from that inner block.
462     * Each branch is compiled with the current sentence state and the
463     * state is recalled after that.  When all branches are compiled the
464     * state is popped out from the stack.
465     * If last branch fails then the whole block fails, and return from the
466     * last branch is return from the block.  So the last branch isn't
467     * placed in a block and is processed with the failures stack that was
468     * before entering the block.  Note: this trick helps us find more
469     * tailcalls.  If the call of a failable function is on the last branch
470     * of the block and the failures stack is empty we can do tailcall.
471     * When the last branch is compiled with the block's stack, all we
472     * should do is to check it.
473     */
474    <Gener-Label "block"> :: t.label,
475    <Save-Snt-State>,
476    (e.branches) /*e.comp-branches*/ $iter {
477      e.branches : (BRANCH e.branch) e.rest-br =
478        <Add-To-Label t.label "branch"> :: t.br-label,
479        <Comp-Sentence
480          s.tail-branch?
481          (v.branch-fails ((BREAK t.br-label)))
482          (e.last-Re)
483          e.branch e.next-terms
484        > :: e.comp-br,
485        <Recall-Snt-State>,
486        (e.rest-br) e.comp-branches (LABEL (t.br-label) e.comp-br (BREAK t.label));
487    } :: (e.branches) e.comp-branches,
488    e.branches : (BRANCH e.branch) =
489    <Comp-Sentence
490      s.tail-branch? (v.branch-fails) (e.last-Re) e.branch e.next-terms
491    > :: e.last-branch,
492    <Pop-Snt-State>,
493    e.decls (LABEL (t.label) e.comp-branches e.last-branch)
494    <Comp-Sentence s.tail? (v.fails) () e.Snt>;
495
496  /*
497   * In case of $iter first of all compile initial assignment to the hard
498   * expression.
499   */
500  (ITER t.body t.format t.cond) e.Snt =
501    <Comp-Sentence s.tail? (v.fails) (e.last-Re)
502      t.format (Comp Iter t.body t.format t.cond) e.Snt
503    >;
504
505  /*
506   * Then compile $iter condition and body both with the current state of the
507   * sentence.
508   * e.Snt can contain (Comp Error) and (protected from errors) pattern or
509   * format which comes from an outer block, so compile it together with the
510   * condition.
511   * If condition fails we should compute the body, so put the compiled
512   * condition in a block and place a break from it to the failures stack.
513   */
514  (Comp Iter (BRANCH e.body) t.format (BRANCH e.condition)) e.Snt =
515    <Gener-Label "iter"> :: t.label,
516    <Gener-Label "exit_iter"> :: t.exit,
517    <Save-Snt-State>,
518    <Comp-Sentence s.tail? (v.fails ((BREAK t.label))) () e.condition e.Snt>
519      :: e.comp-condition,
520    <Pop-Snt-State>,
521    <Comp-Sentence Notail (v.fails) () e.body t.format> :: e.comp-body,
522    (FOR (/*cont-label*/) (t.exit) () ()
523      (LABEL (t.label) e.comp-condition (BREAK t.exit)) e.comp-body
524    );
525
526  /*
527   * In case of $trap/$with at first compile try-sentence.  All $fails from
528   * it should become errors.
529   * Then recall the state of the sentence and compile catching of an error
530   * with a variable err.
531   * e.Snt can contain (Comp Error) and (protected from errors) pattern or
532   * format which comes from an outer block, so compile it together with both
533   * sentences.
534   */
535  (TRY (BRANCH e.try) e.catch) e.Snt =
536    <Save-Snt-State>,
537    <Comp-Sentence Notail ((FATAL)) () e.try e.Snt> :: e.comp-try,
538    <Pop-Snt-State>,
539    <Gener-Err-Var> :: t.var,
540    <Set-Var (Instantiated? True) t.var>,
541    <Comp-Sentence s.tail? (v.fails) (t.var) e.catch e.Snt> :: e.comp-catch,
542    (TRY e.comp-try) (CATCH-ERROR e.comp-catch);
543
544  /*
545   * In case of \? add Stake to the failures stack.  Add last fail after it
546   * for <R 0 v.fails> continue to work.
547   */
548  (STAKE) e.Snt =
549    <Comp-Sentence s.tail? (v.fails (Comp Stake) <R 0 v.fails>) () e.Snt>;
550
551  /*
552   * In case of \! forget all failure catchers after last \?.
553   * If there is no Stake then we are inside negation or error (we assume the
554   * program is correct).  So the right failure catcher is in the bottom of
555   * the stack.
556   */
557  (CUT) e.Snt =
558    {
559      v.fails : $r v.earlier-fails (Comp Stake) e = v.earlier-fails;
560      <L 0 v.fails>;
561    } :: v.fails,
562    <Comp-Sentence s.tail? (v.fails) () e.Snt>;
563
564  /*
565   * In case of = clear the failures stack up to the closest source.
566   */
567  (CUTALL) e.Snt =
568    {
569      v.fails : $r v.earlier-fails (Comp Source) e = v.earlier-fails;
570      <L 0 v.fails>;
571    } :: v.fails,
572    <Comp-Sentence s.tail? (v.fails) () e.Snt>;
573
574  /*
575   * In case of = in the Refal-6 sense (non-transparent hedge for the fails),
576   * $fail(k) should become $error(Fname "Unexpected fail"), so clear the
577   * failures stack and put that value in it.
578   */
579  NOFAIL e.Snt =
580    <Comp-Sentence s.tail? ((FATAL)) (e.last-Re) e.Snt>;
581
582  /*
583   * In case of $fail return last failure catcher.
584   */
585  (FAIL) e.Snt =
586    v.fails : e (e.last-fail),
587    e.last-fail;
588
589  /*
590   * In case of # we should proceed with the rest if the source is computed
591   * to $fail.
592   * We could compile the rest of the sentence and place it in the
593   * failures stack.  But then the compiled sentence would be copied as many
594   * times as there are $fail's to the upper level in the source.  So we
595   * place compiled source in the block and put the break to exit from it in
596   * the stack.
597   * When compiling the source mark it as Notail as usual.
598   * If the source isn't computed to $fail we should proceed with the last
599   * failure catcher.
600   */
601  (NOT (BRANCH e.branch)) e.Snt =
602    <Gener-Label "negation"> :: t.label,
603    v.fails : e (e.last-fail),
604//    <Save-Snt-State>,
605    <Comp-Sentence Notail (((BREAK t.label))) () e.branch> e.last-fail
606      :: e.comp-negation,
607//    <Pop-Snt-State>,
608    (LABEL (t.label) e.comp-negation) <Comp-Sentence s.tail? (v.fails) () e.Snt>;
609
610  /*
611   * In case of $error all fails become $error(Fname "Unexpected fail").  So
612   * place that value in the failures stack and then compile the computation
613   * of the rest of the sentence and the last Re which should be the value of
614   * $error.
615   */
616  (ERROR) e.Snt =
617    <Comp-Sentence Notail ((FATAL)) () e.Snt (Comp Error)>;
618
619  (Comp Error) e.Snt =
620    <Prepare-Res (e.last-Re)> : (e.Re),
621    (ERROR e.Re);
622
623  /*
624   * Protection mark to be used between source and tail.  If there is $error
625   * construction somewhere in the source then the tail shouldn't be
626   * computed, but instead the source value should be used for throwing.
627   */
628  (Comp If-not-error) e.Snt =
629    {
630      e.Snt : e (Comp Error) =
631        <Comp-Sentence s.tail? (v.fails) (e.last-Re) (Comp Error)>;
632      <Comp-Sentence s.tail? (v.fails) (e.last-Re) e.Snt>;
633    };
634
635//  (Comp Fatal) = FATAL;
636
637//  (Comp Retfail) = RETFAIL;
638
639};
640
641
642
643********** Sentence state stack and functions for work with it. **********
644
645$box Snt-State;
646
647/*
648 * Put current state in the stack.
649 */
650Save-Snt-State = <Put &Snt-State <Vars-Copy-State>>;
651
652/*
653 * Set current state to that at the top of the stack.
654 */
655Recall-Snt-State = <Vars-Set-State <R 0 <? &Snt-State>>>;
656
657/*
658 * Pop the top from the stack and set current state to it.
659 */
660Pop-Snt-State =
661  <Recall-Snt-State>,
662  <Store &Snt-State <Middle 0 1 <? &Snt-State>>>;
663
664
665
666********************** Function calls compilation. ***********************
667
668/*
669 * $func Extract-Calls e.Re = (e.last-Re) e.calls;
670 *
671 *
672 *
673 */
674Extract-Calls {
675  (CALL t.name e.arg) e.rest =
676    <Lookup-Func t.name> :: s.linkage s.tag t.pragma (e.Fin) (e.Fout),
677    <Extract-Calls e.arg> :: (e.last-Re) e.calls,
678    <Prepare-Res <Split-Re (e.Fin) e.last-Re>> :: e.splited-Re,
679    <RFP-Extract-Qualifiers t.name> :: t e.prefix,
680*               <Del-Pragmas <Gener-Vars 0 (e.Fout) e.prefix>> : e.Re s,
681//!             <Store-Vars <Vars e.res-Re>> :: e.ress,
682//!             <Instantiate-Vars e.ress>,
683//!             <Ref-To-Var <Strip-STVE e.res-Re>> :: e.res-Re,
684//!             e.decls <Declare-Vars "Expr" e.ress> :: e.decls,
685    <Gener-Vars (e.Fout) e.prefix> :: /*(e.vars)*/ e.Re,
686    <Vars e.Re> :: e.vars,
687    <Map &Set-Var- (Instantiated? True) (e.vars)> : e,
688    {
689      s.tag : FUNC? =   (Failable (CALL t.name (e.splited-Re) (e.vars)));
690      (CALL t.name (e.splited-Re) (e.vars));
691    } :: t.call,
692    <Extract-Calls e.rest> :: (e.rest-Re) e.rest-calls,
693    (e.Re e.rest-Re) e.calls <Vars-Decl e.vars> t.call e.rest-calls;
694  (PAREN e.Re) e.rest =
695    <Extract-Calls e.Re> :: (e.last-Re) e.calls,
696    <Extract-Calls e.rest> :: (e.rest-Re) e.rest-calls,
697    ((PAREN e.last-Re) e.rest-Re) e.calls e.rest-calls;
698  t.Rt e.Re =
699    <Extract-Calls e.Re> :: (e.last-Re) e.calls,
700    (t.Rt e.last-Re) e.calls;
701  /*empty*/ = () /*empty*/;
702};
703
704
705Comp-Calls (e.fail) e.calls, e.calls : {
706  (Failable t.call) e.rest =
707    (IF ((NOT t.call)) e.fail) <Comp-Calls (e.fail) e.rest>;
708  t.call e.rest =
709    t.call <Comp-Calls (e.fail) e.rest>;
710  /*empty*/ = /*empty*/;
711};
712
713
714
715********** Preparation of vars and REs for following processing **********
716*********** Compilation of static parts of result expressions ************
717
718$func Static-Expr? s.create? e.Re = static? e.Re;
719
720$func Static-Term? t.Rt = static? t.Rt;
721
722
723/*
724 * Extract static parts from each Re.
725 * Also get the right names for variables generated during the preprocessing
726 * stage, if those are in the expr.
727 */
728Prepare-Res {
729  (e.Re) e.rest = <Static-Expr? Create e.Re> :: s e.Re, (e.Re) <Prepare-Res e.rest>;
730  /*empty*/     = /*empty*/;
731};
732
733/*
734 * Find all the longest static parts in the upper level of Re.  Create STATIC
735 * form in place of each one.
736 * Return a tag pointing whether the whole expression is static and expression
737 * with static parts replaced by STATIC forms.  Dynamic parts are returned
738 * unchanged.
739 */
740Static-Expr? {
741  s.create? t.Rt e.Re =
742    <Static-Term? t.Rt> : {
743      Static t.Rt =
744        {
745          e.Re : e1 t2 e3, <Static-Term? t2> : Dynamic t.dyn-Rt =
746            <Static-Expr? Create e3> :: s e3,
747            Dynamic <Create-Static t.Rt e1> t.dyn-Rt e3;
748          {
749            s.create? : Create = Static <Create-Static t.Rt e.Re>;
750            Static t.Rt e.Re;
751          };
752        };
753      Dynamic t.dyn-Rt =
754        <Static-Expr? Create e.Re> :: s e.Re,
755        Dynamic t.dyn-Rt e.Re;
756    };
757  s.create? /*empty*/ = Static;
758};
759
760
761/*
762 * The same as Static-Expr? but for terms.
763 */
764Static-Term? {
765  symbol       = Static symbol;
766  (PAREN e.Re) = <Static-Expr? Not-Create e.Re> :: static? e.Re, static? (PAREN e.Re);
767  (REF t.name) = Static (REF t.name);
768  t.var        = <Prepare-Vars t.var> : t.prep-var, Dynamic t.prep-var;
769};
770
771
772Prepare-Vars {
773  (s.var-tag (e.prefix s.n)) e.rest, <Int? s.n> =
774    {
775      <Lookup &Prep-Vars e.prefix s.n>;
776      <Gener-Vars ((s.var-tag)) e.prefix> :: e.var,
777        <Bind &Prep-Vars (e.prefix s.n) (e.var)>,
778        e.var;
779    } :: e.var,
780    e.var <Prepare-Vars e.rest>;
781  t.var e.rest = t.var <Prepare-Vars e.rest>;
782  /*empty*/ = /*empty*/;
783};
784
785
786
787***************** Compilation of assignment to variables *****************
788
789$func Comp-Assign-to-Var e = e;
790
791Comp-Assign-to-Var (t.var (e.Re)) =
792  {
793    t.var : e.Re = /*empty*/;
794    <Generated-Var? e.Re>,
795      # \{ <Get-Var Instantiated? t.var> : True; },
796      <Get-Var Decl e.Re> : s.box =
797      <Gener-Var-Assign t.var e.Re>;
798    <Set-Var (Instantiated? True) t.var>, $fail;
799    <Get-Var Decl t.var> : s = (ASSIGN <Vars-Print t.var> e.Re);
800    <Vars-Decl t.var> : e, (EXPR <Vars-Print t.var> e.Re);
801  };
802
803Comp-Assigns e.assigns = <Map &Comp-Assign-to-Var (e.assigns)>;
804
805
806
807************************** FORMAT compilation. ***************************
808
809$box Aux-Index;
810
811$func Gener-Aux-Var = t.new-aux-var;
812
813Gener-Aux-Var =
814  <? &Aux-Index> : s.n,
815  <Store &Aux-Index <"+" s.n 1>>,
816  (VAR ("aux" s.n));
817
818
819$func Create-Aux-Vars (e.vars) e.splited-Re = e.assigns;
820
821
822Comp-Format (e.last-Re) e.He =
823  <Prepare-Vars <Vars e.He>> :: e.vars,
824  <Prepare-Res <Split-Re (<Format-Exp e.He>) e.last-Re>> :: e.splited-Re,
825  <Store &Aux-Index 1>,
826  <Create-Aux-Vars (e.vars) e.splited-Re> :: e.assigns,
827  <Comp-Assigns e.assigns>;
828
829/*
830 * Итак, e.vars -- все переменные, входящие в форматное выражение.  Каждая
831 * переменная может входить в форматное выражение только один раз, поэтому
832 * повторяющихся среди них нет.
833 * e.splited-Re -- набор результатных выражений.  На каждую переменную из
834 * e.vars по выражению, которое должно быть ей присвоено.
835 *
836 * Если переменная t.var_i используется в выражении e.Re_j, и i /= j, то
837 * переменной t.var_j значение должно быть присвоено раньше, чем перeменной
838 * t.var_i.  Если же, по аналогичным соображениям, t.var_i должна получить
839 * значение раньше t.var_j, необходимо завести вспомогательную переменную.
840 *
841 * Пример:
842 *
843 * t1 (t1 t2) (t1 t3) :: t2 t1 t3
844 *
845 * t3 = (t1 + t3)();
846 * aux_1 = t1;
847 * t1 = (t1 + t2)()
848 * t2 = aux_1;
849 *
850 * В общем случае вспомогательная переменная требуется, если двум переменным
851 * необходимы старые значения друг друга (возможно, не напрямую, а через
852 * промежуточные переменные).
853 *
854 * Вместо того, чтобы искать и анализировать такие циклы, будем действовать по
855 * методу "наибольшей пользы".  А именно:
856 *
857 *   - Для каждой переменной выпишем все другие переменные, которым требуется
858 *     её старое значение, а также отдельно те, старые значения которых
859 *     требуются ей.
860 *
861 *   - Всем переменным, от старых значений которых ничего не зависит, можно
862 *     смело присвоить новые значения.  При этом они исчезают из списков
863 *     зависимостей оставшихся переменных.
864 *
865 *   - Все переменные, новые значения которых ни от чего не зависят, можно
866 *     отложить, чтобы присвоить им значения тогда, когда будет удобно.  Т.е.
867 *     тогда, когда списки зависящих от них переменных опустеют.
868 *
869 *   - Чтобы означить оставшиеся, нужны вспомогательные переменные.  Выберем
870 *     одну из переменных, с максимальным списком тех, от которых она зависит,
871 *     и положим её значение во вспомогательную переменную.  Так как мы сразу
872 *     уменьшили кол-во зависимостей у максимального кол-ва переменных,
873 *     локально мы добились наибольшей пользы, хотя не исключено, что глобально
874 *     такой метод и не даст наименьшего кол-ва вспомогательных переменных.
875 *     Кроме того, мы не пытаемся выбрать наилучшую переменную из нескольких с
876 *     максимальным списком зависимостей.
877 *
878 *   - Повторяем всё это до тех пор, пока у каждой переменной не опустеет
879 *     список зависящих от неё.
880 *
881 *
882 * Для нашего примера:
883 *
884 * t1 (t1 t2) (t1 t3) :: t2 t1 t3
885 *
886 * t1 -- (t2 t3) (t2)
887 * t2 -- (t1)    (t1)
888 * t3 -- ()      (t1)
889 *
890 *
891 * Для каждой переменной var_i найдём все j /= i, такие что в Re_j встречается
892 * var_i -- provide[i], и а также все j /= i, такие что var_j нужна для
893 * подсчёта var_i, т.е. встречается в Re_i.
894 *
895 * Res-vars <- <Map &Vars (Res)>
896 * for var_i in vars
897 *     provide[i] <-
898 *     for vars-Re_j in Res-vars, j /= i
899 *         vars-Re_j : e var_i e = j
900 *     require[i] <- <Res-vars[i] `*` vars[^i]> : e var_j e, j
901 *
902 * Res-vars = map Vars Res
903 * provide, require =
904 *   {   [ j | vars-Re_j <- Res-vars, j /= i, var_i `in` vars-Re_j ]
905 *     , [ j | var_j <- Res-vars[i] `*` vars, i /= j]
906 *     | var_i <- vars
907 *   }
908 *
909 */
910
911$func CAV e.vars (e.assigns) (e.delayed) = e.assigns;
912
913$func Get-Vars e = e;
914Get-Vars (e.Re) = (<Vars e.Re>);
915
916Create-Aux-Vars (e.vars) e.splited-Re =
917  <Zip (<Map &Get-Vars (e.splited-Re)>) (e.vars)> :: e.list,
918  <Box> :: s.box,
919  <Box> :: s.provide-i,
920  <Box> :: s.require-i,
921  {
922    e.vars : e1 t.var-i e2,
923      {
924        e.list : e ((e.vars-Re) t.var-j) e,
925          \{
926            t.var-i : t.var-j = <Put s.require-i <And (e1 e2) e.vars-Re>>;
927            e.vars-Re : e t.var-i e = <Put s.provide-i t.var-j>;
928          },
929          $fail;
930        <L <Length e1> e.splited-Re> :: t.Re-i,
931        <Put s.box (t.var-i t.Re-i (<? s.provide-i>) (<? s.require-i>))>,
932          <Store s.provide-i /*empty*/>,
933          <Store s.require-i /*empty*/>;
934      },
935      $fail;;
936  },
937  <CAV <? s.box> (/*assigns*/) (/*delayed*/)>;
938
939
940/*
941 * Если есть переменная, у которой список provide пуст, её можно посчитать.
942 * Это выражается в том, что она (вместе с присваиваемым значением) добавляется
943 * в список assigns, убирается из списка vars, а также из всех списков provide
944 * и delayed.  В списках require её не было.
945 *
946 * CAV Res vars provide require assigns delayed =
947 *   { i | var_i <- vars, provide_i == [] } ->     // Здесь неверно!  На переменные
948 *                                                    из delayed тоже надо смотреть.
949 *       vars    = vars - var_i
950 *       provide = [ provide_j - i | provide_j <- provide ]
951 *       assigns = assigns++[(var_i, Res[i])]
952 *       delayed = [ (var_j, provide_j - i) | (var_j, provide_j) <- delayed ]
953 *       CAV Res vars provide require assigns delayed
954 */
955
956$func Assign-Empty-Provides e.vars  = e.assigns (e.vars);
957
958Assign-Empty-Provides {
959  e1 (t.var-i t.Re-i (/*empty provide_i*/) (e.require-i)) e2 =
960    <Box> :: s.vars,
961    {
962      e1 e2 : e (t.var-j t.Re-j (e.provide-j) (e.require-j)) e,
963        <Put s.vars (t.var-j t.Re-j (<Sub (e.provide-j) t.var-i>) (e.require-j))>,
964        $fail;;
965    },
966    (t.var-i t.Re-i) <Assign-Empty-Provides <? s.vars>>;
967  e.vars = /*empty*/ (e.vars);
968};
969
970
971/*
972 * Если есть переменная, у которой список require пуст, кладём её в delayed.
973 * Она будет посчитана, когда у неё опустеет список provide, т.е. когда не
974 * останется переменных, у которых она в списке require.
975 */
976$func Delay-Empty-Requires e.vars  = e.delayed (e.vars);
977
978Delay-Empty-Requires {
979  e1 t.var e2, t.var : (t.var-i t.Re-i (e.provide-i) (/*empty require_i*/)) =
980    <Delay-Empty-Requires e2> :: e.delayed (e.vars),
981    t.var e.delayed (e1 e.vars);
982  e.vars = /*empty*/ (e.vars);
983};
984
985
986/*
987 * Выбор переменной (из двух) с более длинным списком требуемых ей значений.
988 */
989$func Max-Require e = e;
990
991Max-Require t.arg1 t.arg2 =
992  t.arg1 : (t.var1 t.Re1 t.provide1 (e.require1)),
993  t.arg2 : (t.var2 t.Re2 t.provide2 (e.require2)),
994  {
995    <"<" (<Length e.require1>) (<Length e.require2>)> = t.arg2;
996    t.arg1;
997  };
998
999
1000/*
1001 * Подставить вспомогательную переменную вместо исходной во всех результатных выражениях.
1002 * Присваивание к исходной переменной убрать (оно к этому моменту уже выполнено).
1003 * Убрать переменную из списков зависимостей.
1004 */
1005$func Subst-Aux-Var e = e;
1006
1007Subst-Aux-Var t.var t.aux (t.v t.Re (e.provide) (e.require)), {
1008  t.var : t.v = /*empty*/;
1009  (
1010    t.v
1011    <Subst (t.var) ((t.aux)) t.Re>
1012    (<Sub (e.provide) t.var>)
1013    (<Sub (e.require) t.var>)
1014  );
1015};
1016
1017
1018/*
1019 * Извлечь присваивание из всей информации о переменной.
1020 */
1021$func Extract-Assigns e = e;
1022Extract-Assigns (t.var t.Re e) = (t.var t.Re);
1023
1024
1025/*
1026 * Основной цикл обработки присваиваний.
1027 *
1028 * 1) Из всех переменных (в том числе и отложенных), от которых больше ничего
1029 *    не зависит, сделать присваивания.
1030 * 2) Все переменные, которые больше ни от чего не зависят, отложить.
1031 * 3) Если осталось хотя бы две неотложенных переменных, выбирать из них ту,
1032 *    которая зависит от наибольшего числа переменных, подставить везде вместо
1033 *    неё вспомогательную, перейти к пункту 1.
1034 */
1035CAV e.vars (e.assigns) (e.delayed) =
1036  <Assign-Empty-Provides e.vars> :: e.new-assigns (e.vars),
1037  e.assigns e.new-assigns <Assign-Empty-Provides e.delayed> :: e.assigns (e.delayed),
1038  e.delayed <Delay-Empty-Requires e.vars> :: e.delayed (e.vars),
1039  {
1040    e.vars : t t e =
1041      <Foldr1 &Max-Require (e.vars)> : (t.var t.Re e),
1042      <Gener-Aux-Var> :: t.aux,
1043      e.assigns (t.aux (t.var)) (t.var t.Re) :: e.assigns,
1044      <Map &Subst-Aux-Var t.var t.aux (e.vars)> :: e.vars,
1045      <Map &Subst-Aux-Var t.var t.aux (e.delayed)> :: e.delayed,
1046      <CAV e.vars (e.assigns) (e.delayed)>;
1047    e.assigns <Map &Extract-Assigns (e.vars e.delayed)>;
1048  };
1049
1050
1051
1052
1053****************** Компиляция сопоставления с образцом *******************
1054
1055Get-Clash-Sequence (e.last-Re) t.Pattern e.Snt =
1056  (/*e.clashes*/) (RESULT e.last-Re) t.Pattern e.Snt $iter {
1057    e.Snt : (RESULT e.Re) (s.dir e.Pe) e.rest =
1058      /*
1059       * Компилируем все константные выражения и заводим в табличке все
1060       * незаведённые переменные.  У старых переменных очищается память
1061       * на предмет клешей, в которых они раньше использовались.
1062       */
1063      <Prepare-Res (e.Re) (e.Pe)> : (e.R1) (e.P1),
1064      <Map &Set-Var- (Clashes /*empty*/) (<Vars e.R1 e.P1>)> : e,
1065      (e.clashes (e.R1) (s.dir e.P1)) e.rest;
1066  } :: (e.clashes) e.Snt,
1067  # \{
1068    e.Snt : \{
1069      (RESULT e.Re) (LEFT e) e = e.Re;
1070      (RESULT e.Re) (RIGHT e) e = e.Re;
1071    } :: e.Re,
1072      <Without-Calls? e.Re>;
1073  } =
1074  (e.clashes) e.Snt;
1075
1076Without-Calls? e.Re =
1077  e.Re $iter {
1078    e.Re : t.Rt e.rest =
1079      t.Rt : {
1080        (CALL e) = $fail;
1081        (BLOCK e) = $fail;
1082        (PAREN e.Re1) = <Without-Calls? e.Re1>;
1083        t.symbol-or-var = /*empty*/;
1084      },
1085      e.rest;
1086  } :: e.Re,
1087  e.Re : /*empty*/;
1088
1089$func CC s.tail? (v.fails) t.end-cycle e.Snt = e.asail-Snt;
1090
1091Comp-Clashes (e.clashes) s.tail? (v.fails) e.Sentence =
1092  <Init-Clashes e.clashes>,
1093  <CC s.tail? (v.fails) <R 0 v.fails> e.Sentence>;
1094
1095$func CC-Known-Lengths t.fail e.idxs = e.conds;
1096
1097$func CC-Compute-Length t.fail t.end-cycle t.idx = e;
1098
1099$func CC-Unknown-Lengths t.fail e.idxs = e.conds;
1100
1101$func CC-Deref t.fail e.actions = e.actions;
1102
1103$func CC-Eqs t.fail (e.assigns) e.eqs = e.actions;
1104
1105$func CC-Compose-And-Compare t.fail = e.actions;
1106
1107CC s.tail? (v.fails) t.end-cycle e.Snt, {
1108  <Domain &Known-Lengths> : v.clashes =
1109    <CC-Known-Lengths t.end-cycle v.clashes>
1110    <CC s.tail? (v.fails) t.end-cycle e.Snt>;
1111  <Domain &Compute-Length> : (t.clash) e =
1112    <CC-Compute-Length <R 0 v.fails> t.end-cycle t.clash>
1113    <CC s.tail? (v.fails) t.end-cycle e.Snt>;
1114  <Domain &Unknown-Lengths> : e.clashes =
1115    <CC-Unknown-Lengths t.end-cycle e.clashes> :: e.conds,
1116    <Update-Hard-Parts> : {
1117      v.actions =
1118        e.conds <CC-Deref <R 0 v.fails> v.actions>
1119        <CC s.tail? (v.fails) t.end-cycle e.Snt>;
1120      /*empty*/ =
1121        {
1122          <Compose-Source-For-Deref> :: e.assign =
1123            e.conds <CC-Eqs <R 0 v.fails> () e.assign>
1124            <CC s.tail? (v.fails) t.end-cycle e.Snt>;
1125          e.conds <CC-Compose-And-Compare <R 0 v.fails>> :: e.actions,
1126            {
1127              <Get-Cycle>
1128              :: e.assign (e.left) (e.right) (e.len)
1129                    t.var t.l-var t.r-var =
1130                {
1131                  e.left : 0, e.right : 0 = /*empty*/ t.var;
1132                  <Gener-Vars ((VAR)) "subexpr_" t.var> : t.sub-var,
1133                    (SUBEXPR t.sub-var t.var (e.left)
1134                      ((INFIX "-" (e.len) (e.left e.right))))
1135                    t.sub-var;
1136                } :: e.subexpr t.var,
1137                <Gener-Label "continue"> :: t.cont-label,
1138                <Gener-Label "exit"> :: t.break-label,
1139                e.actions
1140                <CC-Eqs <R 0 v.fails> () e.assign> e.subexpr
1141                (LSPLIT t.var (<Get-Var Min t.l-var>) t.l-var t.r-var)
1142                (FOR (t.cont-label) (t.break-label) () ((INC-ITER t.var))
1143                  (IF ((NOT (CHECK-ITER t.var))) <Concat <R 0 v.fails>>)
1144                  <CC s.tail?   (v.fails ((CONTINUE t.cont-label)))
1145                    <R 0 v.fails> e.Snt>
1146                  (BREAK t.break-label)
1147                );
1148              e.actions <Comp-Sentence s.tail? (v.fails) () e.Snt>;
1149            };
1150        };
1151    };
1152};
1153
1154CC-Known-Lengths (e.fail) e.idxs, {
1155  e.idxs : (t.idx) e.rest =
1156    <Put &Checked-Lengths t.idx>,
1157    <Lookup &Known-Lengths t.idx> : (e.len-Re) (e.len-Pe),
1158    (IF ((INFIX "!=" (e.len-Re) (e.len-Pe))) e.fail)
1159    <CC-Known-Lengths (e.fail) e.rest>;
1160  <RFP-Clear-Table &Known-Lengths>;
1161};
1162
1163CC-Compute-Length (e.fail) (e.end-cycle) t.idx =
1164  <Lookup &Compute-Length t.idx> : t.var s.mult (e.minuend) (e.subtrahend),
1165  <Create-Int-Var ("len") Aux e.minuend> :: t.m-var e.m-assign,
1166  <Create-Int-Var ("len") Aux e.subtrahend> :: t.s-var e.s-assign,
1167  <Get-Var Min t.var> :: e.min,
1168  ((INFIX "<" (t.m-var)
1169        ((INFIX "+" (t.s-var)
1170              ((INFIX "*" (e.min) (s.mult)))
1171  ))                    )) :: e.min-cond,
1172  <Get-Var Max t.var> : {
1173    /*empty*/;
1174    e.max =
1175      ((INFIX ">" (t.m-var)
1176            ((INFIX "+" (t.s-var)
1177                  ((INFIX "*" (e.max) (s.mult)))
1178      ))                        ));
1179  } :: e.max-cond,
1180  (INFIX "%" ((INFIX "-" (t.m-var) (t.s-var))) (s.mult)) :: e.div-cond,
1181  <Create-Int-Var ("len_") t.var
1182    (INFIX "/" ((INFIX "-" (t.m-var) (t.s-var))) (s.mult))
1183  > :: t.len-var e.len-assign,
1184  <Set-Var (Length t.len-var) t.var>,
1185  <Unbind &Compute-Length t.idx>,
1186  <Put &Checked-Lengths t.idx>,
1187  <Get-Var Clashes t.var> :: e.clashes,
1188  <Map &Reclassify-Clash (<Sub (e.clashes) <? &Checked-Lengths>>)> : e,
1189  e.m-assign e.s-assign
1190  (IF ((INFIX "||" e.min-cond e.max-cond)) e.end-cycle)
1191  (IF (e.div-cond) e.fail)
1192  e.len-assign;
1193
1194$func  Get-Min e = e;
1195
1196$func? Get-Max e = e;
1197
1198CC-Unknown-Lengths (e.fail) e.idxs, {
1199  e.idxs : (t.idx) e.rest =
1200    <Lookup &Unknown-Lengths t.idx> : (e.len-Re) (e.len-Pe) (e.vars-Re) (e.vars-Pe),
1201    {
1202      <Get-Max e.vars-Re> :: e.max =
1203        <Get-Min e.vars-Pe> :: e.min,
1204        ((INFIX "<" (e.len-Re e.max) (e.len-Pe e.min)));
1205      /*empty*/;
1206    } :: e.cond1,
1207    {
1208      <Get-Max e.vars-Pe> :: e.max =
1209        <Get-Min e.vars-Re> :: e.min,
1210        ((INFIX ">" (e.len-Re e.min) (e.len-Pe e.max)));
1211      /*empty*/;
1212    } :: e.cond2,
1213    {
1214      e.cond1 : /*empty*/, e.cond2 : /*empty*/ = /*empty*/;
1215      (IF ((INFIX "||" e.cond1 e.cond2)) e.fail);
1216    } :: e.cond,
1217    e.cond
1218    <CC-Unknown-Lengths (e.fail) e.rest>;
1219  <RFP-Clear-Table &Unknown-Lengths>;
1220};
1221
1222Get-Min
1223{
1224  t.var e.vars = <Get-Var Min t.var> <Get-Min e.vars>;
1225  /*empty*/ = /*empty*/;
1226};
1227
1228Get-Max
1229{
1230  t.var e.vars = <Get-Var Max t.var> : v.max, v.max <Get-Max e.vars>;
1231  /*empty*/ = /*empty*/;
1232};
1233
1234$func Pos (e.Re) s.dir e.pos = e.pos;
1235
1236Pos {
1237  (e.Re) RIGHT e.pos = (INFIX "-" ((LENGTH e.Re)) (1) (e.pos));
1238  (e.Re) LEFT  e.pos = e.pos;
1239};
1240
1241/*
1242 * Информацию о проверках и заведении переменных, необходимых для создания
1243 * клешей из содержимого скобок, кодируем на ASAIL.
1244 */
1245CC-Deref (e.fail) e.actions, e.actions : {
1246  (SYMBOL? e.Re (s.dir e.pos)) e.rest =
1247    (IF ((SYMBOL? e.Re (<Pos (e.Re) s.dir e.pos>))) e.fail)
1248    <CC-Deref (e.fail) e.rest>;
1249  (DEREF t.var e.Re (s.dir e.pos)) e.rest =
1250    (DEREF t.var e.Re (<Pos (e.Re) s.dir e.pos>))
1251    <CC-Deref (e.fail) e.rest>;
1252  /*empty*/ = /*empty*/;
1253};
1254
1255CC-Eqs (e.fail) (e.assigns) e.eqs, {
1256  e.eqs : ((e.Re) (s.dir e.pos) t.Pt (e.len)) e.rest =
1257    {
1258      e.Re : t,
1259        <Get-Known-Length e.Re> : e.len (), // FIXME: здесь надо использовать
1260                          //        калькулятор
1261        s.dir e.pos : \{
1262          LEFT 0;
1263          RIGHT e.len;
1264        } =
1265        e.Re;;
1266    } :: e.Re-term,
1267    {
1268      e.len : 1 = TERM-EQ;      // FIXME: здесь надо использовать
1269                  //        калькулятор
1270      EQ;
1271    } :: s.eq,
1272    <Pos (e.Re) s.dir e.pos> :: e.pos,
1273    {
1274      \{
1275        <Get-Var Instantiated? t.Pt> : True = t.Pt (e.Re);
1276        t.Pt : \{
1277          (REF e);
1278          (STATIC e);
1279        }, {
1280          <Var? e.Re-term> = e.Re-term (t.Pt);
1281          t.Pt (e.Re);
1282        };
1283      } :: el (er),
1284        (IF ((NOT (s.eq el (er) (e.pos)))) e.fail) :: t.cond,
1285        {
1286          e.assigns : $r e1 (SUBEXPR t.Pt e.def) e2 =
1287            <CC-Eqs (e.fail) (e1 (SUBEXPR t.Pt e.def) t.cond e2) e.rest>;
1288          t.cond <CC-Eqs (e.fail) (e.assigns) e.rest>;
1289        };
1290      <Set-Var (Instantiated? True) t.Pt>,
1291        <CC-Eqs (e.fail) (e.assigns (SUBEXPR t.Pt e.Re (e.pos) (e.len))) e.rest>;
1292    };
1293  e.assigns e.eqs;
1294};
1295
1296CC-Compose-And-Compare (e.fail) =
1297  {
1298    <? &Eqs> : v.eqs =
1299      <CC-Eqs (e.fail) () v.eqs> :: e.actions,
1300      <Store &Eqs /*empty*/>,
1301      <Update-Hard-Parts> : e,
1302      e.actions <CC-Compose-And-Compare (e.fail)>;;
1303  };
1304
1305
1306
1307
1308
1309
1310*       /*e.cond*/ (/*!e.clashes!*/) (/*e.fail*/) $iter {
1311*               /*
1312*                * First of all see if we have a clash with all variables of known length
1313*                * and without length conditions written out.
1314*                */
1315*               e.clashes : e1 (e.t1 Known-length e.t2 (e.Re) (s.dir e.Pe)) e2,
1316*                       <Hard-Exp? e.Re e.Pe> =
1317*                       e.cond
1318*                       (Cond IF ((INFIX "==" (<Length-of e.Re>) (<Length-of e.Pe>))))
1319*                       (e1 (e.t1 Checked-length e.t2 (e.Re) (s.dir e.Pe)) e2) (e.fail);
1320*               /*
1321*                * Next see if we can compute length of some variable.
1322*                */
1323*               e.cond <Find-Var-Length e.clashes> (e.fail);
1324*               /*
1325*                * Write out restrictions for the cyclic variables.
1326*                */
1327*               e.cond <Cyclic-Restrictions e.clashes> (e.fail);
1328* //            <Cyclic-Restrictions e.clashes> :: e.new-cond (e.clashes),
1329* //                    {
1330* //                            e.fail : v = e.cond e.new-cond (Clear-Restricted) (e.clashes) (e.fail);
1331* //                            e.cond e.new-cond (e.clashes) (e.fail);
1332* //                    };
1333*               /*
1334*                * After checking all possible lengthes at the upper level change
1335*                * <<current_label_if_fail>>.
1336*                */
1337*               e.fail : v =
1338*                       (Contin e.fail) e.cond (Fail e.fail) (Clear-Restricted) (e.clashes) ();
1339*               /*
1340*                * For all clashes with known left part check unwatched terms whether they
1341*                * are symbols or reference terms or not any.
1342*                */
1343*               \?
1344*               {
1345*                       <Check-Symbols e.clashes> : {
1346*                               v.new-cond (e.new-clashes) s =
1347*                                       e.cond (Cond IF (v.new-cond)) (e.new-clashes) ();
1348*                               (e.new-clashes) New = e.cond (e.new-clashes) ();
1349*                               e \! $fail;
1350*                       };
1351*                       <PrintLN "Check-Symbols: don't know what to do... ;-)">, $fail;
1352*               };
1353*               /*
1354*                * And then try to compose new clash by dereferencing a part of some one.
1355*                */
1356*               e.cond <Dereference-Subexpr e.clashes> ();
1357*               /*
1358*                * If previous doesn't work then compare recursively all known
1359*                * subexpressions and all unknown repeated subexpressions with
1360*                * corresponding parts of source.
1361*                */
1362*               <Compare-Subexpr e.clashes> :: e.new-cond (e.asserts) (e.new-clashes) s.new?,
1363*                       \{
1364*                               e.new-cond : v, {
1365*                                       e.asserts : v =
1366*                                               e.cond (Assert e.asserts) (Cond IF (e.new-cond)) (e.new-clashes) ();
1367*                                       e.cond (Cond IF (e.new-cond)) (e.new-clashes) ();
1368*                               };
1369*                               e.asserts : v = e.cond (Assert e.asserts) (e.new-clashes) ();
1370*                               s.new? : New = e.cond (e.new-clashes) ();
1371*                       };
1372*               /*
1373*                * Then get first uncatenated source and bring it to the normal
1374*                * form, i.e. concatenate and parenthesize until it became single
1375*                * known expression.
1376*                */
1377*               e.cond <Get-Source e.clashes> ();
1378*               /*
1379*                * Now it's time to deal with cycles.
1380*                */
1381*               e.cond <Comp-Cyclic e.clashes>;
1382*               /*
1383*                * At last initialize all new subexpressions from all clashes.
1384*                */
1385*               e.clashes () $iter {
1386*                       e.clashes : (e t.Re (s.dir e.Pe)) e.rest,
1387*                               e.rest (e.new-cond <Get-Subexprs <Vars e.Pe>>);
1388*               } :: e.clashes (e.new-cond),
1389*                       e.clashes : /*empty*/ =
1390*                       {
1391*                               e.new-cond : /*empty*/ = e.cond () ();
1392*                               e.cond (Assert e.new-cond) () ();
1393*                       };
1394*       } :: e.cond (e.clashes) (e.fail),
1395* //    <WriteLN CC-Clashes e.clashes>,
1396* //    <WriteLN CC-Cond e.cond>,
1397*       e.clashes : /*empty*/ =
1398*
1399*       e.cond () 0 $iter {
1400*               e.cond : (Contin (CONTINUE t.label)) e.rest =
1401*                       e.rest (e.contin (Comp Continue t.label)) 0;
1402*               e.cond (e.contin) 1;
1403*       } :: e.cond (e.contin) s.stop?,
1404*       s.stop? : 1 =
1405* //!   <Comp-Sentence () e.Current-Snt e.contin e.Other-Snts> :: e.asail-Snt,
1406*       <Comp-Sentence s.tail? (v.fails) () e.Sentence> :: e.asail-Snt,
1407*       e.cond (e.asail-Snt) () $iter {
1408*               e.cond : e.some (e.last),
1409*                       e.last : {
1410*                               Cond e.condition =
1411*                                       e.some ((e.condition e.asail-Snt)) (e.vars);
1412*                               Assert e.assertion =
1413*                                       e.some (e.assertion e.asail-Snt) (e.vars);
1414*                               Fail e.fail1 =
1415*                                       e.some (e.asail-Snt e.fail1) (e.vars);
1416*                               Restricted t.var =
1417*                                       e.some (e.asail-Snt) (e.vars t.var);
1418*                               If-not-restricted t.var e.restr-cond, {
1419*                                       e.vars : e t.var e = e.some (e.asail-Snt) (e.vars);
1420*                                       e.some e.restr-cond (e.asail-Snt) (e.vars);
1421*                               };
1422*                               Clear-Restricted = e.some (e.asail-Snt) ();
1423*                       };
1424*       } :: e.cond (e.asail-Snt) (e.vars),
1425*       e.cond : /*empty*/ =
1426*       e.asail-Snt/* <Comp-Sentence () e.Other-Snts>*/;
1427
1428
1429Find-Var-Length (e.fail) e.clashes =
1430//  <WriteLN Find-Var-Length e.clashes>,
1431  e.clashes : e1 (e.t1 Unknown-length e.t2 (e.Re) (s.dir e.Pe)) e2 \?
1432  <Unknown-Vars e.Pe> :: e.new-Pe (e.Pe-unknown),
1433  <Unknown-Vars e.Re> :: e.new-Re (e.Re-unknown),
1434//  <Write Unknown>, <Write (e.Re-unknown)>, <WriteLN (e.Pe-unknown)>,
1435  e.Re-unknown e.Pe-unknown : {
1436    /*empty*/ =
1437      (e1 (e.t1 Known-length e.t2 (e.Re) (s.dir e.Pe)) e2);
1438    (VAR t.name) e.rest,
1439      e.rest $iter \{
1440        e.unknown : (VAR t.name) e.rest1 = e.rest1;
1441      } :: e.unknown,
1442      e.unknown : /*empty*/,
1443      <"-" <Length e.Re-unknown> <Length e.Pe-unknown>> : {
1444        0 \! $fail;
1445        s.diff, {
1446          <"<" (s.diff) (0)> =
1447            <"*" s.diff -1>
1448            (INFIX "-" (<Length-of e.new-Re>) (<Length-of e.new-Pe>));
1449          <">" (s.diff) (0)> =
1450            s.diff
1451            (INFIX "-" (<Length-of e.new-Pe>) (<Length-of e.new-Re>));
1452        } :: s.mult e.diff,
1453          t.name : (e.QualifiedName),
1454          (VAR ("len" e.QualifiedName)) :: t.len-var,
1455          {
1456            <?? t.name Max> :: e.max =
1457              (INFIX "<="
1458                (t.len-var)
1459                ((INFIX "*" (s.mult) (e.max)))
1460              );
1461            /*empty*/;
1462          } :: e.cond,
1463          e.cond
1464          (INFIX ">="
1465            (t.len-var)
1466            ((INFIX "*" (s.mult) (<?? t.name Min>)))
1467          )
1468          (NOT (INFIX "%"
1469            (t.len-var)
1470            (s.mult)
1471          )) :: e.cond,
1472          <Set-Var t.name (Max) (//(LENGTH (VAR t.name))
1473            (INFIX "/" (t.len-var) (s.mult))
1474          )>,
1475          <Set-Var t.name (Min) (<?? t.name Max>)>,
1476          <Set-Var t.name (Length) (<?? t.name Max>)>,
1477//          <WriteLN Unknown-Num s.mult> =
1478          (Restricted (VAR t.name))
1479          (Assert
1480            <Declare-Vars "int" t.len-var>
1481            (ASSIGN t.len-var e.diff)
1482          )
1483          (Cond IF (e.cond))
1484          (<Update-Ties (VAR t.name) e1>
1485            (e.t1 Checked-length e.t2 (e.Re) (s.dir e.Pe))
1486          <Update-Ties (VAR t.name) e2>);
1487      };
1488    e.unknown \!
1489      e.t1 Unknown-length e.t2 : e.t3 Ties e.t4 =
1490      e.t1 : t.id e,
1491      e.unknown () $iter {
1492        e.unknown : (VAR t.name) e.rest, {
1493          e.tied : e (VAR t.name) e = e.rest (e.tied);
1494          <Entries (VAR t.name) (e.Re)> :: s.Re-ent e.new-Re,
1495            <Entries (VAR t.name) (e.Pe)> :: s.Pe-ent e.new-Pe,
1496            <"-" s.Re-ent s.Pe-ent> :: s.diff,
1497            {
1498              s.diff : 0 = e.rest (e.tied (VAR t.name));
1499              {
1500                <"<" (s.diff) (0)> =
1501                  <"*" s.diff -1> (e.new-Re) (e.new-Pe);
1502                s.diff (e.new-Pe) (e.new-Re);
1503              } :: s.diff (e.plus) (e.minus),
1504                (
1505                  t.id
1506                  (<Known-Length-of e.plus>)
1507                  (<Known-Length-of e.minus>)
1508                  s.diff
1509                ) :: t.tie,
1510                {
1511                  <?? t.name Ties> : {
1512                    e.c1 (t.id e) e.c2 = e.c1 e.c2;
1513                    e.ties = e.ties;
1514                  };
1515                  /*empty*/;
1516                } :: e.ties,
1517                {
1518                  e.ties : e t.tie e;
1519                  <Set-Var t.name (Ties) (e.ties t.tie)>;
1520                },
1521                e.rest (e.tied (VAR t.name));
1522            };
1523        };
1524      } :: e.unknown (e.tied),
1525      e.unknown : /*empty*/ =
1526      {
1527        e.t3 e.t4 : e Cyclic e = e.t3 e.t4;
1528        e.t3 e.t4 Cyclic;
1529      } :: e.tags,
1530      (e1 (e.tags (e.Re) (s.dir e.Pe)) e2);
1531  };
1532
1533Known-Length-of e.expr =
1534  <Unknown-Vars e.expr> :: e.expr (e.vars),
1535  <Length-of e.expr> (e.vars);
1536
1537Update-Ties t.var e.clashes =
1538  e.clashes () $iter {
1539    e.clashes : t.clash e.rest,
1540      t.clash : (e.tags (e.Re) (s.dir e.Pe)),
1541      {
1542        e.tags : e Ties e = e.rest (e.new-clashes t.clash);
1543        e.Re e.Pe : e t.var e =
1544          e.rest (e.new-clashes (e.tags Ties (e.Re) (s.dir e.Pe)));
1545        e.rest (e.new-clashes t.clash);
1546      };
1547  } :: e.clashes (e.new-clashes),
1548  e.clashes : /*empty*/ =
1549  e.new-clashes;
1550
1551Cyclic-Restrictions e.clashes =
1552  e.clashes : e1 (e.t1 Cyclic e.t2 (e.Re) (s.dir e.Pe)) e2 =
1553  <Unknown-Vars e.Re e.Pe> :: e (e.unknown),
1554  e.unknown () $iter {
1555    e.unknown : t.var e.rest,
1556      t.var : (VAR (e.QualifiedName)),
1557      (VAR ("min" e.QualifiedName)) :: t.min-var,
1558      <Cyclic-Min t.var> :: e.min,
1559      {
1560        <Cyclic-Max t.var> :: e.max =
1561          e.rest (e.cond (Restricted t.var) (If-not-restricted t.var
1562            (Assert
1563              <Declare-Vars "int" t.min-var> (ASSIGN t.min-var e.min)
1564            )
1565            (Cond IF ((INFIX "<=" (t.min-var) (e.max))))
1566        ));
1567        e.rest (e.cond);
1568      };
1569  } :: e.unknown (e.cond),
1570  e.unknown : /*empty*/ =
1571  e.cond (e1 (e.t1 e.t2 (e.Re) (s.dir e.Pe)) e2);
1572
1573Cyclic-Min (VAR t.name) =
1574  <?? t.name Ties> () $iter {
1575    e.ties : (t (e.plus (e.plus-vars)) (e.minus (e.minus-vars)) s.mult) e.rest, {
1576      e.minus-vars () $iter \{
1577        e.minus-vars : t.var e.vars-rest,
1578          e.vars-rest (e.minus-maxes <Cyclic-Max t.var>);
1579      } :: e.minus-vars (e.minus-maxes),
1580        e.minus-vars : /*empty*/ =
1581        e.plus-vars () $iter {
1582          e.plus-vars : (VAR t.var-name) e.vars-rest =
1583            e.vars-rest (e.plus-mins <?? t.var-name Min>);
1584        } :: e.plus-vars (e.plus-mins),
1585        e.plus-vars : /*empty*/ =
1586        e.rest (e.mins ((INFIX "/"
1587          ((INFIX "-" (e.plus e.plus-mins) (e.minus e.minus-maxes))) (s.mult)
1588        )));
1589      e.rest (e.mins);
1590    };
1591  } :: e.ties (e.mins),
1592  e.ties : /*empty*/ =
1593  (<?? t.name Min>) e.mins :: e.mins,
1594  {
1595    e.mins : (e.min) = e.min;
1596    (MAX e.mins);
1597  };
1598
1599Cyclic-Max (VAR t.name) =
1600  <?? t.name Ties> () $iter {
1601    e.ties : (t (e.plus (e.plus-vars)) (e.minus (e.minus-vars)) s.mult) e.rest, {
1602      e.plus-vars () $iter \{
1603        e.plus-vars : (VAR t.var-name) e.vars-rest,
1604          e.vars-rest (e.plus-maxes <?? t.var-name Max>);
1605      } :: e.plus-vars (e.plus-maxes),
1606        e.plus-vars : /*empty*/ =
1607        e.minus-vars () $iter {
1608          e.minus-vars : (VAR t.var-name) e.vars-rest =
1609            e.vars-rest (e.minus-mins <?? t.var-name Min>);
1610        } :: e.minus-vars (e.minus-mins),
1611        e.minus-vars : /*empty*/ =
1612        e.rest (e.maxes ((INFIX "/"
1613          ((INFIX "-" (e.plus e.plus-maxes) (e.minus e.minus-mins))) (s.mult)
1614        )));
1615      e.rest (e.maxes);
1616    };
1617  } :: e.ties (e.maxes),
1618  e.ties : /*empty*/ =
1619  {
1620    (<?? t.name Max>) e.maxes;
1621    e.maxes;
1622  } :: e.maxes,
1623  {
1624    e.maxes : /*empty*/ = $fail;
1625    e.maxes : (e.max) = e.max;
1626    (MIN e.maxes);
1627  };
1628
1629
1630
1631
1632$const New-Clash-Tags = Unknown-length Ties Check-symbols Deref Compare;
1633
1634
1635Get-Source e.clashes =
1636  e.clashes : e1 (e.tags (e.Re) (s.dir e.Pe)) e2,
1637  \{
1638    /*
1639     * If source is an instantiated variable then go to the next clash.
1640     */
1641    e.Re : (VAR t.name),
1642      <?? t.name Instantiated> : True = $fail;
1643    /*
1644     * If in source there is unknown variable then we can't compute it, so
1645     * go to the next clash.
1646     */
1647    e.Re $iter e.Re : {               
1648      (VAR t.name) e.rest =           
1649        \{                   
1650          <?? t.name Instantiated> : True; 
1651          <?? t.name Left-compare> : v;   
1652        }, e.rest;               
1653      t e.rest = e.rest;             
1654    } :: e.Re,                   
1655      e.Re : /*empty*/;             
1656  } =
1657//  <WriteLN Get-Source (e.tags (e.Re) (s.dir e.Pe))>,
1658  {
1659    e.Re : /*empty*/ =
1660      <Store-Vars (EVAR ("empty" 0))> : t.empty,
1661      <Set-Var ("empty") (Instantiated) (True)>,
1662      () () (e.tags (t.empty) (s.dir e.Pe));
1663    e.Re : (VAR t.name) =
1664      (e.Re) () (e.tags (e.Re) (s.dir e.Pe));
1665    {
1666      e.tags : e Without-object-symbols e =
1667        /*empty*/ (e.tags (e.Re) (s.dir e.Pe));
1668      <Get-Static-Exprs e.Re> :: e.Re (e.Re-decls),
1669        <Get-Static-Exprs e.Pe> :: e.Pe (e.Pe-decls) =
1670        e.Re-decls e.Pe-decls (e.tags Without-object-symbols (e.Re) (s.dir e.Pe));
1671    } :: e.asserts (e.tags (e.Re) (s.dir e.Pe)), {
1672      e.Re : (VAR t.name) =
1673        () (e.asserts) (e.tags (e.Re) (s.dir e.Pe));
1674      <Compose-Expr e.Re> :: e.compose (e.not-inst) s.flat?,
1675        <Gener-Label "compose"> :: t.name,
1676        <Declare-Vars "Expr" (VAR t.name)> :: e.decl,
1677        <Instantiate-Vars (VAR t.name)>,
1678        {
1679          s.flat? : 0 = <Set-Var t.name (Flat) (True)>;;
1680        },
1681        <Set-Var t.name (Length) (<Length-of e.Re>)>,
1682        <Set-Var t.name (Format) (<Format-Exp e.Re>)> =
1683        (e.not-inst) (e.asserts e.decl (ASSIGN (VAR t.name) e.compose))
1684        (e.tags ((VAR t.name)) (s.dir e.Pe));
1685    };
1686  } :: (e.not-inst) (e.decl) t.clash,
1687  (Assert <Get-Subexprs e.not-inst> e.decl) (e1 t.clash e2);
1688
1689Compose-Expr e.Re =
1690  e.Re () () 0 $iter {
1691    e.Re : t.Rt e.rest, t.Rt : {
1692      s.ObjectSymbol =
1693        <PrintLN "Compose-Expr: can't deal with object symbols!">, $fail;
1694      (PAREN e.expr) =
1695        <Compose-Expr e.expr> :: e.expr (e.new-not-inst) s,
1696        (PAREN e.expr) (e.new-not-inst) 1;
1697      (VAR t.name) =
1698        {
1699          <?? t.name Instantiated> : True = /*empty*/;
1700          t.Rt;
1701        } :: e.new-not-inst,
1702        {
1703          <?? t.name Flat> : True = 0;
1704          1;
1705        } :: s.new-flat?,
1706        (Used t.Rt) t.Rt (e.new-not-inst) s.new-flat?;
1707      t = t.Rt () 0; // STUB!
1708    } :: e.new-compose (e.new-not-inst) s.new-flat? =
1709      e.rest (e.compose e.new-compose) (e.not-inst e.new-not-inst)
1710      <"+" s.flat? s.new-flat?>;
1711  } :: e.Re (e.compose) (e.not-inst) s.flat?,
1712  e.Re : /*empty*/ =
1713  e.compose (e.not-inst) s.flat?;
1714
1715Get-Subexprs e.vars =
1716//  <WriteLN Get-Subexprs e.vars>,
1717  e.vars () $iter {
1718    e.vars : (VAR t.name) e.rest,
1719      # \{ <?? t.name Instantiated> : True; },
1720      <?? t.name Left-compare> : (t.var s.dir (e.pos) (0) e.len) e =
1721      <Instantiate-Vars (VAR t.name)>,
1722      <Declare-Vars "Expr" (VAR t.name)> : e,
1723      {
1724        s.dir : Right =
1725          (INFIX "-" (<Length-of t.var>) (e.pos e.len));
1726        e.pos;
1727      } :: e.pos,
1728      e.rest (e.decls (Used t.var) (SUBEXPR (VAR t.name) t.var (e.pos) (e.len)));
1729    // STUB:
1730    e.vars : t e.rest = e.rest (e.decls);
1731  } :: e.vars (e.decls),
1732  e.vars : /*empty*/ =
1733  e.decls;
1734
1735Comp-Cyclic e.clashes =
1736  e.clashes : e1 (e.t1 Unknown-length e.t2 (e.Re) (s.dir e.Pe)) e2 =
1737  e.Re : (VAR (e.QualifiedName)),
1738  <Split-Hard-Left e.Pe> :: e.left-hard,
1739  <Split-Hard-Right e.Pe> :: e.right-hard,
1740  e.Pe : e.left-hard e.Cycle e.right-hard,
1741  {
1742    e.left-hard e.right-hard : /*empty*/ = /*empty*/ (e.QualifiedName) ();
1743    <Gener-Label "ref" e.QualifiedName> :: t.name,
1744      t.name : (e.CycleName),
1745      <Declare-Vars "Expr" (VAR t.name)> : e,
1746      <Instantiate-Vars (VAR t.name)>,
1747      <Set-Var t.name (Format) (<Format-Exp e.Cycle>)>,
1748      (INFIX "-" (<Length-of e.Re>) (<Length-of e.right-hard>)) :: e.len,
1749      (Used e.Re)
1750      (SUBEXPR (VAR t.name) e.Re (<Length-of e.left-hard>) (e.len)) :: e.decl,
1751      <Set-Var t.name (Left-compare)
1752        ((e.Re Left (<Length-of e.left-hard>) (0) <Length-of (VAR t.name)>))>,
1753      <Set-Var (e.QualifiedName) (Left-compare) ((
1754        (VAR t.name) Left (0) (<Length-of e.left-hard>) <Length-of (VAR t.name)>
1755      ))> =
1756      (e.t1 Checked-length e.t2 (e.Re) (s.dir e.left-hard (VAR t.name) e.right-hard))
1757      (e.CycleName) (e.decl);
1758  } :: e.old-clash (e.CycleName) (e.decl),
1759  (VAR (e.CycleName)) :: t.var,
1760  <Gener-Label L "For" "Break"> :: t.break-label,
1761  <Gener-Label L "For" "Cont"> :: t.cont-label,
1762  s.dir : {
1763    LEFT =
1764      e.Cycle : t.var-e1 e.rest,
1765      t.var-e1 : (VAR (e.SplitName)),
1766      {
1767//        e.rest : t.var-e2 = t.var-e2;
1768        (VAR <Gener-Label "lsplit" e.CycleName>);
1769      } :: t.var-e2,
1770      <Declare-Vars "Expr" t.var-e2> : e,
1771//!                     <Instantiate-Vars t.var-e1 t.var-e2>
1772      (Assert
1773        e.decl
1774        (LSPLIT t.var ((VAR ("min" e.SplitName))) t.var-e1 t.var-e2)
1775      )
1776      (Cond LABEL (t.break-label))
1777      (Cond FOR (t.cont-label) () ((INC-ITER t.var)))
1778      (Fail (BREAK t.break-label))
1779      (Clear-Restricted)
1780      (<Update-Ties t.var-e2 <Update-Ties t.var-e1 e1>>
1781        e.old-clash
1782        (<Gener-Label "clash"> &New-Clash-Tags (t.var-e2) (s.dir e.rest))
1783      <Update-Ties t.var-e2 <Update-Ties t.var-e1 e2>>)
1784      ((CONTINUE t.cont-label));
1785    RIGHT =
1786      e.Cycle : e.rest t.var-e2,
1787      t.var-e2 : (VAR (e.SplitName)),
1788      {
1789//        e.rest : t.var-e2 = t.var-e2;
1790        (VAR <Gener-Label "lsplit" e.CycleName>);
1791      } :: t.var-e1,
1792      <Declare-Vars "Expr" t.var-e1> : e,
1793      <Instantiate-Vars t.var-e1 t.var-e2>
1794      (Assert
1795        e.decl
1796        (RSPLIT t.var ((VAR ("min" e.SplitName))) t.var-e1 t.var-e2)
1797      )
1798      (Cond LABEL (t.break-label))
1799      (Cond FOR (t.cont-label) () ((INC-ITER t.var)))
1800      (Fail (BREAK t.break-label))
1801      (Clear-Restricted)
1802      (<Update-Ties t.var-e2 <Update-Ties t.var-e1 e1>>
1803        e.old-clash
1804        (<Gener-Label "clash"> &New-Clash-Tags (t.var-e1) (s.dir e.rest))
1805      <Update-Ties t.var-e2 <Update-Ties t.var-e1 e2>>)
1806      ((CONTINUE t.cont-label));
1807  };
1808
1809Split-Hard-Left e.expr =
1810  e.expr () $iter {
1811    e.expr : t.Pt e.rest, {
1812      <Hard-Exp? t.Pt> = e.rest (e.hard t.Pt);
1813      (e.hard);
1814    };
1815  } :: e.expr (e.hard),
1816  e.expr : /*empty*/ =
1817  e.hard;
1818
1819Split-Hard-Right e.expr =
1820  e.expr () $iter {
1821    e.expr : e.some t.Pt, {
1822      <Hard-Exp? t.Pt> = e.some (t.Pt e.hard);
1823      (e.hard);
1824    };
1825  } :: e.expr (e.hard),
1826  e.expr : /*empty*/ =
1827  e.hard;
1828
1829Gener-Label e.QualifiedName =
1830  {
1831    <Lookup &Labels e.QualifiedName> : s.num,
1832      <"+" s.num 1>;
1833    1;
1834  } :: s.num,
1835  <Bind &Labels (e.QualifiedName) (s.num)>,
1836  (e.QualifiedName s.num);
1837
1838Add-To-Label (e.label) e.name = <Gener-Label e.label "_" e.name>;
1839
1840Get-Static-Exprs e.Re =
1841  e.Re () () () $iter {
1842    e.Re : t.Rt e.rest, t.Rt : {
1843      s.ObjectSymbol, {
1844        <Char? t.Rt> =
1845          e.rest (e.new-Re) (e.decls) (e.expr t.Rt);
1846        <Get-Static-Var "chars" e.expr> :: e.expr-var (e.expr-decl),
1847          {
1848            <Int? t.Rt> = "int";
1849            <Word? t.Rt> = "word";
1850          } :: s.prefix,
1851          <Get-Static-Var s.prefix t.Rt> :: e.Rt-var (e.Rt-decl) =
1852          e.rest (e.new-Re e.expr-var e.Rt-var)
1853          (e.decls e.expr-decl e.Rt-decl) ();
1854      };
1855      (PAREN e.paren-Re) =
1856        <Get-Static-Exprs e.paren-Re> :: e.new-paren-Re (e.paren-decls),
1857        <Get-Static-Var "chars" e.expr> :: e.expr-var (e.expr-decl),
1858        e.rest (e.new-Re e.expr-var (PAREN e.new-paren-Re))
1859        (e.decls e.expr-decl e.paren-decls) ();
1860      t.var =
1861        <Get-Static-Var "chars" e.expr> :: e.expr-var (e.expr-decl),
1862        e.rest (e.new-Re e.expr-var t.var) (e.decls e.expr-decl) ();
1863    };
1864  } :: e.Re (e.new-Re) (e.decls) (e.expr),
1865//  <WriteLN Get-Static-Exprs e.Re>,
1866  e.Re : /*empty*/ =
1867  <Get-Static-Var "chars" e.expr> :: e.expr-var (e.expr-decl),
1868  e.new-Re e.expr-var (e.decls e.expr-decl);
1869
1870Get-Static-Var s.prefix e.expr, {
1871  e.expr : /*empty*/ = /*empty*/ ();
1872  {
1873    <Lookup &Static-Exprs s.prefix e.expr> : t.var = t.var ();
1874    ("const" s.prefix e.expr) :: t.name,
1875      <Bind &Static-Exprs (s.prefix e.expr) ((VAR t.name))>,
1876      <Declare-Vars "Expr" (VAR t.name)> : e,
1877      <Instantiate-Vars (VAR t.name)>,
1878      <Set-Var t.name (Flat) (True)>,
1879      <Length e.expr> :: s.len,
1880      <Set-Var t.name (Length) (s.len)>,
1881      <Set-Var t.name (Min) (s.len)>,
1882      <Set-Var t.name (Max) (s.len)>,
1883      <Set-Var t.name (Format) (e.expr)> =
1884      (VAR t.name) ((EXPR (VAR t.name) e.expr));
1885  };
1886};
1887
1888
1889
1890
1891Length-of {
1892  /*empty*/ = 0;
1893  e.Re =
1894    e.Re () $iter {
1895      e.Re : t.Rt e.rest, t.Rt : {
1896        s.ObjectSymbol = 1;     // Может появиться из константы.
1897        (PAREN e) = 1;
1898        (REF t.name) = ; //<Ref-Len t.name>;  STUB!!!
1899        (STATIC t.name) = <Length-of <Get-Static t.Rt>>;
1900        t, <Var? t.Rt>, {
1901          <Get-Var Length t.Rt> : v.len = v.len;
1902          (LENGTH t.Rt);
1903        };
1904      } :: e.new-len,
1905      e.rest (e.Length e.new-len);
1906    } :: e.Re (e.Length),
1907    e.Re : /*empty*/ =
1908    e.Length;
1909};
1910
1911
1912
1913/*
1914 * Ends good if lengths of all variables in the upper level of e.expr can be
1915 * calculated.
1916 */
1917Hard-Exp? e.expr =
1918  e.expr $iter {
1919    e.expr : t.first e.rest =
1920    {
1921      <Var? t.first>, {
1922        <Get-Var Instantiated? t.first> : True;
1923        <Get-Var Length t.first> : v;
1924        = $fail;
1925      };;
1926    },
1927      e.rest;
1928  } :: e.expr,
1929  e.expr : /*empty*/;
1930
1931/*
1932 * Returns those parts of e.expr which lengthes are known. Also returns a list
1933 * of variables with unknown lengthes.
1934 */
1935Unknown-Vars e.expr =
1936  e.expr () () $iter {
1937    e.expr : t.first e.rest, {
1938      t.first : (VAR t.name), {
1939        <?? t.name Instantiated> : True =
1940          e.new-expr t.first (e.unknown);
1941        <?? t.name Max> :: e.max, <?? t.name Min> : e.max =
1942          e.new-expr t.first (e.unknown);
1943        e.new-expr (e.unknown t.first);
1944      };
1945      e.new-expr t.first (e.unknown);
1946    } :: e.new-expr (e.unknown) =
1947      e.rest (e.new-expr) (e.unknown);
1948  } :: e.expr (e.new-expr) (e.unknown),
1949  e.expr : /*empty*/ =
1950  e.new-expr (e.unknown);
1951
1952
1953
1954Lookup-Func t.Fname, \{
1955  <Lookup &Fun t.Fname>;
1956  <Lookup &Fun? t.Fname>;
1957} : s.linkage s.tag t.pragma (e.Fin) (e.Fout) =
1958  s.linkage s.tag t.pragma (e.Fin) (e.Fout);
1959
Note: See TracBrowser for help on using the repository browser.