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

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