writecmds.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use YAML;
   7 use POSIX qw(strftime);
   8
   9 my %tdisp = (
  10         'any' => 'CI_ANYVALUE',
  11         'float' => 'CI_NUMERIC',
  12         'integer' => 'CI_NUMERIC',
  13         'string' => 'CI_STRING',
  14         'agent' => 'CI_AGENT',
  15         'bytestring' => 'CI_BYTESTR',
  16         'variable' => 'CI_VARIABLE',
  17         'any' => 'CI_OTHER',
  18         'anything' => 'CI_OTHER',
  19         'condition' => undef,
  20         'comparison' => undef,
  21         'decimal' => 'CI_NUMERIC',
  22         'decimal variable' => 'CI_OTHER',
  23         'byte-string' => 'CI_BYTESTR',
  24         'label' => undef,
  25         'vector' => 'CI_VECTOR',
  26         'bareword' => 'CI_BAREWORD',
  27         'token' => 'CI_BAREWORD',
  28         'subcommand' => 'CI_SUBCOMMAND',
  29         'command' => 'CI_COMMAND',
  30 );
  31
  32 # zero-tolerance policy
  33 $SIG{__WARN__} = sub { die $_[0] };
  34
  35 my $data = YAML::LoadFile($ARGV[0]);
  36
  37 my $disp_id = 1;
  38 my %disp_tbl;
  39 my @init_funcs;
  40
  41 print qq{// THIS IS AN AUTOMATICALLY GENERATED FILE\n};
  42 print qq{// DO NOT EDIT\n};
  43 print qq{// Generated at }, strftime("%c", localtime(time)), qq{\n};
  44 print qq{\n\n};
  45 print qq{#include <string>\n};
  46 print qq{#include <cstdio>\n};
  47 print qq{#include <climits>\n};
  48 print qq{#include "cmddata.h"\n};
  49 print qq{#include "caosVM.h"\n};
  50 print qq{#include "dialect.h"\n};
  51 print qq{#include "openc2e.h"\n};
  52 print qq{\n\n};
  53
  54 foreach my $variant_name (sort keys %{$data->{variants}}) {
  55         my $variant = $data->{variants}{$variant_name};
  56         for my $key (keys %$variant) {
  57                 $variant->{$key}{key} = $key;
  58         }
  59         my @cmds = values %$variant;
  60
  61         inject_ns(\@cmds);
  62         writelookup(\@cmds);
  63         checkdup(\@cmds, "$variant_name commands");
  64         sortname(\@cmds);
  65         miscprep($variant_name, \@cmds);
  66
  67         printarr(\@cmds, $variant_name, "${variant_name}_cmds");
  68
  69         printinit($variant_name, "${variant_name}_cmds");
  70 }
  71
  72 printdispatch();
  73
  74 print "void registerAutoDelegates() {\n";
  75 for my $f(@init_funcs) {
  76         print "\t$f();\n";
  77 }
  78 print "}\n";
  79
  80
  81 exit 0;
  82
  83 sub miscprep {
  84         my ($variant, $cmds) = @_;
  85
  86         for my $cmd (@$cmds) {
  87                 $cmd->{evalcost}{$variant} = $cmd->{evalcost}{default} unless defined $cmd->{evalcost}{$variant};
  88                 if ($cmd->{type} ne 'command' && $cmd->{evalcost}{$variant} != 0) {
  89                         print STDERR "$cmd->{lookup_key} has non-zero evalcost in an expression cost.";
  90                         print STDERR "This causes a race condition which can potentially lead to crashes.";
  91                         print STDERR "If you really need this, please contact bd_. Aborting for now.";
  92                         exit 1;
  93                 }
  94         }
  95 }
  96
  97 sub printinit {
  98         my ($variant, $cmdarr, $exparr) = @_;
  99         print "static void init_$variant() {\n";
 100         print qq{\tdialects["$variant"] = boost::shared_ptr<Dialect>(new Dialect($cmdarr, std::string("$variant")));\n};
 101         print "}\n";
 102         push @init_funcs, "init_$variant";
 103 }
 104
 105 sub printdispatch {
 106         print "#ifdef VCPP_BROKENNESS\n";
 107         print "void dispatchCAOS(class caosVM *vm, int idx) {\n";
 108         print "\tswitch (idx) {\n";
 109         for my $impl (keys %disp_tbl) {
 110                 print "\t\tcase $disp_tbl{$impl}: vm->$impl(); break;\n";
 111         }
 112         print qq{\t\tdefault:\n\t\t\{\n};
 113         print qq{\t\t\tchar buf[256];\n};
 114         print qq{\t\t\tsprintf(buf, "%d", idx);\n};
 115         print qq{\t\t\tthrow caosException(std::string("Unknown dispatchCAOS index: ") + buf);\n};
 116         print qq{\t\t\}\n};
 117         print "\t}\n";
 118         print "}\n";
 119         print "#endif\n";
 120 }
 121
 122 sub writelookup {
 123         my $cmds = shift;
 124
 125         for my $cmd (@$cmds) {
 126                 my $prefix = 'expr ';
 127                 if ($cmd->{type} eq 'command') {
 128                         $prefix = 'cmd ';
 129                 }
 130                 $cmd->{lookup_key} = $prefix . lc($cmd->{name});
 131         }
 132 }
 133
 134
 135 sub printarr {
 136         my ($cmds, $variant, $arrname) = @_;
 137         my $buf = '';
 138         $buf .= "static const struct cmdinfo $arrname\[\] = {\n";
 139         my $idx = 0;
 140         for my $cmd (@$cmds) {
 141                 my $argp = 'NULL';
 142                 if (defined $cmd->{arguments}) {
 143                         my $args = '';
 144                         for my $arg (@{$cmd->{arguments}}) {
 145                                 my $type = $tdisp{$arg->{type}};
 146                                 if (!defined $type) {
 147                                         undef $args;
 148                                         last;
 149                                 }
 150                                 $args .= "$type, ";
 151                         }
 152                         if (defined $args) {
 153                                 $argp = "${arrname}_t_$cmd->{type}_$cmd->{key}";
 154                                 print "static const enum ci_type $argp\[\] = { ";
 155                                 print $args;
 156                                 print "CI_END };\n";
 157                         }
 158                 }
 159
 160                 $buf .= "\t{ // $idx $cmd->{key}\n";
 161                 $idx++;
 162
 163                 $buf .= "#ifndef VCPP_BROKENNESS\n";
 164                 unless (defined($cmd->{implementation})) {
 165                         $cmd->{implementation} = 'caosVM::dummy_cmd';
 166                 }
 167                 unless (defined($cmd->{saveimpl})) {
 168                         $cmd->{saveimpl} = 'caosVM::dummy_cmd';
 169                 }
 170                 $buf .= "\t\t&$cmd->{implementation}, // handler\n";
 171                 $buf .= "\t\t&$cmd->{saveimpl}, // savehandler\n";
 172                 $buf .= "#else\n";
 173                 $buf .= sprintf "\t\t%d, // handler_idx\n", handler_idx($cmd->{implementation});
 174                 $buf .= sprintf "\t\t%d, // savehandler_idx\n", handler_idx($cmd->{saveimpl});
 175                 $buf .= "#endif\n";
 176
 177                 $buf .= qq{\t\t"$cmd->{lookup_key}", // lookup_key\n};
 178                 $buf .= qq{\t\t"$cmd->{key}", // key\n};
 179                 $buf .= qq{\t\t"}. lc $cmd->{match}. qq{", // name\n};
 180                 $buf .= qq{\t\t"$cmd->{name}", // fullname\n};
 181                 $buf .= qq{\t\t"}. cescape($cmd->{description}). qq{", // docs\n};
 182                 $buf .= "\t\t". scalar(@{$cmd->{arguments}}). ", // argc\n";
 183                 $buf .= "\t\t$cmd->{stackdelta}, // stackdelta\n";
 184                 $buf .= "\t\t$argp, // argtypes\n";
 185
 186                 my $rettype = $tdisp{$cmd->{type}};
 187                 if (!defined $rettype) {
 188                         die "Unknown return type $cmd->{type} in $cmd->{name}: ".YAML::Dump($cmd);
 189                 }
 190                 $buf .= "\t\t$rettype, // rettype\n";
 191                 my $cost = $cmd->{evalcost}{$variant};
 192                 $buf .= "\t\t$cost // evalcost\n";
 193                 $buf .= "\t},\n";
 194
 195         }
 196         $buf .= "\t{ NULL, NULL, NULL, NULL, NULL, NULL, NULL, 0, 0, NULL, CI_END, 0 }\n";
 197
 198         $buf .= "};\n";
 199         print $buf;
 200 }
 201 sub sortname {
 202         my $cmds = shift;
 203         @$cmds = sort { $a->{lookup_key} cmp $b->{lookup_key} } @$cmds;
 204 }
 205
 206 sub inject_ns {
 207         my $cmds = shift;
 208         my %ns;
 209         my %names;
 210         for my $cmd (@$cmds) {
 211                 my $type = ($cmd->{type} eq 'command') ? 'command' : 'any';
 212                 $ns{$cmd->{namespace}}{$type}++ if defined $cmd->{namespace};
 213                 $names{lc "$type $cmd->{name}"}++;
 214         }
 215         for my $ns (keys %ns) {
 216                 for my $type (keys %{$ns{$ns}}) {
 217                         next if $ns eq 'face'; # hack
 218                         next if exists $names{"$type " . lc $ns};
 219                         my $key = 'k_' . uc $ns;
 220                         $key =~ s/[^a-zA-Z0-9_]//g;
 221                         push @$cmds, {
 222                                 arguments => [ {
 223                                         name => "cmd",
 224                                         type => "subcommand",
 225                                 } ],
 226                                 category => "internal",
 227                                 description => "",
 228                                 evalcost => { default => 0 },
 229                                 filename => "",
 230                                 implementation => undef,
 231                                 match => uc $ns,
 232                                 name => lc $ns,
 233                                 pragma => {},
 234                                 status => 'internal',
 235                                 key => $key,
 236                                 type => $type,
 237                                 syntaxstring => (uc $ns) . " (command/expr) subcommand (subcommand)\n",
 238                                 stackdelta => "INT_MAX",
 239                         };
 240                 }
 241         }
 242 }
 243
 244 sub checkdup {
 245         my ($cmds, $desc) = @_;
 246         my %mark;
 247         for my $cmd (@$cmds) {
 248                 if (!defined $cmd->{lookup_key}) {
 249                         print STDERR "No name for $cmd->{key}\n";
 250                         exit 1;
 251                 }
 252                 push @{$mark{$cmd->{lookup_key}}}, $cmd;
 253                 if (scalar @{$mark{$cmd->{lookup_key}}} > 1) {
 254                         # Please do not disable this assert
 255                         # bsearch()'s behavior is unpredictable with duplicate keys
 256                         print STDERR "Duplicate command in $desc: $cmd->{lookup_key}\n";
 257                         print STDERR YAML::Dump($mark{$cmd->{lookup_key}});
 258                         exit 1;
 259                 }
 260         }
 261 }
 262
 263
 264
 265 our %cescapes;
 266 BEGIN { %cescapes = (
 267         "\n" => "\\n",
 268         "\r" => "\\r",
 269         "\t" => "\\t",
 270         "\\" => "\\\\",
 271         "\"" => "\\\"",
 272 ); }
 273
 274 sub cescape {
 275         my $str = shift;
 276         if (!defined $str) { return ""; }
 277         my $ces = join "", keys %cescapes;
 278         $str =~ s/([\Q$ces\E])/$cescapes{$1}/ge;
 279         return $str;
 280 }
 281
 282 sub handler_idx {
 283         my $impl = $_[0];
 284         unless (defined($disp_tbl{$impl})) {
 285                 $disp_tbl{$impl} = $disp_id++;
 286         }
 287         return $disp_tbl{$impl};
 288 }
 289 # vim: set noet: