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

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