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

Last change on this file since 725 was 725, checked in by orlov, 18 years ago
  • Removed generation of empty condition terms.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 83.6 KB
Line 
1// $Source$
2// $Revision: 725 $
3// $Date: 2003-05-06 18:04:13 +0000 (Tue, 06 May 2003) $
4
5$use "rfpc";
6$use "rfp_err";
7$use "rfp_list";
8$use "rfp_helper";
9$use "rfp_check";
10$use "rfp_as2as";
11$use "rfp_format";
12$use "rfp_vars";
13$use "rfp_const";
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 * Tables for storing $const'ant values and their lengthes.
28 */
29$table Const-Len;
30
31/*
32 * Table for storing object names.
33 */
34$table Objects;
35
36/*
37 * Table for storing referenced functions.
38 */
39$table Ref-To-Funcs;
40
41/*
42 * Box for storing function out format
43 */
44$box Out-Format;
45
46/*
47 * Box for storing names for function result variables
48 */
49$box Res-Vars;
50
51/*
52 * Following table is used by Gener-Label function for obtaining unical (for
53 * certain function) label name.
54 * e.Key ::= e.QualifiedName      (parameter given to Gener-Label)
55 * e.Val ::= [Int]          (last index used with such e.QualifiedName)
56 */
57$table Labels;
58
59//$box Var-Stack;
60$table Vars-Tab;
61
62$box Last-Re;
63
64$box Greater-Ineqs;
65$box Less-Ineqs;
66
67$table Static-Exprs;
68
69$func Compile (e.targets) (e.headers) e.Items = e.Compiled-Items (INTERFACE e.headers);
70
71$func Print-Pragma s.channel t.Pragma = ;
72
73$func AS-To-Ref e.AS-Expr = e.Refal-Expr;
74
75$func Length-of e.Re = e.length;
76
77$func? Flat-Const? e.const = ;
78
79$func? Hard-Exp? e.expr = ;
80
81$func Comp-Func-Stubs = e.asail-funcs;
82
83$func Comp-Func s.tag t.name e.params-and-body = e.compiled-func;
84
85$func Set-Drops (e.declared-exprs) e.comp-func = (e.declared-exprs) e.result-func;
86
87$func Comp-Sentence e.Sentence = e.asail-sentence;
88
89$func Save-Snt-State = ;
90
91$func Recall-Snt-State = ;
92
93$func Pop-Snt-State = ;
94
95$func Extract-Calls e.Re = (e.last-Re) e.calls;
96
97$func Comp-Static-Exprs e.Reult-exprs = e.Result-exprs;
98
99$func Get-Clash-Sequence (e.last-Re) e.Snt = (e.clashes) e.rest-of-the-Sentence;
100
101$func Comp-Pattern t.Pattern e.Snt = e.asail-Snt;
102
103$func? Without-Calls? e.Re = ;
104
105//$func Old-Vars e.expr = e.expr;
106
107//$func Find-Known-Lengths e.clashes = (e.known-len-clashes) e.clashes;
108
109//$func? Known-Vars? e.vars = ;
110
111$func Comp-Clashes (e.clashes) s.tail? (v.fails) e.Sentence = e.asail-sentence;
112
113$func? Find-Var-Length e.clashes = e.cond (e.clashes);
114
115$func Update-Ties t.var e.clashes = e.clashes;
116
117$func Known-Length-of e.expr = e.known-length (e.unknown-vars);
118
119$func? Cyclic-Restrictions e.clashes = e.cond (e.clashes);
120
121$func Cyclic-Min t.var = e.min;
122
123$func? Cyclic-Max t.var = e.max;
124
125$func? Check-Symbols e.clashes = e.cond (e.clashes) s.new?;
126
127$func? Check-Ft t.Ft (e.pos) (e.right-pos) t.name s.dir = e.Ft-cond s.stop?;
128
129$func? Dereference-Subexpr e.clashes = e.cond (e.clashes);
130
131$func Compare-Subexpr e.clashes = e.cond (e.asserts) (e.clashes) s.new?;
132
133$func Compare-Ft t.Ft = e.Ft-cond s;
134
135$func? Get-Source e.clashes = e.cond (e.clashes);
136
137$func Compose-Expr e.expr = e.compose (e.not-instantiated-vars) s.flat?;
138
139$func? Comp-Cyclic e.clashes = e.cond (e.clashes) (e.fail);
140
141$func Get-Subexprs e.vars = e.asail-decls;
142
143$func Unknown-Vars e.expr = e.known-expr (e.unknown-vars);
144
145$func Split-Hard-Left e.expr = e.hard;
146
147$func Split-Hard-Right e.expr = e.hard;
148
149$func Gener-Label e.QualifiedName = t.label;
150
151$func Add-To-Label t.label e.name = t.label;
152
153$func Comp-Calls e.Re = e.calls;
154
155$func Comp-Assigns e.assignments = e.asail-assignments;
156
157$func Comp-Format (e.last-Re) e.He = e.assignments;
158
159$func Get-Static-Exprs e.expr = e.expr (e.decls);
160
161$func Get-Static-Var e.expr = e.var (e.decl);
162
163
164
165************ Get AS-Items and targets, and pass it to Compile ************
166
167/*
168 * Ящик для объявлений статических функций, констант и объектов.  Все они
169 * выписываются в самом начале тела модуля.
170 */
171$box Declarations;
172
173RFP-Compile e.Items =
174  { <Lookup &RFP-Options ITEMS>;; } :: e.targets,
175  <Store &Declarations /*empty*/>,
176  <Init-Consts>,
177  <Compile (e.targets) () e.Items> :: e.Items t.Interface,
178  t.Interface (MODULE <? &Declarations> <Comp-Consts> e.Items);
179
180
181
182****************** Choose needed items and compile them ******************
183
184Compile (e.targets) (e.headers) e.Items, {
185  e.Items : e t.item e.rest,
186    {
187      e.targets : v =
188        e.targets : e t.name e,
189        t.item : (t t t t.name e);;
190    },
191    t.item : {
192      (IMPORT e) = () /*empty*/;
193      (s.link s.tag t.pragma t.name (e.in) (e.out) e.body), FUNC FUNC? : e s.tag e =
194        {
195          s.link : EXPORT = (DECL-FUNC EXPORT t.name);
196          <Put &Declarations (DECL-FUNC LOCAL t.name)> = /*empty*/;
197        } :: e.decl,
198        {
199          e.body : (BRANCH t.p e.branch) =
200            <Comp-Func s.tag t.name <Del-Pragmas (e.in) (e.out) e.branch>>;;
201        } :: e.comp-func,
202        (e.decl) e.comp-func;
203      (s.link CONST t.pragma t.name e.expr) =
204        (CONSTEXPR s.link t.name (e.expr) e.expr) :: t.const,
205        {
206          s.link : EXPORT = (t.const) /*empty*/;
207          <Put &Declarations t.const> = () /*empty*/;
208        };
209      (EXPORT s.tag t.pragma t.name) = ((DECL-OBJ EXPORT s.tag t.name)) /*empty*/;
210      (LOCAL  s.tag t.pragma t.name) =
211        <Put &Declarations (DECL-OBJ LOCAL s.tag t.name)>,
212        () /*empty*/;
213    } :: (e.decl) e.item =
214    e.item <Compile (e.targets) (e.headers e.decl) e.rest>;
215  /*<Comp-Func-Stubs>*/ (INTERFACE e.headers);
216};
217
218/*
219 * For each referenced function generate a stub one with format e = e.
220 */
221Comp-Func-Stubs =
222  <Domain &Ref-To-Funcs> () $iter {
223    e.funcs : ((e.QualifiedName)) e.rest,
224      (e.QualifiedName 0) :: t.Fname,
225//      <Bind &Ref-To-Funcs ((e.QualifiedName)) (t.Fname)>,
226//      {
227//        <In-Table? &Fun? (e.QualifiedName)> =
228//          <Bind &Back-Funcs (t.Fname) ()>;;
229//      },
230//      <Bind &Fin (t.Fname) ((EVAR))>,
231//      <Bind &Fout (t.Fname) ((EVAR))>,
232      <Lookup-Func (e.QualifiedName)> :: s.linkage s.tag t.pragma (e.Fin) (e.Fout),
233      <Gener-Vars (e.Fin) "stub"> :: e.He,
234      <Comp-Func s.tag t.Fname ((EVAR ("arg" 1))) ((EVAR ("res" 1)))
235        (LEFT e.He) (RESULT (CALL (e.QualifiedName) e.He))
236      > :: e.asail,
237      e.rest (e.asail-funcs e.asail);
238  } :: e.funcs (e.asail-funcs),
239  e.funcs : /*empty*/ =
240  // Here is place to define expressions - references to stub functions.
241  // Use &Ref-To-Funcs for that.
242  e.asail-funcs;
243
244Comp-Func s.tag t.name (e.in) (e.out) e.Sentence =
245  <RFP-Clear-Table &Labels>,
246  <RFP-Clear-Table &Static-Exprs>,
247  <Store &Greater-Ineqs /*empty*/>,
248  <Store &Less-Ineqs /*empty*/>,
249//!     <RFP-Clear-Table &Vars-Tab>,
250  <Init-Vars>,
251//!     <Ref-To-Var e.Sentence> :: e.Sentence,
252//!     <Store-Vars <Vars e.out>> :: e.res-vars,
253  <Vars <Gener-Vars (e.out) "res">> :: e.res-vars,
254  <Vars-Decl e.res-vars> : e,
255  <Store &Res-Vars e.res-vars>,
256  <Store &Out-Format <Format-Exp e.out>>,
257//!     <Norm-Vars (<Vars e.in>) e.Sentence> :: (e.arg-vars) e.Sentence,
258//!     <Declare-Vars Expr e.arg-vars> : e,
259  <Vars <Gener-Vars (e.in) "arg">> :: e.arg-vars,
260  <Vars-Decl e.arg-vars> : e,
261*       <Instantiate-Vars e.arg-vars>,
262  <Store &Last-Re /*empty*/>,
263  s.tag : {
264    FUNC = FATAL;
265    FUNC? = RETFAIL;
266  } :: t.retfail,
267  (FUNC t.name (<Vars-Print e.arg-vars>) (<Vars-Print e.res-vars>)
268    <Comp-Sentence Tail ((t.retfail)) () e.Sentence>
269  ) :: e.comp-func,
270*       <Set-Drops () <Gener-Var-Names e.comp-func>> :: t e.comp-func,
271  <Gener-Var-Names e.comp-func> :: e.comp-func,
272//!     <Post-Comp (e.res-vars) e.comp-func> :: t e.result,
273//!     e.result;
274  e.comp-func;
275//  :: (e.func-decl) e.func-body,
276//  () <Domain &Declarations> $iter {
277//    e.vars : (t.var) e.rest-vars,
278//      (e.var-decls (DECL t.var)) e.rest-vars;
279//  } :: (e.var-decls) e.vars,
280//  e.vars : /*empty*/,
281//  (e.func-decl e.var-decls e.func-body);
282
283Ref-To-Var e.Snt =
284  () e.Snt $iter {
285    e.Snt : t.Statement e.rest, t.Statement : {
286      (REF t.name) = (e.new-Snt /*<New-Vars (VAR REF t.name)>*/) e.rest;
287
288//!                     <Table> :: s.tab,
289//!                     <Bind &Vars-Tab (t.name) (s.tab)>,
290//!                     <Set-Var t.name (Format) (<Format-Exp (REF t.name)>)>,
291//!                     <Set-Var t.name (Declared) (True)>,
292//!                     <Set-Var t.name (Instantiated) (True)>,
293//!                     <Set-Var t.name (Left-compare) ()>,
294//!                     <Set-Var t.name (Right-compare) ()>,
295//!                     <Set-Var t.name (Left-checks) ()>,
296//!                     <Set-Var t.name (Right-checks) ()>,
297//!                     (e.new-Snt (VAR t.name)) e.rest;
298
299      (e.expr) = (e.new-Snt (<Ref-To-Var e.expr>)) e.rest;
300      t = (e.new-Snt t.Statement) e.rest;
301    };
302  } :: (e.new-Snt) e.Snt,
303  e.Snt : /*empty*/ =
304  e.new-Snt;
305
306Set-Drops (e.declared) e.comp-func =
307  e.comp-func () (e.declared) $iter {
308    e.comp-func : t.first e.rest, {
309      t.first : \{
310        (EXPR t.var e) = (DROP t.var) (t.first) t.var Init;
311        (DEREF t.var e) = (DROP t.var) (t.first) t.var Init;
312        (SUBEXPR t.var e) = (DROP t.var) (t.first) t.var Init;
313        (DECL Expr t.var) = (DROP t.var) () t.var Decl;
314        (DECL "int" t.var) = /*empty*/ () t.var Decl;
315      } :: e.drop (e.constr) t.var s.init,
316        {
317          e.declared : e1 t.var s.old-init e2, s.old-init : {
318            Init, {
319              t.var : (VAR ("const" e)) =
320                e.rest (e.result-func) (e.declared);
321              e.rest (e.result-func e.drop e.constr) (e.declared);
322            };
323            Decl, s.init : {
324              Decl =
325                e.rest (e.result-func) (e.declared);
326              Init =
327                t.first : (s.method t.var e.args),
328                e.rest (e.result-func (ASSIGN t.var (s.method e.args)))
329                (e1 e2 t.var s.init);
330                /*
331                 * FIXME: if s.method is EXPR, it shouldn't be written.
332                 */
333            };
334          };
335          e.rest (e.result-func t.first) (e.declared t.var s.init);
336        };
337      t.first : (LABEL (t.label) e.expr) =
338        <Set-Drops (e.declared) e.expr> :: (e.declared) e.expr,
339        e.rest (e.result-func (LABEL (t.label) e.expr)) (e.declared);
340      t.first : (e.expr) =
341        <Set-Drops (e.declared) e.expr> :: t e.expr,
342        e.rest (e.result-func (e.expr)) (e.declared);
343      t.first : s.symbol =
344        e.rest (e.result-func s.symbol) (e.declared);
345    };
346  } :: e.comp-func (e.result-func) (e.declared),
347  e.comp-func : /*empty*/ =
348  (e.declared) e.result-func;
349
350
351Comp-Sentence s.tail? (v.fails) (e.last-Re) e.Sentence, e.Sentence : {
352
353  /*empty*/ = /*empty*/;
354
355  /*
356   * In case of Re look if we should do a tailcall.  If not, then compile
357   * function calls from the Re and assign results to the out parameters or
358   * use them in compilation of the rest of the sentence.
359   */
360  (RESULT e.Re) e.Snt =
361    {
362      /*
363       * If the Re is the last action in the sentence then we can do
364       * tailcall if one of the following is true:
365       *  - Re is a call of non-failable function;
366       *  - Re is a call of a failable function, current function is
367       *  failable, and the failures stack is empty.
368       * In both cases out format of the called function should coincide
369       * with those of compiled one.
370       * FIXME: really we can do tailcall if all the parameters of
371       * compiled function that won't get their values from the call can
372       * be assigned from other sources.  Some support from runtime is
373       * needed though.
374       */
375      e.Snt : /*empty*/, s.tail? : Tail, e.Re : (CALL t.name e.arg),
376        { <In-Table? &Fun? t.name> = v.fails : (RETFAIL);; },
377        <Lookup-Func t.name> :: s.linkage s.tag t.pragma (e.Fin) (e.Fout),
378        <Subformat? (e.Fout) (<? &Out-Format>)> =
379        <Extract-Calls e.arg> :: (e.last-Re) e.calls,
380        <Comp-Static-Exprs <Split-Re (e.Fin) e.last-Re>> :: e.splited-Re,
381        <Comp-Calls <R 0 v.fails> e.calls>
382        (TAILCALL t.name (e.splited-Re) (<? &Res-Vars>));
383
384      <Extract-Calls e.Re> :: (e.last-Re) e.calls,
385        <Comp-Calls <R 0 v.fails> e.calls> :: e.comp-calls,
386        {
387          e.Snt : /*empty*/, s.tail? : Tail =
388            <Split-Re (<? &Out-Format>) e.last-Re> :: e.splited-Re,
389            <Comp-Static-Exprs e.splited-Re> :: e.splited-Re,
390            e.comp-calls <Comp-Assigns <Zip (<? &Res-Vars>) (e.splited-Re)>>;
391
392          e.comp-calls <Comp-Sentence s.tail? (v.fails) (e.last-Re) e.Snt>;
393        };
394    };
395
396  /*
397   * In case of He compile assignments from last Re and then (with new state
398   * of variables) proceed with the rest of the sentence.
399   */
400  (FORMAT e.He) e.Snt =
401    <Comp-Format (e.last-Re) e.He>
402    <Comp-Sentence s.tail? (v.fails) () e.Snt>;
403
404  /*
405   * In case of Pe get from the begining of the sentence a maximum possible
406   * sequence of clashes and compile it.  New values of variables from the
407   * clashes use in the compilation of the rest of the sentence.
408   */
409  (s.dir e.Pattern) e.Snt, s.dir : \{ LEFT; RIGHT; } =
410    <Get-Clash-Sequence (e.last-Re) e.Sentence> :: (e.clashes) e.Sentence,
411//    <WriteLN !!! e.clashes>,
412    <Comp-Clashes (e.clashes) s.tail? (v.fails) e.Sentence>;
413
414  (s.block) e, BLOCK BLOCK? : e s.block e = <WriteLN! &StdErr "Empty block?">, $fail;
415
416  /*
417   * In case of a block first see if its results are needed for something
418   * after the block and determine whether the block is a source.  Then
419   * compile each branch in turn.
420   */
421  (s.block e.branches) e.Snt,
422    s.block : \{
423      BLOCK = (FATAL);
424      BLOCK?;
425    } :: e.fatal? =
426    /*
427     * If the block initializes an $iter then extract from the $iter the He
428     * for placing it in the end of each branch.
429     * Then look if the block is used by a pattern or format expression.
430     * If so, we should declare variables from that expression before
431     * entering any branch -- those should be visible after the block.
432     * If next after the block is (Comp Error) then block results should be
433     * used as values for $error, so place (Comp Error) in the end of each
434     * branch.
435     */
436    {
437      e.Snt : (ITER t.body t.format t.cond) e.rest =
438        t.format (Comp Iter t.body t.format t.cond) e.rest;
439      e.Snt;
440    } :: e.Snt,
441    e.Snt : {
442      t.first e.rest, t.first : \{
443        (LEFT e.pattern) = e.pattern;
444        (RIGHT e.pattern) = e.pattern;
445        (FORMAT e.format) = e.format;
446      } :: e.expr =
447        <Vars e.expr> :: e.vars,
448*                               <New-Vars e.vars>,
449        (<Vars-Decl e.vars>) (t.first) ((Comp Source)) e.rest;
450      (Comp Error) e.rest =
451        () ((Comp Error)) () /*empty*/;
452      e = () () () e.Snt;
453    } :: (e.decls) (e.next-term) (e.source?) e.Snt,
454    /*
455     * The block is a source if after it goes pattern or format expression
456     * (in that case e.source? isn't empty) or e.Snt isn't empty.
457     * Branches in the block are tail sentences if the current sentence is
458     * tail and the block isn't a source.
459     */
460    {
461      \{ e.source? : v; e.Snt : v; } = ((Comp Source)) Notail;
462      s.tail? : Tail = () Tail;
463      () Notail;
464    } :: (e.source?) s.tail-branch?,
465    /*
466     * In case our block is a source we should mark the position in the
467     * failures stack, so that we can jump to it after CUTALL.  And if our
468     * block isn't failable we should add (FATAL) to the end of the stack.
469     */
470    v.fails e.source? e.fatal? :: v.branch-fails,
471    /*
472     * We put all compiled branches in a block, so positive return from a
473     * branch is a break from that block.
474     * Each branch in its turn is placed in its own block, so for a $fail
475     * to the next branch we should just break from that inner block.
476     * Each branch is compiled with the current sentence state and the
477     * state is recalled after that.  When all branches are compiled the
478     * state is popped out from the stack.
479     * If last branch fails then the whole block fails, and return from the
480     * last branch is return from the block.  So the last branch isn't
481     * placed in a block and is processed with the failures stack that was
482     * before entering the block.  Note: this trick helps us find more
483     * tailcalls.  If the call of a failable function is on the last branch
484     * of the block and the failures stack is empty we can do tailcall.
485     * When the last branch is compiled with the block's stack, all we
486     * should do is to check it.
487     */
488    <Gener-Label "block"> :: t.label,
489    <Save-Snt-State>,
490    (e.branches) /*e.comp-branches*/ $iter {
491      e.branches : (BRANCH e.branch) e.rest-br =
492        <Add-To-Label t.label "branch"> :: t.br-label,
493        <Comp-Sentence
494          s.tail-branch?
495          (v.branch-fails ((BREAK t.br-label)))
496          (e.last-Re)
497          e.branch e.next-term
498        > :: e.comp-br,
499        <Recall-Snt-State>,
500        (e.rest-br) e.comp-branches (LABEL (t.br-label) e.comp-br (BREAK t.label));
501    } :: (e.branches) e.comp-branches,
502    e.branches : (BRANCH e.branch) =
503    <Comp-Sentence
504      s.tail-branch? (v.branch-fails) (e.last-Re) e.branch e.next-term
505    > :: e.last-branch,
506    <Pop-Snt-State>,
507    e.decls (LABEL (t.label) e.comp-branches e.last-branch)
508    <Comp-Sentence s.tail? (v.fails) () e.Snt>;
509
510  /*
511   * In case of $iter first of all compile initial assignment to the hard
512   * expression.
513   */
514  (ITER t.body t.format t.cond) e.Snt =
515    <Comp-Sentence s.tail? (v.fails) (e.last-Re)
516      t.format (Comp Iter t.body t.format t.cond) e.Snt
517    >;
518
519  /*
520   * Then compile $iter condition and body both with the current state of the
521   * sentence.
522   * e.Snt can contain only (Comp Error), so compile it together with the
523   * condition.
524   * If condition fails we should compute the body, so put the compiled
525   * condition in a block and place a break from it to the failures stack.
526   */
527  (Comp Iter (BRANCH e.body) t.format (BRANCH e.condition)) e.Snt =
528    <Gener-Label "iter"> :: t.label,
529    <Save-Snt-State>,
530    <Comp-Sentence s.tail? (v.fails ((BREAK t.label))) () e.condition e.Snt>
531      :: e.comp-condition,
532    <Pop-Snt-State>,
533    <Comp-Sentence Notail (v.fails) () e.body t.format> :: e.comp-body,
534    (FOR () () () (LABEL (t.label) e.comp-condition) e.comp-body);
535
536  /*
537   * In case of $trap/$with at first compile try-sentence.  All $fails from
538   * it should become errors.
539   * Then recall the state of the sentence and compile catching of an error
540   * with a variable err.
541   * e.Snt can be only (Comp Error), so compile it together with both
542   * sentences -- when either of it comuptes to an object expression it
543   * becomes a value of the $error.
544   */
545  (TRY (BRANCH e.try) e.catch) e.Snt =
546    <Save-Snt-State>,
547    <Comp-Sentence Notail ((FATAL)) () e.try e.Snt> :: e.comp-try,
548    <Pop-Snt-State>,
549    <Comp-Sentence s.tail? (v.fails) () (RESULT (EVAR ("err" 0))) e.catch e.Snt>
550      :: e.comp-catch,
551    (TRY e.comp-try) (CATCH-ERROR e.comp-catch);
552
553  /*
554   * In case of \? add Stake to the failures stack.  Add last fail after it
555   * for <R 0 v.fails> continue to work.
556   */
557  (STAKE) e.Snt =
558    <Comp-Sentence s.tail? (v.fails (Comp Stake) <R 0 v.fails>) () e.Snt>;
559
560  /*
561   * In case of \! forget all failure catchers after last \?.
562   * If there is no Stake then we are inside negation or error (we assume the
563   * program is correct).  So the right failure catcher is in the bottom of
564   * the stack.
565   */
566  (CUT) e.Snt =
567    {
568      v.fails : $r v.earlier-fails (Comp Stake) e = v.earlier-fails;
569      <L 0 v.fails>;
570    } :: v.fails,
571    <Comp-Sentence s.tail? (v.fails) () e.Snt>;
572
573  /*
574   * In case of = clear the failures stack up to the closest source.
575   */
576  (CUTALL) e.Snt =
577    {
578      v.fails : $r v.earlier-fails (Comp Source) e = v.earlier-fails;
579      <L 0 v.fails>;
580    } :: v.fails,
581    <Comp-Sentence s.tail? (v.fails) () e.Snt>;
582
583  /*
584   * In case of = in the Refal-6 sense (non-transparent hedge for the fails),
585   * $fail(k) should become $error(Fname "Unexpected fail"), so clear the
586   * failures stack and put that value in it.
587   */
588  NOFAIL e.Snt =
589    <Comp-Sentence s.tail? ((FATAL)) (e.last-Re) e.Snt>;
590
591  /*
592   * In case of $fail return last failure catcher.
593   */
594  (FAIL) e.Snt =
595    v.fails : e (e.last-fail),
596    e.last-fail;
597
598  /*
599   * In case of # we should proceed with the rest if the source is computed
600   * to $fail.
601   * We could compile the rest of the sentence and place it in the
602   * failures stack.  But then the compiled sentence would be copied as many
603   * times as there are $fail's to the upper level in the source.  So we
604   * place compiled source in the block and put the break to exit from it in
605   * the stack.
606   * When compiling the source mark it as Notail as usual.
607   * If the source isn't computed to $fail we should proceed with the last
608   * failure catcher.
609   */
610  (NOT (BRANCH e.branch)) e.Snt =
611    <Gener-Label "negation"> :: t.label,
612    v.fails : e (e.last-fail),
613//    <Save-Snt-State>,
614    <Comp-Sentence Notail (((BREAK t.label))) () e.branch> e.last-fail
615      :: e.comp-negation,
616//    <Pop-Snt-State>,
617    (LABEL (t.label) e.comp-negation)   <Comp-Sentence s.tail? (v.fails) () e.Snt>;
618
619//  (Comp Verbatim expr) = expr;
620
621  /*
622   * In case of $error all fails become $error(Fname "Unexpected fail").  So
623   * place that value in the failures stack and then compile the computation
624   * of the rest of the sentence and the last Re which should be the value of
625   * $error.
626   */
627  (ERROR) e.Snt =
628    <Comp-Sentence Notail ((FATAL)) e.Snt () (Comp Error)>;
629
630  (Comp Error) e.Snt = (ERROR e.last-Re);
631
632//  (Comp Fatal) = FATAL;
633
634//  (Comp Retfail) = RETFAIL;
635
636};
637
638
639
640********** Sentence state stack and functions for work with it. **********
641
642$box Snt-State;
643
644/*
645 * Put current state in the stack.
646 */
647Save-Snt-State = <Put &Snt-State <Vars-Copy-State>>;
648
649/*
650 * Set current state to that at the top of the stack.
651 */
652Recall-Snt-State = <Vars-Set-State <R 0 <? &Snt-State>>>;
653
654/*
655 * Pop the top from the stack and set current state to it.
656 */
657Pop-Snt-State =
658  <Recall-Snt-State>,
659  <Store &Snt-State <Middle 0 1 <? &Snt-State>>>;
660
661
662
663********************** Function calls compilation. ***********************
664
665/*
666 * $func Extract-Calls e.Re = (e.last-Re) e.calls;
667 *
668 *
669 *
670 */
671Extract-Calls {
672  (CALL t.name e.arg) e.rest =
673    <Lookup-Func t.name> :: s.linkage s.tag t.pragma (e.Fin) (e.Fout),
674    <Extract-Calls e.arg> :: (e.last-Re) e.calls,
675    <Comp-Static-Exprs <Split-Re (e.Fin) e.last-Re>> :: e.splited-Re,
676    <RFP-Extract-Qualifiers t.name> :: t e.prefix,
677*               <Del-Pragmas <Gener-Vars 0 (e.Fout) e.prefix>> : e.Re s,
678//!             <Store-Vars <Vars e.res-Re>> :: e.ress,
679//!             <Instantiate-Vars e.ress>,
680//!             <Ref-To-Var <Strip-STVE e.res-Re>> :: e.res-Re,
681//!             e.decls <Declare-Vars "Expr" e.ress> :: e.decls,
682    <Gener-Vars (e.Fout) e.prefix> :: /*(e.vars)*/ e.Re,
683    <Vars e.Re> :: e.vars,
684*               <Instantiate-Vars e.vars>,
685    {
686      s.tag : FUNC? =   (Failable (CALL t.name (e.splited-Re) (e.vars)));
687      (CALL t.name (e.splited-Re) (e.vars));
688    } :: t.call,
689    <Extract-Calls e.rest> :: (e.rest-Re) e.rest-calls,
690    (e.Re e.rest-Re) e.calls <Vars-Decl e.vars> t.call e.rest-calls;
691  (PAREN e.Re) e.rest =
692    <Extract-Calls e.Re> :: (e.last-Re) e.calls,
693    <Extract-Calls e.rest> :: (e.rest-Re) e.rest-calls,
694    ((PAREN e.last-Re) e.rest-Re) e.calls e.rest-calls;
695  t.Rt e.Re =
696    <Extract-Calls e.Re> :: (e.last-Re) e.calls,
697    (t.Rt e.last-Re) e.calls;
698  /*empty*/ = () /*empty*/;
699};
700
701
702Comp-Calls (e.fail) e.calls, e.calls : {
703  (Failable t.call) e.rest =
704    (IF ((NOT t.call)) e.fail) <Comp-Calls (e.fail) e.rest>;
705  t.call e.rest =
706    t.call <Comp-Calls (e.fail) e.rest>;
707  /*empty*/ = /*empty*/;
708};
709
710
711
712*********** Compilation of static parts of result expressions ************
713
714$func Static-Expr? s.create? e.Re = static? e.Re;
715
716$func Static-Term? t.Rt = static? t.Rt;
717
718
719/*
720 * Extract static parts from each Re.
721 */
722Comp-Static-Exprs {
723  (e.Re) e.rest = <Static-Expr? Create e.Re> :: s e.Re, (e.Re) <Comp-Static-Exprs e.rest>;
724  /*empty*/     = /*empty*/;
725};
726
727
728/*
729 * Find all the longest static parts in the upper level of Re.  Create STATIC
730 * form in place of each one.
731 * Return a tag pointing whether the whole expression is static and expression
732 * with static parts replaced by STATIC forms.  Dynamic parts are returned
733 * unchanged.
734 */
735Static-Expr? {
736  s.create? t.Rt e.Re =
737    <Static-Term? t.Rt> : {
738      Static t.Rt =
739        {
740          e.Re : e1 t2 e3, <Static-Term? t2> : Dynamic t.dyn-Rt =
741            <Static-Expr? Create e.Re> :: s e.Re,
742            Dynamic <Create-Static t.Rt e1> t.dyn-Rt e.Re;
743          {
744            s.create? : Create = Static <Create-Static t.Rt e.Re>;
745            Static t.Rt e.Re;
746          };
747        };
748      Dynamic t.dyn-Rt =
749        <Static-Expr? Create e.Re> :: s e.Re,
750        Dynamic t.dyn-Rt e.Re;
751    };
752  s.create? /*empty*/ = Static;
753};
754
755
756/*
757 * The same as Static-Expr? but for terms.
758 */
759Static-Term? {
760  symbol       = Static symbol;
761  (PAREN e.Re) = <Static-Expr? Not-Create e.Re> :: static? e.Re, static? (PAREN e.Re);
762  (REF t.name) = Static (REF t.name);
763  t.var        = Dynamic t.var;
764};
765
766
767
768***************** Compilation of assignment to variables *****************
769
770$func Comp-Assign-to-Var e = e;
771
772Comp-Assign-to-Var (t.var (e.Re)), {
773  t.var : e.Re = /*empty*/;
774  <Generated-Var? e.Re> = <Gener-Var-Assign t.var e.Re>;
775  <Get-Var Decl t.var> : s = (ASSIGN <Vars-Print t.var> e.Re);
776  <Vars-Decl t.var> : e, (EXPR <Vars-Print t.var> e.Re);
777};
778
779Comp-Assigns e.assigns = <Map &Comp-Assign-to-Var (e.assigns)>;
780
781
782
783************************** FORMAT compilation. ***************************
784
785$box Aux-Index;
786
787$func Gener-Aux-Var = t.new-aux-var;
788
789Gener-Aux-Var =
790  <? &Aux-Index> : s.n,
791  <Store &Aux-Index <"+" s.n 1>>,
792  (VAR ("aux" s.n));
793
794
795$func Create-Aux-Vars (e.vars) e.splited-Re = e.assigns;
796
797
798Comp-Format (e.last-Re) e.He =
799  <Vars e.He> :: e.vars,
800  <Comp-Static-Exprs <Split-Re (<Format-Exp e.He>) e.last-Re>> :: e.splited-Re,
801  <Store &Aux-Index 1>,
802  <Create-Aux-Vars (e.vars) e.splited-Re> :: e.assigns,
803  <Comp-Assigns e.assigns>;
804
805/*
806 * Итак, e.vars -- все переменные, входящие в форматное выражение.  Каждая
807 * переменная может входить в форматное выражение только один раз, поэтому
808 * повторяющихся среди них нет.
809 * e.splited-Re -- набор результатных выражений.  На каждую переменную из
810 * e.vars по выражению, которое должно быть ей присвоено.
811 *
812 * Если переменная t.var_i используется в выражении e.Re_j, и i /= j, то
813 * переменной t.var_j значение должно быть присвоено раньше, чем перeменной
814 * t.var_i.  Если же, по аналогичным соображениям, t.var_i должна получить
815 * значение раньше t.var_j, необходимо завести вспомогательную переменную.
816 *
817 * Пример:
818 *
819 * t1 (t1 t2) (t1 t3) :: t2 t1 t3
820 *
821 * t3 = (t1 + t3)();
822 * aux_1 = t1;
823 * t1 = (t1 + t2)()
824 * t2 = aux_1;
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 *     такой метод и не даст наименьшего кол-ва вспомогательных переменных.
851 *     Кроме того, мы не пытаемся выбрать наилучшую переменную из нескольких с
852 *     максимальным списком зависимостей.
853 *
854 *   - Повторяем всё это до тех пор, пока у каждой переменной не опустеет
855 *     список зависящих от неё.
856 *
857 *
858 * Для нашего примера:
859 *
860 * t1 (t1 t2) (t1 t3) :: t2 t1 t3
861 *
862 * t1 -- (t2 t3) (t2)
863 * t2 -- (t1)    (t1)
864 * t3 -- ()      (t1)
865 *
866 *
867 * Для каждой переменной var_i найдём все j /= i, такие что в Re_j встречается
868 * var_i -- provide[i], и а также все j /= i, такие что var_j нужна для
869 * подсчёта var_i, т.е. встречается в Re_i.
870 *
871 * Res-vars <- <Map &Vars (Res)>
872 * for var_i in vars
873 *     provide[i] <-
874 *     for vars-Re_j in Res-vars, j /= i
875 *         vars-Re_j : e var_i e = j
876 *     require[i] <- <Res-vars[i] `*` vars[^i]> : e var_j e, j
877 *
878 * Res-vars = map Vars Res
879 * provide, require =
880 *   {   [ j | vars-Re_j <- Res-vars, j /= i, var_i `in` vars-Re_j ]
881 *     , [ j | var_j <- Res-vars[i] `*` vars, i /= j]
882 *     | var_i <- vars
883 *   }
884 *
885 */
886
887$func CAV e.vars (e.assigns) (e.delayed) = e.assigns;
888
889$func Get-Vars e = e;
890Get-Vars (e.Re) = (<Vars e.Re>);
891
892Create-Aux-Vars (e.vars) e.splited-Re =
893  <Zip (<Map &Get-Vars (e.splited-Re)>) (e.vars)> :: e.list,
894  <Box> :: s.box,
895  <Box> :: s.provide-i,
896  <Box> :: s.require-i,
897  {
898    e.vars : e1 t.var-i e2,
899      {
900        e.list : e ((e.vars-Re) t.var-j) e,
901          \{
902            t.var-i : t.var-j = <Put s.require-i <And (e1 e2) e.vars-Re>>;
903            e.vars-Re : e t.var-i e = <Put s.provide-i t.var-j>;
904          },
905          $fail;
906        <L <Length e1> e.splited-Re> :: t.Re-i,
907        <Put s.box (t.var-i t.Re-i (<? s.provide-i>) (<? s.require-i>))>,
908          <Store s.provide-i /*empty*/>,
909          <Store s.require-i /*empty*/>;
910      },
911      $fail;;
912  },
913  <CAV <? s.box> (/*assigns*/) (/*delayed*/)>;
914
915
916/*
917 * Если есть переменная, у которой список provide пуст, её можно посчитать.
918 * Это выражается в том, что она (вместе с присваиваемым значением) добавляется
919 * в список assigns, убирается из списка vars, а также из всех списков provide
920 * и delayed.  В списках require её не было.
921 *
922 * CAV Res vars provide require assigns delayed =
923 *   { i | var_i <- vars, provide_i == [] } ->     // Здесь неверно!  На переменные
924 *                                                    из delayed тоже надо смотреть.
925 *       vars    = vars - var_i
926 *       provide = [ provide_j - i | provide_j <- provide ]
927 *       assigns = assigns++[(var_i, Res[i])]
928 *       delayed = [ (var_j, provide_j - i) | (var_j, provide_j) <- delayed ]
929 *       CAV Res vars provide require assigns delayed
930 */
931
932$func Assign-Empty-Provides e.vars  = e.assigns (e.vars);
933
934Assign-Empty-Provides {
935  e1 (t.var-i t.Re-i (/*empty provide_i*/) (e.require-i)) e2 =
936    <Box> :: s.vars,
937    {
938      e1 e2 : e (t.var-j t.Re-j (e.provide-j) (e.require-j)) e,
939        <Put s.vars (t.var-j t.Re-j (<Sub (e.provide-j) t.var-i>) (e.require-j))>,
940        $fail;;
941    },
942    (t.var-i t.Re-i) <Assign-Empty-Provides <? s.vars>>;
943  e.vars = /*empty*/ (e.vars);
944};
945
946
947/*
948 * Если есть переменная, у которой список require пуст, кладём её в delayed.
949 * Она будет посчитана, когда у неё опустеет список provide, т.е. когда не
950 * останется переменных, у которых она в списке require.
951 */
952$func Delay-Empty-Requires e.vars  = e.delayed (e.vars);
953
954Delay-Empty-Requires {
955  e1 t.var e2, t.var : (t.var-i t.Re-i (e.provide-i) (/*empty require_i*/)) =
956    <Delay-Empty-Requires e2> :: e.delayed (e.vars),
957    t.var e.delayed (e1 e.vars);
958  e.vars = /*empty*/ (e.vars);
959};
960
961
962/*
963 * Выбор переменной (из двух) с более длинным списком требуемых ей значений.
964 */
965$func Max-Require e = e;
966
967Max-Require t.arg1 t.arg2 =
968  t.arg1 : (t.var1 t.Re1 t.provide1 (e.require1)),
969  t.arg2 : (t.var2 t.Re2 t.provide2 (e.require2)),
970  {
971    <"<" (<Length e.require1>) (<Length e.require2>)> = t.arg2;
972    t.arg1;
973  };
974
975
976/*
977 * Подставить вспомогательную переменную вместо исходной во всех результатных выражениях.
978 * Присваивание к исходной переменной убрать (оно к этому моменту уже выполнено).
979 * Убрать переменную из списков зависимостей.
980 */
981$func Subst-Aux-Var e = e;
982
983Subst-Aux-Var t.var t.aux (t.v t.Re (e.provide) (e.require)), {
984  t.var : t.v = /*empty*/;
985  (
986    t.v
987    <Subst (t.var) ((t.aux)) t.Re>
988    (<Sub (e.provide) t.var>)
989    (<Sub (e.require) t.var>)
990  );
991};
992
993
994/*
995 * Извлечь присваивание из всей информации о переменной.
996 */
997$func Extract-Assigns e = e;
998Extract-Assigns (t.var t.Re e) = (t.var t.Re);
999
1000
1001/*
1002 * Основной цикл обработки присваиваний.
1003 *
1004 * 1) Из всех переменных (в том числе и отложенных), от которых больше ничего
1005 *    не зависит, сделать присваивания.
1006 * 2) Все переменные, которые больше ни от чего не зависят, отложить.
1007 * 3) Если осталось хотя бы две неотложенных переменных, выбирать из них ту,
1008 *    которая зависит от наибольшего числа переменных, подставить везде вместо
1009 *    неё вспомогательную, перейти к пункту 1.
1010 */
1011CAV e.vars (e.assigns) (e.delayed) =
1012  <Assign-Empty-Provides e.vars> :: e.new-assigns (e.vars),
1013  e.assigns e.new-assigns <Assign-Empty-Provides e.delayed> :: e.assigns (e.delayed),
1014  e.delayed <Delay-Empty-Requires e.vars> :: e.delayed (e.vars),
1015  {
1016    e.vars : t t e =
1017      <Foldr1 &Max-Require (e.vars)> : (t.var t.Re e),
1018      <Gener-Aux-Var> :: t.aux,
1019      e.assigns (t.aux (t.var)) (t.var t.Re) :: e.assigns,
1020      <Map &Subst-Aux-Var t.var t.aux (e.vars)> :: e.vars,
1021      <Map &Subst-Aux-Var t.var t.aux (e.delayed)> :: e.delayed,
1022      <CAV e.vars (e.assigns) (e.delayed)>;
1023    e.assigns <Map &Extract-Assigns (e.vars e.delayed)>;
1024  };
1025
1026
1027
1028
1029Get-Clash-Sequence (e.last-Re) t.Pattern e.Snt =
1030  ((e.last-Re) t.Pattern) e.Snt $iter {
1031    e.Snt : (RESULT e.Re) t.Pt e.rest =
1032      (e.clashes (e.Re) t.Pt) e.rest;
1033  } :: (e.clashes) e.Snt,
1034  # \{
1035    e.Snt : \{
1036      (RESULT e.Re) (LEFT e) e = e.Re;
1037      (RESULT e.Re) (RIGHT e) e = e.Re;
1038    } :: e.Re,
1039      <Without-Calls? e.Re>;
1040  } =
1041  (e.clashes) e.Snt;
1042
1043
1044Comp-Pattern (s.dir e.PatternExp) e.Sentence =
1045  <Norm-Vars (<Vars e.PatternExp>) (s.dir e.PatternExp) e.Sentence>
1046    : t t.Pattern e.Snt,
1047//  (Unwatched (<? &Last-Re>) t.Pattern) e.Snt $iter {
1048  /*
1049   * Uncomment previous line and delete next one to activate Split-Clashes
1050   * function
1051   */
1052  ((<? &Last-Re>) t.Pattern) e.Snt $iter {
1053    e.Snt : (RESULT e.Re) (s.d e.Pe) e =
1054//      <WriteLN Matching (RESULT e.Re) (s.d e.Pe)>,
1055      <Norm-Vars (<Vars e.Pe>) e.Snt> : t t.R t.P e.rest,
1056//      (e.clashes Unwatched (e.Re) t.P) e.rest;
1057      /*
1058       * Uncomment previous line and delete next one to activate
1059       * Split-Clashes function
1060       */
1061      (e.clashes (e.Re) t.P) e.rest;
1062  } :: (e.clashes) e.Snt,
1063  # \{
1064    e.Snt : \{
1065      (RESULT e.Re) (LEFT e) e = e.Re;
1066      (RESULT e.Re) (RIGHT e) e = e.Re;
1067    } :: e.Re,
1068      <Without-Calls? e.Re>;
1069  } =
1070  e.Snt : e.Current-Snt (Comp Sentence) e.Other-Snts =
1071  <Comp-Sentence () e.Other-Snts> :: e.asail-Others,
1072  {
1073//    <Split-Clashes (e.clashes) e.Current-Snt>
1074//    :: (e.greater) (e.less) (e.hards) (e.clashes) e.Current-Snt =
1075//      <WriteLN "Hards: " e.hards>,
1076//      <WriteLN "Less: " e.less>,
1077//      <WriteLN "Greater: " e.greater>,
1078//      <WriteLN "Current-Snt: " e.Current-Snt>,
1079//!                     <Comp-Clashes (e.clashes)
1080//!                             (e.Current-Snt (Comp Sentence)) e.Other-Snts> :: e.asail-Clashes,
1081//      e.asail-Clashes (e.greater) $iter {
1082//        e.greater : (e.vars s.num) e.rest,
1083//          <Old-Vars e.vars> :: e.vars,  // temporary step
1084//          (IF ((INFIX ">=" ((LENGTH e.vars)) (s.num)))
1085//            e.asail-Clashes
1086//          ) (e.rest);
1087//      } :: e.asail-Clashes (e.greater),
1088//      e.greater : /*empty*/ =
1089//      e.asail-Clashes (e.less) $iter {
1090//        e.less : (e.vars s.num) e.rest,
1091//          <Old-Vars e.vars> :: e.vars,  // temporary step
1092//          (IF ((INFIX "<=" ((LENGTH e.vars)) (s.num)))
1093//            e.asail-Clashes
1094//          ) (e.rest);
1095//      } :: e.asail-Clashes (e.less),
1096//      e.less : /*empty*/ =
1097//      e.asail-Clashes (e.hards) $iter {
1098//        e.hards : (e.Re) (e.Pe) e.rest,
1099//          <Old-Vars e.Re> :: e.Re,    // temporary step
1100//          <Old-Vars e.Pe> :: e.Pe,    // temporary step
1101//          (IF ((INFIX "==" (e.Re) (e.Pe))) e.asail-Clashes) (e.rest);
1102//      } :: e.asail-Clashes (e.hards),
1103//      e.hards : /*empty*/ =
1104//!                     e.asail-Clashes e.asail-Others;
1105    e.asail-Others;
1106//    <Comp-Sentence () e.Other-Snts>;
1107  };
1108
1109Without-Calls? e.Re =
1110  e.Re $iter {
1111    e.Re : t.Rt e.rest =
1112      t.Rt : {
1113        (CALL e) = $fail;
1114        (BLOCK e) = $fail;
1115        (PAREN e.Re1) = <Without-Calls? e.Re1>;
1116        t.symbol-or-var = /*empty*/;
1117      },
1118      e.rest;
1119  } :: e.Re,
1120  e.Re : /*empty*/;
1121
1122//Comp-Clashes (e.clashes) (e.Current-Snt) e.Other-Snts =
1123//  <WriteLN Clashes e.clashes>,
1124////  /*
1125////   * Collect in e.vars all varibles from all clashes.
1126////   */
1127////  () e.clashes $iter {
1128////    e.not-watched : (e.expr) e.rest = (e.vars <Vars e.expr>) e.rest;
1129////  } :: (e.vars) e.not-watched,
1130////  e.not-watched : /*empty*/ =
1131////  /*
1132////   * Rename all collected variables in all clashes. Never mind multiple
1133////   * occurences.
1134////   */
1135////  (e.clashes) e.vars $iter {
1136////    e.vars : (s.var-tag s.m (e.n) e.var-id) e.rest, {
1137////      <Known-Vars? (s.var-tag e.var-id)> =
1138////        e.var-id : e.NEW (e.QualifiedName),
1139////        <Subst ((s.var-tag s.m (e.n) e.var-id))
1140////          (((s.var-tag (s.var-tag NEW ("len" e.QualifiedName))
1141////          s.m (e.n) e.var-id))) e.clashes>;
1142////      s.m : e.n =
1143////        <Subst ((s.var-tag s.m (e.n) e.var-id))
1144////          (((s.var-tag (s.m) s.m (e.n) e.var-id))) e.clashes>;
1145////    } :: e.clashes,
1146////    (e.clashes) e.rest;
1147////  } :: (e.clashes) e.vars,
1148////  e.vars : /*empty*/ =
1149////  /*
1150////   * Now all variables with known length have ref. term after s.var-tag.
1151////   * Well, lets see if there are closed variables and compute their lengthes
1152////   * too.
1153////   */
1154////  e.clashes (e.clashes) () $iter {
1155////    e.not-watched : (e.Re) (s.dir e.Pe) e.rest, {
1156////      <Find-Closed-Var e.Pe> :: t.old-var t.new-var e.new-cond,
1157////        <Subst (t.old-var) ((t.new-var)) e.clashes> :: e.clashes,
1158////        e.clashes (e.clashes) (e.cond e.new-cond);
1159////      e.rest (e.clashes) (e.cond);
1160////    };
1161////  } :: e.not-watched (e.clashes) (e.cond),
1162////  e.not-watched : /*empty*/ =
1163//
1164//  /*
1165//   * Parenthesize each clash, so from now on they can be seen as a sequence
1166//   * of such terms: (e.temp-tags (e.Re) t.P)
1167//   */
1168//  e.clashes () $iter {
1169//    e.old-clashes : t.R t.P e.rest =
1170//      e.rest (e.clashes (t.R t.P));
1171//  } :: e.old-clashes e.clashes,
1172//  e.old-clashes : /*empty*/ =
1173// 
1174//  <Find-Known-Lengths e.clashes> :: (e.known-len-clashes) e.clashes,
1175//  {
1176//    e.known-len-clashes : /*empty*/ =
1177//      <Find-Symbol-Checks e.clashes> :: (e.sym-check-clashes) e.clashes,
1178//      {
1179//        e.sym-check-clashes : /*empty*/ =
1180//          e.clashes : {
1181//            (e.Re) (s.dir e.Pe) e.rest =
1182//              <Gener-Label L> :: t.label,
1183//              <Comp-Clashes (e.rest) (e.Current-Snt)
1184//                (Comp Continue t.label) e.Other-Snts>
1185//              :: e.asail-Snt,
1186//              (FOR t.label () () ()
1187//                e.asail-Snt
1188//              )
1189//              <Comp-Sentence () e.Other-Snts>;
1190//            /*empty*/ =
1191//              <Comp-Sentence () e.Current-Snt e.Other-Snts>;
1192//          };
1193//        <Comp-Clashes (e.clashes) (e.Current-Snt) e.Other-Snts> :: e.asail-Snt,
1194//          (e.sym-check-clashes) e.asail-Snt $iter {
1195//            e.sym-check-clashes : e.something (e (e.Re) (s.dir e.Pe)),
1196//             
1197//    <Comp-Clashes (e.clashes) (e.Current-Snt) e.Other-Snts> :: e.asail-Snt,
1198//      (e.known-len-clashes) e.asail-Snt $iter {
1199//        e.known-len-clashes : e.something (e.tags (e.Re) (s.dir e.Pe)),
1200//          (e.something)
1201//          (IF ((INFIX "==" (<Length-of e.Re>) (<Length-of e.Pe>)))
1202//            e.asail-Snt
1203//          );
1204//      } :: (e.known-len-clashes) e.asail-Snt,
1205//      e.known-len-clashes : /*empty*/ =
1206//      e.asail-Snt
1207//      <Comp-Sentence () e.Other-Snts>;
1208//  };
1209//
1210//Find-Known-Lengths e.clashes =
1211//  e.clashes () () $iter {
1212//    e.old-clashes : t.first e.rest, t.first : {
1213//      (e1 Known-length e2) =
1214//        e.rest (e.known) (e.clashes t.first);
1215//      (e.tags (e.Re) (s.dir e.Pe)) =
1216////        Known <Vars e.Re> <Vars e.Pe> $iter {
1217////          e.vars : (VAR t.name) e.rest-vars, {
1218////            <?? t.name Length> : e = Known;
1219////            <?? t.name Instantiated> : True = Known;
1220////            Unknown;
1221////          } :: s.known? =
1222////            s.known? e.rest-vars;
1223////        } :: s.known? e.vars,
1224////        \{
1225////          s.known? : Unknown =
1226////            e.rest (e.known) (e.clashes t.first);
1227////          e.vars : /*empty*/ =
1228////            e.rest (e.known t.first)
1229////            (e.clashes (e.tags Known-length (e.Re) (s.dir e.Pe)));
1230////        };
1231//        {
1232//          <Hard-Exp? <Vars e.Re> <Vars e.Pe>> =
1233//            e.rest (e.known t.first)
1234//            (e.clashes (e.tags Known-length (e.Re) (s.dir e.Pe)));
1235//          e.rest (e.known) (e.clashes t.first);
1236//        };
1237//    };
1238//  } :: e.old-clashes (e.known) (e.clashes),
1239//  e.old-clashes : /*empty*/ =
1240//  (e.known) e.clashes;
1241//
1242//Known-Vars? e.vars =
1243//  <? &Var-Stack> :: e.known-vars,
1244//  e.vars $iter {
1245//    e.vars : t.var e.rest =
1246//      e.known-vars : e t.var e,
1247//      e.rest;
1248//  } :: e.vars,
1249//  e.vars : /*empty*/;
1250
1251$func CC (e.clashes) s.tail? (v.fails) e.Snt = e.asail-Snt;
1252
1253$const New-Clash-Tags = Unknown-length Ties Check-symbols Dereference Compare;
1254
1255Comp-Clashes (e.clashes) s.tail? (v.fails) e.Sentence =
1256//  <WriteLN Clashes e.clashes>,
1257  /*
1258   * Parenthesize each clash, so from now on they can be seen as a sequence
1259   * of such terms: (e.temp-tags (e.Re) t.P)
1260   */
1261  e.clashes () $iter {
1262    e.old-clashes : (e.Re) (s.dir e.Pe) e.rest =
1263      <Comp-Static-Exprs (e.Re) (e.Pe)> : (e.R1) (e.P1),
1264      <Map &Ref-Set-Var (<Vars e.R1 e.P1>)> : e,
1265      e.rest (e.clashes (<Gener-Label "clash"> &New-Clash-Tags (e.R1) (s.dir e.P1)));
1266  } :: e.old-clashes (e.clashes),
1267  e.old-clashes : /*empty*/ =
1268  <CC (e.clashes) s.tail? (v.fails) e.Sentence>;
1269
1270$func Get-Known-Length e.expr = e.length-of-known-part (e.unknown-vars);
1271
1272$func Compare-Subexprs (e.fail) e.clashes = e.cond;
1273
1274$func Assign-Value e = e;
1275
1276CC (e.clashes) s.tail? (e.prev-fails (e.fail)) e.Snt, {
1277  e.clashes : e1 (e.t1 Unknown-length e.t2 (e.Re) (s.dir e.Pe)) e2,
1278    <Get-Known-Length e.Re> :: e.len-Re (e.vars-Re),
1279    <Get-Known-Length e.Pe> :: e.len-Pe (e.vars-Pe),
1280    \{
1281      /*
1282       * Если длины всех переменных на верхних уровнях e.Re и e.Pe
1283       * известны, то надо просто выписать условие на равенство длин
1284       * выражения и образца.
1285       */
1286      e.vars-Re : /*empty*/, e.vars-Pe : /*empty*/ =
1287        (IF ((INFIX "!=" (e.len-Re) (e.len-Pe))) e.fail)
1288        <CC (e1 (e.t1 Checked-length e.t2 (e.Re) (s.dir e.Pe)) e2)
1289          s.tail? (e.prev-fails (e.fail)) e.Snt>;
1290      /*
1291       * Если неизвестная переменная во всём клэше ровно одна, и она
1292       * входит в левую и правую части разное кол-во раз, то её длину
1293       * можно вычислить.
1294       */
1295      <"-" <Length e.vars-Re> <Length e.vars-Pe>> :: s.diff,
1296        <"/=" (s.diff) (0)>,
1297        <Nub e.vars-Re e.vars-Pe> : t.var =
1298        {
1299          <"<" (s.diff) (0)> =
1300            <"*" s.diff -1> (INFIX "-" (e.len-Re) (e.len-Pe));
1301          s.diff (INFIX "-" (e.len-Pe) (e.len-Re));
1302        } :: s.mult e.diff,
1303        <Create-Int-Var ("len_") t.var e.diff> :: t.len-var e.len-assign,
1304        <Set-Var (Length (INFIX "/" (t.var) (s.mult))) t.len-var>,
1305        {
1306          <Get-Var Max t.var> : v.max =
1307            ((INFIX ">" (t.len-var) ((INFIX "*" (s.mult) (v.max)))));
1308          /*empty*/;
1309        } :: e.max-cond,
1310        <Get-Var Min t.var> : {
1311          0 = /*empty*/;
1312          e.min = ((INFIX "<" (t.len-var) ((INFIX "*" (s.mult) (e.min)))));
1313        } :: e.min-cond,
1314        e.len-assign
1315        (IF ((INFIX "||"
1316            e.max-cond e.min-cond ((INFIX "%" (t.len-var) (s.mult)))
1317          ))
1318          e.fail)
1319        <CC (e1 (e.t1 Checked-length e.t2 (e.Re) (s.dir e.Pe)) e2)
1320          s.tail? (e.prev-fails (e.fail)) e.Snt>;
1321    };
1322
1323  /*
1324   * If previous doesn't work then compare recursively all known
1325   * subexpressions and all unknown repeated subexpressions with
1326   * corresponding parts of source.
1327   */
1328  <Compare-Subexprs (e.fail) e.clashes> :: e.cond,
1329    e.clashes (/*e.assigns*/) $iter {
1330      e.clashes : (e (e.Re) (s.dir e.Pe)) e.rest =
1331        e.rest (e.assigns <Map &Assign-Value (<Vars e.Pe>)>);
1332    } :: e.clashes (e.assigns),
1333    e.clashes : /*empty*/ =
1334    e.cond e.assigns <Comp-Sentence s.tail? (e.prev-fails (e.fail)) () e.Snt>;
1335};
1336
1337Assign-Value t.var =
1338  {
1339    <Get-Var Value t.var> : (expr) (e.pos) (e.len) =
1340      (SUBEXPR t.var expr (e.pos) (e.len));
1341    /*empty*/;
1342  };
1343
1344
1345
1346*       /*e.cond*/ (/*!e.clashes!*/) (/*e.fail*/) $iter {
1347*               /*
1348*                * First of all see if we have a clash with all variables of known length
1349*                * and without length conditions written out.
1350*                */
1351*               e.clashes : e1 (e.t1 Known-length e.t2 (e.Re) (s.dir e.Pe)) e2,
1352*                       <Hard-Exp? e.Re e.Pe> =
1353*                       e.cond
1354*                       (Cond IF ((INFIX "==" (<Length-of e.Re>) (<Length-of e.Pe>))))
1355*                       (e1 (e.t1 Checked-length e.t2 (e.Re) (s.dir e.Pe)) e2) (e.fail);
1356*               /*
1357*                * Next see if we can compute length of some variable.
1358*                */
1359*               e.cond <Find-Var-Length e.clashes> (e.fail);
1360*               /*
1361*                * Write out restrictions for the cyclic variables.
1362*                */
1363*               e.cond <Cyclic-Restrictions e.clashes> (e.fail);
1364* //            <Cyclic-Restrictions e.clashes> :: e.new-cond (e.clashes),
1365* //                    {
1366* //                            e.fail : v = e.cond e.new-cond (Clear-Restricted) (e.clashes) (e.fail);
1367* //                            e.cond e.new-cond (e.clashes) (e.fail);
1368* //                    };
1369*               /*
1370*                * After checking all possible lengthes at the upper level change
1371*                * <<current_label_if_fail>>.
1372*                */
1373*               e.fail : v =
1374*                       (Contin e.fail) e.cond (Fail e.fail) (Clear-Restricted) (e.clashes) ();
1375*               /*
1376*                * For all clashes with known left part check unwatched terms whether they
1377*                * are symbols or reference terms or not any.
1378*                */
1379*               \?
1380*               {
1381*                       <Check-Symbols e.clashes> : {
1382*                               v.new-cond (e.new-clashes) s =
1383*                                       e.cond (Cond IF (v.new-cond)) (e.new-clashes) ();
1384*                               (e.new-clashes) New = e.cond (e.new-clashes) ();
1385*                               e \! $fail;
1386*                       };
1387*                       <PrintLN "Check-Symbols: don't know what to do... ;-)">, $fail;
1388*               };
1389*               /*
1390*                * And then try to compose new clash by dereferencing a part of some one.
1391*                */
1392*               e.cond <Dereference-Subexpr e.clashes> ();
1393*               /*
1394*                * If previous doesn't work then compare recursively all known
1395*                * subexpressions and all unknown repeated subexpressions with
1396*                * corresponding parts of source.
1397*                */
1398*               <Compare-Subexpr e.clashes> :: e.new-cond (e.asserts) (e.new-clashes) s.new?,
1399*                       \{
1400*                               e.new-cond : v, {
1401*                                       e.asserts : v =
1402*                                               e.cond (Assert e.asserts) (Cond IF (e.new-cond)) (e.new-clashes) ();
1403*                                       e.cond (Cond IF (e.new-cond)) (e.new-clashes) ();
1404*                               };
1405*                               e.asserts : v = e.cond (Assert e.asserts) (e.new-clashes) ();
1406*                               s.new? : New = e.cond (e.new-clashes) ();
1407*                       };
1408*               /*
1409*                * Then get first uncatenated source and bring it to the normal
1410*                * form, i.e. concatenate and parenthesize until it became single
1411*                * known expression.
1412*                */
1413*               e.cond <Get-Source e.clashes> ();
1414*               /*
1415*                * Now it's time to deal with cycles.
1416*                */
1417*               e.cond <Comp-Cyclic e.clashes>;
1418*               /*
1419*                * At last initialize all new subexpressions from all clashes.
1420*                */
1421*               e.clashes () $iter {
1422*                       e.clashes : (e t.Re (s.dir e.Pe)) e.rest,
1423*                               e.rest (e.new-cond <Get-Subexprs <Vars e.Pe>>);
1424*               } :: e.clashes (e.new-cond),
1425*                       e.clashes : /*empty*/ =
1426*                       {
1427*                               e.new-cond : /*empty*/ = e.cond () ();
1428*                               e.cond (Assert e.new-cond) () ();
1429*                       };
1430*       } :: e.cond (e.clashes) (e.fail),
1431* //    <WriteLN CC-Clashes e.clashes>,
1432* //    <WriteLN CC-Cond e.cond>,
1433*       e.clashes : /*empty*/ =
1434*
1435*       e.cond () 0 $iter {
1436*               e.cond : (Contin (CONTINUE t.label)) e.rest =
1437*                       e.rest (e.contin (Comp Continue t.label)) 0;
1438*               e.cond (e.contin) 1;
1439*       } :: e.cond (e.contin) s.stop?,
1440*       s.stop? : 1 =
1441* //!   <Comp-Sentence () e.Current-Snt e.contin e.Other-Snts> :: e.asail-Snt,
1442*       <Comp-Sentence s.tail? (v.fails) () e.Sentence> :: e.asail-Snt,
1443*       e.cond (e.asail-Snt) () $iter {
1444*               e.cond : e.some (e.last),
1445*                       e.last : {
1446*                               Cond e.condition =
1447*                                       e.some ((e.condition e.asail-Snt)) (e.vars);
1448*                               Assert e.assertion =
1449*                                       e.some (e.assertion e.asail-Snt) (e.vars);
1450*                               Fail e.fail1 =
1451*                                       e.some (e.asail-Snt e.fail1) (e.vars);
1452*                               Restricted t.var =
1453*                                       e.some (e.asail-Snt) (e.vars t.var);
1454*                               If-not-restricted t.var e.restr-cond, {
1455*                                       e.vars : e t.var e = e.some (e.asail-Snt) (e.vars);
1456*                                       e.some e.restr-cond (e.asail-Snt) (e.vars);
1457*                               };
1458*                               Clear-Restricted = e.some (e.asail-Snt) ();
1459*                       };
1460*       } :: e.cond (e.asail-Snt) (e.vars),
1461*       e.cond : /*empty*/ =
1462*       e.asail-Snt/* <Comp-Sentence () e.Other-Snts>*/;
1463
1464
1465Find-Var-Length (e.fail) e.clashes =
1466//  <WriteLN Find-Var-Length e.clashes>,
1467  e.clashes : e1 (e.t1 Unknown-length e.t2 (e.Re) (s.dir e.Pe)) e2 \?
1468  <Unknown-Vars e.Pe> :: e.new-Pe (e.Pe-unknown),
1469  <Unknown-Vars e.Re> :: e.new-Re (e.Re-unknown),
1470//  <Write Unknown>, <Write (e.Re-unknown)>, <WriteLN (e.Pe-unknown)>,
1471  e.Re-unknown e.Pe-unknown : {
1472    /*empty*/ =
1473      (e1 (e.t1 Known-length e.t2 (e.Re) (s.dir e.Pe)) e2);
1474    (VAR t.name) e.rest,
1475      e.rest $iter \{
1476        e.unknown : (VAR t.name) e.rest1 = e.rest1;
1477      } :: e.unknown,
1478      e.unknown : /*empty*/,
1479      <"-" <Length e.Re-unknown> <Length e.Pe-unknown>> : {
1480        0 \! $fail;
1481        s.diff, {
1482          <"<" (s.diff) (0)> =
1483            <"*" s.diff -1>
1484            (INFIX "-" (<Length-of e.new-Re>) (<Length-of e.new-Pe>));
1485          <">" (s.diff) (0)> =
1486            s.diff
1487            (INFIX "-" (<Length-of e.new-Pe>) (<Length-of e.new-Re>));
1488        } :: s.mult e.diff,
1489          t.name : (e.QualifiedName),
1490          (VAR ("len" e.QualifiedName)) :: t.len-var,
1491          {
1492            <?? t.name Max> :: e.max =
1493              (INFIX "<="
1494                (t.len-var)
1495                ((INFIX "*" (s.mult) (e.max)))
1496              );
1497            /*empty*/;
1498          } :: e.cond,
1499          e.cond
1500          (INFIX ">="
1501            (t.len-var)
1502            ((INFIX "*" (s.mult) (<?? t.name Min>)))
1503          )
1504          (NOT (INFIX "%"
1505            (t.len-var)
1506            (s.mult)
1507          )) :: e.cond,
1508          <Set-Var t.name (Max) (//(LENGTH (VAR t.name))
1509            (INFIX "/" (t.len-var) (s.mult))
1510          )>,
1511          <Set-Var t.name (Min) (<?? t.name Max>)>,
1512          <Set-Var t.name (Length) (<?? t.name Max>)>,
1513//          <WriteLN Unknown-Num s.mult> =
1514          (Restricted (VAR t.name))
1515          (Assert
1516            <Declare-Vars "int" t.len-var>
1517            (ASSIGN t.len-var e.diff)
1518          )
1519          (Cond IF (e.cond))
1520          (<Update-Ties (VAR t.name) e1>
1521            (e.t1 Checked-length e.t2 (e.Re) (s.dir e.Pe))
1522          <Update-Ties (VAR t.name) e2>);
1523      };
1524    e.unknown \!
1525      e.t1 Unknown-length e.t2 : e.t3 Ties e.t4 =
1526      e.t1 : t.id e,
1527      e.unknown () $iter {
1528        e.unknown : (VAR t.name) e.rest, {
1529          e.tied : e (VAR t.name) e = e.rest (e.tied);
1530          <Entries (VAR t.name) (e.Re)> :: s.Re-ent e.new-Re,
1531            <Entries (VAR t.name) (e.Pe)> :: s.Pe-ent e.new-Pe,
1532            <"-" s.Re-ent s.Pe-ent> :: s.diff,
1533            {
1534              s.diff : 0 = e.rest (e.tied (VAR t.name));
1535              {
1536                <"<" (s.diff) (0)> =
1537                  <"*" s.diff -1> (e.new-Re) (e.new-Pe);
1538                s.diff (e.new-Pe) (e.new-Re);
1539              } :: s.diff (e.plus) (e.minus),
1540                (
1541                  t.id
1542                  (<Known-Length-of e.plus>)
1543                  (<Known-Length-of e.minus>)
1544                  s.diff
1545                ) :: t.tie,
1546                {
1547                  <?? t.name Ties> : {
1548                    e.c1 (t.id e) e.c2 = e.c1 e.c2;
1549                    e.ties = e.ties;
1550                  };
1551                  /*empty*/;
1552                } :: e.ties,
1553                {
1554                  e.ties : e t.tie e;
1555                  <Set-Var t.name (Ties) (e.ties t.tie)>;
1556                },
1557                e.rest (e.tied (VAR t.name));
1558            };
1559        };
1560      } :: e.unknown (e.tied),
1561      e.unknown : /*empty*/ =
1562      {
1563        e.t3 e.t4 : e Cyclic e = e.t3 e.t4;
1564        e.t3 e.t4 Cyclic;
1565      } :: e.tags,
1566      (e1 (e.tags (e.Re) (s.dir e.Pe)) e2);
1567  };
1568
1569Known-Length-of e.expr =
1570  <Unknown-Vars e.expr> :: e.expr (e.vars),
1571  <Length-of e.expr> (e.vars);
1572
1573Update-Ties t.var e.clashes =
1574  e.clashes () $iter {
1575    e.clashes : t.clash e.rest,
1576      t.clash : (e.tags (e.Re) (s.dir e.Pe)),
1577      {
1578        e.tags : e Ties e = e.rest (e.new-clashes t.clash);
1579        e.Re e.Pe : e t.var e =
1580          e.rest (e.new-clashes (e.tags Ties (e.Re) (s.dir e.Pe)));
1581        e.rest (e.new-clashes t.clash);
1582      };
1583  } :: e.clashes (e.new-clashes),
1584  e.clashes : /*empty*/ =
1585  e.new-clashes;
1586
1587Cyclic-Restrictions e.clashes =
1588  e.clashes : e1 (e.t1 Cyclic e.t2 (e.Re) (s.dir e.Pe)) e2 =
1589  <Unknown-Vars e.Re e.Pe> :: e (e.unknown),
1590  e.unknown () $iter {
1591    e.unknown : t.var e.rest,
1592      t.var : (VAR (e.QualifiedName)),
1593      (VAR ("min" e.QualifiedName)) :: t.min-var,
1594      <Cyclic-Min t.var> :: e.min,
1595      {
1596        <Cyclic-Max t.var> :: e.max =
1597          e.rest (e.cond (Restricted t.var) (If-not-restricted t.var
1598            (Assert
1599              <Declare-Vars "int" t.min-var> (ASSIGN t.min-var e.min)
1600            )
1601            (Cond IF ((INFIX "<=" (t.min-var) (e.max))))
1602        ));
1603        e.rest (e.cond);
1604      };
1605  } :: e.unknown (e.cond),
1606  e.unknown : /*empty*/ =
1607  e.cond (e1 (e.t1 e.t2 (e.Re) (s.dir e.Pe)) e2);
1608
1609Cyclic-Min (VAR t.name) =
1610  <?? t.name Ties> () $iter {
1611    e.ties : (t (e.plus (e.plus-vars)) (e.minus (e.minus-vars)) s.mult) e.rest, {
1612      e.minus-vars () $iter \{
1613        e.minus-vars : t.var e.vars-rest,
1614          e.vars-rest (e.minus-maxes <Cyclic-Max t.var>);
1615      } :: e.minus-vars (e.minus-maxes),
1616        e.minus-vars : /*empty*/ =
1617        e.plus-vars () $iter {
1618          e.plus-vars : (VAR t.var-name) e.vars-rest =
1619            e.vars-rest (e.plus-mins <?? t.var-name Min>);
1620        } :: e.plus-vars (e.plus-mins),
1621        e.plus-vars : /*empty*/ =
1622        e.rest (e.mins ((INFIX "/"
1623          ((INFIX "-" (e.plus e.plus-mins) (e.minus e.minus-maxes))) (s.mult)
1624        )));
1625      e.rest (e.mins);
1626    };
1627  } :: e.ties (e.mins),
1628  e.ties : /*empty*/ =
1629  (<?? t.name Min>) e.mins :: e.mins,
1630  {
1631    e.mins : (e.min) = e.min;
1632    (MAX e.mins);
1633  };
1634
1635Cyclic-Max (VAR t.name) =
1636  <?? t.name Ties> () $iter {
1637    e.ties : (t (e.plus (e.plus-vars)) (e.minus (e.minus-vars)) s.mult) e.rest, {
1638      e.plus-vars () $iter \{
1639        e.plus-vars : (VAR t.var-name) e.vars-rest,
1640          e.vars-rest (e.plus-maxes <?? t.var-name Max>);
1641      } :: e.plus-vars (e.plus-maxes),
1642        e.plus-vars : /*empty*/ =
1643        e.minus-vars () $iter {
1644          e.minus-vars : (VAR t.var-name) e.vars-rest =
1645            e.vars-rest (e.minus-mins <?? t.var-name Min>);
1646        } :: e.minus-vars (e.minus-mins),
1647        e.minus-vars : /*empty*/ =
1648        e.rest (e.maxes ((INFIX "/"
1649          ((INFIX "-" (e.plus e.plus-maxes) (e.minus e.minus-mins))) (s.mult)
1650        )));
1651      e.rest (e.maxes);
1652    };
1653  } :: e.ties (e.maxes),
1654  e.ties : /*empty*/ =
1655  {
1656    (<?? t.name Max>) e.maxes;
1657    e.maxes;
1658  } :: e.maxes,
1659  {
1660    e.maxes : /*empty*/ = $fail;
1661    e.maxes : (e.max) = e.max;
1662    (MIN e.maxes);
1663  };
1664
1665Check-Symbols e.clashes =
1666  e.clashes () () Old $iter {
1667    e.clashes : t.clash e.rest, {
1668      t.clash : (e.t1 Check-symbols e.t2 (e.Re) (s.dir e.Pe)),
1669        e.Re : (VAR t.name),
1670        <?? t.name Instantiated> : True =
1671//        <Format e.Pe> () () Continue $iter {
1672        e.Pe () () Continue $iter {
1673          e.format : t.Ft e.Fe =
1674            <Length-of e.left> :: e.pos,
1675            <Check-Ft t.Ft (e.pos) (1 <Length-of e.Fe>) t.name Left-checks> : {
1676              /*empty*/ s.stop??? = /*empty*/ s.stop???;
1677              Sym s.stop??? =
1678                (Used e.Re) (SYMBOL? e.Re (e.pos)) s.stop???;
1679              Ref s.stop??? =
1680                (Used e.Re) (NOT (SYMBOL? e.Re (e.pos))) s.stop???;
1681              Flat e.len s.stop??? =
1682                (Used e.Re) (FLAT-SUBEXPR? e.Re (e.pos) (e.len)) s.stop???;
1683            } :: e.Ft-cond s.stop? =
1684            e.Fe (e.left t.Ft) (e.new-cond e.Ft-cond) s.stop?;
1685        } :: e.format (e.left) (e.new-cond) s.stop?,
1686        \{
1687          e.format : /*empty*/ =
1688            e.rest (e.cond e.new-cond)
1689            (e.new-clashes (e.t1 e.t2 (e.Re) (s.dir e.Pe))) New;
1690          s.stop? : Stop =
1691            e.format () (e.new-cond) Continue $iter {
1692              e.format : e.Fe t.Ft =
1693                1 <Length-of e.right> :: e.pos,
1694                <Check-Ft t.Ft (e.pos) () t.name Right-checks>
1695                  :: e.Ft-cond s.stop?,
1696                e.Ft-cond : {
1697                  /*empty*/ = /*empty*/;
1698                  Sym =
1699                    (Used e.Re)
1700                    (SYMBOL? e.Re (
1701                      (INFIX "-" (<Length-of e.Re>) (e.pos))
1702                    ));
1703                  Ref =
1704                    (Used e.Re)
1705                    (NOT (SYMBOL? e.Re (
1706                      (INFIX "-" (<Length-of e.Re>) (e.pos))
1707                    )));
1708                  Flat e.len s.stop??? =
1709                    (Used e.Re)
1710                    (FLAT-SUBEXPR? e.Re (
1711                      (INFIX "-" (<Length-of e.Re>) (e.pos))
1712                    ) e.len) s.stop???;
1713                } :: e.Ft-cond,
1714                e.Fe (t.Ft e.right) (e.new-cond e.Ft-cond) s.stop?;
1715            } :: e.format (e.right) (e.new-cond) s.stop?,
1716            s.stop? : Stop =
1717            e.rest (e.cond e.new-cond) (e.new-clashes t.clash) s.new?;
1718        };
1719      e.rest (e.cond) (e.new-clashes t.clash) s.new?;
1720    };
1721  } :: e.clashes (e.cond) (e.new-clashes) s.new?,
1722//  <WriteLN Check-Symbols e.clashes (e.cond) (e.new-clashes) s.new?>,
1723  e.clashes : /*empty*/ =
1724  e.cond (e.new-clashes) s.new?;
1725
1726Check-Ft t.Ft (e.pos) (e.right-pos) t.name s.dir, t.Ft : {
1727  s.ObjectSymbol, {
1728    <?? t.name s.dir> : \{
1729      e (e.pos Sym) e = /*empty*/ Continue;
1730      e (e.pos (Ref e)) e = $fail;
1731    };
1732    s.dir : Left-checks,
1733      <?? t.name Right-checks> : \{
1734        e (e.right-pos Sym) e = /*empty*/ Continue;
1735        e (e.right-pos (Ref e)) e = $fail;
1736      };
1737    <Set-Var t.name (s.dir) (<?? t.name s.dir> (e.pos Sym))> = Sym Continue;
1738  };
1739  (PAREN e.expr), {
1740    <?? t.name s.dir> : \{
1741      e (e.pos (Ref e)) e = /*empty*/ Continue;
1742      e (e.pos Sym) e = $fail;
1743    };
1744    s.dir : Left-checks,
1745      <?? t.name Right-checks> : \{
1746        e (e.right-pos (Ref e)) e = /*empty*/ Continue;
1747        e (e.right-pos Sym) e = $fail;
1748      };
1749    s.dir : {
1750      Left-checks = "lderef";
1751      Right-checks = "rderef";
1752    } :: s.name-dir,
1753      t.name : (e.QualifiedName),
1754      <Gener-Label s.name-dir e.QualifiedName> :: t.ref-name,
1755//      <Declare-Vars "Expr" (VAR t.ref-name)> : e,
1756      <Set-Var t.name (s.dir) (<?? t.name s.dir> (e.pos (Ref t.ref-name)))> =
1757      Ref Continue;
1758  };
1759//!     (VAR t.Ft-name), {
1760  (s t.Ft-name), { // STUB!
1761    <Hard-Exp? t.Ft>, {
1762      <?? t.Ft-name Flat> : True, {
1763        <?? t.Ft-name Length> : 1, {
1764          <?? t.name s.dir> : \{
1765            e (e.pos Sym) e = /*empty*/ Continue;
1766            e (e.pos (Ref e)) e = $fail;
1767          };
1768          s.dir : Left-checks,
1769            <?? t.name Right-checks> : \{
1770              e (e.right-pos Sym) e = /*empty*/ Continue;
1771              e (e.right-pos (Ref e)) e = $fail;
1772            };
1773//          <?? t.Ft-name Instantiated> : True =
1774//            /*empty*/ Continue;
1775          <Set-Var t.name (s.dir) (<?? t.name s.dir> (e.pos Sym))> =
1776            Sym Continue;
1777        };
1778        <Set-Var t.name (s.dir) (<?? t.name s.dir> (e.pos Flat))> =
1779          Flat <Length-of t.Ft> Continue;
1780      };
1781      /*empty*/ Continue;
1782    };
1783    /*empty*/ Stop;
1784  };
1785};
1786
1787Dereference-Subexpr e.clashes =
1788  e.clashes : e1 (e.t1 Dereference e.t2 (e.Re) (s.dir e.Pe)) e2 \?
1789  e.Re : (VAR t.name),
1790  <?? t.name Instantiated> : True,
1791//  <WriteLN Dereference!!! t.name <?? t.name Right-checks>>,
1792//  <Format e.Pe> : e.f1 t.Ft e.f2 \?
1793  e.Pe : e.f1 t.Ft e.f2 \?
1794  \{
1795    t.Ft : (PAREN e.expr),
1796      <Length-of e.f1> :: e.pos,
1797      {
1798        <?? t.name Left-checks> : e (e.pos (Ref t.ref-name)) e \!
1799          # \{ <?? t.ref-name Instantiated> : True; } =
1800          <Declare-Vars "Expr" (VAR t.ref-name)> : e,
1801          <Instantiate-Vars (VAR t.ref-name)>,
1802          (Assert (DEREF (VAR t.ref-name) e.Re (e.pos))) :: e.cond,
1803          (e.t1 Dereference e.t2 (e.Re) (s.dir e.Pe)) :: t.old-clash,
1804          {
1805            e.t1 e.t2 : e Without-object-symbols e = Without-object-symbols;
1806            /*empty*/;
1807          } :: e.wos,
1808          (<Gener-Label "clash"> &New-Clash-Tags e.wos
1809            ((VAR t.ref-name)) (s.dir e.expr)
1810          ) :: t.new-clash,
1811          s.dir : {
1812            LEFT =
1813              e.cond (e1 t.new-clash t.old-clash e2);
1814            RIGHT =
1815              e.cond (e1 t.old-clash t.new-clash e2);
1816          };
1817        t.Ft e.f2 : $r e.f3 (PAREN e.expr1) e.f4 \?
1818          1 <Length-of e.f4> :: e.pos,
1819          {
1820            <?? t.name Right-checks> : e (e.pos (Ref t.ref-name)) e \!
1821              # \{ <?? t.ref-name Instantiated> : True; } =
1822              <Declare-Vars "Expr" (VAR t.ref-name)> : e,
1823              <Instantiate-Vars (VAR t.ref-name)>,
1824              (Assert
1825                (DEREF (VAR t.ref-name) e.Re (
1826                  (INFIX "-" (<Length-of e.Re>) (e.pos))
1827                ))
1828              ) :: e.cond,
1829              (e.t1 Dereference e.t2 (e.Re) (s.dir e.Pe)) :: t.old-clash,
1830              {
1831                e.t1 e.t2 : e Without-object-symbols e =
1832                  Without-object-symbols;
1833                /*empty*/;
1834              } :: e.wos,
1835              (<Gener-Label "clash"> &New-Clash-Tags e.wos
1836                ((VAR t.ref-name)) (s.dir e.expr1)
1837              ) :: t.new-clash,
1838              s.dir : {
1839                RIGHT =
1840                  e.cond (e1 t.new-clash t.old-clash e2);
1841                LEFT =
1842                  e.cond (e1 t.old-clash t.new-clash e2);
1843              };
1844            \!\!\! $fail;
1845          };
1846        \!\! $fail;
1847      };
1848    e.f2 : /*empty*/ =
1849      (e1 (e.t1 e.t2 (e.Re) (s.dir e.Pe)) e2);
1850  };
1851
1852
1853
1854$func Compare-Terms-Left  (e.fail) (e.pos) (e.Re) e.Pe = e.cond (e.rest-Pe);
1855$func Compare-Terms-Right (e.fail) (e.pos) (e.Re) e.Pe = e.cond (e.rest-Pe);
1856
1857Compare-Subexprs (e.fail) e.clashes, {
1858  e.clashes : (e.t (e.Re) (s.dir e.Pe)) e.rest =
1859    <Compare-Terms-Left (e.fail) (0) (e.Re) e.Pe> :: e.left-cond (e.rest-Pe),
1860    <Compare-Terms-Right (e.fail) (0) (e.Re) e.rest-Pe> :: e.right-cond t,
1861    e.left-cond e.right-cond <Compare-Subexprs (e.fail) e.rest>;
1862  /*empty*/;
1863};
1864
1865Compare-Terms-Left (e.fail) (e.pos) (e.Re) e.Pe, {
1866  e.Pe : t.Pt e.rest, {
1867    <Get-Known-Length t.Pt> : e.len (), {
1868      \{
1869        <Get-Var Instantiated? t.Pt> : True =
1870          {
1871            <Get-Var Flat? t.Pt> : True = FLAT-EQ;
1872            EQ;
1873          };
1874        t.Pt : \{
1875          (REF e) = t.Pt;
1876          (STATIC e) = <Get-Static t.Pt>;
1877        } :: e.Pt =
1878          {
1879            <Flat-Const? e.Pt> = FLAT-EQ;
1880            EQ;
1881          };
1882        <Var? t.Pt> =
1883          <Set-Var (Value (e.Re) (e.pos) (e.len)) t.Pt>,
1884          $fail;
1885      } :: s.eq =
1886        (IF ((NOT (EQ (e.Re) (e.pos) (e.len) (t.Pt) (0) (e.len)))) e.fail);
1887      /*empty*/;
1888    } :: e.cond =
1889      e.cond <Compare-Terms-Left (e.fail) (e.pos e.len) (e.Re) e.rest>;
1890    (e.Pe);
1891  };
1892  ();
1893};
1894
1895Compare-Terms-Right (e.fail) (e.pos) (e.Re) e.Pe = ();
1896
1897
1898
1899Compare-Subexpr e.clashes =
1900  e.clashes () () () Old $iter e.clashes : {
1901    (e.t1 Compare e.t2 (e.Re) (s.dir e.Pe)) e.rest,
1902      e.Re : (VAR t.name),
1903      <?? t.name Instantiated> : True =
1904      {
1905        e.t1 e.t2 : e Without-object-symbols e =
1906          /*empty*/ (e.t2) (e.Re) (e.Pe);
1907        <Get-Static-Exprs e.Re> :: e.Re (e.Re-decls),
1908          <Get-Static-Exprs e.Pe> :: e.Pe (e.Pe-decls) =
1909          e.Re-decls e.Pe-decls (e.t2 Without-object-symbols) (e.Re) (e.Pe);
1910      } :: e.new-asserts (e.t2) (e.Re) (e.Pe),
1911      e.Pe () () Continue $iter {
1912        e.format : t.Ft e.Fe,
1913          <Length-of e.left> :: e.pos,
1914          <Length-of t.Ft> :: e.len,
1915          <Length-of e.Fe> :: e.right-pos,
1916          {
1917            \{
1918              <?? t.name Left-compare> :
1919                e (t.Ft Left (0) (e.pos) e.len) e;
1920              <?? t.name Right-compare> :
1921                e (t.Ft Left (0) (e.right-pos) e.len) e;
1922            } =
1923               /*empty*/ Continue;
1924            <Compare-Ft t.Ft> : {
1925              /*empty*/ s.stop??? = /*empty*/ s.stop???;
1926              e.compare s.eq =
1927//                <WriteLN Compare e.compare s.eq>,
1928                t.Ft : (VAR t.Ft-name),
1929                <Set-Var t.name (Left-compare) (<?? t.name Left-compare>
1930                  (t.Ft Left (0) (e.pos) e.len))>,
1931                <Set-Var t.Ft-name (Left-compare)
1932                  (<?? t.Ft-name Left-compare>
1933                  (e.Re Left (e.pos) (0) e.len))>,
1934                e.compare : {
1935                  Empty = /*empty*/ Continue;
1936                  Instantiated =
1937                    (t.Ft) (0) (e.len) :: e.sub1,
1938                    (e.Re) (e.pos) (e.len) :: e.sub2,
1939                    { s.eq : EQ = 0; 1; } :: s.R,
1940                    (Used t.Ft e.Re)
1941                    (s.eq <Middle 0 s.R e.sub1> e.sub2) Continue;
1942//                    (s.eq ((FIRST t.Ft)) ((LAST t.Ft))
1943//                      ((FIRST e.Re) e.pos) ((FIRST e.Re) e.pos e.len)
1944//                    ) Continue;
1945                  (t.var s.dir1 (e.pos1) (0) e.len), s.dir1 : {
1946                    Left =
1947                      (t.var) (e.pos1) (e.len) :: e.sub1,
1948                      (e.Re) (e.pos) (e.len) :: e.sub2,
1949                      { s.eq : EQ = 0; 1; } :: s.R,
1950                      (Used t.var e.Re)
1951                      (s.eq <Middle 0 s.R e.sub1> e.sub2) Continue;
1952//                      (s.eq ((FIRST t.var) e.pos1)
1953//                        ((FIRST t.var) e.pos1 e.len)
1954//                        ((FIRST e.Re) e.pos)
1955//                        ((FIRST e.Re) e.pos e.len)
1956//                      ) Continue;
1957                    Right =
1958                      (t.var)
1959                      ((INFIX "-" ((LENGTH t.var)) (e.pos1) (e.len)))
1960                      (e.len) :: e.sub1,
1961                      (e.Re) (e.pos) (e.len) :: e.sub2,
1962                      { s.eq : EQ = 0; 1; } :: s.R,
1963                      (Used t.var e.Re)
1964                      (s.eq <Middle 0 s.R e.sub1> e.sub2) Continue;
1965//                      (s.eq
1966//                        ((INFIX "-"
1967//                          ((LAST t.var)) (e.pos1) (e.len))
1968//                        )
1969//                        ((INFIX "-" ((LAST t.var)) (e.pos1)))
1970//                        ((FIRST e.Re) e.pos)
1971//                        ((FIRST e.Re) e.pos e.len)
1972//                      ) Continue;
1973//                    <Set-Var t.name Left-compare
1974//                      <?? t.name Left-compare>
1975//                      (t.name1 s.dir (e.pos1) (e.pos) e.len)
1976                  };
1977                };
1978            };
1979          } :: e.Ft-cond s.stop? =
1980          e.Fe (e.left t.Ft) (e.new-cond e.Ft-cond) s.stop?;
1981      } :: e.format (e.left) (e.new-cond) s.stop?,
1982      \{
1983        e.format : /*empty*/ =
1984          e.rest (e.cond e.new-cond) (e.new-asserts)
1985          (e.new-clashes (e.t1 e.t2 (e.Re) (s.dir e.Pe))) New;
1986        s.stop? : Stop = e.format () (e.new-cond) Continue $iter {
1987          e.format : e.Fe t.Ft,
1988            <Length-of e.right> :: e.pos,
1989            <Length-of t.Ft> :: e.len,
1990            {
1991              <?? t.name Right-compare> : e (t.Ft Left (0) (e.pos) e.len) e =
1992                /*empty*/ Continue;
1993              <Compare-Ft t.Ft> : {
1994                /*empty*/ s.stop??? = /*empty*/ s.stop???;
1995                e.compare s.eq =
1996                  t.Ft : (VAR t.Ft-name),
1997                  <Set-Var t.name (Right-compare)
1998                    (<?? t.name Right-compare>
1999                    (t.Ft Left (0) (e.pos) e.len))>,
2000                  <Set-Var t.Ft-name (Left-compare)
2001                    (<?? t.Ft-name Left-compare>
2002                    (e.Re Right (e.pos) (0) e.len))>,
2003                  e.compare : {
2004                    Empty = /*empty*/ Continue;
2005                    Instantiated =
2006                      (t.Ft) (0) (e.len) :: e.sub1,
2007                      (e.Re)
2008                      ((INFIX "-" ((LENGTH e.Re)) (e.pos) (e.len)))
2009                      (e.len) :: e.sub2,
2010                      { s.eq : EQ = 0; 1; } :: s.R,
2011                      (Used t.Ft e.Re)
2012                      (s.eq <Middle 0 s.R e.sub1> e.sub2) Continue;
2013//                      (s.eq ((FIRST t.Ft)) ((LAST t.Ft))
2014//                        ((INFIX "-" ((LAST e.Re)) (e.pos) (e.len)))
2015//                        ((INFIX "-" ((LAST e.Re)) (e.pos)))
2016//                      ) Continue;
2017                    (t.var s.dir1 (e.pos1) (0) e.len), s.dir1 : {
2018                      Left =
2019                        (t.var) (e.pos1) (e.len) :: e.sub1,
2020                        (e.Re)
2021                        ((INFIX "-"
2022                          ((LENGTH e.Re)) (e.pos) (e.len)
2023                        )) (e.len) :: e.sub2,
2024                        { s.eq : EQ = 0; 1; } :: s.R,
2025                        (Used t.var e.Re)
2026                        (s.eq <Middle 0 s.R e.sub1> e.sub2)
2027                        Continue;
2028//                        (s.eq ((FIRST t.var) e.pos1)
2029//                          ((FIRST t.var) e.pos1 e.len)
2030//                          ((INFIX "-"
2031//                            ((LAST e.Re)) (e.pos) (e.len)
2032//                          ))
2033//                          ((INFIX "-" ((LAST e.Re)) (e.pos)))
2034//                        ) Continue;
2035                      Right =
2036                        (t.var)
2037                        ((INFIX "-"
2038                          ((LENGTH t.var)) (e.pos1) (e.len)
2039                        )) (e.len) :: e.sub1,
2040                        (e.Re)
2041                        ((INFIX "-"
2042                          ((LENGTH e.Re)) (e.pos) (e.len)
2043                        )) (e.len) :: e.sub2,
2044                        { s.eq : EQ = 0; 1; } :: s.R,
2045                        (Used t.var e.Re)
2046                        (s.eq <Middle 0 s.R e.sub1> e.sub2)
2047                        Continue;
2048//                        (s.eq
2049//                          ((INFIX "-"
2050//                            ((LAST t.var)) (e.pos1) (e.len)
2051//                          ))
2052//                          ((INFIX "-" ((LAST t.var)) (e.pos1)))
2053//                          ((INFIX "-"
2054//                            ((LAST e.Re)) (e.pos) (e.len)
2055//                          ))
2056//                          ((INFIX "-" ((LAST e.Re)) (e.pos)))
2057//                        ) Continue;
2058                    };
2059                  };
2060              };
2061            } :: e.Ft-cond s.stop? =
2062            e.Fe (t.Ft e.right) (e.new-cond e.Ft-cond) s.stop?;
2063        } :: e.format (e.right) (e.new-cond) s.stop?,
2064          s.stop? : Stop =
2065          e.rest (e.cond e.new-cond) (e.new-asserts)
2066          (e.new-clashes (e.t1 Compare e.t2 (e.Re) (s.dir e.Pe))) s.new?;
2067      };
2068    t.clash e.rest = e.rest (e.cond) (e.asserts) (e.new-clashes t.clash) s.new?;
2069  } :: e.clashes (e.cond) (e.asserts) (e.new-clashes) s.new?,
2070//  <WriteLN Compare-Subexpr e.clashes (e.cond) (e.asserts) (e.new-clashes) s.new?>,
2071  e.clashes : /*empty*/ =
2072  e.cond (e.asserts) (e.new-clashes) s.new?;
2073
2074Compare-Ft {
2075  s.ObjectSymbol =
2076    <PrintLN "Compare-Ft: can't compare object symbols!">, $fail;
2077  (PAREN e.expr) =
2078    /*empty*/ Continue;
2079  (VAR t.name), {
2080    <Hard-Exp? (VAR t.name)>, {
2081      <?? t.name Instantiated> : True = Instantiated;
2082      <?? t.name Left-compare> : {
2083        t.compare e = t.compare;
2084        /*empty*/ = Empty;
2085      };
2086    } :: e.compare,
2087      {
2088        <?? t.name Flat> : True,
2089          <?? t.name Length> : 1 = FLAT-EQ;
2090        EQ;
2091      } :: s.eq =
2092      e.compare s.eq;
2093    /*empty*/ Stop;
2094  };
2095};
2096
2097Get-Source e.clashes =
2098  e.clashes : e1 (e.tags (e.Re) (s.dir e.Pe)) e2,
2099  \{
2100    /*
2101     * If source is an instantiated variable then go to the next clash.
2102     */
2103    e.Re : (VAR t.name),
2104      <?? t.name Instantiated> : True = $fail;
2105    /*
2106     * If in source there is unknown variable then we can't compute it, so
2107     * go to the next clash.
2108     */
2109    e.Re $iter e.Re : {               
2110      (VAR t.name) e.rest =           
2111        \{                   
2112          <?? t.name Instantiated> : True; 
2113          <?? t.name Left-compare> : v;   
2114        }, e.rest;               
2115      t e.rest = e.rest;             
2116    } :: e.Re,                   
2117      e.Re : /*empty*/;             
2118  } =
2119//  <WriteLN Get-Source (e.tags (e.Re) (s.dir e.Pe))>,
2120  {
2121    e.Re : /*empty*/ =
2122      <Store-Vars (EVAR ("empty" 0))> : t.empty,
2123      <Set-Var ("empty") (Instantiated) (True)>,
2124      () () (e.tags (t.empty) (s.dir e.Pe));
2125    e.Re : (VAR t.name) =
2126      (e.Re) () (e.tags (e.Re) (s.dir e.Pe));
2127    {
2128      e.tags : e Without-object-symbols e =
2129        /*empty*/ (e.tags (e.Re) (s.dir e.Pe));
2130      <Get-Static-Exprs e.Re> :: e.Re (e.Re-decls),
2131        <Get-Static-Exprs e.Pe> :: e.Pe (e.Pe-decls) =
2132        e.Re-decls e.Pe-decls (e.tags Without-object-symbols (e.Re) (s.dir e.Pe));
2133    } :: e.asserts (e.tags (e.Re) (s.dir e.Pe)), {
2134      e.Re : (VAR t.name) =
2135        () (e.asserts) (e.tags (e.Re) (s.dir e.Pe));
2136      <Compose-Expr e.Re> :: e.compose (e.not-inst) s.flat?,
2137        <Gener-Label "compose"> :: t.name,
2138        <Declare-Vars "Expr" (VAR t.name)> :: e.decl,
2139        <Instantiate-Vars (VAR t.name)>,
2140        {
2141          s.flat? : 0 = <Set-Var t.name (Flat) (True)>;;
2142        },
2143        <Set-Var t.name (Length) (<Length-of e.Re>)>,
2144        <Set-Var t.name (Format) (<Format-Exp e.Re>)> =
2145        (e.not-inst) (e.asserts e.decl (ASSIGN (VAR t.name) e.compose))
2146        (e.tags ((VAR t.name)) (s.dir e.Pe));
2147    };
2148  } :: (e.not-inst) (e.decl) t.clash,
2149  (Assert <Get-Subexprs e.not-inst> e.decl) (e1 t.clash e2);
2150
2151Compose-Expr e.Re =
2152  e.Re () () 0 $iter {
2153    e.Re : t.Rt e.rest, t.Rt : {
2154      s.ObjectSymbol =
2155        <PrintLN "Compose-Expr: can't deal with object symbols!">, $fail;
2156      (PAREN e.expr) =
2157        <Compose-Expr e.expr> :: e.expr (e.new-not-inst) s,
2158        (PAREN e.expr) (e.new-not-inst) 1;
2159      (VAR t.name) =
2160        {
2161          <?? t.name Instantiated> : True = /*empty*/;
2162          t.Rt;
2163        } :: e.new-not-inst,
2164        {
2165          <?? t.name Flat> : True = 0;
2166          1;
2167        } :: s.new-flat?,
2168        (Used t.Rt) t.Rt (e.new-not-inst) s.new-flat?;
2169      t = t.Rt () 0; // STUB!
2170    } :: e.new-compose (e.new-not-inst) s.new-flat? =
2171      e.rest (e.compose e.new-compose) (e.not-inst e.new-not-inst)
2172      <"+" s.flat? s.new-flat?>;
2173  } :: e.Re (e.compose) (e.not-inst) s.flat?,
2174  e.Re : /*empty*/ =
2175  e.compose (e.not-inst) s.flat?;
2176
2177Comp-Cyclic e.clashes =
2178  <WriteLN ??? e.clashes>,
2179  e.clashes : e1 (e.t1 Unknown-length e.t2 (e.Re) (s.dir e.Pe)) e2 =
2180  e.Re : (VAR (e.QualifiedName)),
2181  <Split-Hard-Left e.Pe> :: e.left-hard,
2182  <Split-Hard-Right e.Pe> :: e.right-hard,
2183  e.Pe : e.left-hard e.Cycle e.right-hard,
2184  {
2185    e.left-hard e.right-hard : /*empty*/ = /*empty*/ (e.QualifiedName) ();
2186    <Gener-Label "ref" e.QualifiedName> :: t.name,
2187      t.name : (e.CycleName),
2188      <Declare-Vars "Expr" (VAR t.name)> : e,
2189      <Instantiate-Vars (VAR t.name)>,
2190      <Set-Var t.name (Format) (<Format-Exp e.Cycle>)>,
2191      (INFIX "-" (<Length-of e.Re>) (<Length-of e.right-hard>)) :: e.len,
2192      (Used e.Re)
2193      (SUBEXPR (VAR t.name) e.Re (<Length-of e.left-hard>) (e.len)) :: e.decl,
2194      <Set-Var t.name (Left-compare)
2195        ((e.Re Left (<Length-of e.left-hard>) (0) <Length-of (VAR t.name)>))>,
2196      <Set-Var (e.QualifiedName) (Left-compare) ((
2197        (VAR t.name) Left (0) (<Length-of e.left-hard>) <Length-of (VAR t.name)>
2198      ))> =
2199      (e.t1 Checked-length e.t2 (e.Re) (s.dir e.left-hard (VAR t.name) e.right-hard))
2200      (e.CycleName) (e.decl);
2201  } :: e.old-clash (e.CycleName) (e.decl),
2202  (VAR (e.CycleName)) :: t.var,
2203  <Gener-Label L "For" "Break"> :: t.break-label,
2204  <Gener-Label L "For" "Cont"> :: t.cont-label,
2205  s.dir : {
2206    LEFT =
2207      <WriteLN XXXXX e.Cycle>,
2208      e.Cycle : t.var-e1 e.rest,
2209//!                     t.var-e1 : (VAR (e.SplitName)),
2210      t.var-e1 : (s (e.SplitName)), //STUB!
2211      {
2212//        e.rest : t.var-e2 = t.var-e2;
2213        (VAR <Gener-Label "lsplit" e.CycleName>);
2214      } :: t.var-e2,
2215      <Declare-Vars "Expr" t.var-e2> : e,
2216//!                     <Instantiate-Vars t.var-e1 t.var-e2>
2217      (Assert
2218        e.decl
2219        (LSPLIT t.var ((VAR ("min" e.SplitName))) t.var-e1 t.var-e2)
2220      )
2221      (Cond LABEL (t.break-label))
2222      (Cond FOR (t.cont-label) () ((INC-ITER t.var)))
2223      (Fail (BREAK t.break-label))
2224      (Clear-Restricted)
2225      (<Update-Ties t.var-e2 <Update-Ties t.var-e1 e1>>
2226        e.old-clash
2227        (<Gener-Label "clash"> &New-Clash-Tags (t.var-e2) (s.dir e.rest))
2228      <Update-Ties t.var-e2 <Update-Ties t.var-e1 e2>>)
2229      ((CONTINUE t.cont-label));
2230    RIGHT =
2231      e.Cycle : e.rest t.var-e2,
2232      t.var-e2 : (VAR (e.SplitName)),
2233      {
2234//        e.rest : t.var-e2 = t.var-e2;
2235        (VAR <Gener-Label "lsplit" e.CycleName>);
2236      } :: t.var-e1,
2237      <Declare-Vars "Expr" t.var-e1> : e,
2238      <Instantiate-Vars t.var-e1 t.var-e2>
2239      (Assert
2240        e.decl
2241        (RSPLIT t.var ((VAR ("min" e.SplitName))) t.var-e1 t.var-e2)
2242      )
2243      (Cond LABEL (t.break-label))
2244      (Cond FOR (t.cont-label) () ((INC-ITER t.var)))
2245      (Fail (BREAK t.break-label))
2246      (Clear-Restricted)
2247      (<Update-Ties t.var-e2 <Update-Ties t.var-e1 e1>>
2248        e.old-clash
2249        (<Gener-Label "clash"> &New-Clash-Tags (t.var-e1) (s.dir e.rest))
2250      <Update-Ties t.var-e2 <Update-Ties t.var-e1 e2>>)
2251      ((CONTINUE t.cont-label));
2252  };
2253
2254Get-Subexprs e.vars =
2255//  <WriteLN Get-Subexprs e.vars>,
2256  e.vars () $iter {
2257    e.vars : (VAR t.name) e.rest,
2258      # \{ <?? t.name Instantiated> : True; },
2259      <?? t.name Left-compare> : (t.var s.dir (e.pos) (0) e.len) e =
2260      <Instantiate-Vars (VAR t.name)>,
2261      <Declare-Vars "Expr" (VAR t.name)> : e,
2262      {
2263        s.dir : Right =
2264          (INFIX "-" (<Length-of t.var>) (e.pos e.len));
2265        e.pos;
2266      } :: e.pos,
2267      e.rest (e.decls (Used t.var) (SUBEXPR (VAR t.name) t.var (e.pos) (e.len)));
2268    // STUB:
2269    e.vars : t e.rest = e.rest (e.decls);
2270  } :: e.vars (e.decls),
2271  e.vars : /*empty*/ =
2272  e.decls;
2273
2274Split-Hard-Left e.expr =
2275  e.expr () $iter {
2276    e.expr : t.Pt e.rest, {
2277      <Hard-Exp? t.Pt> = e.rest (e.hard t.Pt);
2278      (e.hard);
2279    };
2280  } :: e.expr (e.hard),
2281  e.expr : /*empty*/ =
2282  e.hard;
2283
2284Split-Hard-Right e.expr =
2285  e.expr () $iter {
2286    e.expr : e.some t.Pt, {
2287      <Hard-Exp? t.Pt> = e.some (t.Pt e.hard);
2288      (e.hard);
2289    };
2290  } :: e.expr (e.hard),
2291  e.expr : /*empty*/ =
2292  e.hard;
2293
2294Gener-Label e.QualifiedName =
2295  {
2296    <Lookup &Labels e.QualifiedName> : s.num,
2297      <"+" s.num 1>;
2298    1;
2299  } :: s.num,
2300  <Bind &Labels (e.QualifiedName) (s.num)>,
2301  (e.QualifiedName s.num);
2302
2303Add-To-Label (e.label) e.name = <Gener-Label e.label "_" e.name>;
2304
2305Get-Static-Exprs e.Re =
2306  e.Re () () () $iter {
2307    e.Re : t.Rt e.rest, t.Rt : {
2308      s.ObjectSymbol, {
2309        <Char? t.Rt> =
2310          e.rest (e.new-Re) (e.decls) (e.expr t.Rt);
2311        <Get-Static-Var "chars" e.expr> :: e.expr-var (e.expr-decl),
2312          {
2313            <Int? t.Rt> = "int";
2314            <Word? t.Rt> = "word";
2315          } :: s.prefix,
2316          <Get-Static-Var s.prefix t.Rt> :: e.Rt-var (e.Rt-decl) =
2317          e.rest (e.new-Re e.expr-var e.Rt-var)
2318          (e.decls e.expr-decl e.Rt-decl) ();
2319      };
2320      (PAREN e.paren-Re) =
2321        <Get-Static-Exprs e.paren-Re> :: e.new-paren-Re (e.paren-decls),
2322        <Get-Static-Var "chars" e.expr> :: e.expr-var (e.expr-decl),
2323        e.rest (e.new-Re e.expr-var (PAREN e.new-paren-Re))
2324        (e.decls e.expr-decl e.paren-decls) ();
2325      t.var =
2326        <Get-Static-Var "chars" e.expr> :: e.expr-var (e.expr-decl),
2327        e.rest (e.new-Re e.expr-var t.var) (e.decls e.expr-decl) ();
2328    };
2329  } :: e.Re (e.new-Re) (e.decls) (e.expr),
2330//  <WriteLN Get-Static-Exprs e.Re>,
2331  e.Re : /*empty*/ =
2332  <Get-Static-Var "chars" e.expr> :: e.expr-var (e.expr-decl),
2333  e.new-Re e.expr-var (e.decls e.expr-decl);
2334
2335Get-Static-Var s.prefix e.expr, {
2336  e.expr : /*empty*/ = /*empty*/ ();
2337  {
2338    <Lookup &Static-Exprs s.prefix e.expr> : t.var = t.var ();
2339    ("const" s.prefix e.expr) :: t.name,
2340      <Bind &Static-Exprs (s.prefix e.expr) ((VAR t.name))>,
2341      <Declare-Vars "Expr" (VAR t.name)> : e,
2342      <Instantiate-Vars (VAR t.name)>,
2343      <Set-Var t.name (Flat) (True)>,
2344      <Length e.expr> :: s.len,
2345      <Set-Var t.name (Length) (s.len)>,
2346      <Set-Var t.name (Min) (s.len)>,
2347      <Set-Var t.name (Max) (s.len)>,
2348      <Set-Var t.name (Format) (e.expr)> =
2349      (VAR t.name) ((EXPR (VAR t.name) e.expr));
2350  };
2351};
2352
2353
2354
2355$func Ref-Len t.name = e.length;
2356
2357/*
2358 * Из верхнего уровня выражения изымаются все переменные, длина которых не
2359 * может быть посчитана (она неизвестна из формата, и переменная ещё не
2360 * получила значение в run-time).  Список этих переменных возвращается вторым
2361 * параметром.  Первым параметром возвращается длина оставшегося после их
2362 * изъятия выражения.
2363 */
2364Get-Known-Length e.Re =
2365  e.Re (/*e.length*/) (/*e.unknown-vars*/) $iter {
2366    e.Re : t.Rt e.rest, t.Rt : {
2367      s.ObjectSymbol = 1 ();    // Может появиться из константы.
2368      (PAREN e) = 1 ();
2369      (REF t.name) = <Ref-Len t.name> ();
2370      (STATIC t.name) = <Get-Known-Length <Get-Static t.Rt>>;
2371      t, <Var? t.Rt>, {
2372        <Get-Var Length t.Rt> : v.len = v.len ();
2373        <Get-Var Instantiated? t.Rt> : True = (LENGTH t.Rt) ();
2374        /*empty*/ (t.Rt);
2375      };
2376    } :: e.len (e.var),
2377      e.rest (e.length e.len) (e.unknown-vars e.var);
2378  } :: e.Re (e.length) (e.unknown-vars),
2379  e.Re : /*empty*/ =
2380  {
2381    e.length : /*empty*/ = 0 (e.unknown-vars);
2382    e.length (e.unknown-vars);
2383  };
2384
2385Length-of {
2386  /*empty*/ = 0;
2387  e.Re =
2388    e.Re () $iter {
2389      e.Re : t.Rt e.rest, t.Rt : {
2390        s.ObjectSymbol = 1;     // Может появиться из константы.
2391        (PAREN e) = 1;
2392        (REF t.name) = <Ref-Len t.name>;
2393        (STATIC t.name) = <Length-of <Get-Static t.Rt>>;
2394        t, <Var? t.Rt>, {
2395          <Get-Var Length t.Rt> : v.len = v.len;
2396          (LENGTH t.Rt);
2397        };
2398      } :: e.new-len,
2399      e.rest (e.Length e.new-len);
2400    } :: e.Re (e.Length),
2401    e.Re : /*empty*/ =
2402    e.Length;
2403};
2404
2405Ref-Len t.name = {
2406  <Lookup &Const-Len t.name>;
2407  <Length-of <Middle 3 0 <Lookup &Const t.name>>> :: e.len =
2408    <Bind &Const-Len (t.name) (e.len)>,
2409    e.len;
2410  1;
2411};
2412
2413Flat-Const? {
2414  (PAREN e) e = $fail;
2415  (REF t.name) e.rest, {
2416    <Middle 3 0 <Lookup &Const t.name>> :: e.const =
2417      <Flat-Const? e.const> <Flat-Const? e.rest>;
2418    <Flat-Const? e.rest>;
2419  };
2420  s.ObjectSymbol e.rest = <Flat-Const? e.rest>;
2421  /*empty*/;
2422};
2423
2424/*
2425 * Ends good if lengths of all variables in the upper level of e.expr can be
2426 * calculated.
2427 */
2428Hard-Exp? e.expr =
2429  e.expr $iter {
2430    e.expr : t.first e.rest =
2431    {
2432      <Var? t.first>, {
2433        <Get-Var Instantiated? t.first> : True;
2434        <Get-Var Length t.first> : v;
2435        = $fail;
2436      };;
2437    },
2438      e.rest;
2439  } :: e.expr,
2440  e.expr : /*empty*/;
2441
2442/*
2443 * Returns those parts of e.expr which lengthes are known. Also returns a list
2444 * of variables with unknown lengthes.
2445 */
2446Unknown-Vars e.expr =
2447  e.expr () () $iter {
2448    e.expr : t.first e.rest, {
2449      t.first : (VAR t.name), {
2450        <?? t.name Instantiated> : True =
2451          e.new-expr t.first (e.unknown);
2452        <?? t.name Max> :: e.max, <?? t.name Min> : e.max =
2453          e.new-expr t.first (e.unknown);
2454        e.new-expr (e.unknown t.first);
2455      };
2456      e.new-expr t.first (e.unknown);
2457    } :: e.new-expr (e.unknown) =
2458      e.rest (e.new-expr) (e.unknown);
2459  } :: e.expr (e.new-expr) (e.unknown),
2460  e.expr : /*empty*/ =
2461  e.new-expr (e.unknown);
2462
2463
2464
2465Print-Error s.WE e.Descrip t.Pragma =
2466  <? &Error-Counter> : s.n,
2467  <Store &Error-Counter <"+" s.n 1>>,
2468  <Print-Pragma &StdErr t.Pragma>,
2469  <Print! &StdErr " " s.WE " ">,
2470  s.WE e.Descrip : {
2471    Error! Re = <PrintLN! &StdErr "Wrong format of result expression">;
2472    Error! Call = <PrintLN! &StdErr "Wrong argument format in function call">;
2473    Error! Pattern = <PrintLN! &StdErr "Wrong format of pattern expression">;
2474    Warning! Pattern = <PrintLN! &StdErr "Clash can't be solved">;
2475    Error! Var-Re t.var =
2476      <PrintLN! &StdErr "Unknown variable '"
2477                <AS-To-Ref t.var> "' in result expression">;
2478    Error! Var-Hard t.var =
2479      <PrintLN! &StdErr "Repeated occurence of the variable '"
2480                <AS-To-Ref t.var> "' in hard expression">;
2481    Error! Var-Type t.var s.type =
2482      <PrintLN! &StdErr "Incorrect type '" <AS-To-Ref s.type>
2483                "' of the variable '" <AS-To-Ref t.var> "'">;
2484    Error! Cut = <PrintLN! &StdErr "'\\\\!' without corresponding '\\\\?'">;
2485  };
2486
2487Print-Pragma s.channel (PRAGMA e.pragmas),
2488  e.pragmas : {
2489    e (FILE e.file-name) e, <Print! s.channel e.file-name>, $fail;
2490    e (LINE s.line s.col) e, <Print! s.channel (s.line ", " s.col)>, $fail;
2491    e = <Print! s.channel ":">;
2492  };
2493
2494AS-To-Ref {
2495  SVAR = 's';
2496  TVAR = 't';
2497  VVAR = 'v';
2498  EVAR = 'e';
2499  (s.tag t (e.name)) = <AS-To-Ref s.tag> '.' <To-Chars e.name>;
2500};
2501
2502Lookup-Func t.Fname, \{
2503  <Lookup &Fun t.Fname>;
2504  <Lookup &Fun? t.Fname>;
2505} : s.linkage s.tag t.pragma (e.Fin) (e.Fout) =
2506  s.linkage s.tag t.pragma (e.Fin) (e.Fout);
2507
Note: See TracBrowser for help on using the repository browser.