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