gdb/make-target-delegates

   1 #!/usr/bin/perl
   2
   3 # Copyright (C) 2013-2020 Free Software Foundation, Inc.
   4 #
   5 # This file is part of GDB.
   6 #
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20
  21 # Usage:
  22 #    make-target-delegates target.h > target-delegates.c
  23
  24 # The line we search for in target.h that marks where we should start
  25 # looking for methods.
  26 $TRIGGER = qr,^struct target_ops$,;
  27 # The end of the methods part.
  28 $ENDER = qr,^\s*};$,;
  29
  30 # Match a C symbol.
  31 $SYMBOL = qr,[a-zA-Z_][a-zA-Z0-9_]*,;
  32 # Match the name part of a method in struct target_ops.
  33 $NAME_PART = qr,(?<name>${SYMBOL}+)\s,;
  34 # Match the arguments to a method.
  35 $ARGS_PART = qr,(?<args>\(.*\)),;
  36 # We strip the indentation so here we only need the caret.
  37 $INTRO_PART = qr,^,;
  38
  39 $POINTER_PART = qr,\s*(\*)?\s*,;
  40
  41 # Match a C++ symbol, including scope operators and template
  42 # parameters.  E.g., 'std::vector<something>'.
  43 $CP_SYMBOL = qr,[a-zA-Z_][a-zA-Z0-9_<>:]*,;
  44 # Match the return type when it is "ordinary".
  45 $SIMPLE_RETURN_PART = qr,((struct|class|enum|union)\s+)?${CP_SYMBOL}+,;
  46
  47 # Match a return type.
  48 $RETURN_PART = qr,((const|volatile)\s+)?(${SIMPLE_RETURN_PART})${POINTER_PART},;
  49
  50 # Match "virtual".
  51 $VIRTUAL_PART = qr,virtual\s,;
  52
  53 # Match the TARGET_DEFAULT_* attribute for a method.
  54 $TARGET_DEFAULT_PART = qr,TARGET_DEFAULT_(?<style>[A-Z_]+)\s*\((?<default_arg>.*)\),;
  55
  56 # Match the arguments and trailing attribute of a method definition.
  57 # Note we don't match the trailing ";".
  58 $METHOD_TRAILER = qr,\s*${TARGET_DEFAULT_PART}$,;
  59
  60 # Match an entire method definition.
  61 $METHOD = ($INTRO_PART . $VIRTUAL_PART . "(?<return_type>" . $RETURN_PART . ")"
  62            . $NAME_PART . $ARGS_PART
  63            . $METHOD_TRAILER);
  64
  65 # Match TARGET_DEBUG_PRINTER in an argument type.
  66 # This must match the whole "sub-expression" including the parens.
  67 # Reference $1 must refer to the function argument.
  68 $TARGET_DEBUG_PRINTER = qr,\s*TARGET_DEBUG_PRINTER\s*\(([^)]*)\)\s*,;
  69
  70 sub trim($) {
  71     my ($result) = @_;
  72
  73     $result =~ s,^\s+,,;
  74     $result =~ s,\s+$,,;
  75
  76     return $result;
  77 }
  78
  79 # Read from the input files until we find the trigger line.
  80 # Die if not found.
  81 sub find_trigger() {
  82     while (<>) {
  83         chomp;
  84         return if m/$TRIGGER/;
  85     }
  86
  87     die "could not find trigger line\n";
  88 }
  89
  90 # Scan target.h and return a list of possible target_ops method entries.
  91 sub scan_target_h() {
  92     my $all_the_text = '';
  93
  94     find_trigger();
  95     while (<>) {
  96         chomp;
  97         # Skip the open brace.
  98         next if /{/;
  99         last if m/$ENDER/;
 100
 101         # Strip // comments.
 102         $_ =~ s,//.*$,,;
 103
 104         $all_the_text .= $_;
 105     }
 106
 107     # Now strip out the C comments.
 108     $all_the_text =~ s,/\*(.*?)\*/,,g;
 109
 110     # Replace sequences of tabs and/or whitespace with a single
 111     # whitespace character.  We need the whitespace because the method
 112     # may have been split between multiple lines, like e.g.:
 113     #
 114     #  virtual std::vector<long_type_name>
 115     #    my_long_method_name ()
 116     #    TARGET_DEFAULT_IGNORE ();
 117     #
 118     # If we didn't preserve the whitespace, then we'd end up with:
 119     #
 120     #  virtual std::vector<long_type_name>my_long_method_name ()TARGET_DEFAULT_IGNORE ()
 121     #
 122     # ... which wouldn't later be parsed correctly.
 123     $all_the_text =~ s/[\t\s]+/ /g;
 124
 125     return split (/;/, $all_the_text);
 126 }
 127
 128 # Parse arguments into a list.
 129 sub parse_argtypes($) {
 130     my ($typestr) = @_;
 131
 132     $typestr =~ s/^\((.*)\)$/\1/;
 133
 134     my (@typelist) = split (/,\s*/, $typestr);
 135     my (@result, $iter, $onetype);
 136
 137     foreach $iter (@typelist) {
 138         if ($iter =~ m/^(enum\s+${SYMBOL}\s*)(${SYMBOL})?$/) {
 139             $onetype = $1;
 140         } elsif ($iter =~ m/^(.*(enum\s+)?${SYMBOL}.*(\s|\*|&))${SYMBOL}+$/) {
 141             $onetype = $1;
 142         } elsif ($iter eq 'void') {
 143             next;
 144         } else {
 145             $onetype = $iter;
 146         }
 147         push @result, trim ($onetype);
 148     }
 149
 150     return @result;
 151 }
 152
 153 sub dname($) {
 154     my ($name) = @_;
 155     return "target_ops::" . $name;
 156 }
 157
 158 # Write function header given name, return type, and argtypes.
 159 # Returns a list of actual argument names.
 160 sub write_function_header($$$@) {
 161     my ($decl, $name, $return_type, @argtypes) = @_;
 162
 163     print $return_type;
 164
 165     if ($decl) {
 166         if ($return_type !~ m,\*$,) {
 167             print " ";
 168         }
 169     } else {
 170         print "\n";
 171     }
 172
 173     print $name . ' (';
 174
 175     my $iter;
 176     my @argdecls;
 177     my @actuals;
 178     my $i = 0;
 179     foreach $iter (@argtypes) {
 180         my $val = $iter;
 181
 182         $val =~ s/$TARGET_DEBUG_PRINTER//;
 183
 184         if ($iter !~ m,(\*|&)$,) {
 185             $val .= ' ';
 186         }
 187
 188         my $vname;
 189         $vname .= "arg$i";
 190         $val .= $vname;
 191
 192         push @argdecls, $val;
 193         push @actuals, $vname;
 194         ++$i;
 195     }
 196
 197     print join (', ', @argdecls) . ")";
 198
 199     if ($decl) {
 200         print " override;\n";
 201     } else {
 202         print "\n{\n";
 203     }
 204
 205     return @actuals;
 206 }
 207
 208 # Write out a declaration.
 209 sub write_declaration($$@) {
 210     my ($name, $return_type, @argtypes) = @_;
 211
 212     write_function_header (1, $name, $return_type, @argtypes);
 213 }
 214
 215 # Write out a delegation function.
 216 sub write_delegator($$@) {
 217     my ($name, $return_type, @argtypes) = @_;
 218
 219     my (@names) = write_function_header (0, dname ($name),
 220                                          $return_type, @argtypes);
 221
 222     print "  ";
 223     if ($return_type ne 'void') {
 224         print "return ";
 225     }
 226     print "this->beneath ()->" . $name . " (";
 227     print join (', ', @names);
 228     print ");\n";
 229     print "}\n\n";
 230 }
 231
 232 sub tdname ($) {
 233     my ($name) = @_;
 234     return "dummy_target::" . $name;
 235 }
 236
 237 # Write out a default function.
 238 sub write_tdefault($$$$@) {
 239     my ($content, $style, $name, $return_type, @argtypes) = @_;
 240
 241     my (@names) = write_function_header (0, tdname ($name),
 242                                          $return_type, @argtypes);
 243
 244     if ($style eq 'FUNC') {
 245         print "  ";
 246         if ($return_type ne 'void') {
 247             print "return ";
 248         }
 249         print $content . " (this";
 250         if (@names) {
 251             print ", ";
 252         }
 253         print join (', ', @names);
 254         print ");\n";
 255     } elsif ($style eq 'RETURN') {
 256         print "  return $content;\n";
 257     } elsif ($style eq 'NORETURN') {
 258         print "  $content;\n";
 259     } elsif ($style eq 'IGNORE') {
 260         # Nothing.
 261     } else {
 262         die "unrecognized style: $style\n";
 263     }
 264
 265     print "}\n\n";
 266
 267     return tdname ($name);
 268 }
 269
 270 sub munge_type($) {
 271     my ($typename) = @_;
 272     my ($result);
 273
 274     if ($typename =~ m/$TARGET_DEBUG_PRINTER/) {
 275         $result = $1;
 276     } else {
 277         ($result = $typename) =~ s/\s+$//;
 278         $result =~ s/[ ()<>:]/_/g;
 279         $result =~ s/[*]/p/g;
 280         $result =~ s/&/r/g;
 281
 282         # Identifers with double underscores are reserved to the C++
 283         # implementation.
 284         $result =~ s/_+/_/g;
 285
 286         # Avoid ending the function name with underscore, for
 287         # cosmetics.  Trailing underscores appear after munging types
 288         # with template parameters, like e.g. "foo<int>".
 289         $result =~ s/_$//g;
 290
 291         $result = 'target_debug_print_' . $result;
 292     }
 293
 294     return $result;
 295 }
 296
 297 # Write out a debug method.
 298 sub write_debugmethod($$$@) {
 299     my ($content, $name, $return_type, @argtypes) = @_;
 300
 301     my ($debugname) = "debug_target::" . $name;
 302     my ($targetname) = $name;
 303
 304     my (@names) = write_function_header (0, $debugname, $return_type, @argtypes);
 305
 306     if ($return_type ne 'void') {
 307         print "  $return_type result;\n";
 308     }
 309
 310     print "  fprintf_unfiltered (gdb_stdlog, \"-> %s->$name (...)\\n\", this->beneath ()->shortname ());\n";
 311
 312     # Delegate to the beneath target.
 313     print "  ";
 314     if ($return_type ne 'void') {
 315         print "result = ";
 316     }
 317     print "this->beneath ()->" . $name . " (";
 318     print join (', ', @names);
 319     print ");\n";
 320
 321     # Now print the arguments.
 322     print "  fprintf_unfiltered (gdb_stdlog, \"<- %s->$name (\", this->beneath ()->shortname ());\n";
 323     for my $i (0 .. $#argtypes) {
 324         if ($i > 0) {
 325             print "  fputs_unfiltered (\", \", gdb_stdlog);\n"
 326         }
 327         my $printer = munge_type ($argtypes[$i]);
 328         print "  $printer ($names[$i]);\n";
 329     }
 330     if ($return_type ne 'void') {
 331         print "  fputs_unfiltered (\") = \", gdb_stdlog);\n";
 332         my $printer = munge_type ($return_type);
 333         print "  $printer (result);\n";
 334         print "  fputs_unfiltered (\"\\n\", gdb_stdlog);\n";
 335     } else {
 336         print "  fputs_unfiltered (\")\\n\", gdb_stdlog);\n";
 337     }
 338
 339     if ($return_type ne 'void') {
 340         print "  return result;\n";
 341     }
 342
 343     print "}\n\n";
 344
 345     return $debugname;
 346 }
 347
 348 print "/* THIS FILE IS GENERATED -*- buffer-read-only: t -*- */\n";
 349 print "/* vi:set ro: */\n\n";
 350 print "/* To regenerate this file, run:*/\n";
 351 print "/*      make-target-delegates target.h > target-delegates.c */\n";
 352 print "\n";
 353
 354 @lines = scan_target_h();
 355
 356 @delegators = ();
 357 @return_types = ();
 358 @tdefaults = ();
 359 @styles = ();
 360 @argtypes_array = ();
 361
 362 foreach $current_line (@lines) {
 363     # See comments in scan_target_h.  Here we strip away the leading
 364     # and trailing whitespace.
 365     $current_line = trim ($current_line);
 366
 367     next unless $current_line =~ m/$METHOD/;
 368
 369     my $name = $+{name};
 370     my $current_line = $+{args};
 371     my $return_type = trim ($+{return_type});
 372     my $current_args = $+{args};
 373     my $tdefault = $+{default_arg};
 374     my $style = $+{style};
 375
 376     my @argtypes = parse_argtypes ($current_args);
 377
 378     push @delegators, $name;
 379
 380     $return_types{$name} = $return_type;
 381     $tdefaults{$name} = $tdefault;
 382     $styles{$name} = $style;
 383     $argtypes_array{$name} = \@argtypes;
 384 }
 385
 386 sub print_class($) {
 387     my ($name) = @_;
 388
 389     print "struct " . $name . " : public target_ops\n";
 390     print "{\n";
 391     print "  const target_info &info () const override;\n";
 392     print "\n";
 393     print "  strata stratum () const override;\n";
 394     print "\n";
 395
 396     for $name (@delegators) {
 397         my $return_type = $return_types{$name};
 398         my @argtypes = @{$argtypes_array{$name}};
 399
 400         print "  ";
 401         write_declaration ($name, $return_type, @argtypes);
 402     }
 403
 404     print "};\n\n";
 405 }
 406
 407 print_class ("dummy_target");
 408 print_class ("debug_target");
 409
 410 for $name (@delegators) {
 411     my $tdefault = $tdefaults{$name};
 412     my $return_type = $return_types{$name};
 413     my $style = $styles{$name};
 414     my @argtypes = @{$argtypes_array{$name}};
 415
 416     write_delegator ($name, $return_type, @argtypes);
 417
 418     write_tdefault ($tdefault, $style, $name, $return_type, @argtypes);
 419
 420     write_debugmethod ($tdefault, $name, $return_type, @argtypes);
 421 }