#!/usr/bin/perl # Copyright (C) 2013-2020 Free Software Foundation, Inc. # # This file is part of GDB. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <http://www.gnu.org/licenses/>. # Usage: # make-target-delegates target.h > target-delegates.c # The line we search for in target.h that marks where we should start # looking for methods. $TRIGGER = qr,^struct target_ops$,; # The end of the methods part. $ENDER = qr,^\s*};$,; # Match a C symbol. $SYMBOL = qr,[a-zA-Z_][a-zA-Z0-9_]*,; # Match the name part of a method in struct target_ops. $NAME_PART = qr,(?<name>${SYMBOL}+)\s,; # Match the arguments to a method. $ARGS_PART = qr,(?<args>\(.*\)),; # We strip the indentation so here we only need the caret. $INTRO_PART = qr,^,; $POINTER_PART = qr,\s*(\*)?\s*,; # Match a C++ symbol, including scope operators and template # parameters. E.g., 'std::vector<something>'. $CP_SYMBOL = qr,[a-zA-Z_][a-zA-Z0-9_<>:]*,; # Match the return type when it is "ordinary". $SIMPLE_RETURN_PART = qr,((struct|class|enum|union)\s+)?${CP_SYMBOL}+,; # Match a return type. $RETURN_PART = qr,((const|volatile)\s+)?(${SIMPLE_RETURN_PART})${POINTER_PART},; # Match "virtual". $VIRTUAL_PART = qr,virtual\s,; # Match the TARGET_DEFAULT_* attribute for a method. $TARGET_DEFAULT_PART = qr,TARGET_DEFAULT_(?<style>[A-Z_]+)\s*\((?<default_arg>.*)\),; # Match the arguments and trailing attribute of a method definition. # Note we don't match the trailing ";". $METHOD_TRAILER = qr,\s*${TARGET_DEFAULT_PART}$,; # Match an entire method definition. $METHOD = ($INTRO_PART . $VIRTUAL_PART . "(?<return_type>" . $RETURN_PART . ")" . $NAME_PART . $ARGS_PART . $METHOD_TRAILER); # Match TARGET_DEBUG_PRINTER in an argument type. # This must match the whole "sub-expression" including the parens. # Reference $1 must refer to the function argument. $TARGET_DEBUG_PRINTER = qr,\s*TARGET_DEBUG_PRINTER\s*\(([^)]*)\)\s*,; sub trim($) { my ($result) = @_; $result =~ s,^\s+,,; $result =~ s,\s+$,,; return $result; } # Read from the input files until we find the trigger line. # Die if not found. sub find_trigger() { while (<>) { chomp; return if m/$TRIGGER/; } die "could not find trigger line\n"; } # Scan target.h and return a list of possible target_ops method entries. sub scan_target_h() { my $all_the_text = ''; find_trigger(); while (<>) { chomp; # Skip the open brace. next if /{/; last if m/$ENDER/; # Strip // comments. $_ =~ s,//.*$,,; $all_the_text .= $_; } # Now strip out the C comments. $all_the_text =~ s,/\*(.*?)\*/,,g; # Replace sequences of tabs and/or whitespace with a single # whitespace character. We need the whitespace because the method # may have been split between multiple lines, like e.g.: # # virtual std::vector<long_type_name> # my_long_method_name () # TARGET_DEFAULT_IGNORE (); # # If we didn't preserve the whitespace, then we'd end up with: # # virtual std::vector<long_type_name>my_long_method_name ()TARGET_DEFAULT_IGNORE () # # ... which wouldn't later be parsed correctly. $all_the_text =~ s/[\t\s]+/ /g; return split (/;/, $all_the_text); } # Parse arguments into a list. sub parse_argtypes($) { my ($typestr) = @_; $typestr =~ s/^\((.*)\)$/\1/; my (@typelist) = split (/,\s*/, $typestr); my (@result, $iter, $onetype); foreach $iter (@typelist) { if ($iter =~ m/^(enum\s+${SYMBOL}\s*)(${SYMBOL})?$/) { $onetype = $1; } elsif ($iter =~ m/^(.*(enum\s+)?${SYMBOL}.*(\s|\*|&))${SYMBOL}+$/) { $onetype = $1; } elsif ($iter eq 'void') { next; } else { $onetype = $iter; } push @result, trim ($onetype); } return @result; } sub dname($) { my ($name) = @_; return "target_ops::" . $name; } # Write function header given name, return type, and argtypes. # Returns a list of actual argument names. sub write_function_header($$$@) { my ($decl, $name, $return_type, @argtypes) = @_; print $return_type; if ($decl) { if ($return_type !~ m,\*$,) { print " "; } } else { print "\n"; } print $name . ' ('; my $iter; my @argdecls; my @actuals; my $i = 0; foreach $iter (@argtypes) { my $val = $iter; $val =~ s/$TARGET_DEBUG_PRINTER//; if ($iter !~ m,(\*|&)$,) { $val .= ' '; } my $vname; $vname .= "arg$i"; $val .= $vname; push @argdecls, $val; push @actuals, $vname; ++$i; } print join (', ', @argdecls) . ")"; if ($decl) { print " override;\n"; } else { print "\n{\n"; } return @actuals; } # Write out a declaration. sub write_declaration($$@) { my ($name, $return_type, @argtypes) = @_; write_function_header (1, $name, $return_type, @argtypes); } # Write out a delegation function. sub write_delegator($$@) { my ($name, $return_type, @argtypes) = @_; my (@names) = write_function_header (0, dname ($name), $return_type, @argtypes); print " "; if ($return_type ne 'void') { print "return "; } print "this->beneath ()->" . $name . " ("; print join (', ', @names); print ");\n"; print "}\n\n"; } sub tdname ($) { my ($name) = @_; return "dummy_target::" . $name; } # Write out a default function. sub write_tdefault($$$$@) { my ($content, $style, $name, $return_type, @argtypes) = @_; my (@names) = write_function_header (0, tdname ($name), $return_type, @argtypes); if ($style eq 'FUNC') { print " "; if ($return_type ne 'void') { print "return "; } print $content . " (this"; if (@names) { print ", "; } print join (', ', @names); print ");\n"; } elsif ($style eq 'RETURN') { print " return $content;\n"; } elsif ($style eq 'NORETURN') { print " $content;\n"; } elsif ($style eq 'IGNORE') { # Nothing. } else { die "unrecognized style: $style\n"; } print "}\n\n"; return tdname ($name); } sub munge_type($) { my ($typename) = @_; my ($result); if ($typename =~ m/$TARGET_DEBUG_PRINTER/) { $result = $1; } else { ($result = $typename) =~ s/\s+$//; $result =~ s/[ ()<>:]/_/g; $result =~ s/[*]/p/g; $result =~ s/&/r/g; # Identifers with double underscores are reserved to the C++ # implementation. $result =~ s/_+/_/g; # Avoid ending the function name with underscore, for # cosmetics. Trailing underscores appear after munging types # with template parameters, like e.g. "foo<int>". $result =~ s/_$//g; $result = 'target_debug_print_' . $result; } return $result; } # Write out a debug method. sub write_debugmethod($$$@) { my ($content, $name, $return_type, @argtypes) = @_; my ($debugname) = "debug_target::" . $name; my ($targetname) = $name; my (@names) = write_function_header (0, $debugname, $return_type, @argtypes); if ($return_type ne 'void') { print " $return_type result;\n"; } print " fprintf_unfiltered (gdb_stdlog, \"-> %s->$name (...)\\n\", this->beneath ()->shortname ());\n"; # Delegate to the beneath target. print " "; if ($return_type ne 'void') { print "result = "; } print "this->beneath ()->" . $name . " ("; print join (', ', @names); print ");\n"; # Now print the arguments. print " fprintf_unfiltered (gdb_stdlog, \"<- %s->$name (\", this->beneath ()->shortname ());\n"; for my $i (0 .. $#argtypes) { if ($i > 0) { print " fputs_unfiltered (\", \", gdb_stdlog);\n" } my $printer = munge_type ($argtypes[$i]); print " $printer ($names[$i]);\n"; } if ($return_type ne 'void') { print " fputs_unfiltered (\") = \", gdb_stdlog);\n"; my $printer = munge_type ($return_type); print " $printer (result);\n"; print " fputs_unfiltered (\"\\n\", gdb_stdlog);\n"; } else { print " fputs_unfiltered (\")\\n\", gdb_stdlog);\n"; } if ($return_type ne 'void') { print " return result;\n"; } print "}\n\n"; return $debugname; } print "/* THIS FILE IS GENERATED -*- buffer-read-only: t -*- */\n"; print "/* vi:set ro: */\n\n"; print "/* To regenerate this file, run:*/\n"; print "/* make-target-delegates target.h > target-delegates.c */\n"; print "\n"; @lines = scan_target_h(); @delegators = (); @return_types = (); @tdefaults = (); @styles = (); @argtypes_array = (); foreach $current_line (@lines) { # See comments in scan_target_h. Here we strip away the leading # and trailing whitespace. $current_line = trim ($current_line); next unless $current_line =~ m/$METHOD/; my $name = $+{name}; my $current_line = $+{args}; my $return_type = trim ($+{return_type}); my $current_args = $+{args}; my $tdefault = $+{default_arg}; my $style = $+{style}; my @argtypes = parse_argtypes ($current_args); push @delegators, $name; $return_types{$name} = $return_type; $tdefaults{$name} = $tdefault; $styles{$name} = $style; $argtypes_array{$name} = \@argtypes; } sub print_class($) { my ($name) = @_; print "struct " . $name . " : public target_ops\n"; print "{\n"; print " const target_info &info () const override;\n"; print "\n"; print " strata stratum () const override;\n"; print "\n"; for $name (@delegators) { my $return_type = $return_types{$name}; my @argtypes = @{$argtypes_array{$name}}; print " "; write_declaration ($name, $return_type, @argtypes); } print "};\n\n"; } print_class ("dummy_target"); print_class ("debug_target"); for $name (@delegators) { my $tdefault = $tdefaults{$name}; my $return_type = $return_types{$name}; my $style = $styles{$name}; my @argtypes = @{$argtypes_array{$name}}; write_delegator ($name, $return_type, @argtypes); write_tdefault ($tdefault, $style, $name, $return_type, @argtypes); write_debugmethod ($tdefault, $name, $return_type, @argtypes); }