gdb/make-target-delegates

   1 #!/usr/bin/perl
   2
   3 # Copyright (C) 2013-2014 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 sub trim($) {
  58     my ($result) = @_;
  59
  60     $result =~ s,^\s+,,;
  61     $result =~ s,\s+$,,;
  62
  63     return $result;
  64 }
  65
  66 # Read from the input files until we find the trigger line.
  67 # Die if not found.
  68 sub find_trigger() {
  69     while (<>) {
  70         chomp;
  71         return if m/$TRIGGER/;
  72     }
  73
  74     die "could not find trigger line\n";
  75 }
  76
  77 # Scan target.h and return a list of possible target_ops method entries.
  78 sub scan_target_h() {
  79     my $all_the_text = '';
  80
  81     find_trigger();
  82     while (<>) {
  83         chomp;
  84         # Skip the open brace.
  85         next if /{/;
  86         last if m/$ENDER/;
  87
  88         # Just in case somebody ever uses C99.
  89         $_ =~ s,//.*$,,;
  90         $_ = trim ($_);
  91
  92         $all_the_text .= $_;
  93     }
  94
  95     # Now strip out the C comments.
  96     $all_the_text =~ s,/\*(.*?)\*/,,g;
  97
  98     return split (/;/, $all_the_text);
  99 }
 100
 101 # Parse arguments into a list.
 102 sub parse_argtypes($) {
 103     my ($typestr) = @_;
 104
 105     $typestr =~ s/^\((.*)\)$/\1/;
 106
 107     my (@typelist) = split (/,\s*/, $typestr);
 108     my (@result, $iter, $onetype);
 109
 110     foreach $iter (@typelist) {
 111         if ($iter =~ m/^(enum\s+${SYMBOL}\s*)(${SYMBOL})?$/) {
 112             $onetype = $1;
 113         } elsif ($iter =~ m/^(.*(enum\s+)?${SYMBOL}.*(\s|\*))${SYMBOL}+$/) {
 114             $onetype = $1;
 115         } elsif ($iter eq 'void') {
 116             next;
 117         } else {
 118             $onetype = $iter;
 119         }
 120         push @result, trim ($onetype);
 121     }
 122
 123     return @result;
 124 }
 125
 126 sub dname($) {
 127     my ($name) = @_;
 128     $name =~ s/to_/delegate_/;
 129     return $name;
 130 }
 131
 132 # Write function header given name, return type, and argtypes.
 133 # Returns a list of actual argument names.
 134 sub write_function_header($$@) {
 135     my ($name, $return_type, @argtypes) = @_;
 136
 137     print "static " . $return_type . "\n";
 138     print $name . ' (';
 139
 140     my $iter;
 141     my @argdecls;
 142     my @actuals;
 143     my $i = 0;
 144     foreach $iter (@argtypes) {
 145         my $val = $iter;
 146
 147         if ($iter !~ m,\*$,) {
 148             $val .= ' ';
 149         }
 150
 151         my $vname;
 152         if ($i == 0) {
 153             # Just a random nicety.
 154             $vname = 'self';
 155         } else {
 156             $vname .= "arg$i";
 157         }
 158         $val .= $vname;
 159
 160         push @argdecls, $val;
 161         push @actuals, $vname;
 162         ++$i;
 163     }
 164
 165     print join (', ', @argdecls) . ")\n";
 166     print "{\n";
 167
 168     return @actuals;
 169 }
 170
 171 # Write out a delegation function.
 172 sub write_delegator($$@) {
 173     my ($name, $return_type, @argtypes) = @_;
 174
 175     my (@names) = write_function_header (dname ($name), $return_type,
 176                                          @argtypes);
 177
 178     print "  $names[0] = $names[0]->beneath;\n";
 179     print "  ";
 180     if ($return_type ne 'void') {
 181         print "return ";
 182     }
 183     print "$names[0]->" . $name . " (";
 184     print join (', ', @names);
 185     print ");\n";
 186     print "}\n\n";
 187 }
 188
 189 sub tdname ($) {
 190     my ($name) = @_;
 191     $name =~ s/to_/tdefault_/;
 192     return $name;
 193 }
 194
 195 # Write out a default function.
 196 sub write_tdefault($$$$@) {
 197     my ($content, $style, $name, $return_type, @argtypes) = @_;
 198
 199     if ($style eq 'FUNC') {
 200         return $content;
 201     }
 202
 203     write_function_header (tdname ($name), $return_type, @argtypes);
 204
 205     if ($style eq 'RETURN') {
 206         print "  return $content;\n";
 207     } elsif ($style eq 'NORETURN') {
 208         print "  $content;\n";
 209     } elsif ($style eq 'IGNORE') {
 210         # Nothing.
 211     } else {
 212         die "unrecognized style: $style\n";
 213     }
 214
 215     print "}\n\n";
 216
 217     return tdname ($name);
 218 }
 219
 220 print "/* THIS FILE IS GENERATED -*- buffer-read-only: t -*- */\n";
 221 print "/* vi:set ro: */\n\n";
 222 print "/* To regenerate this file, run:*/\n";
 223 print "/*      make-target-delegates target.h > target-delegates.c */\n";
 224
 225 @lines = scan_target_h();
 226
 227
 228 %tdefault_names = ();
 229 @delegators = ();
 230 foreach $current_line (@lines) {
 231     next unless $current_line =~ m/$METHOD/;
 232
 233     $name = $+{name};
 234     $current_line = $+{args};
 235     $return_type = trim ($+{return_type});
 236     $current_args = $+{args};
 237     $tdefault = $+{default_arg};
 238     $style = $+{style};
 239
 240     @argtypes = parse_argtypes ($current_args);
 241
 242     # The first argument must be "this" to be delegatable.
 243     if ($argtypes[0] =~ /\s*struct\s+target_ops\s*\*\s*/) {
 244         write_delegator ($name, $return_type, @argtypes);
 245
 246         push @delegators, $name;
 247
 248         $tdefault_names{$name} = write_tdefault ($tdefault, $style,
 249                                                  $name, $return_type,
 250                                                  @argtypes);
 251     }
 252 }
 253
 254 # Now the delegation code.
 255 print "static void\ninstall_delegators (struct target_ops *ops)\n{\n";
 256
 257 for $iter (@delegators) {
 258     print "  if (ops->" . $iter . " == NULL)\n";
 259     print "    ops->" . $iter . " = " . dname ($iter) . ";\n";
 260 }
 261 print "}\n\n";
 262
 263 # Now the default method code.
 264 print "static void\ninstall_dummy_methods (struct target_ops *ops)\n{\n";
 265
 266 for $iter (@delegators) {
 267     print "  ops->" . $iter . " = " . $tdefault_names{$iter} . ";\n";
 268 }
 269 print "}\n";