[deliverable/binutils-gdb.git] / gdb / make-target-delegates

#!/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;
	$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, $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";
Commit	Line	Data
1101cb7b TT	1	#!/usr/bin/perl
1101cb7b TT	2
e2882c85	3	# Copyright (C) 2013-2018 Free Software Foundation, Inc.
1101cb7b TT	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,;
a8bdc56b TT	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,^,;
1101cb7b TT	38
	39	# Match the return type when it is "ordinary".
	40	$SIMPLE_RETURN_PART = qr,[^\(]+,;
	41	# Match the return type when it is a VEC.
	42	$VEC_RETURN_PART = qr,VEC\s\([^\)]+\)[^\(],;
	43
	44	# Match the TARGET_DEFAULT_* attribute for a method.
	45	$TARGET_DEFAULT_PART = qr,TARGET_DEFAULT_(?<style>[A-Z_]+)\s\((?<default_arg>.)\),;
	46
a8bdc56b TT	47	# Match the arguments and trailing attribute of a method definition.
	48	# Note we don't match the trailing ";".
	49	$METHOD_TRAILER = qr,\s*${TARGET_DEFAULT_PART}$,;
	50
	51	# Match an entire method definition.
1101cb7b TT	52	$METHOD = ($INTRO_PART . "(?<return_type>" . $SIMPLE_RETURN_PART
1101cb7b TT	53	. "\|" . $VEC_RETURN_PART . ")"
a8bdc56b TT	54	. $NAME_PART . $ARGS_PART
a8bdc56b TT	55	. $METHOD_TRAILER);
1101cb7b	56
a7068b60 TT	57	# Match TARGET_DEBUG_PRINTER in an argument type.
	58	# This must match the whole "sub-expression" including the parens.
	59	# Reference $1 must refer to the function argument.
	60	$TARGET_DEBUG_PRINTER = qr,\sTARGET_DEBUG_PRINTER\s\(([^)])\)\s,;
	61
1101cb7b TT	62	sub trim($) {
1101cb7b TT	63	my ($result) = @_;
a8bdc56b TT	64
	65	$result =~ s,^\s+,,;
	66	$result =~ s,\s+$,,;
	67
1101cb7b TT	68	return $result;
	69	}
	70
	71	# Read from the input files until we find the trigger line.
	72	# Die if not found.
	73	sub find_trigger() {
	74	while (<>) {
	75	chomp;
	76	return if m/$TRIGGER/;
	77	}
	78
	79	die "could not find trigger line\n";
	80	}
	81
