Commit | Line | Data |
---|---|---|
1101cb7b TT |
1 | #!/usr/bin/perl |
2 | ||
3 | # Copyright (C) 2013-2014 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 start of arguments to a method. | |
35 | $ARGS_PART = qr,(?<args>\(.*)$,; | |
36 | # Match indentation. | |
37 | $INTRO_PART = qr,^\s*,; | |
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 | ||
47 | # Match the introductory line to a method definition. | |
48 | $METHOD = ($INTRO_PART . "(?<return_type>" . $SIMPLE_RETURN_PART | |
49 | . "|" . $VEC_RETURN_PART . ")" | |
50 | . $NAME_PART . $ARGS_PART); | |
51 | ||
52 | # Match the arguments and trailing attribute of a method definition. | |
53 | $METHOD_TRAILER = qr,(?<args>\(.+\))\s*${TARGET_DEFAULT_PART};$,; | |
54 | ||
55 | sub trim($) { | |
56 | my ($result) = @_; | |
57 | $result =~ s,^\s*(\S*)\s*$,\1,; | |
58 | return $result; | |
59 | } | |
60 | ||
61 | # Read from the input files until we find the trigger line. | |
62 | # Die if not found. | |
63 | sub find_trigger() { | |
64 | while (<>) { | |
65 | chomp; | |
66 | return if m/$TRIGGER/; | |
67 | } | |
68 | ||
69 | die "could not find trigger line\n"; | |
70 | } | |
71 | ||
72 | # Parse arguments into a list. | |
73 | sub parse_argtypes($) { | |
74 | my ($typestr) = @_; | |
75 | ||
76 | $typestr =~ s/^\((.*)\)$/\1/; | |
77 | ||
78 | my (@typelist) = split (/,\s*/, $typestr); | |
79 | my (@result, $iter, $onetype); | |
80 | ||
81 | foreach $iter (@typelist) { | |
82 | if ($iter =~ m/^(enum\s+${SYMBOL}\s*)(${SYMBOL})?$/) { | |
83 | $onetype = $1; | |
84 | } elsif ($iter =~ m/^(.*(enum\s+)?${SYMBOL}.*(\s|\*))${SYMBOL}+$/) { | |
85 | $onetype = $1; | |
86 | } elsif ($iter eq 'void') { | |
87 | next; | |
88 | } else { | |
89 | $onetype = $iter; | |
90 | } | |
91 | push @result, trim ($onetype); | |
92 | } | |
93 | ||
94 | return @result; | |
95 | } | |
96 | ||
97 | sub dname($) { | |
98 | my ($name) = @_; | |
99 | $name =~ s/to_/delegate_/; | |
100 | return $name; | |
101 | } | |
102 | ||
103 | # Write function header given name, return type, and argtypes. | |
104 | # Returns a list of actual argument names. | |
105 | sub write_function_header($$@) { | |
106 | my ($name, $return_type, @argtypes) = @_; | |
107 | ||
108 | print "static " . $return_type . "\n"; | |
109 | print $name . ' ('; | |
110 | ||
111 | my $iter; | |
112 | my @argdecls; | |
113 | my @actuals; | |
114 | my $i = 0; | |
115 | foreach $iter (@argtypes) { | |
116 | my $val = $iter; | |
117 | ||
118 | if ($iter !~ m,\*$,) { | |
119 | $val .= ' '; | |
120 | } | |
121 | ||
122 | my $vname; | |
123 | if ($i == 0) { | |
124 | # Just a random nicety. | |
125 | $vname = 'self'; | |
126 | } else { | |
127 | $vname .= "arg$i"; | |
128 | } | |
129 | $val .= $vname; | |
130 | ||
131 | push @argdecls, $val; | |
132 | push @actuals, $vname; | |
133 | ++$i; | |
134 | } | |
135 | ||
136 | print join (', ', @argdecls) . ")\n"; | |
137 | print "{\n"; | |
138 | ||
139 | return @actuals; | |
140 | } | |
141 | ||
142 | # Write out a delegation function. | |
143 | sub write_delegator($$@) { | |
144 | my ($name, $return_type, @argtypes) = @_; | |
145 | ||
146 | my (@names) = write_function_header (dname ($name), $return_type, | |
147 | @argtypes); | |
148 | ||
149 | print " $names[0] = $names[0]->beneath;\n"; | |
150 | print " "; | |
151 | if ($return_type ne 'void') { | |
152 | print "return "; | |
153 | } | |
154 | print "$names[0]->" . $name . " ("; | |
155 | print join (', ', @names); | |
156 | print ");\n"; | |
157 | print "}\n\n"; | |
158 | } | |
159 | ||
160 | sub tdname ($) { | |
161 | my ($name) = @_; | |
162 | $name =~ s/to_/tdefault_/; | |
163 | return $name; | |
164 | } | |
165 | ||
166 | # Write out a default function. | |
167 | sub write_tdefault($$$$@) { | |
168 | my ($content, $style, $name, $return_type, @argtypes) = @_; | |
169 | ||
170 | if ($style eq 'FUNC') { | |
171 | return $content; | |
172 | } | |
173 | ||
174 | write_function_header (tdname ($name), $return_type, @argtypes); | |
175 | ||
176 | if ($style eq 'RETURN') { | |
177 | print " return $content;\n"; | |
178 | } elsif ($style eq 'NORETURN') { | |
179 | print " $content;\n"; | |
180 | } elsif ($style eq 'IGNORE') { | |
181 | # Nothing. | |
182 | } else { | |
183 | die "unrecognized style: $style\n"; | |
184 | } | |
185 | ||
186 | print "}\n\n"; | |
187 | ||
188 | return tdname ($name); | |
189 | } | |
190 | ||
191 | print "/* THIS FILE IS GENERATED -*- buffer-read-only: t -*- */\n"; | |
192 | print "/* vi:set ro: */\n\n"; | |
193 | print "/* To regenerate this file, run:*/\n"; | |
194 | print "/* make-target-delegates target.h > target-delegates.c */\n"; | |
195 | ||
196 | find_trigger(); | |
197 | ||
198 | %tdefault_names = (); | |
199 | @delegators = (); | |
200 | $current_line = ''; | |
201 | while (<>) { | |
202 | chomp; | |
203 | last if m/$ENDER/; | |
204 | ||
205 | if ($current_line ne '') { | |
206 | s/^\s*//; | |
207 | $current_line .= $_; | |
208 | } elsif (m/$METHOD/) { | |
209 | $name = $+{name}; | |
210 | $current_line = $+{args}; | |
211 | $return_type = trim ($+{return_type}); | |
212 | } | |
213 | ||
214 | if ($current_line =~ /\);\s*$/) { | |
215 | if ($current_line =~ m,$METHOD_TRAILER,) { | |
216 | $current_args = $+{args}; | |
217 | $tdefault = $+{default_arg}; | |
218 | $style = $+{style}; | |
219 | ||
220 | @argtypes = parse_argtypes ($current_args); | |
221 | ||
222 | # The first argument must be "this" to be delegatable. | |
223 | if ($argtypes[0] =~ /\s*struct\s+target_ops\s*\*\s*/) { | |
224 | write_delegator ($name, $return_type, @argtypes); | |
225 | ||
226 | push @delegators, $name; | |
227 | ||
228 | $tdefault_names{$name} = write_tdefault ($tdefault, $style, | |
229 | $name, $return_type, | |
230 | @argtypes); | |
231 | } | |
232 | } | |
233 | ||
234 | $current_line = ''; | |
235 | } | |
236 | } | |
237 | ||
238 | # Now the delegation code. | |
239 | print "static void\ninstall_delegators (struct target_ops *ops)\n{\n"; | |
240 | ||
241 | for $iter (@delegators) { | |
242 | print " if (ops->" . $iter . " == NULL)\n"; | |
243 | print " ops->" . $iter . " = " . dname ($iter) . ";\n"; | |
244 | } | |
245 | print "}\n\n"; | |
246 | ||
247 | # Now the default method code. | |
248 | print "static void\ninstall_dummy_methods (struct target_ops *ops)\n{\n"; | |
249 | ||
250 | for $iter (@delegators) { | |
251 | print " ops->" . $iter . " = " . $tdefault_names{$iter} . ";\n"; | |
252 | } | |
253 | print "}\n"; |