gdb/make-target-delegates

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