126a53354Schristos#!/usr/bin/perl 226a53354Schristos 3*1424dfb3Schristos# Copyright (C) 2013-2020 Free Software Foundation, Inc. 426a53354Schristos# 526a53354Schristos# This file is part of GDB. 626a53354Schristos# 726a53354Schristos# This program is free software; you can redistribute it and/or modify 826a53354Schristos# it under the terms of the GNU General Public License as published by 926a53354Schristos# the Free Software Foundation; either version 3 of the License, or 1026a53354Schristos# (at your option) any later version. 1126a53354Schristos# 1226a53354Schristos# This program is distributed in the hope that it will be useful, 1326a53354Schristos# but WITHOUT ANY WARRANTY; without even the implied warranty of 1426a53354Schristos# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 1526a53354Schristos# GNU General Public License for more details. 1626a53354Schristos# 1726a53354Schristos# You should have received a copy of the GNU General Public License 1826a53354Schristos# along with this program. If not, see <http://www.gnu.org/licenses/>. 1926a53354Schristos 2026a53354Schristos 2126a53354Schristos# Usage: 2226a53354Schristos# make-target-delegates target.h > target-delegates.c 2326a53354Schristos 2426a53354Schristos# The line we search for in target.h that marks where we should start 2526a53354Schristos# looking for methods. 2626a53354Schristos$TRIGGER = qr,^struct target_ops$,; 2726a53354Schristos# The end of the methods part. 2826a53354Schristos$ENDER = qr,^\s*};$,; 2926a53354Schristos 3026a53354Schristos# Match a C symbol. 3126a53354Schristos$SYMBOL = qr,[a-zA-Z_][a-zA-Z0-9_]*,; 3226a53354Schristos# Match the name part of a method in struct target_ops. 3307163879Schristos$NAME_PART = qr,(?<name>${SYMBOL}+)\s,; 3426a53354Schristos# Match the arguments to a method. 3526a53354Schristos$ARGS_PART = qr,(?<args>\(.*\)),; 3626a53354Schristos# We strip the indentation so here we only need the caret. 3726a53354Schristos$INTRO_PART = qr,^,; 3826a53354Schristos 3907163879Schristos$POINTER_PART = qr,\s*(\*)?\s*,; 4007163879Schristos 4107163879Schristos# Match a C++ symbol, including scope operators and template 4207163879Schristos# parameters. E.g., 'std::vector<something>'. 4307163879Schristos$CP_SYMBOL = qr,[a-zA-Z_][a-zA-Z0-9_<>:]*,; 4426a53354Schristos# Match the return type when it is "ordinary". 4507163879Schristos$SIMPLE_RETURN_PART = qr,((struct|class|enum|union)\s+)?${CP_SYMBOL}+,; 4607163879Schristos 4707163879Schristos# Match a return type. 48*1424dfb3Schristos$RETURN_PART = qr,((const|volatile)\s+)?(${SIMPLE_RETURN_PART})${POINTER_PART},; 4907163879Schristos 5007163879Schristos# Match "virtual". 5107163879Schristos$VIRTUAL_PART = qr,virtual\s,; 5226a53354Schristos 5326a53354Schristos# Match the TARGET_DEFAULT_* attribute for a method. 5426a53354Schristos$TARGET_DEFAULT_PART = qr,TARGET_DEFAULT_(?<style>[A-Z_]+)\s*\((?<default_arg>.*)\),; 5526a53354Schristos 5626a53354Schristos# Match the arguments and trailing attribute of a method definition. 5726a53354Schristos# Note we don't match the trailing ";". 5826a53354Schristos$METHOD_TRAILER = qr,\s*${TARGET_DEFAULT_PART}$,; 5926a53354Schristos 6026a53354Schristos# Match an entire method definition. 6107163879Schristos$METHOD = ($INTRO_PART . $VIRTUAL_PART . "(?<return_type>" . $RETURN_PART . ")" 6226a53354Schristos . $NAME_PART . $ARGS_PART 6326a53354Schristos . $METHOD_TRAILER); 6426a53354Schristos 6526a53354Schristos# Match TARGET_DEBUG_PRINTER in an argument type. 6626a53354Schristos# This must match the whole "sub-expression" including the parens. 6726a53354Schristos# Reference $1 must refer to the function argument. 6826a53354Schristos$TARGET_DEBUG_PRINTER = qr,\s*TARGET_DEBUG_PRINTER\s*\(([^)]*)\)\s*,; 6926a53354Schristos 7026a53354Schristossub trim($) { 7126a53354Schristos my ($result) = @_; 7226a53354Schristos 7326a53354Schristos $result =~ s,^\s+,,; 7426a53354Schristos $result =~ s,\s+$,,; 7526a53354Schristos 7626a53354Schristos return $result; 7726a53354Schristos} 7826a53354Schristos 7926a53354Schristos# Read from the input files until we find the trigger line. 8026a53354Schristos# Die if not found. 8126a53354Schristossub find_trigger() { 8226a53354Schristos while (<>) { 8326a53354Schristos chomp; 8426a53354Schristos return if m/$TRIGGER/; 8526a53354Schristos } 8626a53354Schristos 8726a53354Schristos die "could not find trigger line\n"; 8826a53354Schristos} 8926a53354Schristos 9026a53354Schristos# Scan target.h and return a list of possible target_ops method entries. 9126a53354Schristossub scan_target_h() { 9226a53354Schristos my $all_the_text = ''; 9326a53354Schristos 9426a53354Schristos find_trigger(); 9526a53354Schristos while (<>) { 9626a53354Schristos chomp; 9726a53354Schristos # Skip the open brace. 9826a53354Schristos next if /{/; 9926a53354Schristos last if m/$ENDER/; 10026a53354Schristos 10107163879Schristos # Strip // comments. 10226a53354Schristos $_ =~ s,//.*$,,; 10326a53354Schristos 10426a53354Schristos $all_the_text .= $_; 10526a53354Schristos } 10626a53354Schristos 10726a53354Schristos # Now strip out the C comments. 10826a53354Schristos $all_the_text =~ s,/\*(.*?)\*/,,g; 10926a53354Schristos 11007163879Schristos # Replace sequences of tabs and/or whitespace with a single 11107163879Schristos # whitespace character. We need the whitespace because the method 11207163879Schristos # may have been split between multiple lines, like e.g.: 11307163879Schristos # 11407163879Schristos # virtual std::vector<long_type_name> 11507163879Schristos # my_long_method_name () 11607163879Schristos # TARGET_DEFAULT_IGNORE (); 11707163879Schristos # 11807163879Schristos # If we didn't preserve the whitespace, then we'd end up with: 11907163879Schristos # 12007163879Schristos # virtual std::vector<long_type_name>my_long_method_name ()TARGET_DEFAULT_IGNORE () 12107163879Schristos # 12207163879Schristos # ... which wouldn't later be parsed correctly. 12307163879Schristos $all_the_text =~ s/[\t\s]+/ /g; 12407163879Schristos 12526a53354Schristos return split (/;/, $all_the_text); 12626a53354Schristos} 12726a53354Schristos 12826a53354Schristos# Parse arguments into a list. 12926a53354Schristossub parse_argtypes($) { 13026a53354Schristos my ($typestr) = @_; 13126a53354Schristos 13226a53354Schristos $typestr =~ s/^\((.*)\)$/\1/; 13326a53354Schristos 13426a53354Schristos my (@typelist) = split (/,\s*/, $typestr); 13526a53354Schristos my (@result, $iter, $onetype); 13626a53354Schristos 13726a53354Schristos foreach $iter (@typelist) { 13826a53354Schristos if ($iter =~ m/^(enum\s+${SYMBOL}\s*)(${SYMBOL})?$/) { 13926a53354Schristos $onetype = $1; 14007163879Schristos } elsif ($iter =~ m/^(.*(enum\s+)?${SYMBOL}.*(\s|\*|&))${SYMBOL}+$/) { 14126a53354Schristos $onetype = $1; 14226a53354Schristos } elsif ($iter eq 'void') { 14326a53354Schristos next; 14426a53354Schristos } else { 14526a53354Schristos $onetype = $iter; 14626a53354Schristos } 14726a53354Schristos push @result, trim ($onetype); 14826a53354Schristos } 14926a53354Schristos 15026a53354Schristos return @result; 15126a53354Schristos} 15226a53354Schristos 15326a53354Schristossub dname($) { 15426a53354Schristos my ($name) = @_; 15507163879Schristos return "target_ops::" . $name; 15626a53354Schristos} 15726a53354Schristos 15826a53354Schristos# Write function header given name, return type, and argtypes. 15926a53354Schristos# Returns a list of actual argument names. 16007163879Schristossub write_function_header($$$@) { 16107163879Schristos my ($decl, $name, $return_type, @argtypes) = @_; 16226a53354Schristos 16307163879Schristos print $return_type; 16407163879Schristos 16507163879Schristos if ($decl) { 16607163879Schristos if ($return_type !~ m,\*$,) { 16707163879Schristos print " "; 16807163879Schristos } 16907163879Schristos } else { 17007163879Schristos print "\n"; 17107163879Schristos } 17207163879Schristos 17326a53354Schristos print $name . ' ('; 17426a53354Schristos 17526a53354Schristos my $iter; 17626a53354Schristos my @argdecls; 17726a53354Schristos my @actuals; 17826a53354Schristos my $i = 0; 17926a53354Schristos foreach $iter (@argtypes) { 18026a53354Schristos my $val = $iter; 18126a53354Schristos 18226a53354Schristos $val =~ s/$TARGET_DEBUG_PRINTER//; 18326a53354Schristos 18407163879Schristos if ($iter !~ m,(\*|&)$,) { 18526a53354Schristos $val .= ' '; 18626a53354Schristos } 18726a53354Schristos 18826a53354Schristos my $vname; 18926a53354Schristos $vname .= "arg$i"; 19026a53354Schristos $val .= $vname; 19126a53354Schristos 19226a53354Schristos push @argdecls, $val; 19326a53354Schristos push @actuals, $vname; 19426a53354Schristos ++$i; 19526a53354Schristos } 19626a53354Schristos 19707163879Schristos print join (', ', @argdecls) . ")"; 19807163879Schristos 19907163879Schristos if ($decl) { 20007163879Schristos print " override;\n"; 20107163879Schristos } else { 20207163879Schristos print "\n{\n"; 20307163879Schristos } 20426a53354Schristos 20526a53354Schristos return @actuals; 20626a53354Schristos} 20726a53354Schristos 20807163879Schristos# Write out a declaration. 20907163879Schristossub write_declaration($$@) { 21007163879Schristos my ($name, $return_type, @argtypes) = @_; 21107163879Schristos 21207163879Schristos write_function_header (1, $name, $return_type, @argtypes); 21307163879Schristos} 21407163879Schristos 21526a53354Schristos# Write out a delegation function. 21626a53354Schristossub write_delegator($$@) { 21726a53354Schristos my ($name, $return_type, @argtypes) = @_; 21826a53354Schristos 21907163879Schristos my (@names) = write_function_header (0, dname ($name), 22007163879Schristos $return_type, @argtypes); 22126a53354Schristos 22226a53354Schristos print " "; 22326a53354Schristos if ($return_type ne 'void') { 22426a53354Schristos print "return "; 22526a53354Schristos } 22607163879Schristos print "this->beneath ()->" . $name . " ("; 22726a53354Schristos print join (', ', @names); 22826a53354Schristos print ");\n"; 22926a53354Schristos print "}\n\n"; 23026a53354Schristos} 23126a53354Schristos 23226a53354Schristossub tdname ($) { 23326a53354Schristos my ($name) = @_; 23407163879Schristos return "dummy_target::" . $name; 23526a53354Schristos} 23626a53354Schristos 23726a53354Schristos# Write out a default function. 23826a53354Schristossub write_tdefault($$$$@) { 23926a53354Schristos my ($content, $style, $name, $return_type, @argtypes) = @_; 24026a53354Schristos 24107163879Schristos my (@names) = write_function_header (0, tdname ($name), 24207163879Schristos $return_type, @argtypes); 24307163879Schristos 24426a53354Schristos if ($style eq 'FUNC') { 24507163879Schristos print " "; 24607163879Schristos if ($return_type ne 'void') { 24707163879Schristos print "return "; 24826a53354Schristos } 24907163879Schristos print $content . " (this"; 25007163879Schristos if (@names) { 25107163879Schristos print ", "; 25207163879Schristos } 25307163879Schristos print join (', ', @names); 25407163879Schristos print ");\n"; 25507163879Schristos } elsif ($style eq 'RETURN') { 25626a53354Schristos print " return $content;\n"; 25726a53354Schristos } elsif ($style eq 'NORETURN') { 25826a53354Schristos print " $content;\n"; 25926a53354Schristos } elsif ($style eq 'IGNORE') { 26026a53354Schristos # Nothing. 26126a53354Schristos } else { 26226a53354Schristos die "unrecognized style: $style\n"; 26326a53354Schristos } 26426a53354Schristos 26526a53354Schristos print "}\n\n"; 26626a53354Schristos 26726a53354Schristos return tdname ($name); 26826a53354Schristos} 26926a53354Schristos 27026a53354Schristossub munge_type($) { 27126a53354Schristos my ($typename) = @_; 27226a53354Schristos my ($result); 27326a53354Schristos 27426a53354Schristos if ($typename =~ m/$TARGET_DEBUG_PRINTER/) { 27526a53354Schristos $result = $1; 27626a53354Schristos } else { 27726a53354Schristos ($result = $typename) =~ s/\s+$//; 27807163879Schristos $result =~ s/[ ()<>:]/_/g; 27926a53354Schristos $result =~ s/[*]/p/g; 28007163879Schristos $result =~ s/&/r/g; 28107163879Schristos 28207163879Schristos # Identifers with double underscores are reserved to the C++ 28307163879Schristos # implementation. 28407163879Schristos $result =~ s/_+/_/g; 28507163879Schristos 28607163879Schristos # Avoid ending the function name with underscore, for 28707163879Schristos # cosmetics. Trailing underscores appear after munging types 28807163879Schristos # with template parameters, like e.g. "foo<int>". 28907163879Schristos $result =~ s/_$//g; 29007163879Schristos 29126a53354Schristos $result = 'target_debug_print_' . $result; 29226a53354Schristos } 29326a53354Schristos 29426a53354Schristos return $result; 29526a53354Schristos} 29626a53354Schristos 29726a53354Schristos# Write out a debug method. 29807163879Schristossub write_debugmethod($$$@) { 29907163879Schristos my ($content, $name, $return_type, @argtypes) = @_; 30026a53354Schristos 30107163879Schristos my ($debugname) = "debug_target::" . $name; 30226a53354Schristos my ($targetname) = $name; 30326a53354Schristos 30407163879Schristos my (@names) = write_function_header (0, $debugname, $return_type, @argtypes); 30526a53354Schristos 30626a53354Schristos if ($return_type ne 'void') { 30726a53354Schristos print " $return_type result;\n"; 30826a53354Schristos } 30926a53354Schristos 31007163879Schristos print " fprintf_unfiltered (gdb_stdlog, \"-> %s->$name (...)\\n\", this->beneath ()->shortname ());\n"; 31126a53354Schristos 31226a53354Schristos # Delegate to the beneath target. 31326a53354Schristos print " "; 31426a53354Schristos if ($return_type ne 'void') { 31526a53354Schristos print "result = "; 31626a53354Schristos } 31707163879Schristos print "this->beneath ()->" . $name . " ("; 31807163879Schristos print join (', ', @names); 31926a53354Schristos print ");\n"; 32026a53354Schristos 32126a53354Schristos # Now print the arguments. 32207163879Schristos print " fprintf_unfiltered (gdb_stdlog, \"<- %s->$name (\", this->beneath ()->shortname ());\n"; 32326a53354Schristos for my $i (0 .. $#argtypes) { 32407163879Schristos if ($i > 0) { 32507163879Schristos print " fputs_unfiltered (\", \", gdb_stdlog);\n" 32607163879Schristos } 32726a53354Schristos my $printer = munge_type ($argtypes[$i]); 32807163879Schristos print " $printer ($names[$i]);\n"; 32926a53354Schristos } 33026a53354Schristos if ($return_type ne 'void') { 33126a53354Schristos print " fputs_unfiltered (\") = \", gdb_stdlog);\n"; 33226a53354Schristos my $printer = munge_type ($return_type); 33326a53354Schristos print " $printer (result);\n"; 33426a53354Schristos print " fputs_unfiltered (\"\\n\", gdb_stdlog);\n"; 33526a53354Schristos } else { 33626a53354Schristos print " fputs_unfiltered (\")\\n\", gdb_stdlog);\n"; 33726a53354Schristos } 33826a53354Schristos 33926a53354Schristos if ($return_type ne 'void') { 34026a53354Schristos print " return result;\n"; 34126a53354Schristos } 34226a53354Schristos 34326a53354Schristos print "}\n\n"; 34426a53354Schristos 34526a53354Schristos return $debugname; 34626a53354Schristos} 34726a53354Schristos 34826a53354Schristosprint "/* THIS FILE IS GENERATED -*- buffer-read-only: t -*- */\n"; 34926a53354Schristosprint "/* vi:set ro: */\n\n"; 35026a53354Schristosprint "/* To regenerate this file, run:*/\n"; 35126a53354Schristosprint "/* make-target-delegates target.h > target-delegates.c */\n"; 35207163879Schristosprint "\n"; 35326a53354Schristos 35426a53354Schristos@lines = scan_target_h(); 35526a53354Schristos 35626a53354Schristos@delegators = (); 35707163879Schristos@return_types = (); 35807163879Schristos@tdefaults = (); 35907163879Schristos@styles = (); 36007163879Schristos@argtypes_array = (); 36107163879Schristos 36226a53354Schristosforeach $current_line (@lines) { 36307163879Schristos # See comments in scan_target_h. Here we strip away the leading 36407163879Schristos # and trailing whitespace. 36507163879Schristos $current_line = trim ($current_line); 36607163879Schristos 36726a53354Schristos next unless $current_line =~ m/$METHOD/; 36826a53354Schristos 36907163879Schristos my $name = $+{name}; 37007163879Schristos my $current_line = $+{args}; 37107163879Schristos my $return_type = trim ($+{return_type}); 37207163879Schristos my $current_args = $+{args}; 37307163879Schristos my $tdefault = $+{default_arg}; 37407163879Schristos my $style = $+{style}; 37526a53354Schristos 37607163879Schristos my @argtypes = parse_argtypes ($current_args); 37726a53354Schristos 37826a53354Schristos push @delegators, $name; 37926a53354Schristos 38007163879Schristos $return_types{$name} = $return_type; 38107163879Schristos $tdefaults{$name} = $tdefault; 38207163879Schristos $styles{$name} = $style; 38307163879Schristos $argtypes_array{$name} = \@argtypes; 38426a53354Schristos} 38526a53354Schristos 38607163879Schristossub print_class($) { 38707163879Schristos my ($name) = @_; 38826a53354Schristos 38907163879Schristos print "struct " . $name . " : public target_ops\n"; 39007163879Schristos print "{\n"; 39107163879Schristos print " const target_info &info () const override;\n"; 39207163879Schristos print "\n"; 39307163879Schristos print " strata stratum () const override;\n"; 39407163879Schristos print "\n"; 39507163879Schristos 39607163879Schristos for $name (@delegators) { 39707163879Schristos my $return_type = $return_types{$name}; 39807163879Schristos my @argtypes = @{$argtypes_array{$name}}; 39907163879Schristos 40007163879Schristos print " "; 40107163879Schristos write_declaration ($name, $return_type, @argtypes); 40226a53354Schristos } 40326a53354Schristos 40407163879Schristos print "};\n\n"; 40526a53354Schristos} 40626a53354Schristos 40707163879Schristosprint_class ("dummy_target"); 40807163879Schristosprint_class ("debug_target"); 40907163879Schristos 41007163879Schristosfor $name (@delegators) { 41107163879Schristos my $tdefault = $tdefaults{$name}; 41207163879Schristos my $return_type = $return_types{$name}; 41307163879Schristos my $style = $styles{$name}; 41407163879Schristos my @argtypes = @{$argtypes_array{$name}}; 41507163879Schristos 41607163879Schristos write_delegator ($name, $return_type, @argtypes); 41707163879Schristos 41807163879Schristos write_tdefault ($tdefault, $style, $name, $return_type, @argtypes); 41907163879Schristos 42007163879Schristos write_debugmethod ($tdefault, $name, $return_type, @argtypes); 42126a53354Schristos} 422