1#!/usr/bin/perl
2
3# Copyright (C) 2013-2020 Free Software Foundation, Inc.
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,;
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,^,;
38
39$POINTER_PART = qr,\s*(\*)?\s*,;
40
41# Match a C++ symbol, including scope operators and template
42# parameters.  E.g., 'std::vector<something>'.
43$CP_SYMBOL = qr,[a-zA-Z_][a-zA-Z0-9_<>:]*,;
44# Match the return type when it is "ordinary".
45$SIMPLE_RETURN_PART = qr,((struct|class|enum|union)\s+)?${CP_SYMBOL}+,;
46
47# Match a return type.
48$RETURN_PART = qr,((const|volatile)\s+)?(${SIMPLE_RETURN_PART})${POINTER_PART},;
49
50# Match "virtual".
51$VIRTUAL_PART = qr,virtual\s,;
52
53# Match the TARGET_DEFAULT_* attribute for a method.
54$TARGET_DEFAULT_PART = qr,TARGET_DEFAULT_(?<style>[A-Z_]+)\s*\((?<default_arg>.*)\),;
55
56# Match the arguments and trailing attribute of a method definition.
57# Note we don't match the trailing ";".
58$METHOD_TRAILER = qr,\s*${TARGET_DEFAULT_PART}$,;
59
60# Match an entire method definition.
61$METHOD = ($INTRO_PART . $VIRTUAL_PART . "(?<return_type>" . $RETURN_PART . ")"
62	   . $NAME_PART . $ARGS_PART
63	   . $METHOD_TRAILER);
64
65# Match TARGET_DEBUG_PRINTER in an argument type.
66# This must match the whole "sub-expression" including the parens.
67# Reference $1 must refer to the function argument.
68$TARGET_DEBUG_PRINTER = qr,\s*TARGET_DEBUG_PRINTER\s*\(([^)]*)\)\s*,;
69
70sub trim($) {
71    my ($result) = @_;
72
73    $result =~ s,^\s+,,;
74    $result =~ s,\s+$,,;
75
76    return $result;
77}
78
79# Read from the input files until we find the trigger line.
80# Die if not found.
81sub find_trigger() {
82    while (<>) {
83	chomp;
84	return if m/$TRIGGER/;
85    }
86
87    die "could not find trigger line\n";
88}
89
90# Scan target.h and return a list of possible target_ops method entries.
91sub scan_target_h() {
92    my $all_the_text = '';
93
94    find_trigger();
95    while (<>) {
96	chomp;
97	# Skip the open brace.
98	next if /{/;
99	last if m/$ENDER/;
100
101	# Strip // comments.
102	$_ =~ s,//.*$,,;
103
104	$all_the_text .= $_;
105    }
106
107    # Now strip out the C comments.
108    $all_the_text =~ s,/\*(.*?)\*/,,g;
109
110    # Replace sequences of tabs and/or whitespace with a single
111    # whitespace character.  We need the whitespace because the method
112    # may have been split between multiple lines, like e.g.:
113    #
114    #  virtual std::vector<long_type_name>
115    #    my_long_method_name ()
116    #    TARGET_DEFAULT_IGNORE ();
117    #
118    # If we didn't preserve the whitespace, then we'd end up with:
119    #
120    #  virtual std::vector<long_type_name>my_long_method_name ()TARGET_DEFAULT_IGNORE ()
121    #
122    # ... which wouldn't later be parsed correctly.
123    $all_the_text =~ s/[\t\s]+/ /g;
124
125    return split (/;/, $all_the_text);
126}
127
128# Parse arguments into a list.
129sub parse_argtypes($) {
130    my ($typestr) = @_;
131
132    $typestr =~ s/^\((.*)\)$/\1/;
133
134    my (@typelist) = split (/,\s*/, $typestr);
135    my (@result, $iter, $onetype);
136
137    foreach $iter (@typelist) {
138	if ($iter =~ m/^(enum\s+${SYMBOL}\s*)(${SYMBOL})?$/) {
139	    $onetype = $1;
140	} elsif ($iter =~ m/^(.*(enum\s+)?${SYMBOL}.*(\s|\*|&))${SYMBOL}+$/) {
141	    $onetype = $1;
142	} elsif ($iter eq 'void') {
143	    next;
144	} else {
145	    $onetype = $iter;
146	}
147	push @result, trim ($onetype);
148    }
149
150    return @result;
151}
152
153sub dname($) {
154    my ($name) = @_;
155    return "target_ops::" . $name;
156}
157
158# Write function header given name, return type, and argtypes.
159# Returns a list of actual argument names.
160sub write_function_header($$$@) {
161    my ($decl, $name, $return_type, @argtypes) = @_;
162
163    print $return_type;
164
165    if ($decl) {
166	if ($return_type !~ m,\*$,) {
167	    print " ";
168	}
169    } else {
170	print "\n";
171    }
172
173    print $name . ' (';
174
175    my $iter;
176    my @argdecls;
177    my @actuals;
178    my $i = 0;
179    foreach $iter (@argtypes) {
180	my $val = $iter;
181
182	$val =~ s/$TARGET_DEBUG_PRINTER//;
183
184	if ($iter !~ m,(\*|&)$,) {
185	    $val .= ' ';
186	}
187
188	my $vname;
189	$vname .= "arg$i";
190	$val .= $vname;
191
192	push @argdecls, $val;
193	push @actuals, $vname;
194	++$i;
195    }
196
197    print join (', ', @argdecls) . ")";
198
199    if ($decl) {
200	print " override;\n";
201    } else {
202	print "\n{\n";
203    }
204
205    return @actuals;
206}
207
208# Write out a declaration.
209sub write_declaration($$@) {
210    my ($name, $return_type, @argtypes) = @_;
211
212    write_function_header (1, $name, $return_type, @argtypes);
213}
214
215# Write out a delegation function.
216sub write_delegator($$@) {
217    my ($name, $return_type, @argtypes) = @_;
218
219    my (@names) = write_function_header (0, dname ($name),
220					 $return_type, @argtypes);
221
222    print "  ";
223    if ($return_type ne 'void') {
224	print "return ";
225    }
226    print "this->beneath ()->" . $name . " (";
227    print join (', ', @names);
228    print ");\n";
229    print "}\n\n";
230}
231
232sub tdname ($) {
233    my ($name) = @_;
234    return "dummy_target::" . $name;
235}
236
237# Write out a default function.
238sub write_tdefault($$$$@) {
239    my ($content, $style, $name, $return_type, @argtypes) = @_;
240
241    my (@names) = write_function_header (0, tdname ($name),
242					 $return_type, @argtypes);
243
244    if ($style eq 'FUNC') {
245	print "  ";
246	if ($return_type ne 'void') {
247	    print "return ";
248	}
249	print $content . " (this";
250	if (@names) {
251	    print ", ";
252	}
253	print join (', ', @names);
254	print ");\n";
255    } elsif ($style eq 'RETURN') {
256	print "  return $content;\n";
257    } elsif ($style eq 'NORETURN') {
258	print "  $content;\n";
259    } elsif ($style eq 'IGNORE') {
260	# Nothing.
261    } else {
262	die "unrecognized style: $style\n";
263    }
264
265    print "}\n\n";
266
267    return tdname ($name);
268}
269
270sub munge_type($) {
271    my ($typename) = @_;
272    my ($result);
273
274    if ($typename =~ m/$TARGET_DEBUG_PRINTER/) {
275	$result = $1;
276    } else {
277	($result = $typename) =~ s/\s+$//;
278	$result =~ s/[ ()<>:]/_/g;
279	$result =~ s/[*]/p/g;
280	$result =~ s/&/r/g;
281
282	# Identifers with double underscores are reserved to the C++
283	# implementation.
284	$result =~ s/_+/_/g;
285
286	# Avoid ending the function name with underscore, for
287	# cosmetics.  Trailing underscores appear after munging types
288	# with template parameters, like e.g. "foo<int>".
289	$result =~ s/_$//g;
290
291	$result = 'target_debug_print_' . $result;
292    }
293
294    return $result;
295}
296
297# Write out a debug method.
298sub write_debugmethod($$$@) {
299    my ($content, $name, $return_type, @argtypes) = @_;
300
301    my ($debugname) = "debug_target::" . $name;
302    my ($targetname) = $name;
303
304    my (@names) = write_function_header (0, $debugname, $return_type, @argtypes);
305
306    if ($return_type ne 'void') {
307	print "  $return_type result;\n";
308    }
309
310    print "  fprintf_unfiltered (gdb_stdlog, \"-> %s->$name (...)\\n\", this->beneath ()->shortname ());\n";
311
312    # Delegate to the beneath target.
313    print "  ";
314    if ($return_type ne 'void') {
315	print "result = ";
316    }
317    print "this->beneath ()->" . $name . " (";
318    print join (', ', @names);
319    print ");\n";
320
321    # Now print the arguments.
322    print "  fprintf_unfiltered (gdb_stdlog, \"<- %s->$name (\", this->beneath ()->shortname ());\n";
323    for my $i (0 .. $#argtypes) {
324	if ($i > 0) {
325	    print "  fputs_unfiltered (\", \", gdb_stdlog);\n"
326	}
327	my $printer = munge_type ($argtypes[$i]);
328	print "  $printer ($names[$i]);\n";
329    }
330    if ($return_type ne 'void') {
331	print "  fputs_unfiltered (\") = \", gdb_stdlog);\n";
332	my $printer = munge_type ($return_type);
333	print "  $printer (result);\n";
334	print "  fputs_unfiltered (\"\\n\", gdb_stdlog);\n";
335    } else {
336	print "  fputs_unfiltered (\")\\n\", gdb_stdlog);\n";
337    }
338
339    if ($return_type ne 'void') {
340	print "  return result;\n";
341    }
342
343    print "}\n\n";
344
345    return $debugname;
346}
347
348print "/* THIS FILE IS GENERATED -*- buffer-read-only: t -*- */\n";
349print "/* vi:set ro: */\n\n";
350print "/* To regenerate this file, run:*/\n";
351print "/*      make-target-delegates target.h > target-delegates.c */\n";
352print "\n";
353
354@lines = scan_target_h();
355
356@delegators = ();
357@return_types = ();
358@tdefaults = ();
359@styles = ();
360@argtypes_array = ();
361
362foreach $current_line (@lines) {
363    # See comments in scan_target_h.  Here we strip away the leading
364    # and trailing whitespace.
365    $current_line = trim ($current_line);
366
367    next unless $current_line =~ m/$METHOD/;
368
369    my $name = $+{name};
370    my $current_line = $+{args};
371    my $return_type = trim ($+{return_type});
372    my $current_args = $+{args};
373    my $tdefault = $+{default_arg};
374    my $style = $+{style};
375
376    my @argtypes = parse_argtypes ($current_args);
377
378    push @delegators, $name;
379
380    $return_types{$name} = $return_type;
381    $tdefaults{$name} = $tdefault;
382    $styles{$name} = $style;
383    $argtypes_array{$name} = \@argtypes;
384}
385
386sub print_class($) {
387    my ($name) = @_;
388
389    print "struct " . $name . " : public target_ops\n";
390    print "{\n";
391    print "  const target_info &info () const override;\n";
392    print "\n";
393    print "  strata stratum () const override;\n";
394    print "\n";
395
396    for $name (@delegators) {
397	my $return_type = $return_types{$name};
398	my @argtypes = @{$argtypes_array{$name}};
399
400	print "  ";
401	write_declaration ($name, $return_type, @argtypes);
402    }
403
404    print "};\n\n";
405}
406
407print_class ("dummy_target");
408print_class ("debug_target");
409
410for $name (@delegators) {
411    my $tdefault = $tdefaults{$name};
412    my $return_type = $return_types{$name};
413    my $style = $styles{$name};
414    my @argtypes = @{$argtypes_array{$name}};
415
416    write_delegator ($name, $return_type, @argtypes);
417
418    write_tdefault ($tdefault, $style, $name, $return_type, @argtypes);
419
420    write_debugmethod ($tdefault, $name, $return_type, @argtypes);
421}
422