gdb/make-target-delegates

   1 #!/usr/bin/perl
   2
   3 # Copyright (C) 2013-2018 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         $_ = trim ($_);
 106
 107         $all_the_text .= $_;
 108     }
 109
 110     # Now strip out the C comments.
 111     $all_the_text =~ s,/\*(.*?)\*/,,g;
 112
 113     return split (/;/, $all_the_text);
 114 }
 115
 116 # Parse arguments into a list.
 117 sub parse_argtypes($) {
 118     my ($typestr) = @_;
 119
 120     $typestr =~ s/^\((.*)\)$/\1/;
 121
 122     my (@typelist) = split (/,\s*/, $typestr);
 123     my (@result, $iter, $onetype);
 124
 125     foreach $iter (@typelist) {
 126         if ($iter =~ m/^(enum\s+${SYMBOL}\s*)(${SYMBOL})?$/) {
 127             $onetype = $1;
 128         } elsif ($iter =~ m/^(.*(enum\s+)?${SYMBOL}.*(\s|\*|&))${SYMBOL}+$/) {
 129             $onetype = $1;
 130         } elsif ($iter eq 'void') {
 131             next;
 132         } else {
 133             $onetype = $iter;
 134         }
 135         push @result, trim ($onetype);
 136     }
 137
 138     return @result;
 139 }
 140
 141 sub dname($) {
 142     my ($name) = @_;
 143     return "target_ops::" . $name;
 144 }
 145
 146 # Write function header given name, return type, and argtypes.
 147 # Returns a list of actual argument names.
 148 sub write_function_header($$$@) {
 149     my ($decl, $name, $return_type, @argtypes) = @_;
 150
 151     print $return_type;
 152
 153     if ($decl) {
 154         if ($return_type !~ m,\*$,) {
 155             print " ";
 156         }
 157     } else {
 158         print "\n";
 159     }
 160
 161     print $name . ' (';
 162
 163     my $iter;
 164     my @argdecls;
 165     my @actuals;
 166     my $i = 0;
 167     foreach $iter (@argtypes) {
 168         my $val = $iter;
 169
 170         $val =~ s/$TARGET_DEBUG_PRINTER//;
 171
 172         if ($iter !~ m,(\*|&)$,) {
 173             $val .= ' ';
 174         }
 175
 176         my $vname;
 177         $vname .= "arg$i";
 178         $val .= $vname;
 179
 180         push @argdecls, $val;
 181         push @actuals, $vname;
 182         ++$i;
 183     }
 184
 185     print join (', ', @argdecls) . ")";
 186
 187     if ($decl) {
 188         print " override;\n";
 189     } else {
 190         print "\n{\n";
 191     }
 192
 193     return @actuals;
 194 }
 195
 196 # Write out a declaration.
 197 sub write_declaration($$@) {
 198     my ($name, $return_type, @argtypes) = @_;
 199
 200     write_function_header (1, $name, $return_type, @argtypes);
 201 }
 202
 203 # Write out a delegation function.
 204 sub write_delegator($$@) {
 205     my ($name, $return_type, @argtypes) = @_;
 206
 207     my (@names) = write_function_header (0, dname ($name),
 208                                          $return_type, @argtypes);
 209
 210     print "  ";
 211     if ($return_type ne 'void') {
 212         print "return ";
 213     }
 214     print "this->beneath->" . $name . " (";
 215     print join (', ', @names);
 216     print ");\n";
 217     print "}\n\n";
 218 }
 219
 220 sub tdname ($) {
 221     my ($name) = @_;
 222     return "dummy_target::" . $name;
 223 }
 224
 225 # Write out a default function.
 226 sub write_tdefault($$$$@) {
 227     my ($content, $style, $name, $return_type, @argtypes) = @_;
 228
 229     my (@names) = write_function_header (0, tdname ($name),
 230                                          $return_type, @argtypes);
 231
 232     if ($style eq 'FUNC') {
 233         print "  ";
 234         if ($return_type ne 'void') {
 235             print "return ";
 236         }
 237         print $content . " (this";
 238         if (@names) {
 239             print ", ";
 240         }
 241         print join (', ', @names);
 242         print ");\n";
 243     } elsif ($style eq 'RETURN') {
 244         print "  return $content;\n";
 245     } elsif ($style eq 'NORETURN') {
 246         print "  $content;\n";
 247     } elsif ($style eq 'IGNORE') {
 248         # Nothing.
 249     } else {
 250         die "unrecognized style: $style\n";
 251     }
 252
 253     print "}\n\n";
 254
 255     return tdname ($name);
 256 }
 257
 258 sub munge_type($) {
 259     my ($typename) = @_;
 260     my ($result);
 261
 262     if ($typename =~ m/$TARGET_DEBUG_PRINTER/) {
 263         $result = $1;
 264     } else {
 265         ($result = $typename) =~ s/\s+$//;
 266         $result =~ s/[ ()<>:]/_/g;
 267         $result =~ s/[*]/p/g;
 268         $result =~ s/&/r/g;
 269
 270         # Identifers with double underscores are reserved to the C++
 271         # implementation.
 272         $result =~ s/_+/_/g;
 273
 274         # Avoid ending the function name with underscore, for
 275         # cosmetics.  Trailing underscores appear after munging types
 276         # with template parameters, like e.g. "foo<int>".
 277         $result =~ s/_$//g;
 278
 279         $result = 'target_debug_print_' . $result;
 280     }
 281
 282     return $result;
 283 }
 284
 285 # Write out a debug method.
 286 sub write_debugmethod($$$@) {
 287     my ($content, $name, $return_type, @argtypes) = @_;
 288
 289     my ($debugname) = "debug_target::" . $name;
 290     my ($targetname) = $name;
 291
 292     my (@names) = write_function_header (0, $debugname, $return_type, @argtypes);
 293
 294     if ($return_type ne 'void') {
 295         print "  $return_type result;\n";
 296     }
 297
 298     print "  fprintf_unfiltered (gdb_stdlog, \"-> %s->$name (...)\\n\", this->beneath->shortname ());\n";
 299
 300     # Delegate to the beneath target.
 301     print "  ";
 302     if ($return_type ne 'void') {
 303         print "result = ";
 304     }
 305     print "this->beneath->" . $name . " (";
 306     print join (', ', @names);
 307     print ");\n";
 308
 309     # Now print the arguments.
 310     print "  fprintf_unfiltered (gdb_stdlog, \"<- %s->$name (\", this->beneath->shortname ());\n";
 311     for my $i (0 .. $#argtypes) {
 312         if ($i > 0) {
 313             print "  fputs_unfiltered (\", \", gdb_stdlog);\n"
 314         }
 315         my $printer = munge_type ($argtypes[$i]);
 316         print "  $printer ($names[$i]);\n";
 317     }
 318     if ($return_type ne 'void') {
 319         print "  fputs_unfiltered (\") = \", gdb_stdlog);\n";
 320         my $printer = munge_type ($return_type);
 321         print "  $printer (result);\n";
 322         print "  fputs_unfiltered (\"\\n\", gdb_stdlog);\n";
 323     } else {
 324         print "  fputs_unfiltered (\")\\n\", gdb_stdlog);\n";
 325     }
 326
 327     if ($return_type ne 'void') {
 328         print "  return result;\n";
 329     }
 330
 331     print "}\n\n";
 332
 333     return $debugname;
 334 }
 335
 336 print "/* THIS FILE IS GENERATED -*- buffer-read-only: t -*- */\n";
 337 print "/* vi:set ro: */\n\n";
 338 print "/* To regenerate this file, run:*/\n";
 339 print "/*      make-target-delegates target.h > target-delegates.c */\n";
 340 print "\n";
 341
 342 @lines = scan_target_h();
 343
 344 @delegators = ();
 345 @return_types = ();
 346 @tdefaults = ();
 347 @styles = ();
 348 @argtypes_array = ();
 349
 350 foreach $current_line (@lines) {
 351     next unless $current_line =~ m/$METHOD/;
 352
 353     my $name = $+{name};
 354     my $current_line = $+{args};
 355     my $return_type = trim ($+{return_type});
 356     my $current_args = $+{args};
 357     my $tdefault = $+{default_arg};
 358     my $style = $+{style};
 359
 360     my @argtypes = parse_argtypes ($current_args);
 361
 362     push @delegators, $name;
 363
 364     $return_types{$name} = $return_type;
 365     $tdefaults{$name} = $tdefault;
 366     $styles{$name} = $style;
 367     $argtypes_array{$name} = \@argtypes;
 368 }
 369
 370 sub print_class($) {
 371     my ($name) = @_;
 372
 373     print "struct " . $name . " : public target_ops\n";
 374     print "{\n";
 375     print "  $name ();\n";
 376     print "\n";
 377     print "  const char *shortname () override;\n";
 378     print "  const char *longname () override;\n";
 379     print "  const char *doc () override;\n";
 380     print "\n";
 381
 382     for $name (@delegators) {
 383         my $return_type = $return_types{$name};
 384         my @argtypes = @{$argtypes_array{$name}};
 385
 386         print "  ";
 387         write_declaration ($name, $return_type, @argtypes);
 388     }
 389
 390     print "};\n\n";
 391 }
 392
 393 print_class ("dummy_target");
 394 print_class ("debug_target");
 395
 396 for $name (@delegators) {
 397     my $tdefault = $tdefaults{$name};
 398     my $return_type = $return_types{$name};
 399     my $style = $styles{$name};
 400     my @argtypes = @{$argtypes_array{$name}};
 401
 402     write_delegator ($name, $return_type, @argtypes);
 403
 404     write_tdefault ($tdefault, $style, $name, $return_type, @argtypes);
 405
 406     write_debugmethod ($tdefault, $name, $return_type, @argtypes);
 407 }