a8bdc56b TT	82	# Scan target.h and return a list of possible target_ops method entries.
	83	sub scan_target_h() {
	84	my $all_the_text = '';
	85
	86	find_trigger();
	87	while (<>) {
	88	chomp;
	89	# Skip the open brace.
	90	next if /{/;
	91	last if m/$ENDER/;
	92
	93	# Just in case somebody ever uses C99.
	94	$_ =~ s,//.*$,,;
	95	$_ = trim ($_);
	96
	97	$all_the_text .= $_;
	98	}
	99
	100	# Now strip out the C comments.
	101	$all_the_text =~ s,/\(.?)\*/,,g;
	102
	103	return split (/;/, $all_the_text);
	104	}
	105
1101cb7b TT	106	# Parse arguments into a list.
	107	sub parse_argtypes($) {
	108	my ($typestr) = @_;
	109
	110	$typestr =~ s/^\((.*)\)$/\1/;
	111
	112	my (@typelist) = split (/,\s*/, $typestr);
	113	my (@result, $iter, $onetype);
	114
	115	foreach $iter (@typelist) {
	116	if ($iter =~ m/^(enum\s+${SYMBOL}\s*)(${SYMBOL})?$/) {
	117	$onetype = $1;
c252925c	118	} elsif ($iter =~ m/^(.(enum\s+)?${SYMBOL}.(\s\|\*\|&))${SYMBOL}+$/) {
1101cb7b TT	119	$onetype = $1;
	120	} elsif ($iter eq 'void') {
	121	next;
	122	} else {
	123	$onetype = $iter;
	124	}
	125	push @result, trim ($onetype);
	126	}
	127
	128	return @result;
	129	}
	130
	131	sub dname($) {
	132	my ($name) = @_;
	133	$name =~ s/to_/delegate_/;
	134	return $name;
	135	}
	136
	137	# Write function header given name, return type, and argtypes.
	138	# Returns a list of actual argument names.
	139	sub write_function_header($$@) {
	140	my ($name, $return_type, @argtypes) = @_;
	141
	142	print "static " . $return_type . "\n";
	143	print $name . ' (';
	144
	145	my $iter;
	146	my @argdecls;
	147	my @actuals;
	148	my $i = 0;
	149	foreach $iter (@argtypes) {
	150	my $val = $iter;
	151
a7068b60 TT	152	$val =~ s/$TARGET_DEBUG_PRINTER//;
a7068b60 TT	153
c252925c	154	if ($iter !~ m,(\*\|&)$,) {
1101cb7b TT	155	$val .= ' ';
	156	}
	157
	158	my $vname;
	159	if ($i == 0) {
	160	# Just a random nicety.
	161	$vname = 'self';
	162	} else {
	163	$vname .= "arg$i";
	164	}
	165	$val .= $vname;
	166
	167	push @argdecls, $val;
	168	push @actuals, $vname;
	169	++$i;
	170	}
	171
	172	print join (', ', @argdecls) . ")\n";
	173	print "{\n";
	174
	175	return @actuals;
	176	}
	177
	178	# Write out a delegation function.
	179	sub write_delegator($$@) {
	180	my ($name, $return_type, @argtypes) = @_;
	181
	182	my (@names) = write_function_header (dname ($name), $return_type,
	183	@argtypes);
	184
	185	print " $names[0] = $names[0]->beneath;\n";
	186	print " ";
	187	if ($return_type ne 'void') {
	188	print "return ";
	189	}
	190	print "$names[0]->" . $name . " (";
	191	print join (', ', @names);
	192	print ");\n";
	193	print "}\n\n";
	194	}
	195
	196	sub tdname ($) {
	197	my ($name) = @_;
	198	$name =~ s/to_/tdefault_/;
	199	return $name;
	200	}
	201
	202	# Write out a default function.
	203	sub write_tdefault($$$$@) {
	204	my ($content, $style, $name, $return_type, @argtypes) = @_;
	205
	206	if ($style eq 'FUNC') {
	207	return $content;
	208	}
	209
	210	write_function_header (tdname ($name), $return_type, @argtypes);
	211
	212	if ($style eq 'RETURN') {
	213	print " return $content;\n";
	214	} elsif ($style eq 'NORETURN') {
	215	print " $content;\n";
	216	} elsif ($style eq 'IGNORE') {
	217	# Nothing.
	218	} else {
219	die "unrecognized style: $style\n";
220	}
221
222	print "}\n\n";
223
224	return tdname ($name);
225	}
226
a7068b60 TT	227	sub munge_type($) {
	228	my ($typename) = @_;
	229	my ($result);
	230
	231	if ($typename =~ m/$TARGET_DEBUG_PRINTER/) {
	232	$result = $1;
	233	} else {
	234	($result = $typename) =~ s/\s+$//;
10f64178	235	$result =~ s/[ ()<>:]/_/g;
a7068b60	236	$result =~ s/[*]/p/g;
c252925c	237	$result =~ s/&/r/g;
10f64178 PA	238
	239	# Identifers with double underscores are reserved to the C++
	240	# implementation.
	241	$result =~ s/_+/_/g;
	242
	243	# Avoid ending the function name with underscore, for
	244	# cosmetics. Trailing underscores appear after munging types
	245	# with template parameters, like e.g. "foo<int>".
	246	$result =~ s/_$//g;
	247
a7068b60 TT	248	$result = 'target_debug_print_' . $result;
	249	}
	250
	251	return $result;
	252	}
	253
	254	# Write out a debug method.
	255	sub write_debugmethod($$$$@) {
	256	my ($content, $style, $name, $return_type, @argtypes) = @_;
	257
	258	my ($debugname) = $name;
	259	$debugname =~ s/to_/debug_/;
	260	my ($targetname) = $name;
	261	$targetname =~ s/to_/target_/;
	262
	263	my (@names) = write_function_header ($debugname, $return_type, @argtypes);
	264
	265	if ($return_type ne 'void') {
	266	print " $return_type result;\n";
	267	}
	268
	269	print " fprintf_unfiltered (gdb_stdlog, \"-> %s->$name (...)\\n\", debug_target.to_shortname);\n";
	270
	271	# Delegate to the beneath target.
	272	print " ";
	273	if ($return_type ne 'void') {
	274	print "result = ";
	275	}
	276	print "debug_target." . $name . " (";
	277	my @names2 = @names;
	278	@names2[0] = "&debug_target";
	279	print join (', ', @names2);
	280	print ");\n";
	281
	282	# Now print the arguments.
	283	print " fprintf_unfiltered (gdb_stdlog, \"<- %s->$name (\", debug_target.to_shortname);\n";
	284	for my $i (0 .. $#argtypes) {
	285	print " fputs_unfiltered (\", \", gdb_stdlog);\n" if $i > 0;
	286	my $printer = munge_type ($argtypes[$i]);
	287	print " $printer ($names2[$i]);\n";
	288	}
	289	if ($return_type ne 'void') {
	290	print " fputs_unfiltered (\") = \", gdb_stdlog);\n";
	291	my $printer = munge_type ($return_type);
	292	print " $printer (result);\n";
	293	print " fputs_unfiltered (\"\\n\", gdb_stdlog);\n";
	294	} else {
	295	print " fputs_unfiltered (\")\\n\", gdb_stdlog);\n";
	296	}
	297
	298	if ($return_type ne 'void') {
	299	print " return result;\n";
	300	}
	301
	302	print "}\n\n";
	303
	304	return $debugname;
	305	}
	306
1101cb7b TT	307	print "/* THIS FILE IS GENERATED -- buffer-read-only: t -- */\n";
	308	print "/* vi:set ro: */\n\n";
	309	print "/* To regenerate this file, run:*/\n";
	310	print "/* make-target-delegates target.h > target-delegates.c */\n";
	311
a8bdc56b TT	312	@lines = scan_target_h();
a8bdc56b TT	313
1101cb7b TT	314
1101cb7b TT	315	%tdefault_names = ();
a7068b60	316	%debug_names = ();
1101cb7b	317	@delegators = ();
a8bdc56b TT	318	foreach $current_line (@lines) {
a8bdc56b TT	319	next unless $current_line =~ m/$METHOD/;
1101cb7b	320
a8bdc56b TT	321	$name = $+{name};
	322	$current_line = $+{args};
	323	$return_type = trim ($+{return_type});
	324	$current_args = $+{args};
	325	$tdefault = $+{default_arg};
	326	$style = $+{style};
1101cb7b	327
a8bdc56b	328	@argtypes = parse_argtypes ($current_args);
1101cb7b	329
a8bdc56b TT	330	# The first argument must be "this" to be delegatable.
	331	if ($argtypes[0] =~ /\sstruct\s+target_ops\s\\s/) {
	332	write_delegator ($name, $return_type, @argtypes);
1101cb7b	333
a8bdc56b	334	push @delegators, $name;
1101cb7b	335
a8bdc56b TT	336	$tdefault_names{$name} = write_tdefault ($tdefault, $style,
	337	$name, $return_type,
	338	@argtypes);
a7068b60 TT	339
	340	$debug_names{$name} = write_debugmethod ($tdefault, $style,
	341	$name, $return_type,
	342	@argtypes);
1101cb7b TT	343	}
	344	}
	345
	346	# Now the delegation code.
	347	print "static void\ninstall_delegators (struct target_ops *ops)\n{\n";
	348
	349	for $iter (@delegators) {
	350	print " if (ops->" . $iter . " == NULL)\n";
	351	print " ops->" . $iter . " = " . dname ($iter) . ";\n";
	352	}
	353	print "}\n\n";
	354
	355	# Now the default method code.
	356	print "static void\ninstall_dummy_methods (struct target_ops *ops)\n{\n";
	357
	358	for $iter (@delegators) {
	359	print " ops->" . $iter . " = " . $tdefault_names{$iter} . ";\n";
	360	}
a7068b60 TT	361	print "}\n\n";
	362
	363	# The debug method code.
	364	print "static void\ninit_debug_target (struct target_ops *ops)\n{\n";
	365	for $iter (@delegators) {
	366	print " ops->" . $iter . " = " . $debug_names{$iter} . ";\n";
	367	}
1101cb7b	368	print "}\n";