gdb/make-target-delegates

#!/usr/bin/perl

# Copyright (C) 2013-2021 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);
}