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 # Match the return type when it is "ordinary".
  40 $SIMPLE_RETURN_PART = qr,[^\(]+,;
  41 # Match the return type when it is a VEC.
  42 $VEC_RETURN_PART = qr,VEC\s*\([^\)]+\)[^\(]*,;
  43
  44 # Match the TARGET_DEFAULT_* attribute for a method.
  45 $TARGET_DEFAULT_PART = qr,TARGET_DEFAULT_(?<style>[A-Z_]+)\s*\((?<default_arg>.*)\),;
  46
  47 # Match the arguments and trailing attribute of a method definition.
  48 # Note we don't match the trailing ";".
  49 $METHOD_TRAILER = qr,\s*${TARGET_DEFAULT_PART}$,;
  50
  51 # Match an entire method definition.
  52 $METHOD = ($INTRO_PART . "(?<return_type>" . $SIMPLE_RETURN_PART
  53            . "|" . $VEC_RETURN_PART . ")"
  54            . $NAME_PART . $ARGS_PART
  55            . $METHOD_TRAILER);
  56
  57 # Match TARGET_DEBUG_PRINTER in an argument type.
  58 # This must match the whole "sub-expression" including the parens.
  59 # Reference $1 must refer to the function argument.
  60 $TARGET_DEBUG_PRINTER = qr,\s*TARGET_DEBUG_PRINTER\s*\(([^)]*)\)\s*,;
  61
  62 sub trim($) {
  63     my ($result) = @_;
  64
  65     $result =~ s,^\s+,,;
  66     $result =~ s,\s+$,,;
  67
  68     return $result;
  69 }
  70
  71 # Read from the input files until we find the trigger line.
  72 # Die if not found.
  73 sub find_trigger() {
  74     while (<>) {
  75         chomp;
  76         return if m/$TRIGGER/;
  77     }
  78
  79     die "could not find trigger line\n";
  80 }
  81
  82 # Scan target.h and return a list of possible target_ops method entries.
  83 sub scan_target_h() {
  84     my $all_the_text = '';
  85
  86     find_trigger();
  87     while (<>) {
  88         chomp;
  89         # Skip the open brace.
  90         next if /{/;
  91         last if m/$ENDER/;
  92
  93         # Just in case somebody ever uses C99.
  94         $_ =~ s,//.*$,,;
  95         $_ = trim ($_);
  96
  97         $all_the_text .= $_;
  98     }
  99
 100     # Now strip out the C comments.
 101     $all_the_text =~ s,/\*(.*?)\*/,,g;
 102
 103     return split (/;/, $all_the_text);
 104 }
 105
 106 # Parse arguments into a list.
 107 sub parse_argtypes($) {
 108     my ($typestr) = @_;
 109
 110     $typestr =~ s/^\((.*)\)$/\1/;
 111
 112     my (@typelist) = split (/,\s*/, $typestr);
 113     my (@result, $iter, $onetype);
 114
 115     foreach $iter (@typelist) {
 116         if ($iter =~ m/^(enum\s+${SYMBOL}\s*)(${SYMBOL})?$/) {
 117             $onetype = $1;
 118         } elsif ($iter =~ m/^(.*(enum\s+)?${SYMBOL}.*(\s|\*|&))${SYMBOL}+$/) {
 119             $onetype = $1;
 120         } elsif ($iter eq 'void') {
 121             next;
 122         } else {
 123             $onetype = $iter;
 124         }
 125         push @result, trim ($onetype);
 126     }
 127
 128     return @result;
 129 }
 130
 131 sub dname($) {
 132     my ($name) = @_;
 133     $name =~ s/to_/delegate_/;
 134     return $name;
 135 }
 136
 137 # Write function header given name, return type, and argtypes.
 138 # Returns a list of actual argument names.
 139 sub write_function_header($$@) {
 140     my ($name, $return_type, @argtypes) = @_;
 141
 142     print "static " . $return_type . "\n";
 143     print $name . ' (';
 144
 145     my $iter;
 146     my @argdecls;
 147     my @actuals;
 148     my $i = 0;
 149     foreach $iter (@argtypes) {
 150         my $val = $iter;
 151
 152         $val =~ s/$TARGET_DEBUG_PRINTER//;
 153
 154         if ($iter !~ m,(\*|&)$,) {
 155             $val .= ' ';
 156         }
 157
 158         my $vname;
 159         if ($i == 0) {
 160             # Just a random nicety.
 161             $vname = 'self';
 162         } else {
 163             $vname .= "arg$i";
 164         }
 165         $val .= $vname;
 166
 167         push @argdecls, $val;
 168         push @actuals, $vname;
 169         ++$i;
 170     }
 171
 172     print join (', ', @argdecls) . ")\n";
 173     print "{\n";
 174
 175     return @actuals;
 176 }
 177
 178 # Write out a delegation function.
 179 sub write_delegator($$@) {
 180     my ($name, $return_type, @argtypes) = @_;
 181
 182     my (@names) = write_function_header (dname ($name), $return_type,
 183                                          @argtypes);
 184
 185     print "  $names[0] = $names[0]->beneath;\n";
 186     print "  ";
 187     if ($return_type ne 'void') {
 188         print "return ";
 189     }
 190     print "$names[0]->" . $name . " (";
 191     print join (', ', @names);
 192     print ");\n";
 193     print "}\n\n";
 194 }
 195
 196 sub tdname ($) {
 197     my ($name) = @_;
 198     $name =~ s/to_/tdefault_/;
 199     return $name;
 200 }
 201
 202 # Write out a default function.
 203 sub write_tdefault($$$$@) {
 204     my ($content, $style, $name, $return_type, @argtypes) = @_;
 205
 206     if ($style eq 'FUNC') {
 207         return $content;
 208     }
 209
 210     write_function_header (tdname ($name), $return_type, @argtypes);
 211
 212     if ($style eq 'RETURN') {
 213         print "  return $content;\n";
 214     } elsif ($style eq 'NORETURN') {
 215         print "  $content;\n";
 216     } elsif ($style eq 'IGNORE') {
 217         # Nothing.
 218     } else {
 219         die "unrecognized style: $style\n";
 220     }
 221
 222     print "}\n\n";
 223
 224     return tdname ($name);
 225 }
 226
 227 sub munge_type($) {
 228     my ($typename) = @_;
 229     my ($result);
 230
 231     if ($typename =~ m/$TARGET_DEBUG_PRINTER/) {
 232         $result = $1;
 233     } else {
 234         ($result = $typename) =~ s/\s+$//;
 235         $result =~ s/[ ()<>:]/_/g;
 236         $result =~ s/[*]/p/g;
 237         $result =~ s/&/r/g;
 238
 239         # Identifers with double underscores are reserved to the C++
 240         # implementation.
 241         $result =~ s/_+/_/g;
 242
 243         # Avoid ending the function name with underscore, for
 244         # cosmetics.  Trailing underscores appear after munging types
 245         # with template parameters, like e.g. "foo<int>".
 246         $result =~ s/_$//g;
 247
 248         $result = 'target_debug_print_' . $result;
 249     }
 250
 251     return $result;
 252 }
 253
 254 # Write out a debug method.
 255 sub write_debugmethod($$$$@) {
 256     my ($content, $style, $name, $return_type, @argtypes) = @_;
 257
 258     my ($debugname) = $name;
 259     $debugname =~ s/to_/debug_/;
 260     my ($targetname) = $name;
 261     $targetname =~ s/to_/target_/;
 262
 263     my (@names) = write_function_header ($debugname, $return_type, @argtypes);
 264
 265     if ($return_type ne 'void') {
 266         print "  $return_type result;\n";
 267     }
 268
 269     print "  fprintf_unfiltered (gdb_stdlog, \"-> %s->$name (...)\\n\", debug_target.to_shortname);\n";
 270
 271     # Delegate to the beneath target.
 272     print "  ";
 273     if ($return_type ne 'void') {
 274         print "result = ";
 275     }
 276     print "debug_target." . $name . " (";
 277     my @names2 = @names;
 278     @names2[0] = "&debug_target";
 279     print join (', ', @names2);
 280     print ");\n";
 281
 282     # Now print the arguments.
 283     print "  fprintf_unfiltered (gdb_stdlog, \"<- %s->$name (\", debug_target.to_shortname);\n";
 284     for my $i (0 .. $#argtypes) {
 285         print "  fputs_unfiltered (\", \", gdb_stdlog);\n" if $i > 0;
 286         my $printer = munge_type ($argtypes[$i]);
 287         print "  $printer ($names2[$i]);\n";
 288     }
 289     if ($return_type ne 'void') {
 290         print "  fputs_unfiltered (\") = \", gdb_stdlog);\n";
 291         my $printer = munge_type ($return_type);
 292         print "  $printer (result);\n";
 293         print "  fputs_unfiltered (\"\\n\", gdb_stdlog);\n";
 294     } else {
 295         print "  fputs_unfiltered (\")\\n\", gdb_stdlog);\n";
 296     }
 297
 298     if ($return_type ne 'void') {
 299         print "  return result;\n";
 300     }
 301
 302     print "}\n\n";
 303
 304     return $debugname;
 305 }
 306
 307 print "/* THIS FILE IS GENERATED -*- buffer-read-only: t -*- */\n";
 308 print "/* vi:set ro: */\n\n";
 309 print "/* To regenerate this file, run:*/\n";
 310 print "/*      make-target-delegates target.h > target-delegates.c */\n";
 311
 312 @lines = scan_target_h();
 313
 314
 315 %tdefault_names = ();
 316 %debug_names = ();
 317 @delegators = ();
 318 foreach $current_line (@lines) {
 319     next unless $current_line =~ m/$METHOD/;
 320
 321     $name = $+{name};
 322     $current_line = $+{args};
 323     $return_type = trim ($+{return_type});
 324     $current_args = $+{args};
 325     $tdefault = $+{default_arg};
 326     $style = $+{style};
 327
 328     @argtypes = parse_argtypes ($current_args);
 329
 330     # The first argument must be "this" to be delegatable.
 331     if ($argtypes[0] =~ /\s*struct\s+target_ops\s*\*\s*/) {
 332         write_delegator ($name, $return_type, @argtypes);
 333
 334         push @delegators, $name;
 335
 336         $tdefault_names{$name} = write_tdefault ($tdefault, $style,
 337                                                  $name, $return_type,
 338                                                  @argtypes);
 339
 340         $debug_names{$name} = write_debugmethod ($tdefault, $style,
 341                                                  $name, $return_type,
 342                                                  @argtypes);
 343     }
 344 }
 345
 346 # Now the delegation code.
 347 print "static void\ninstall_delegators (struct target_ops *ops)\n{\n";
 348
 349 for $iter (@delegators) {
 350     print "  if (ops->" . $iter . " == NULL)\n";
 351     print "    ops->" . $iter . " = " . dname ($iter) . ";\n";
 352 }
 353 print "}\n\n";
 354
 355 # Now the default method code.
 356 print "static void\ninstall_dummy_methods (struct target_ops *ops)\n{\n";
 357
 358 for $iter (@delegators) {
 359     print "  ops->" . $iter . " = " . $tdefault_names{$iter} . ";\n";
 360 }
 361 print "}\n\n";
 362
 363 # The debug method code.
 364 print "static void\ninit_debug_target (struct target_ops *ops)\n{\n";
 365 for $iter (@delegators) {
 366     print "  ops->" . $iter . " = " . $debug_names{$iter} . ";\n";
 367 }
 368 print "}\n";