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