// $Source$ // $Revision$ // $Date$ $use "rfpc"; $use "rfp_helper"; $use "rfp_check"; $use "rfp_as2as"; $use "rfp_format"; $use "rfp_vars"; $use "rfp_const"; $use "rfp_clashes"; $use StdIO; $use Table; $use Box; $use Arithm; $use Access; $use Compare; $use Convert; $use Class; $use Apply; $use Dos; $use List; /* * Table for storing object names. */ $table Objects; /* * Table for storing parameters of referenced functions. */ $table Stub-Funcs; /* * Box for storing function out format */ $box Out-Format; /* * Box for storing names for function result variables */ $box Res-Vars; /* * Following table is used by Gener-Label function for obtaining unical (for * certain function) label name. * e.Key ::= e.QualifiedName (parameter given to Gener-Label) * e.Val ::= [Int] (last index used with such e.QualifiedName) */ $table Labels; /* * Table for storing variables used in place of preprocessor-generated ones. */ $table Prep-Vars; $func Compile (e.targets) (e.headers) e.Items = e.Compiled-Items (INTERFACE e.headers); $func Comp-Func-Stubs = e.asail-funcs; $func Comp-Func s.tag t.name e.params-and-body = e.compiled-func; $func Set-Drops (e.declared-exprs) e.comp-func = (e.declared-exprs) e.result-func; $func Comp-Sentence e.Sentence = e.asail-sentence; $func Save-Snt-State = ; $func Recall-Snt-State = ; $func Pop-Snt-State = ; $func Extract-Calls e.Re = (e.last-Re) e.calls; $func Get-Clash-Sequence (e.last-Re) e.Snt = (e.clashes) e.rest-of-the-Sentence; $func? Without-Calls? e.Re = ; $func Comp-Clashes (e.clashes) s.tail? (v.fails) e.Sentence = e.asail-sentence; $func Gener-Label e.QualifiedName = t.label; $func Add-To-Label t.label e.name = t.label; $func Comp-Calls e.Re = e.calls; $func Prepare-Vars e.vars = e.vars; $func Prepare-Res e.Reult-exprs = e.Result-exprs; $func Prepare-Const e.const-expr = e.const-expr; $func Comp-Assigns e.assignments = e.asail-assignments; $func Comp-Format (e.last-Re) e.He = e.assignments; ************ Get AS-Items and targets, and pass it to Compile ************ /* * Ящик для объявлений статических функций, констант и объектов. Все они * выписываются в самом начале тела модуля. */ $box Declarations; $box Trace-Names; $table Includes; RFP-Compile e.Items = { ;; } :: e.targets, , , , , , :: e.Items t.Interface, :: e.stub-funcs, t.Interface (MODULE e.Items e.stub-funcs); ****************** Choose needed items and compile them ****************** Compile (e.targets) (e.headers) e.Items, { e.Items : e t.item e.rest, { e.targets : v = e.targets : e t.name e, t.item : (t t t t.name e);; }, t.item : { (IMPORT s.tag t.pragma t.name e) = { t.pragma : (PRAGMA e (FILE e.fname) e) = :: (e.mod-name) e, ;; }, () /*empty*/; (TRACE t.name) = , () /*empty*/; (EXTERN t.pragma t.name) = , () /*empty*/; (s.link s.tag t.pragma t.name (e.in) (e.out) e.body), FUNC FUNC? TFUNC : e s.tag e = { : $r e (s t.name) e = /*empty*/; (DECL-FUNC t.name); } :: e.decl, , { s.link : EXPORT = e.decl; /*empty*/; } :: e.decl, { e.body : (BRANCH t.p e.branch) = >;; } :: e.comp-func, (e.decl) e.comp-func; (s.link CONST t.pragma t.name e.expr) = (CONSTEXPR s.link t.name (e.expr) ) :: t.const, , { s.link : EXPORT = ((DECL-OBJ t.name)) /*empty*/; () /*empty*/; }; (EXPORT s.tag t.pragma t.name) = , ((DECL-OBJ t.name)) /*empty*/; (LOCAL s.tag t.pragma t.name) = , () /*empty*/; } :: (e.decl) e.item = e.item ; /**/ (INTERFACE e.headers); }; $func Gener-Stub e = e; /* * For each referenced function generate a stub one with format e = e. */ Comp-Func-Stubs = )>; Gener-Stub (t.name) = : t.stub-name s.tag (e.Fin) (e.Fout), , :: e.He, ; Comp-Func s.tag t.name (e.in) (e.out) e.Sentence = , , , > :: e.res-vars, : e, , >, : (e.arg), :: e.arg-vars, : e, s.tag : { FUNC = FUNC (FATAL); FUNC? = FUNC? (RETFAIL); TFUNC = TFUNC (FATAL); STUB = : (e.message), FUNC? (RETFAIL) ((ERROR e.message)); } :: s.tag e.fails, (s.tag t.name () () ) :: e.comp-func, * > :: t e.comp-func, :: e.comp-func, //! :: t e.result, //! e.result; e.comp-func; // :: (e.func-decl) e.func-body, // () $iter { // e.vars : (t.var) e.rest-vars, // (e.var-decls (DECL t.var)) e.rest-vars; // } :: (e.var-decls) e.vars, // e.vars : /*empty*/, // (e.func-decl e.var-decls e.func-body); Set-Drops (e.declared) e.comp-func = e.comp-func () (e.declared) $iter { e.comp-func : t.first e.rest, { t.first : \{ (EXPR t.var e) = (DROP t.var) (t.first) t.var Init; (DEREF t.var e) = (DROP t.var) (t.first) t.var Init; (SUBEXPR t.var e) = (DROP t.var) (t.first) t.var Init; (DECL Expr t.var) = (DROP t.var) () t.var Decl; (DECL "int" t.var) = /*empty*/ () t.var Decl; } :: e.drop (e.constr) t.var s.init, { e.declared : e1 t.var s.old-init e2, s.old-init : { Init, { t.var : (VAR ("const" e)) = e.rest (e.result-func) (e.declared); e.rest (e.result-func e.drop e.constr) (e.declared); }; Decl, s.init : { Decl = e.rest (e.result-func) (e.declared); Init = t.first : (s.method t.var e.args), e.rest (e.result-func (ASSIGN t.var (s.method e.args))) (e1 e2 t.var s.init); /* * FIXME: if s.method is EXPR, it shouldn't be written. */ }; }; e.rest (e.result-func t.first) (e.declared t.var s.init); }; t.first : (LABEL (t.label) e.expr) = :: (e.declared) e.expr, e.rest (e.result-func (LABEL (t.label) e.expr)) (e.declared); t.first : (e.expr) = :: t e.expr, e.rest (e.result-func (e.expr)) (e.declared); t.first : s.symbol = e.rest (e.result-func s.symbol) (e.declared); }; } :: e.comp-func (e.result-func) (e.declared), e.comp-func : /*empty*/ = (e.declared) e.result-func; Comp-Sentence s.tail? (v.fails) (e.last-Re) e.Sentence, e.Sentence : { /*empty*/ = /*empty*/; /* * In case of Re look if we should do a tailcall. If not, then compile * function calls from the Re and assign results to the out parameters or * use them in compilation of the rest of the sentence. */ (RESULT e.Re) e.Snt = { /* * If the Re is the last action in the sentence then we can do * tailcall if one of the following is true: * - Re is a call of non-failable function; * - Re is a call of a failable function, current function is * failable, and the failures stack is empty. * In both cases out format of the called function should coincide * with those of compiled one. * FIXME: really we can do tailcall if all the parameters of * compiled function that won't get their values from the call can * be assigned from other sources. Some support from runtime is * needed though. */ e.Snt : /*empty*/, s.tail? : Tail, e.Re : (CALL t.name e.arg), { = v.fails : (RETFAIL), TAILCALL?; TAILCALL; } :: s.tailcall, :: s.linkage s.tag t.pragma (e.Fin) (e.Fout), )> = :: (e.last-Re) e.calls, > :: e.splited-Re, e.calls> (s.tailcall t.name (e.splited-Re) ()); :: (e.last-Re) e.calls, e.calls> :: e.comp-calls, { e.Snt : /*empty*/, Tail Tail-in-Trap : e s.tail? e = ) e.last-Re> :: e.splited-Re, :: e.splited-Re, e.comp-calls ) (e.splited-Re)>>; e.comp-calls ; }; }; /* * In case of He compile assignments from last Re and then (with new state * of variables) proceed with the rest of the sentence. */ (FORMAT e.He) e.Snt = ; /* * In case of Pe get from the begining of the sentence a maximum possible * sequence of clashes and compile it. New values of variables from the * clashes use in the compilation of the rest of the sentence. */ (s.dir e.Pattern) e.Snt, s.dir : \{ LEFT; RIGHT; } = :: (e.clashes) e.Sentence, ; (s.block) e, BLOCK BLOCK? : e s.block e = , $fail; /* * In case of a block first see if its results are needed for something * after the block and determine whether the block is a source. Then * compile each branch in turn. */ (s.block e.branches) e.Snt, s.block : \{ BLOCK = (FATAL); BLOCK?; } :: e.fatal? = /* * If the block initializes an $iter then extract from the $iter the He * for placing it in the end of each branch. * Then look if the block is used by a format expression. * If so, we should declare variables from that expression before * entering any branch -- those should be visible after the block. * The format expression is placed in the end of each branch. * But if a branch computes to $error, the expression shouldn't be * used, so protect it with (Comp If-not-error). * If next after the block is (Comp Error) then block results should be * used as values for $error, so place (Comp Error) in the end of each * branch. * If next after the block is (Comp If-not-error) then our block is in * the end of a branch of an outer block and has next pattern or format * inherited from there. In that case we should place all the sentence * rest in the end of each branch because the block can be inside the * $error already. */ { e.Snt : (ITER t.body t.format t.cond) e.rest = t.format (Comp Iter t.body t.format t.cond) e.rest; e.Snt; } :: e.Snt, e.Snt : { (FORMAT e.format) e.rest = > :: e.vars, (e.vars) ((Comp If-not-error) (FORMAT e.format)) ((Comp Source)) e.rest; (Comp Error) e.rest = () ((Comp Error)) () /*empty*/; (Comp If-not-error) e.rest = () (e.Snt) () /*empty*/; e = () () () e.Snt; } :: (e.out-vars) (e.next-terms) (e.source?) e.Snt, /* * The block is a source if after it goes format expression * (in that case e.source? isn't empty) or e.Snt isn't empty. * Branches in the block are tail sentences if the current sentence is * tail and the block isn't a source. */ { \{ e.source? : v; e.Snt : v; } = ((Comp Source) ) Notail; () s.tail?; } :: (e.source?) s.tail-branch?, /* * In case our block is a source we should mark the position in the * failures stack, so that we can jump to it after CUTALL. And if our * block isn't failable we should add (FATAL) to the end of the stack. */ v.fails e.source? e.fatal? :: v.branch-fails, /* * Before compile the branches mark all out-vars as declared. */ :: e.decls, /* * We put all compiled branches in a block, so positive return from a * branch is a break from that block. * Each branch in its turn is placed in its own block, so for a $fail * to the next branch we should just break from that inner block. * Each branch is compiled with the current sentence state and the * state is recalled after that. When all branches are compiled the * state is popped out from the stack. * If last branch fails then the whole block fails, and return from the * last branch is return from the block. So the last branch isn't * placed in a block and is processed with the failures stack that was * before entering the block. Note: this trick helps us find more * tailcalls. If the call of a failable function is on the last branch * of the block and the failures stack is empty we can do tailcall. * When the last branch is compiled with the block's stack, all we * should do is to check it. */ :: t.label, , (e.branches) /*e.comp-branches*/ $iter { e.branches : (BRANCH e.branch) e.rest-br = :: t.br-label, :: e.comp-br, , (e.rest-br) e.comp-branches (LABEL (t.br-label) e.comp-br (BREAK t.label)); } :: (e.branches) e.comp-branches, e.branches : (BRANCH e.branch) = :: e.last-branch, , , e.decls (LABEL (t.label) e.comp-branches e.last-branch) ; /* * In case of $iter first of all compile initial assignment to the hard * expression. */ (ITER t.body t.format t.cond) e.Snt = ; /* * Before compiling $iter condition or body we should forget available info * about all format variables, because that info can be changed during * cycle iterations. * Then compile $iter condition and body both with the current state of the * sentence. * e.Snt can contain (Comp Error) and (protected from errors) pattern or * format which comes from an outer block, so compile it together with the * condition. * If condition fails we should compute the body, so put the compiled * condition in a block and place a break from it to the failures stack. */ (Comp Iter (BRANCH e.body) t.format (BRANCH e.condition)) e.Snt = t.format : (FORMAT e.Fe), >>, , :: t.label, :: t.exit, :: e.comp-condition, , :: e.comp-body, (FOR (/*cont-label*/) (t.exit) () () (LABEL (t.label) e.comp-condition (BREAK t.exit)) e.comp-body ); /* * In case of $trap/$with at first compile try-sentence. All $fails from * it should become errors. * Then recall the state of the sentence and compile catching of an error * with a variable err. * e.Snt can contain (Comp Error) and (protected from errors) pattern or * format which comes from an outer block, so compile it together with both * sentences. */ (TRY (BRANCH e.try) e.catch) e.Snt = , { s.tail? : Tail = Tail-in-Trap; s.tail?; } :: s.tail-in-trap?, :: e.comp-try, , :: t.var, , :: e.comp-catch, (TRY e.comp-try) (CATCH-ERROR e.comp-catch); /* * In case of \? add Stake to the failures stack. Add last fail after it * for continue to work. */ (STAKE) e.Snt = ) () e.Snt>; /* * In case of \! forget all failure catchers after last \?. * If there is no Stake then we are inside negation or error (we assume the * program is correct). So the right failure catcher is in the bottom of * the stack. */ (CUT) e.Snt = { v.fails : $r v.earlier-fails (Comp Stake) e = v.earlier-fails; ; } :: v.fails, ; /* * In case of = clear the failures stack up to the closest source. * Don't clear last fail after it for continue to work. */ (CUTALL) e.Snt = { v.fails : $r v.earlier-fails (Comp Source) t.fail e = v.earlier-fails (Comp Source) t.fail; ; } :: v.fails, ; /* * In case of = in the Refal-6 sense (non-transparent hedge for the fails), * $fail(k) should become $error(Fname "Unexpected fail"), so clear the * failures stack and put that value in it. */ NOFAIL e.Snt = ; /* * In case of $fail return last failure catcher. */ (FAIL) e.Snt = v.fails : e (e.last-fail), e.last-fail; /* * In case of # we should proceed with the rest if the source is computed * to $fail. * We could compile the rest of the sentence and place it in the * failures stack. But then the compiled sentence would be copied as many * times as there are $fail's to the upper level in the source. So we * place compiled source in the block and put the break to exit from it in * the stack. * When compiling the source mark it as Notail as usual. * If the source isn't computed to $fail we should proceed with the last * failure catcher. */ (NOT (BRANCH e.branch)) e.Snt = :: t.label, v.fails : e (e.last-fail), // , e.last-fail :: e.comp-negation, // , (LABEL (t.label) e.comp-negation) ; /* * In case of $error all fails become $error(Fname "Unexpected fail"). So * place that value in the failures stack and then compile the computation * of the rest of the sentence and the last Re which should be the value of * $error. */ (ERROR) e.Snt = ; (Comp Error) e.Snt = : (e.Re), (ERROR e.Re); /* * Protection mark to be used between source and tail. If there is $error * construction somewhere in the source then the tail shouldn't be * computed, but instead the source value should be used for throwing. */ (Comp If-not-error) e.Snt = { e.Snt : e (Comp Error) = ; ; }; // (Comp Fatal) = FATAL; // (Comp Retfail) = RETFAIL; }; ********** Sentence state stack and functions for work with it. ********** $box Snt-State; /* * Put current state in the stack. */ Save-Snt-State = >; /* * Set current state to that at the top of the stack. */ Recall-Snt-State = >>; /* * Pop the top from the stack and set current state to it. */ Pop-Snt-State = , >>; ********************** Function calls compilation. *********************** /* * $func Extract-Calls e.Re = (e.last-Re) e.calls; * * * */ Extract-Calls { (CALL t.name e.arg) e.rest = :: s.linkage s.tag t.pragma (e.Fin) (e.Fout), :: (e.last-Re) e.calls, > :: e.splited-Re, :: t e.prefix, :: e.Re, :: e.vars, : e, { s.tag : FUNC? = (Failable (CALL t.name (e.splited-Re) (e.vars))); (CALL t.name (e.splited-Re) (e.vars)); } :: t.call, :: (e.rest-Re) e.rest-calls, (e.Re e.rest-Re) e.calls t.call e.rest-calls; (PAREN e.Re) e.rest = :: (e.last-Re) e.calls, :: (e.rest-Re) e.rest-calls, ((PAREN e.last-Re) e.rest-Re) e.calls e.rest-calls; t.Rt e.Re = :: (e.last-Re) e.calls, (t.Rt e.last-Re) e.calls; /*empty*/ = () /*empty*/; }; Comp-Calls (e.fail) e.calls, e.calls : { (Failable t.call) e.rest = (IF ((NOT t.call)) e.fail) ; t.call e.rest = t.call ; /*empty*/ = /*empty*/; }; ********** Preparation of vars and REs for following processing ********** *********** Compilation of static parts of result expressions ************ $func Static-Expr? s.create? e.Re = static? e.Re; $func Ref-Func? t = t; $func Static-Term? t.Rt = static? e.Re; $func Stub-Name t.name = t.stub-name; /* * Extract static parts from each Re. * Also get the right names for variables generated during the preprocessing * stage, if those are in the expr. */ Prepare-Res { (e.Re) e.rest = :: s e.Re, (e.Re) ; /*empty*/ = /*empty*/; }; /* * Find all the longest static parts in the upper level of Re. Create STATIC * form in place of each one. * Return a tag pointing whether the whole expression is static and expression * with static parts replaced by STATIC forms. Dynamic parts are returned * unchanged. */ Static-Expr? s.create? e.Re = (/*e.static*/) e.Re $iter { e.Re : t.Rt e.rest = : { Static e.st-Re = (e.static e.st-Re) e.rest; Dynamic t.dyn-Rt = :: s e.rest, (e.static) (Dynamic t.dyn-Rt e.rest); }; (e.static); } :: (e.static) e.Re, e.Re : \{ /*empty*/, { s.create? : Create = Static ; Static e.static; }; (Dynamic e.dynamic) = Dynamic e.dynamic; }; /* * The same as Static-Expr? but for terms. */ Static-Term? { symbol = Static symbol; (PAREN e.Re) = :: static? e.Re, static? (PAREN e.Re); (REF t.name) = Static ; (STATIC t.name) = Static ; t.var = : t.prep-var, Dynamic t.prep-var; }; Ref-Func? { (REF t.name) = { : { s.linkage s.tag t.pragma ((EVAR)) ((EVAR)) = (s.tag t.name); s.linkage s.tag t.pragma (e.Fin) (e.Fout) = { : t.stub-name e = (FUNC? t.stub-name); :: t.stub-name, , (FUNC? t.stub-name); }; }; (REF t.name); }; term = term; }; /* * Обеспечивает, что сгенерированные препроцессорами переменные (с именами, * оканчивающимися на число) не пересекаются с программными переменными (за * счёт того, что таг будет VAR). */ Prepare-Vars { // (s.var-tag (e.prefix s.n)) e.rest, = // { // ; // :: e.var, // , // e.var; // } :: e.var, // e.var ; t.var e.rest = t.var ; /*empty*/ = /*empty*/; }; /* * Генерируем уникальные внутри модуля имена для функций-заглушек. */ Stub-Name (e.qualifiers s.name) = : { e1 '_' s.n, = e1 '_' <"+" s.n 1>; e1 = e1 '_' 0; } :: e.name, (/*e.qualifiers*/ ) :: t.name, { : e = ; t.name; }; Prepare-Const { (PAREN expr) e.rest = (PAREN ) ; t1 e.rest = ; /*empty*/ = /*empty*/; }; ***************** Compilation of assignment to variables ***************** $func Comp-Assign-to-Var t.var e.Re (e.assigned-vars) = e.assign (e.used-vars); Comp-Assign-to-Var t.var e.Re (e.assigned-vars) = { t.var : e.Re = /*empty*/ (); , $fail; , # \{ e.assigned-vars : e t.var e; } = (); : s = (ASSIGN e.Re) (); : e, (EXPR e.Re) (); }; Comp-Assigns e.assigns = e.assigns (/*e.assigned-vars*/) (/*e.comp-assigns*/) $iter { e.assigns : (t.var (e.Re)) e.rest = :: e.c-as (e.a-vs), e.rest (e.assigned-vars e.a-vs) (e.comp-assigns e.c-as); } :: e.assigns (e.assigned-vars) (e.comp-assigns), e.assigns : /*empty*/ = e.comp-assigns; ************************** FORMAT compilation. *************************** $box Aux-Index; $func Gener-Aux-Var = t.new-aux-var; Gener-Aux-Var = : s.n, >, (VAR ("aux" s.n)); $func Create-Aux-Vars (e.vars) e.splited-Re = e.assigns; Comp-Format (e.last-Re) e.He = > :: e.vars, ) e.last-Re>> :: e.splited-Re, , :: e.assigns, ; /* * Итак, e.vars -- все переменные, входящие в форматное выражение. Каждая * переменная может входить в форматное выражение только один раз, поэтому * повторяющихся среди них нет. * e.splited-Re -- набор результатных выражений. На каждую переменную из * e.vars по выражению, которое должно быть ей присвоено. * * Если переменная t.var_i используется в выражении e.Re_j, и i /= j, то * переменной t.var_j значение должно быть присвоено раньше, чем перeменной * t.var_i. Если же, по аналогичным соображениям, t.var_i должна получить * значение раньше t.var_j, необходимо завести вспомогательную переменную. * * Пример: * * t1 (t1 t2) (t1 t3) :: t2 t1 t3 * * t3 = (t1 + t3)(); * aux_1 = t1; * t1 = (t1 + t2)() * t2 = aux_1; * * В общем случае вспомогательная переменная требуется, если двум переменным * необходимы старые значения друг друга (возможно, не напрямую, а через * промежуточные переменные). * * Вместо того, чтобы искать и анализировать такие циклы, будем действовать по * методу "наибольшей пользы". А именно: * * - Для каждой переменной выпишем все другие переменные, которым требуется * её старое значение, а также отдельно те, старые значения которых * требуются ей. * * - Всем переменным, от старых значений которых ничего не зависит, можно * смело присвоить новые значения. При этом они исчезают из списков * зависимостей оставшихся переменных. * * - Все переменные, новые значения которых ни от чего не зависят, можно * отложить, чтобы присвоить им значения тогда, когда будет удобно. Т.е. * тогда, когда списки зависящих от них переменных опустеют. * * - Чтобы означить оставшиеся, нужны вспомогательные переменные. Выберем * одну из переменных, с максимальным списком тех, от которых она зависит, * и положим её значение во вспомогательную переменную. Так как мы сразу * уменьшили кол-во зависимостей у максимального кол-ва переменных, * локально мы добились наибольшей пользы, хотя не исключено, что глобально * такой метод и не даст наименьшего кол-ва вспомогательных переменных. * Кроме того, мы не пытаемся выбрать наилучшую переменную из нескольких с * максимальным списком зависимостей. * * - Повторяем всё это до тех пор, пока у каждой переменной не опустеет * список зависящих от неё. * * * Для нашего примера: * * t1 (t1 t2) (t1 t3) :: t2 t1 t3 * * t1 -- (t2 t3) (t2) * t2 -- (t1) (t1) * t3 -- () (t1) * * * Для каждой переменной var_i найдём все j /= i, такие что в Re_j встречается * var_i -- provide[i], и а также все j /= i, такие что var_j нужна для * подсчёта var_i, т.е. встречается в Re_i. * * Res-vars <- * for var_i in vars * provide[i] <- * for vars-Re_j in Res-vars, j /= i * vars-Re_j : e var_i e = j * require[i] <- : e var_j e, j * * Res-vars = map Vars Res * provide, require = * { [ j | vars-Re_j <- Res-vars, j /= i, var_i `in` vars-Re_j ] * , [ j | var_j <- Res-vars[i] `*` vars, i /= j] * | var_i <- vars * } * */ $func CAV e.vars (e.assigns) (e.delayed) = e.assigns; $func Get-Vars e = e; Get-Vars (e.Re) = (); Create-Aux-Vars (e.vars) e.splited-Re = ) (e.vars)> :: e.list, :: s.box, :: s.provide-i, :: s.require-i, { e.vars : e1 t.var-i e2, { e.list : e ((e.vars-Re) t.var-j) e, \{ t.var-i : t.var-j = >; e.vars-Re : e t.var-i e = ; }, $fail; e.splited-Re> :: t.Re-i, ) ())>, , ; }, $fail;; }, (/*assigns*/) (/*delayed*/)>; /* * Если есть переменная, у которой список provide пуст, её можно посчитать. * Это выражается в том, что она (вместе с присваиваемым значением) добавляется * в список assigns, убирается из списка vars, а также из всех списков provide * и delayed. В списках require её не было. * * CAV Res vars provide require assigns delayed = * { i | var_i <- vars, provide_i == [] } -> // Здесь неверно! На переменные * из delayed тоже надо смотреть. * vars = vars - var_i * provide = [ provide_j - i | provide_j <- provide ] * assigns = assigns++[(var_i, Res[i])] * delayed = [ (var_j, provide_j - i) | (var_j, provide_j) <- delayed ] * CAV Res vars provide require assigns delayed */ $func Assign-Empty-Provides e.vars = e.assigns (e.vars); Assign-Empty-Provides { e1 (t.var-i t.Re-i (/*empty provide_i*/) (e.require-i)) e2 = :: s.vars, { e1 e2 : e (t.var-j t.Re-j (e.provide-j) (e.require-j)) e, ) (e.require-j))>, $fail;; }, (t.var-i t.Re-i) >; e.vars = /*empty*/ (e.vars); }; /* * Если есть переменная, у которой список require пуст, кладём её в delayed. * Она будет посчитана, когда у неё опустеет список provide, т.е. когда не * останется переменных, у которых она в списке require. */ $func Delay-Empty-Requires e.vars = e.delayed (e.vars); Delay-Empty-Requires { e1 t.var e2, t.var : (t.var-i t.Re-i (e.provide-i) (/*empty require_i*/)) = :: e.delayed (e.vars), t.var e.delayed (e1 e.vars); e.vars = /*empty*/ (e.vars); }; /* * Выбор переменной (из двух) с более длинным списком требуемых ей значений. */ $func Max-Require e = e; Max-Require t.arg1 t.arg2 = t.arg1 : (t.var1 t.Re1 t.provide1 (e.require1)), t.arg2 : (t.var2 t.Re2 t.provide2 (e.require2)), { <"<" () ()> = t.arg2; t.arg1; }; /* * Подставить вспомогательную переменную вместо исходной во всех результатных выражениях. * Присваивание к исходной переменной убрать (оно к этому моменту уже выполнено). * Убрать переменную из списков зависимостей. */ $func Subst-Aux-Var e = e; Subst-Aux-Var t.var t.aux (t.v t.Re (e.provide) (e.require)), { t.var : t.v = /*empty*/; ( t.v () () ); }; /* * Извлечь присваивание из всей информации о переменной. */ $func Extract-Assigns e = e; Extract-Assigns (t.var t.Re e) = (t.var t.Re); /* * Основной цикл обработки присваиваний. * * 1) Из всех переменных (в том числе и отложенных), от которых больше ничего * не зависит, сделать присваивания. * 2) Все переменные, которые больше ни от чего не зависят, отложить. * 3) Если осталось хотя бы две неотложенных переменных, выбирать из них ту, * которая зависит от наибольшего числа переменных, подставить везде вместо * неё вспомогательную, перейти к пункту 1. */ CAV e.vars (e.assigns) (e.delayed) = :: e.new-assigns (e.vars), e.assigns e.new-assigns :: e.assigns (e.delayed), e.delayed :: e.delayed (e.vars), { e.vars : t t e = : (t.var t.Re e), :: t.aux, e.assigns (t.aux (t.var)) (t.var t.Re) :: e.assigns, :: e.vars, :: e.delayed, ; e.assigns ; }; ****************** Компиляция сопоставления с образцом ******************* Get-Clash-Sequence (e.last-Re) t.Pattern e.Snt = (/*e.clashes*/) (RESULT e.last-Re) t.Pattern e.Snt $iter { e.Snt : (RESULT e.Re) (s.dir e.Pe) e.rest = /* * Компилируем все константные выражения и заводим в табличке все * незаведённые переменные. У старых переменных очищается память * на предмет клешей, в которых они раньше использовались. */ : (e.R1) (e.P1), )> : e, (e.clashes (e.R1) (s.dir e.P1)) e.rest; } :: (e.clashes) e.Snt, # \{ e.Snt : \{ (RESULT e.Re) (LEFT e) e = e.Re; (RESULT e.Re) (RIGHT e) e = e.Re; } :: e.Re, ; } = (e.clashes) e.Snt; Without-Calls? e.Re = e.Re $iter { e.Re : t.Rt e.rest = t.Rt : { (CALL e) = $fail; (BLOCK e) = $fail; (PAREN e.Re1) = ; t.symbol-or-var = /*empty*/; }, e.rest; } :: e.Re, e.Re : /*empty*/; $func CC s.tail? (v.fails) t.end-cycle e.Snt = e.asail-Snt; Comp-Clashes (e.clashes) s.tail? (v.fails) e.Sentence = , e.Sentence>; $func CC-Known-Lengths t.fail e.idxs = e.conds; $func CC-Compute-Length t.fail t.end-cycle t.idx = e; $func CC-Unknown-Lengths t.fail e.idxs = e.conds; $func CC-Deref t.fail e.actions = e.actions; $func CC-Eqs t.fail (e.assigns) e.eqs = e.actions; CC s.tail? (v.fails) t.end-cycle e.Snt, { : v.clashes = ; : (t.clash) e = t.end-cycle t.clash> ; : e.clashes = :: e.conds, /* * Когда мы добрались до сюда, все условия на длины на текущем уровне * выписаны. Невыполнение любого из оставшихся условий (на * соответствие типов, равенство, длины внутри скобок) ведёт не к * прекращению текущего цикла, а переход к его следующей итерации. * Поэтому в качестве t.end-cycle везде дальше подставляется текущий * откат. */ : { v.actions = e.conds v.actions> e.Snt>; /*empty*/ = e.conds () > :: e.actions, , { :: e.assign = e.actions () e.assign> e.Snt>; { :: s.split (e.left) (e.right) (e.len) t.var t.l-var t.r-var = { e.left : 0, e.right : 0 = /*empty*/ t.var; : t.sub-var, (SUBEXPR t.sub-var t.var (e.left) ((INFIX "-" (e.len) (e.left e.right)))) t.sub-var; } :: e.subexpr t.var, { s.split : RSPLIT = t.r-var t.l-var DEC-ITER; t.l-var t.r-var INC-ITER; } :: t.l-var t.r-var s.iter-op, :: t.cont-label, :: t.break-label, e.actions e.subexpr (s.split t.var () t.l-var t.r-var) (FOR (t.cont-label) (t.break-label) () ((s.iter-op t.var)) (IF ((NOT (CHECK-ITER t.var))) >) e.Snt> (BREAK t.break-label) ); e.actions ; }; }; }; }; CC-Known-Lengths (e.fail) e.idxs, { e.idxs : (t.idx) e.rest = , : (e.len-Re) (e.len-Pe), (IF ((INFIX "!=" (e.len-Re) (e.len-Pe))) e.fail) ; ; }; CC-Compute-Length (e.fail) (e.end-cycle) t.idx = : t.var s.mult (e.minuend) (e.subtrahend), :: e.min, { t.var : (Len-Var e) = , (IF ((INFIX "<" (e.minuend) ((INFIX "+" (e.subtrahend) ((INFIX "*" (e.min) (s.mult))) )) )) e.end-cycle ); :: t.m-var e.m-assign, :: t.s-var e.s-assign, ((INFIX "<" (t.m-var) ((INFIX "+" (t.s-var) ((INFIX "*" (e.min) (s.mult))) )) )) :: e.min-cond, : { /*empty*/; e.max = ((INFIX ">" (t.m-var) ((INFIX "+" (t.s-var) ((INFIX "*" (e.max) (s.mult))) )) )); } :: e.max-cond, (INFIX "%" ((INFIX "-" (t.m-var) (t.s-var))) (s.mult)) :: e.div-cond, :: t.len-var e.len-assign, , , , :: e.clashes, >)> : e, e.m-assign e.s-assign (IF ((INFIX "||" e.min-cond e.max-cond)) e.end-cycle) (IF (e.div-cond) e.fail) e.len-assign; }; $func Get-Min e = e; $func? Get-Max e = e; CC-Unknown-Lengths (e.fail) e.idxs, { e.idxs : (t.idx) e.rest = : (e.len-Re) (e.len-Pe) (e.vars-Re) (e.vars-Pe), { :: e.max = :: e.min, ((INFIX "<" (e.len-Re e.max) (e.len-Pe e.min))); /*empty*/; } :: e.cond1, { :: e.max = :: e.min, ((INFIX ">" (e.len-Re e.min) (e.len-Pe e.max))); /*empty*/; } :: e.cond2, { e.cond1 : /*empty*/, e.cond2 : /*empty*/ = /*empty*/; (IF ((INFIX "||" e.cond1 e.cond2)) e.fail); } :: e.cond, e.cond ; ; }; Get-Min { t.var e.vars = ; /*empty*/ = /*empty*/; }; Get-Max { t.var e.vars = : v.max, v.max ; /*empty*/ = /*empty*/; }; $func Pos (e.Re) s.dir e.pos = e.pos; Pos { (e.Re) RIGHT e.pos = (INFIX "-" ((LENGTH e.Re)) (1) (e.pos)); (e.Re) LEFT e.pos = e.pos; }; /* * Информацию о проверках и заведении переменных, необходимых для создания * клешей из содержимого скобок, кодируем на ASAIL. */ CC-Deref (e.fail) e.actions, e.actions : { (SYMBOL? e.Re (s.dir e.pos)) e.rest = (IF ((SYMBOL? e.Re ())) e.fail) ; (DEREF t.var e.Re (s.dir e.pos)) e.rest = (DEREF t.var e.Re ()) ; /*empty*/ = /*empty*/; }; CC-Eqs (e.fail) (e.assigns) e.eqs, { e.eqs : ((e.Re) (s.dir e.pos) t.Pt (e.len)) e.rest = { e.Re : t, : e.len (), // FIXME: здесь надо использовать // калькулятор s.dir e.pos : \{ LEFT 0; RIGHT e.len; } = e.Re;; } :: e.Re-term, { e.len : 1 = TERM-EQ; // FIXME: здесь надо использовать // калькулятор EQ; } :: s.eq, :: e.pos, { \{ : True = t.Pt (e.Re); t.Pt : \{ (REF e); (STATIC e); }, { = e.Re-term (t.Pt); t.Pt (e.Re); }; } :: el (er), (IF ((NOT (s.eq el (er) (e.pos)))) e.fail) :: t.cond, { /* * Мы предполагаем, что во всех пришедших e.eqs все e.Re * уже были определены ранее. */ e.assigns : $r e1 (s.op t.Pt e.def) e2 = ; t.cond ; }; , { t.Pt : (SVAR e) = (IF ((NOT (SYMBOL? e.Re ()))) e.fail );; } :: e.cond, { : s = e.cond ; : e, e.cond ; }; }; e.assigns e.eqs; }; Gener-Label e.QualifiedName = { : s.num, <"+" s.num 1>; 1; } :: s.num, , (e.QualifiedName s.num); Add-To-Label (e.label) e.name = ; Lookup-Func t.Fname, \{ ; ; } : s.linkage s.tag t.pragma (e.Fin) (e.Fout) = s.linkage s.tag t.pragma (e.Fin) (e.Fout);