[Projects] XRM 29: Clean up the code and add more tests.

https://svn.lrde.epita.fr/svn/xrm/trunk Index: ChangeLog from SIGOURE Benoit &lt;sigoure.benoit(a)lrde.epita.fr&gt; Clean up the code and add more tests. * src/str/xrm-to-prism.str: Big chunks moved to ... * src/str/check-meta-vars.str: this and... * src/str/desugar-array-accesses.str: this and... * src/str/eval-meta-code.str: this. * src/str/ice.str: New. * src/str/prism-desugar.str: Change some comments. * tests/test-pp-prism.sh.in: Add more tests. * tests/test-parse-xrm.sh.in: Ditto. * tests/test-parse-prism.sh.in: Ditto. * tests/test-pp-xrm.sh.in: Ditto. src/str/check-meta-vars.str | 60 ++++++++++ src/str/desugar-array-accesses.str | 66 +++++++++++ src/str/eval-meta-code.str | 113 ++++++++++++++++++ src/str/ice.str | 22 +++ src/str/prism-desugar.str | 8 - src/str/xrm-to-prism.str | 222 ++----------------------------------- tests/test-parse-prism.sh.in | 2 tests/test-parse-xrm.sh.in | 2 tests/test-pp-prism.sh.in | 2 tests/test-pp-xrm.sh.in | 2 10 files changed, 282 insertions(+), 217 deletions(-) Index: src/str/check-meta-vars.str --- src/str/check-meta-vars.str (revision 0) +++ src/str/check-meta-vars.str (revision 0) @@ -0,0 +1,60 @@ +/* +** This sub-module is used to check that meta-vars are correctly used +** throughout the program. This implies: +** - checking that they have been defined when they're used +** - checking that they are not redefined in the same scope +** - checking that some expressions are only using meta-variables to +** ensure that they are statically evaluable. (eg: array subscripts, +** meta-if conditions) +*/ +module check-meta-vars + +strategies + + check-meta-vars = + check-meta-for + <+ check-meta-if + <+ ArrayAccess(id, check-all-identifers-are-meta-vars) + <+ ArrayAccessPrime(id, check-all-identifers-are-meta-vars) + <+ all(check-meta-vars) + + check-meta-for = + ?MetaFor(new-meta-var, from, to, step, body) + ; where({| MetaVars: + <add-meta-var> new-meta-var + ; <check-all-identifers-are-meta-vars> from + ; <check-all-identifers-are-meta-vars> to + ; <check-all-identifers-are-meta-vars> step + ; <check-meta-vars> body + |}) + + check-meta-if = + ?MetaIf(condition, then-part, else-part) + ; where( + <check-all-identifers-are-meta-vars> condition + ; <check-meta-vars> then-part + ; <check-meta-vars> else-part + ) + + check-all-identifers-are-meta-vars = + (?Identifier(_); check-meta-var-declared) + <+ all(check-all-identifers-are-meta-vars) + + add-meta-var = + check-meta-var-unicity + ; ?meta-var + ; rules(MetaVars: meta-var) + + check-meta-var-declared = + ?Identifier(idf) + ; if not(<MetaVars> Identifier(idf)) then + err-msg(|<concat-strings>["undeclared meta-var: ", idf]) + ; <xtc-exit> 2 + end + + check-meta-var-unicity = + ?Identifier(idf) + ; if <MetaVars> Identifier(idf) then + err-msg(|<concat-strings>["meta-var already defined: ", idf]) + ; <xtc-exit> 2 + end Index: src/str/desugar-array-accesses.str --- src/str/desugar-array-accesses.str (revision 0) +++ src/str/desugar-array-accesses.str (revision 0) @@ -0,0 +1,66 @@ +module desugar-array-accesses + +rules + + /** + ** Transform an array access into an identifier (eg: x[i] -> x_i) + */ + remove-array-accesses: + ArrayAccess(Identifier(idf), access-list) -> Identifier(idf') + where flatten-access-list(|idf, access-list) => idf' + + remove-array-accesses: + ArrayAccessPrime(Identifier(idf), access-list) -> IdentifierPrime(idf') + where flatten-access-list(|idf, access-list) => idf' + +strategies + + /** + ** @internal + ** Transform an access list (in array accesses) into a flat variable name + ** eg: flatten-access-list(|"x", [Int("1"), Int("2")]) -> "x_1_2" + ** NOTE: The access list can contain expressions as long as it possible to + ** evaluate them down to a constant positive Int() value. + ** + ** @param idf String + ** @param access-list List of Int() + */ + flatten-access-list(|idf, access-list) = + /* eval meta expressions in the access-list + * eg: Plus(Int("1"), Int("2")) -> Int("3") */ + <prism-desugar> access-list + + /* Now the access must only contain a list of Int: [Int("1"), Int("2"), ..] + * So we can remove the Int() constructor. */ + ; map(\ Int(i) -> i \ <+ invalid-array-access) + + /* Now we have a list of strings such as: ["1", "2", ...] + * Check that the list only contains positive integers as strings */ + ; try(map(string-to-int; neg; invalid-array-access)) + + /* Insert underscores between each integer */ + ; separate-by(|"_") + + /* Produce the final identifier: eg: idf_1_2 */ + ; <concat-strings> [idf, "_" | <id>] + + /** + ** @internal + ** Report invalid array accesses. + */ + invalid-array-access = + if ?Identifier(i) then + ice(|"invalid-array-access", <concat-strings>["internal compiler error: ", + "undeclared meta-variable: ", i, + " (should have been detected earlier!)"]) + else + if (is-int; neg) then + err-msg(|"error: negative array subscript detected:") + ; debug + ; <xtc-exit> 2 + else + err-msg(|"error: non constant term in array access:") + ; debug + ; <xtc-exit> 2 + end + end Index: src/str/xrm-to-prism.str --- src/str/xrm-to-prism.str (revision 28) +++ src/str/xrm-to-prism.str (working copy) @@ -1,7 +1,14 @@ +/* +** This sub-module does the real work of the front-end. It transforms the +** program into a valid PRISM AST. +*/ module xrm-to-prism imports XRM prism-desugar + desugar-array-accesses + check-meta-vars + eval-meta-code strategies @@ -34,6 +41,7 @@ xrm-to-prism-desugar: |[ e1 << e2 ]| -> |[ e1 * func(pow, 2, e2) ]| + // if the step is not specified, it is implicitely set to 1 xrm-to-prism-desugar: MetaFor(identifier, from, to, body) -> MetaFor(identifier, from, to, Int("1"), body) @@ -43,74 +51,10 @@ //|[ if e then s* end ]| -> |[ if e then s* else end ]| MetaIf(e, m*) -> MetaIf(e, m*, []) -rules - - /** - ** Transform an array access into an identifier (eg: x[i] -> x_i) - */ - remove-array-accesses: - ArrayAccess(Identifier(idf), access-list) -> Identifier(idf') - where flatten-access-list(|idf, access-list) => idf' - - remove-array-accesses: - ArrayAccessPrime(Identifier(idf), access-list) -> IdentifierPrime(idf') - where flatten-access-list(|idf, access-list) => idf' - strategies /** - ** @internal - ** Transform an access list (in array accesses) into a flat variable name - ** eg: flatten-access-list(|"x", [Int("1"), Int("2")]) -> "x_1_2" - ** NOTE: The access list can contain expressions as long as it possible to - ** evaluate them down to a constant positive Int() value. - ** - ** @param idf String - ** @param access-list List of Int() - */ - flatten-access-list(|idf, access-list) = - /* eval meta expressions in the access-list - * eg: Plus(Int("1"), Int("2")) -> Int("3") */ - <prism-desugar> access-list - - /* Now the access must only contain a list of Int: [Int("1"), Int("2"), ..] - * So we can remove the Int() constructor. */ - ; map(\ Int(i) -> i \ <+ invalid-array-access) - - /* Now we have a list of strings such as: ["1", "2", ...] - * Check that the list only contains positive integers as strings */ - ; try(map(string-to-int; neg; invalid-array-access)) - - /* Insert underscores between each integer */ - ; separate-by(|"_") - - /* Produce the final identifier: eg: idf_1_2 */ - ; <concat-strings> [idf, "_" | <id>] - - /** - ** @internal - ** Report invalid array accesses. - */ - invalid-array-access = - if ?Identifier(i) then - fatal-err-msg(|<concat-strings>["internal compiler error: ", - "undeclared meta-variable: ", i, - " (should have been detected earlier!)"]) - else - if (is-int; neg) then - err-msg(|"error: negative array subscript detected:") - ; debug - ; <xtc-exit> 2 - else - err-msg(|"error: non constant term in array access:") - ; debug - ; <xtc-exit> 2 - end - end - -strategies - - /** Re-order modules so that the declarations are separated from the + ** Re-order modules so that the declarations are separated from the ** commands, as required by the original PRISM grammar. */ reorder-module-contents = @@ -119,9 +63,9 @@ Module(id, map(add-command <+ add-declaration)) ; where( bagof-DeclarationList - ; reverse - ; ?dec-list - ; bagof-CommandList + ; reverse /* We reverse the result of bagof-* */ + ; ?dec-list /* because it yields the dynamic */ + ; bagof-CommandList /* rules' content in reverse order */ ; reverse ; ?cmd-list ) @@ -138,145 +82,3 @@ add-declaration = ?current-term ; rules(DeclarationList:+ _ -> current-term) - -strategies - - check-meta-vars = - check-meta-for - <+ check-meta-if - <+ ArrayAccess(id, check-all-identifers-are-meta-vars) - <+ ArrayAccessPrime(id, check-all-identifers-are-meta-vars) - <+ all(check-meta-vars) - - check-meta-for = - ?MetaFor(new-meta-var, from, to, step, body) - ; where({| MetaVars: - <add-meta-var> new-meta-var - ; <check-all-identifers-are-meta-vars> from - ; <check-all-identifers-are-meta-vars> to - ; <check-all-identifers-are-meta-vars> step - ; <check-meta-vars> body - |}) - - check-meta-if = - ?MetaIf(condition, then-part, else-part) - ; where( - <check-all-identifers-are-meta-vars> condition - ; <check-meta-vars> then-part - ; <check-meta-vars> else-part - ) - - check-all-identifers-are-meta-vars = - (?Identifier(_); check-meta-var-declared) - <+ all(check-all-identifers-are-meta-vars) - - add-meta-var = - check-meta-var-unicity - ; ?meta-var - ; rules(MetaVars: meta-var) - - check-meta-var-declared = - ?Identifier(idf) - ; if not(<MetaVars> Identifier(idf)) then - err-msg(|<concat-strings>["undeclared meta-var: ", idf]) - ; <xtc-exit> 2 - end - - check-meta-var-unicity = - ?Identifier(idf) - ; if <MetaVars> Identifier(idf) then - err-msg(|<concat-strings>["meta-var already defined: ", idf]) - ; <xtc-exit> 2 - end - -strategies - - eval-meta-code = - eval-meta-if - <+ unroll-meta-loops - <+ all(eval-meta-code) - -strategies - - eval-meta-if = - ?MetaIf(condition, then-part, else-part) - /*DEBUG*/; say(!" @@@ eval-meta-if: starting:") - /*DEBUG*/; printf(|" condition = ", condition) - ; where(<prism-desugar> condition => condition-value) - /*DEBUG*/; printf(|" condition-value = ", condition-value) - ; if !condition-value => True() then - <eval-meta-code> then-part - else - if !condition-value => False() then - <eval-meta-code> else-part - else - fatal-err-msg(|"internal compiler error in eval-meta-if") - end - end - -strategies - - unroll-meta-loops = - ?MetaFor(meta-var, Int(from), Int(to), Int(step), body) - ; where(check-loop-validity(|meta-var, from, to)) - ; {| MetaCode: - /*DEBUG*/say(!" @@@ unroll-meta-loops: starting:") - /*DEBUG*/; printf(|" meta-var = ", meta-var) - /*DEBUG*/; printf(|" from = ", from) - /*DEBUG*/; printf(|" to = ", to) - ; where(<check-meta-var-unicity> meta-var) - ; for-loop(gen-meta-code | from, to, step, []) - /*DEBUG*/; say(!" ~~~ unroll-meta-loops: before bagof-MetaModule") - /*DEBUG*/; debug - ; bagof-MetaCode - ; reverse - /*DEBUG*/; say(!" ~~~ unroll-meta-loops: after bagof-MetaModule") - /*DEBUG*/; debug - |} - - check-loop-validity(|meta-var, from, to) = - if <gtS>(from, to) then - !meta-var => Identifier(idf) - ; err-msg(|<concat-strings>["bad `for' loop on the meta-var ", - idf, " starts at ", from, - " which is less than ", to]) - ; <xtc-exit> 2 - end - -strategies - - gen-meta-code(|i, args) = - /*DEBUG*/say(!" ### gen-meta-code starting"); debug; - (?MetaFor(meta-var, _, _, _, body) <+ fatal-err-msg(|"ICE!")) - /*DEBUG*/; say(!" >>> gen-meta-code -- start -- current term >>>") - /*DEBUG*/; debug - /*DEBUG*/; say(!" >>> gen-meta-code -- start -- iterator >>>") - /*DEBUG*/; printf(|" meta-var = ", meta-var) - /*DEBUG*/; printf(|" i = ", i) - /*DEBUG*/; say(!" <<< gen-meta-code -- propagating meta-var's value <<< ") - ; !body - ; topdown(try(?meta-var; !Int(i))) - /*DEBUG*/; debug - /*DEBUG*/; say(!" ~~~ gen-meta-code: now recursing") - ; eval-meta-code => generated-code - ; rules(MetaCode:+ _ -> generated-code) - /*DEBUG*/; say(!" ~~~ gen-meta-code: recursion finished, final result:") - /*DEBUG*/; debug - /*DEBUG*/; say(!" <<<<<<<<<<<<<<<<< gen-meta-code <<<<<<<<<<<<<<<<< ") - -strategies - /*DEBUG*/printf(|str, term) = where(<fprintnl> (stderr, [str, term])) - - /** - * for-loop(s | low, up, step, data) - * <=> in C: - * for(i = low; i <= up; i += step) - * s(|i, data) - */ - for-loop(s : Int * a * List(a) -> a | low, up, step, data) = - /*DEBUG*/where(say(!"--- for-loop ---"); printf(|" i = ", low) - /*DEBUG*/ ; printf(|" up = ", up); printf(|" step = ", step)); - if <leqS>(low, up) then - where(s(|low, data)) - ; for-loop(s | <addS>(low, step), up, step, data) - end Index: src/str/ice.str --- src/str/ice.str (revision 0) +++ src/str/ice.str (revision 0) @@ -0,0 +1,22 @@ +/* +** Handle internal errors (things that should not happen) +*/ +module ice + +strategies + + ice(|calling-strategy-name) = ice(|calling-strategy-name, "unknown reason") + + /** Reports an ICE and exit 42 */ + ice(|calling-strategy-name, reason) = + log(|Critical(), <concat-strings>["internal compiler error in strategy ", + calling-strategy-name, ": ", reason]) + ; <xtc-exit> 42 + + ice(|calling-strategy-name, reason, term) = + // FIXME: if has-annotation ... + log(|Critical(), <concat-strings>["internal compiler error in strategy ", + calling-strategy-name, ": ", reason]) + ; !term + ; debug + ; <xtc-exit> 42 Index: src/str/prism-desugar.str --- src/str/prism-desugar.str (revision 28) +++ src/str/prism-desugar.str (working copy) @@ -29,7 +29,7 @@ IntToDouble: Int(i) -> Double(i) - // Transform a round (or almost round) Double into an Int. + /** Transforms a round (or almost round) Double into an Int. */ SimplifyDoubles: Double(d) -> Int(i) // eg: Double("41.9999999999999") -> Int("42") where !d // "41.9999999999999" @@ -40,7 +40,7 @@ // strcmp(decimals, "000000") == 0 ? id : fail ; !decimals => "000000" - // Round real numbers up to 6 digits and remove trailing zeros + /** Round real numbers up to 6 digits and remove trailing zeros */ TruncateDouble: Double(d) -> Double(d') where <rtrim-chars(?'0')> (<real-to-string(|6)> (<string-to-real> d)) => d' @@ -48,6 +48,7 @@ rules /** + ** Remove conditionnal updates. ** [] guard -> unconditionnal-update-list; ** is rewritten as: ** [] guard -> 1:(unconditionnal-update-list); @@ -61,9 +62,10 @@ */ strategies - // used by the rules below to evaluate constant comparisons + /** @internal used by the rules below to evaluate constant comparisons */ compare(s) = if s then !True() else !False() end + /** @internal report divisions by zero detected during constant exp eval */ catch-div-by-zero = ?|[ e / 0D ]| ; err-msg(|"Division by zero detected:") Index: src/str/eval-meta-code.str --- src/str/eval-meta-code.str (revision 0) +++ src/str/eval-meta-code.str (revision 0) @@ -0,0 +1,113 @@ +/** +** This sub-module does all the meta-code evaluation and generation. +** XRM modules can contain meta for loops as well as meta if statements +** which have to evaluated and transformed in PRISM source code. +** +** NOTE: This is a tricky part so debugging stuff have been kept and +** commented out instead of being deleted. Hopefully this will make +** debugging easier. This might also make the code easier to understand. +** Sorry if it makes the source a bit overloaded with comments. +** +** If you want to enable debugging simply use: +** sed 's@///\*@/*@g' < eval-meta-code.str > .tmp +** mv .tmp eval-meta-code.str +*/ +module eval-meta-code +imports ice + +strategies + + eval-meta-code = + eval-meta-if + <+ unroll-meta-loops + <+ all(eval-meta-code) + +strategies + + eval-meta-if = + ?MetaIf(condition, then-part, else-part) + ///*DEBUG*/; say(!" @@@ eval-meta-if: starting:") + ///*DEBUG*/; printf(|" condition = ", condition) + ; where(<prism-desugar> condition => condition-value) + ///*DEBUG*/; printf(|" condition-value = ", condition-value) + ; if !condition-value => True() then + <eval-meta-code> then-part + else + if !condition-value => False() then + <eval-meta-code> else-part + else + ice(|"eval-meta-code", <concat-strings> [ + "the conditionnal test of a meta if could ", + "not be reduced to a single value (True or", + " False), this should have been detected ", + "earlier"], + condition) + end + end + +strategies + + unroll-meta-loops = + ?MetaFor(meta-var, Int(from), Int(to), Int(step), body) + ; where(check-loop-validity(|meta-var, from, to)) + ; {| MetaCode: + ///*DEBUG*/say(!" @@@ unroll-meta-loops: starting:") + ///*DEBUG*/; printf(|" meta-var = ", meta-var) + ///*DEBUG*/; printf(|" from = ", from) + ///*DEBUG*/; printf(|" to = ", to); + where(<check-meta-var-unicity> meta-var) + ; for-loop(gen-meta-code | from, to, step, []) + ///*DEBUG*/; say(!" ~~~ unroll-meta-loops: before bagof-MetaModule") + ///*DEBUG*/; debug + ; bagof-MetaCode + ; reverse + ///*DEBUG*/; say(!" ~~~ unroll-meta-loops: after bagof-MetaModule") + ///*DEBUG*/; debug + |} + + check-loop-validity(|meta-var, from, to) = + if <gtS>(from, to) then + !meta-var => Identifier(idf) + ; err-msg(|<concat-strings>["bad `for' loop on the meta-var ", + idf, " starts at ", from, + " which is less than ", to]) + ; <xtc-exit> 2 + end + +strategies + + gen-meta-code(|i, args) = + ///*DEBUG*/say(!" ### gen-meta-code starting"); debug; + (?MetaFor(meta-var, _, _, _, body) <+ fatal-err-msg(|"ICE!")) + ///*DEBUG*/; say(!" >>> gen-meta-code -- start -- current term >>>") + ///*DEBUG*/; debug + ///*DEBUG*/; say(!" >>> gen-meta-code -- start -- iterator >>>") + ///*DEBUG*/; printf(|" meta-var = ", meta-var) + ///*DEBUG*/; printf(|" i = ", i) + ///*DEBUG*/; say(!" <<< gen-meta-code -- propagating meta-var's value <<< ") + ; !body + ; topdown(try(?meta-var; !Int(i))) + ///*DEBUG*/; debug + ///*DEBUG*/; say(!" ~~~ gen-meta-code: now recursing") + ; eval-meta-code => generated-code + ; rules(MetaCode:+ _ -> generated-code) + ///*DEBUG*/; say(!" ~~~ gen-meta-code: recursion finished, final result:") + ///*DEBUG*/; debug + ///*DEBUG*/; say(!" <<<<<<<<<<<<<<<<< gen-meta-code <<<<<<<<<<<<<<<<< ") + +strategies + ///*DEBUG*/printf(|str, term) = where(<fprintnl> (stderr, [str, term])) + + /** + * for-loop(s | low, up, step, data) + * <=> in C: + * for(i = low; i <= up; i += step) + * s(|i, data) + */ + for-loop(s : Int * a * List(a) -> a | low, up, step, data) = + ///*DEBUG*/where(say(!"--- for-loop ---"); printf(|" i = ", low) + ///*DEBUG*/ ; printf(|" up = ", up); printf(|" step = ", step)); + if <leqS>(low, up) then + where(s(|low, data)) + ; for-loop(s | <addS>(low, step), up, step, data) + end Index: tests/test-pp-prism.sh.in --- tests/test-pp-prism.sh.in (revision 28) +++ tests/test-pp-prism.sh.in (working copy) @@ -20,7 +20,7 @@ outdir="`pwd`" cd .. -for file in `find "@srcdir@" -name '*.pm' | sort`; do +for file in `find "@srcdir@" -name '*.pm' -o -name '*.nm' -o -name '*.sm' | sort`; do basefile="`basename $file`" bfile="`echo \"$basefile\" | sed 's/\.pm$//'`" Index: tests/test-parse-xrm.sh.in --- tests/test-parse-xrm.sh.in (revision 28) +++ tests/test-parse-xrm.sh.in (working copy) @@ -11,7 +11,7 @@ test_cnt=0 test_pass=0 -for file in `find "@srcdir@" -name '*.pm' -o -name '*.xpm' | sort`; do +for file in `find "@srcdir@" -name '*.pm' -o -name '*.nm' -o -name '*.sm' -o -name '*.xpm' | sort`; do echo @ECHO_N@ " Parsing `basename $file` ... " "@top_builddir@/src/tools/parse-xrm" -i "$file" -o /dev/null if [ $? -eq 0 ]; then Index: tests/test-parse-prism.sh.in --- tests/test-parse-prism.sh.in (revision 28) +++ tests/test-parse-prism.sh.in (working copy) @@ -11,7 +11,7 @@ test_cnt=0 test_pass=0 -for file in `find "@srcdir@" -name '*.pm' | sort`; do +for file in `find "@srcdir@" -name '*.pm' -o -name '*.nm' -o -name '*.sm' | sort`; do echo @ECHO_N@ " Parsing `basename $file` ... " "@top_builddir@/src/tools/parse-prism" -i "$file" -o /dev/null if [ $? -eq 0 ]; then Index: tests/test-pp-xrm.sh.in --- tests/test-pp-xrm.sh.in (revision 28) +++ tests/test-pp-xrm.sh.in (working copy) @@ -20,7 +20,7 @@ outdir="`pwd`" cd .. -for file in `find "@srcdir@" -name '*.pm' -o -name '*.xpm' | sort`; do +for file in `find "@srcdir@" -name '*.pm' -o -name '*.nm' -o -name '*.sm' -o -name '*.xpm' | sort`; do basefile="`basename $file`" bfile="`echo \"$basefile\" | sed 's/\.x\?pm$//'`"