Initial commitHEADmaster

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;
+}