368 lines
9.0 KiB
Perl
Executable File
368 lines
9.0 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
|
|
# Copyright (C) 2013-2018 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,^,;
|
|
|
|
# Match the return type when it is "ordinary".
|
|
$SIMPLE_RETURN_PART = qr,[^\(]+,;
|
|
# Match the return type when it is a VEC.
|
|
$VEC_RETURN_PART = qr,VEC\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 . "(?<return_type>" . $SIMPLE_RETURN_PART
|
|
. "|" . $VEC_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/;
|
|
|
|
# Just in case somebody ever uses C99.
|
|
$_ =~ s,//.*$,,;
|
|
$_ = trim ($_);
|
|
|
|
$all_the_text .= $_;
|
|
}
|
|
|
|
# Now strip out the C comments.
|
|
$all_the_text =~ 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) = @_;
|
|
$name =~ s/to_/delegate_/;
|
|
return $name;
|
|
}
|
|
|
|
# Write function header given name, return type, and argtypes.
|
|
# Returns a list of actual argument names.
|
|
sub write_function_header($$@) {
|
|
my ($name, $return_type, @argtypes) = @_;
|
|
|
|
print "static " . $return_type . "\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;
|
|
if ($i == 0) {
|
|
# Just a random nicety.
|
|
$vname = 'self';
|
|
} else {
|
|
$vname .= "arg$i";
|
|
}
|
|
$val .= $vname;
|
|
|
|
push @argdecls, $val;
|
|
push @actuals, $vname;
|
|
++$i;
|
|
}
|
|
|
|
print join (', ', @argdecls) . ")\n";
|
|
print "{\n";
|
|
|
|
return @actuals;
|
|
}
|
|
|
|
# Write out a delegation function.
|
|
sub write_delegator($$@) {
|
|
my ($name, $return_type, @argtypes) = @_;
|
|
|
|
my (@names) = write_function_header (dname ($name), $return_type,
|
|
@argtypes);
|
|
|
|
print " $names[0] = $names[0]->beneath;\n";
|
|
print " ";
|
|
if ($return_type ne 'void') {
|
|
print "return ";
|
|
}
|
|
print "$names[0]->" . $name . " (";
|
|
print join (', ', @names);
|
|
print ");\n";
|
|
print "}\n\n";
|
|
}
|
|
|
|
sub tdname ($) {
|
|
my ($name) = @_;
|
|
$name =~ s/to_/tdefault_/;
|
|
return $name;
|
|
}
|
|
|
|
# Write out a default function.
|
|
sub write_tdefault($$$$@) {
|
|
my ($content, $style, $name, $return_type, @argtypes) = @_;
|
|
|
|
if ($style eq 'FUNC') {
|
|
return $content;
|
|
}
|
|
|
|
write_function_header (tdname ($name), $return_type, @argtypes);
|
|
|
|
if ($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;
|
|
|
|
# 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, $style, $name, $return_type, @argtypes) = @_;
|
|
|
|
my ($debugname) = $name;
|
|
$debugname =~ s/to_/debug_/;
|
|
my ($targetname) = $name;
|
|
$targetname =~ s/to_/target_/;
|
|
|
|
my (@names) = write_function_header ($debugname, $return_type, @argtypes);
|
|
|
|
if ($return_type ne 'void') {
|
|
print " $return_type result;\n";
|
|
}
|
|
|
|
print " fprintf_unfiltered (gdb_stdlog, \"-> %s->$name (...)\\n\", debug_target.to_shortname);\n";
|
|
|
|
# Delegate to the beneath target.
|
|
print " ";
|
|
if ($return_type ne 'void') {
|
|
print "result = ";
|
|
}
|
|
print "debug_target." . $name . " (";
|
|
my @names2 = @names;
|
|
@names2[0] = "&debug_target";
|
|
print join (', ', @names2);
|
|
print ");\n";
|
|
|
|
# Now print the arguments.
|
|
print " fprintf_unfiltered (gdb_stdlog, \"<- %s->$name (\", debug_target.to_shortname);\n";
|
|
for my $i (0 .. $#argtypes) {
|
|
print " fputs_unfiltered (\", \", gdb_stdlog);\n" if $i > 0;
|
|
my $printer = munge_type ($argtypes[$i]);
|
|
print " $printer ($names2[$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";
|
|
|
|
@lines = scan_target_h();
|
|
|
|
|
|
%tdefault_names = ();
|
|
%debug_names = ();
|
|
@delegators = ();
|
|
foreach $current_line (@lines) {
|
|
next unless $current_line =~ m/$METHOD/;
|
|
|
|
$name = $+{name};
|
|
$current_line = $+{args};
|
|
$return_type = trim ($+{return_type});
|
|
$current_args = $+{args};
|
|
$tdefault = $+{default_arg};
|
|
$style = $+{style};
|
|
|
|
@argtypes = parse_argtypes ($current_args);
|
|
|
|
# The first argument must be "this" to be delegatable.
|
|
if ($argtypes[0] =~ /\s*struct\s+target_ops\s*\*\s*/) {
|
|
write_delegator ($name, $return_type, @argtypes);
|
|
|
|
push @delegators, $name;
|
|
|
|
$tdefault_names{$name} = write_tdefault ($tdefault, $style,
|
|
$name, $return_type,
|
|
@argtypes);
|
|
|
|
$debug_names{$name} = write_debugmethod ($tdefault, $style,
|
|
$name, $return_type,
|
|
@argtypes);
|
|
}
|
|
}
|
|
|
|
# Now the delegation code.
|
|
print "static void\ninstall_delegators (struct target_ops *ops)\n{\n";
|
|
|
|
for $iter (@delegators) {
|
|
print " if (ops->" . $iter . " == NULL)\n";
|
|
print " ops->" . $iter . " = " . dname ($iter) . ";\n";
|
|
}
|
|
print "}\n\n";
|
|
|
|
# Now the default method code.
|
|
print "static void\ninstall_dummy_methods (struct target_ops *ops)\n{\n";
|
|
|
|
for $iter (@delegators) {
|
|
print " ops->" . $iter . " = " . $tdefault_names{$iter} . ";\n";
|
|
}
|
|
print "}\n\n";
|
|
|
|
# The debug method code.
|
|
print "static void\ninit_debug_target (struct target_ops *ops)\n{\n";
|
|
for $iter (@delegators) {
|
|
print " ops->" . $iter . " = " . $debug_names{$iter} . ";\n";
|
|
}
|
|
print "}\n";
|