diff options
Diffstat (limited to 'toolbin/transform_dsl.pl')
| -rwxr-xr-x | toolbin/transform_dsl.pl | 276 |
1 files changed, 276 insertions, 0 deletions
diff --git a/toolbin/transform_dsl.pl b/toolbin/transform_dsl.pl new file mode 100755 index 0000000..ebb1241 --- /dev/null +++ b/toolbin/transform_dsl.pl @@ -0,0 +1,276 @@ +#!/usr/bin/perl6 +use v6; + +grammar DSL { + my $e = "document start"; + token TOP { ^ <include_block>* <quant_block>* $ } + + token include_block { + 'include' \s+ '"' <filename> '"' \s* ';' \s* + } + token quant_block { + <quant_type> \s+ <name> \s* '{' \s* + [[{$e=$/} <decl>|<evolve>|<on_block>|<emit_block>|<comment>] \s*] * + \s* '}' \s* } + token on_block { + 'on' \s+ <name> \s* '{' \s* + [[{$e=$/} <evolve>|<comment>] \s*] * + \s* '}' } + token emit_block { + 'emit' \s+ <name> \s* '{' \s* + [[{$e=$/} <evolve>|<default>|<after>|<if_>|<comment>] \s*] * + \s* '}' } + + token decl { <type> \s+ <name> \s* ['=' \s* <expr> \s*]? ';' } + token evolve { <name>\' \s* '=' \s* <expr> \s* ';' } + token default { 'default' \s+ <bool> \s* ';' } + token if_ { 'if' \s+ <name>\' <expr> \s* ';' } + token after { 'after' \s+ <expr> \s* ';' } + token comment { '//' \N* $$ } + + token name { \w+ } + token filename { \w+ } + token type { [':'|\w]+ } + token quant_type { ['discrete'|'continuous'|'const'] } + token bool { ['true'|'false'] } + token expr { <-[;{}]>* } # MAYBE TODO: improve + + method error() { + return $e; + } +} + +sub transform($quant_blocks) { + my %quant_types; + my %vars; + my %consts; + my %res = :const(''), :decl(''), :evolve(''), :on(''), + :qdq(''), :emit(''), :gpe(''), :gen(''), :debug(''); + + my %rawexpr_evolve; + + # funs to replace def strings to C++-Code + sub replace_consts($expr is copy) { + for %consts.kv -> $name, $val { + $expr = $expr.subst(rx/<<$name>>/, "$val /* $name */", :g); + } + return $expr; + } + + sub replace_dt($expr is copy) { + $expr = $expr.subst(rx/<<'dt'>>/, "td()", :g); + return $expr; + } + + sub replace_expr($expr is copy, %local_exprs) { + # replace post-event vars ONCE + for %vars.kv -> $prop, $quant { + # post event is only defined for continuous quants + next if %quant_types{$quant} eq 'discrete'; + $expr = $expr.subst(rx/<<$prop>>"'"/, "(%local_exprs{$prop})", :g); + } + return $expr; + } + + sub replace_vars($expr is copy) { + # replace normal vars + for %vars.kv -> $prop, $quant { + if %quant_types{$quant} eq 'continuous' { + $expr = $expr.subst(rx/<<$prop>>/, "_CP($prop)", :g); + } else { + die unless %quant_types{$quant} eq 'discrete'; + $expr = $expr.subst(rx/<<$prop>>/, "_DP($prop)", :g); + } + } + return $expr; + } + + sub replace_all($expr is copy, %local_exprs) { + $expr = replace_consts( + replace_dt( + replace_vars( + replace_expr($expr, %local_exprs)))); + $expr = $expr.subst(rx/"_PROT">>/, "q", :g); + return $expr; + } + + sub replace_all_after($expr is copy, %local_exprs) { + $expr = $expr.subst(rx/"'"/, "_PROTTICK", :g); + $expr = replace_vars($expr); + $expr = $expr.subst(rx/"_PROTTICK"/, "'", :g); + return replace_consts( + replace_expr($expr, %local_exprs)); + } + + # gather all properties (required to patch expressions) + for @($quant_blocks) { + my $qc = $_<name>; + my $qt = $_<quant_type>; + %quant_types{$qc} = $qt; + for @($_<decl>) { + my $name = $_<name>; + if $qt eq 'const' { + if not %consts{$name} { + my $type = $_<type>; + %consts{$name} = $_<expr>; + %res<const> ~= "const $type $name = $_<expr>;\n"; + } + } else { + die "multiple declaration of $_<name>" if %(%vars, %consts){$name}; + %vars{$name} = $qc; + } + } + for @($_<evolve>) { %rawexpr_evolve{$_<name>} = $_<expr>; } + } + + # print definitions + for @($quant_blocks) { + my $qc = $_<name>; + my $emit = $_<emit_block>; + my %types; + next if ($qc eq 'const'); + %res = %res <<~>> "// Quantor: $qc\n"; + for @($_<decl>) { + %types{$_<name>} = $_<type>; + if %quant_types{%vars{$_<name>}} eq 'continuous' { + %res<decl> ~= + "GEN_CP($qc, $_<name>, \"$_<name>\", $_<type>, (" + ~ replace_consts($_<expr>) ~ "));\n"; + } else { + %res<decl> ~= + "GEN_DP($qc, $_<name>, \"$_<name>\", $_<type>);\n"; + } + } + for @($_<evolve>) { + %res<evolve> ~= "GEN_CP_EVOLVE($_<name>, " + ~ replace_all($_<expr>, %rawexpr_evolve) ~ ");\n"; + } + for @($_<emit_block>) { + my $dqc = $_<name>; + my %rawexpr_emit = + gather for @($_<evolve>) { take %($_<name>, $_<expr>); }; + my %rawexpr_after = + gather for @(%vars) { my $k=$_.key; take %($k, "_TP($k)"); }; + + %res<emit> ~= "GEN_QUANT_EMIT($qc, $dqc, $_<default>[0]<bool>);\n"; + if $_<after>.elems > 0 { + # TODO: generate has-var-delay statement at most + # once per discrete quant + %res<emit> ~= + "GEN_QUANT_HASVARDELAY($dqc);\n" + ~ "GEN_DP_DELAY($dqc, $qc, " + ~ replace_all_after($_<after>[0]<expr>, %rawexpr_after) + ~ ");\n"; + } + for @($_<evolve>) { + die "$_<name> of %vars{$_<name>} != $qc, $dqc" + unless (%vars{$_<name>} eq $dqc) || (%vars{$_<name>} eq $qc); + %res<gpe> ~= + "GEN_CP_GENERATE($qc, $dqc, $_<name>) \{ " + ~ "value = " ~ replace_all($_<expr>, %rawexpr_emit) + ~ "; \}\};\n"; + } + } + for @($_<on_block>) { + my $src_quant = $_<name>; + %res<qdq> ~= "GEN_QDQ($_<name>, $qc);\n"; + my %is_evolved; + my %rawexpr_on = + gather for @($_<evolve>) { take %($_<name>, $_<expr>); }; + for @($_<evolve>) { + my $dprop = $_<name>; + %res<on> ~= "GEN_CP_APPLY($dprop, $src_quant, true) \{\n" + ~ " const %types{$dprop} tmp = " + ~ replace_all($_<expr>, %rawexpr_on) ~ ";\n" + ~ " transaction.template set<$dprop>(tmp);\n"; + for @($emit) { + my $dst_quant = $_<name>; + my %rawexpr_emit = + gather for @($_<evolve>) { take %($_<name>, $_<expr>); }; + for @($_<if_>) { + if $_<name> eq $dprop { + # %res<on> ~= "std::cout << \"combine(tmp($dprop" ~ replace_consts($_<expr>) ~ ")\" << std::endl;"; + %res<on> ~= " intent.template get<$dst_quant>()" + ~ ".combine(tmp" ~ replace_consts($_<expr>) + ~ ");\n"; + } + } + } + %res<on> ~= "\}\};\n"; # sic! + %is_evolved{$dprop} = True; + } + for @($emit) { + my $dst_quant = $_<name>; + for @($_<if_>) { + unless %is_evolved{$_<name>} { + # HINT: use _CP for access because the value is unchanged + %res<on> ~= + "GEN_CP_APPLY($_<name>, $src_quant, false) \{\n" + # ~ "std::cout << \"combine(_CP($_<name>" ~ replace_consts($_<expr>) ~ ")\" << std::endl;" + ~ " intent.template get<$dst_quant>()" + ~ ".combine(_CP($_<name>)" ~ replace_consts($_<expr>) + ~ ");\n\}\};\n"; + # TODO: replace consts + } + } + } + } + } + + # create list of + %res<lists> = + "typedef boost::mpl::list<\n\t" + ~ %vars.keys.map({"boost::mpl::pair<$_, boost::mpl::bool_<true>>"}).join(",\n\t") + ~ "\n> all;\n\n" + ~ "typedef boost::mpl::list<\n\t" + ~ %vars.keys.map({"boost::mpl::pair<$_, boost::mpl::bool_<false>>"}).join(",\n\t") + ~ "\n> all_ro;"; + + # push results + %res = %res <<~>> "\n"; + say "#ifndef RASIMU_SIMULATION_DEFINITION +#define RASIMU_SIMULATION_DEFINITION + +#include \"core/property_abbrevations_begin.hpp\" + +namespace ModelConsts \{ +%res<const> +\} +%res<decl> +%res<evolve> +%res<on> +%res<qdq> +%res<emit> +%res<gen> +%res<gpe>"," + +namespace Lists \{ +%res<lists>"," +\} + +// generated by ",qqx{perl6 --version|grep version}," + +/* DEBUG MSGS +%res<debug> +*/ +#include \"core/property_abbrevations_end.hpp\" +#endif // RASIMU_SIMULATION_DEFINITION"; +} + +sub parse($src) { + my $p = DSL.new; + if $p.parse(slurp $src) { + my @qbs = @($<quant_block>); + for @($<include_block>) { + @qbs.push(parse($_<filename> ~ ".model")); + } + return @qbs; + } else { + die "Error after:\n", $p.error; + } +} + +sub MAIN($src) { + transform(parse($src)); + #parse($src).perl.say; +} |