parsedocs.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use YAML;
   7
   8 my @variants = qw(c3 cv sm);
   9
  10 $SIG{__WARN__} = sub { die $_[0] };
  11
  12 my %fnmap = ( # default category mappings
  13         'caosVM_agent.cpp' => 'Agents',
  14         'caosVM_camera.cpp' => 'Cameras',
  15         'caosVM_core.cpp' => 'Core functions',
  16         'caosVM_creatures.cpp' => 'Creatures',
  17         'caosVM_compound.cpp' => 'Compound agents',
  18         'caosVM_debug.cpp' => 'Debugging',
  19         'caosVM_files.cpp' => 'Files',
  20         'caosVM_flow.cpp' => 'Flow control',
  21         'caosVM_genetics.cpp' => 'Genetics',
  22         'caosVM_history.cpp' => 'History',
  23         'caosVM_input.cpp' => 'Input',
  24         'caosVM_map.cpp' => 'Map',
  25         'caosVM_motion.cpp' => 'Motion',
  26         'caosVM_net.cpp' => 'Networking',
  27         'caosVM_ports.cpp' => 'Ports',
  28         'caosVM_resources.cpp' => 'Resources',
  29         'caosVM_scripts.cpp' => 'Scripts',
  30         'caosVM_sounds.cpp' => 'Sound',
  31         'caosVM_time.cpp' => 'Time',
  32         'caosVM_variables.cpp' => 'Variables',
  33         'caosVM_vectors.cpp' => 'Vectors',
  34         'caosVM_vehicles.cpp' => 'Vehicles',
  35         'caosVM_world.cpp' => 'World',
  36 );
  37
  38 my %data;
  39 my %ns;
  40
  41 my $prev;
  42
  43 my $missing_status = 0;
  44
  45 while (<>) {
  46         my $file = $ARGV;
  47
  48         unless (m{/\*\*}) {
  49                 if (m/STUB|TODO/ && defined $prev && !defined $prev->{status}) {
  50                         $prev->{status} = 'stub';
  51                 }
  52                 next;
  53         }
  54         $_ = <>;
  55         defined $_ or exit;
  56         $_ =~ s/^\s* \** \s*//x; # accept leading * etc
  57         next unless m{
  58                 ^\s*
  59                 # DBG: and the like
  60                 ( \S+ \s+ )?
  61                 # eg MOWS (command), LAWN (agent)
  62                 (\S+) \s* \((\w+)\) \s*
  63                 ( (?:
  64                         # argument bit
  65                         # we parse this in more detail later
  66                         (?:\w+) \s*
  67                         (?:\([^)]+\)) \s*
  68                 )* )
  69                 \s*$
  70         }x;
  71         my $firstline = $_;
  72
  73         my ($cns, $cname, $ctype, $argdata) = ($1, $2, $3, $4);
  74         if (defined $cns) {
  75                 $cns =~ s/\s//g;
  76         }
  77
  78         my $fullname = ($cns ? "$cns " : "") . $cname;
  79
  80         my $impl;
  81         my $saveimpl;
  82         if ($ctype eq 'command') {
  83                 $impl = 'c_';
  84         } else {
  85                 $impl = 'v_';
  86         }
  87         if ($cns && $cns ne '') {
  88                 $_ = $cns . "_";
  89                 $_ =~ s/[^a-zA-Z0-9_]//g;
  90                 $impl .= uc $_;
  91         }
  92         $_ = $cname;
  93         $_ =~ s/[^a-zA-Z0-9_]//g;
  94         $impl .= $_;
  95         my $key = $impl;
  96         $impl = "caosVM::$impl";
  97         my $stackdelta = ($ctype eq 'command' ? 0 : 1);
  98
  99
 100
 101         my @args;
 102         while ($argdata =~ s/.*?(\w+)\s*\(([^)]+)\)\s*//) {
 103                 my ($argname, $argtype) = ($1, $2);
 104                 push @args, {
 105                         name => $argname,
 106                         type => $argtype,
 107                 };
 108                 $stackdelta-- unless $argtype =~ /variable/;
 109         }
 110
 111         my @lines;
 112         DOCLINE: while (<>) {
 113                 last DOCLINE if m{\*/};
 114                 $_ =~ m{^\s* (?: \* \s* )* (.*?) \s*$}x;
 115                 push @lines, $1;
 116         }
 117         shift @lines while (@lines && $lines[0] eq '');
 118         pop @lines while (@lines && $lines[-1] eq '');
 119
 120         my %pragma;
 121         my %evalcost;
 122         my $status;
 123         my $cat;
 124
 125         if ($ctype eq 'command') {
 126                 $evalcost{default} = 1;
 127         } else {
 128                 $evalcost{default} = 0;
 129         }
 130
 131         while (@lines && ($lines[0] =~ s{^\%([a-zA-Z]+)\s+}{} || $lines[0] =~ m{^\s*$})) {
 132                 my $l = shift @lines;
 133                 chomp $l;
 134                 next unless $1;
 135                 if ($1 eq 'pragma') {
 136                         unless ($l =~ m{(\w+)\s*(.*)}) {
 137                                 warn "bad pragma";
 138                         }
 139                         $pragma{$1} = $2;
 140                         chomp $pragma{$1};
 141                         if ($pragma{$1} eq '') {
 142                                 $pragma{$1} = 1;
 143                         }
 144                 } elsif ($1 eq 'status') {
 145                         if ($status) {
 146                                 die "Set status twice";
 147                         }
 148                         $status = $l;
 149                         chomp $status;
 150                 } elsif ($1 eq 'category') {
 151                         if ($cat) {
 152                                 die "set category twice";
 153                         }
 154                         $cat = $l;
 155                 } elsif ($1 eq 'cost') {
 156                         if ($l =~ m{^\s*(-?\d+)\s*$}) {
 157                                 $evalcost{default} = $1;
 158                         } elsif ($l =~ m{(\S+)\s+(-?\d+)\s*$}) {
 159                                 my $cost = $2;
 160                                 my @variants = split ',', $1;
 161                                 for my $v (@variants) {
 162                                         $evalcost{$v} = $cost;
 163                                 }
 164                         } else {
 165                                 die "malformed cost directive";
 166                         }
 167                 } else {
 168                         die "Unrecognized directive: $1";
 169                 }
 170         }
 171
 172         if (!$status) {
 173                 $missing_status++;
 174                 print STDERR "Missing \%status for $fullname\n";
 175         }
 176
 177         if (!$cat) {
 178                 $cat = lc $fnmap{$file} || 'unknown';
 179         }
 180
 181         $stackdelta = $pragma{stackdelta} if defined $pragma{stackdelta};
 182         $stackdelta = "INT_MAX" if lc $pragma{stackdelta} eq "any";
 183         die "Deprecated use of pragma retc for $fullname" if defined $pragma{retc};
 184
 185
 186         if ($pragma{implementation}) {
 187                 $impl = $pragma{implementation};
 188         }
 189         if ($pragma{saveimpl}) {
 190                 $saveimpl = $pragma{saveimpl};
 191         } else {
 192                 if ($ctype eq 'variable') {
 193                         $saveimpl = $impl;
 194                         $saveimpl =~ s/caosVM::v/caosVM::s/;
 195                 } else {
 196                         $saveimpl = "caosVM::dummy_cmd";
 197                 }
 198         }
 199         $firstline =~ s/^\s*//;
 200         my $desc = join("\n", @lines);
 201         $desc .= "\n";
 202
 203         my $cd = {
 204                 type => $ctype,
 205                 name => $fullname,
 206                 match => $cname,
 207                 arguments => \@args,
 208                 syntaxstring => $firstline,
 209                 description => @lines ? $desc : undef,
 210                 filename => $file,
 211                 implementation => $impl,
 212                 saveimpl => $saveimpl,
 213                 status => $status,
 214                 category => $cat,
 215                 evalcost => \%evalcost,
 216                 stackdelta => $stackdelta,
 217         };
 218         if (%pragma) {
 219                 $cd->{pragma} = \%pragma;
 220         }
 221         if ($cns && $cns ne '') {
 222                 $cd->{namespace} = lc $cns;
 223         }
 224         unless ($cd->{status}) {
 225                 $cd->{status} = 'probablyok';
 226         }
 227         $prev = $cd;
 228
 229         my @v = @variants;
 230         if ($pragma{variants}) {
 231                 @v = grep { $_ ne ''; } split ' ', $pragma{variants};
 232         }
 233
 234         for my $v (@v) {
 235                 if ($v eq 'all') {
 236                         @v = qw(all);
 237                         last;
 238                 }
 239         }
 240
 241         for my $v (@v) {
 242                 if (exists $data{$v}{$key}) {
 243                         print STDERR "Name collision for ($key) in variant $v\n";
 244                         exit 1;
 245                 }
 246                 $data{$v}{$key} = $cd;
 247         }
 248 }
 249
 250 if ($missing_status) {
 251         print STDERR "$missing_status commands are missing \%status, fixit.\n";
 252         exit 1;
 253 }
 254
 255 for my $key (keys %{$data{all}}) {
 256         for my $variant (keys %data) {
 257                 next if $variant eq 'all';
 258                 if (exists $data{$variant}{$key}) {
 259                         print STDERR "Name collision for ($key) in variant $variant\n";
 260                         exit 1;
 261                 }
 262                 $data{$variant}{$key} = $data{all}{$key};
 263         }
 264 }
 265
 266 delete $data{all};
 267
 268 print Dump {
 269         variants => \%data,
 270         namespaces => [keys %ns],
 271 };
 272 # vim: set noet: