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