Commit | Line | Data |
---|---|---|
916e4025 | 1 | #!/usr/bin/perl -w |
f83e001e YO |
2 | # |
3 | # | |
6294c161 DM |
4 | # Regenerate (overwriting only if changed): |
5 | # | |
65aa4ca7 | 6 | # pod/perldebguts.pod |
6294c161 DM |
7 | # regnodes.h |
8 | # | |
9 | # from information stored in | |
10 | # | |
11 | # regcomp.sym | |
12 | # regexp.h | |
13 | # | |
65aa4ca7 FC |
14 | # pod/perldebguts.pod is not completely regenerated. Only the table of |
15 | # regexp nodes is replaced; other parts remain unchanged. | |
16 | # | |
6294c161 DM |
17 | # Accepts the standard regen_lib -q and -v args. |
18 | # | |
19 | # This script is normally invoked from regen.pl. | |
20 | ||
36bb303b NC |
21 | BEGIN { |
22 | # Get function prototypes | |
3d7c117d | 23 | require './regen/regen_lib.pl'; |
36bb303b | 24 | } |
03363afd | 25 | use strict; |
03363afd | 26 | |
f83e001e YO |
27 | # NOTE I don't think anyone actually knows what all of these properties mean, |
28 | # and I suspect some of them are outright unused. This is a first attempt to | |
29 | # clean up the generation so maybe one day we can move to something more self | |
30 | # documenting. (One might argue that an array of hashes of properties would | |
31 | # be easier to use.) | |
32 | # | |
33 | # Why we use the term regnode and nodes, and not say, opcodes, I am not sure. | |
34 | ||
35 | # General thoughts: | |
36 | # 1. We use a single continuum to represent both opcodes and states, | |
37 | # and in regexec.c we switch on the combined set. | |
38 | # 2. Opcodes have more information associated to them, states are simpler, | |
39 | # basically just an identifier/number that can be used to switch within | |
40 | # the state machine. | |
41 | # 3. Some opcode are order dependent. | |
42 | # 4. Output files often use "tricks" to reduce diff effects. Some of what | |
43 | # we do below is more clumsy looking than it could be because of this. | |
44 | ||
45 | # Op/state properties: | |
46 | # | |
47 | # Property In Descr | |
48 | # ---------------------------------------------------------------------------- | |
49 | # name Both Name of op/state | |
50 | # id Both integer value for this opcode/state | |
51 | # optype Both Either 'op' or 'state' | |
e21ef692 | 52 | # line_num Both line_num number of the input file for this item. |
f83e001e | 53 | # type Op Type of node (aka regkind) |
e21ef692 KW |
54 | # code Op Apparently not used |
55 | # suffix Op which regnode struct this uses, so if this is '1', it | |
56 | # uses 'struct regnode_1' | |
57 | # flags Op S for simple; V for varies | |
46167d76 | 58 | # longj Op Boolean as to if this node is a longjump |
e21ef692 KW |
59 | # comment Both Comment about node, if any. Placed in perlredebguts |
60 | # as its description | |
f83e001e | 61 | # pod_comment Both Special comments for pod output (preceding lines in def) |
e21ef692 | 62 | # Such lines begin with '#*' |
f83e001e YO |
63 | |
64 | # Global State | |
65 | my @all; # all opcodes/state | |
66 | my %all; # hash of all opcode/state names | |
67 | ||
68 | my @ops; # array of just opcodes | |
69 | my @states; # array of just states | |
70 | ||
71 | my $longest_name_length= 0; # track lengths of names for nicer reports | |
72 | my (%type_alias); # map the type (??) | |
73 | ||
74 | # register a newly constructed node into our state tables. | |
75 | # ensures that we have no name collisions (on name anyway), | |
76 | # and issues the "id" for the node. | |
77 | sub register_node { | |
78 | my ($node)= @_; | |
79 | ||
80 | if ( $all{ $node->{name} } ) { | |
81 | die "Duplicate item '$node->{name}' in regcomp.sym line $node->{line_num} " | |
82 | . "previously defined on line $all{ $node->{name} }{line_num}\n"; | |
83 | } elsif (!$node->{optype}) { | |
84 | die "must have an optype in node ", Dumper($node); | |
85 | } elsif ($node->{optype} eq "op") { | |
86 | push @ops, $node; | |
87 | } elsif ($node->{optype} eq "state") { | |
88 | push @states, $node; | |
89 | } else { | |
90 | die "Uknown optype '$node->{optype}' in ", Dumper($node); | |
03363afd | 91 | } |
f83e001e YO |
92 | $node->{id}= 0 + @all; |
93 | push @all, $node; | |
94 | $all{ $node->{name} }= $node; | |
46167d76 KW |
95 | |
96 | if ($node->{longj} && $node->{longj} != 1) { | |
97 | die "longj field must be in [01] if present in ", Dumper($node); | |
98 | } | |
99 | ||
f83e001e | 100 | } |
d3d47aac | 101 | |
f83e001e | 102 | # Parse and add an opcode definition to the global state. |
e21ef692 | 103 | # What an opcode definition looks like is given in regcomp.sym. |
f83e001e | 104 | # |
e21ef692 KW |
105 | # Not every opcode definition has all of the components. We should maybe make |
106 | # this nicer/easier to read in the future. Also note that the above is tab | |
f83e001e YO |
107 | # sensitive. |
108 | ||
e21ef692 KW |
109 | # Special comments for an entry precede it, and begin with '#*' and are placed |
110 | # in the generated pod file just before the entry. | |
111 | ||
f83e001e YO |
112 | sub parse_opcode_def { |
113 | my ( $text, $line_num, $pod_comment )= @_; | |
114 | my $node= { | |
115 | line_num => $line_num, | |
116 | pod_comment => $pod_comment, | |
117 | optype => "op", | |
118 | }; | |
d3d47aac | 119 | |
f83e001e YO |
120 | # first split the line into three, the initial NAME, a middle part |
121 | # that we call "desc" which contains various (not well documented) things, | |
122 | # and a comment section. | |
123 | @{$node}{qw(name desc comment)}= /^(\S+)\s+([^\t]+?)\s*;\s*(.*)/ | |
124 | or die "Failed to match $_"; | |
d3d47aac | 125 | |
f83e001e | 126 | # the content of the "desc" field from the first step is extracted here: |
484678fc | 127 | @{$node}{qw(type code suffix flags longj)}= split /[,\s]\s*/, $node->{desc}; |
d3d47aac | 128 | |
d1bd48a0 | 129 | defined $node->{$_} or $node->{$_} = "" |
484678fc | 130 | for qw(type code suffix flags longj); |
f83e001e YO |
131 | |
132 | register_node($node); # has to be before the type_alias code below | |
133 | ||
134 | if ( !$all{ $node->{type} } and !$type_alias{ $node->{type} } ) { | |
135 | ||
136 | #warn "Regop type '$node->{type}' from regcomp.sym line $line_num" | |
137 | # ." is not an existing regop, and will be aliased to $node->{name}\n" | |
138 | # if -t STDERR; | |
139 | $type_alias{ $node->{type} }= $node->{name}; | |
140 | } | |
141 | ||
142 | $longest_name_length= length $node->{name} | |
143 | if length $node->{name} > $longest_name_length; | |
144 | } | |
145 | ||
146 | # parse out a state definition and add the resulting data | |
147 | # into the global state. may create multiple new states from | |
148 | # a single definition (this is part of the point). | |
149 | # Format for states: | |
150 | # REGOP \t typelist [ \t typelist] | |
151 | # typelist= namelist | |
152 | # = namelist:FAIL | |
153 | # = name:count | |
154 | # Eg: | |
155 | # WHILEM A_pre,A_min,A_max,B_min,B_max:FAIL | |
156 | # BRANCH next:FAIL | |
157 | # CURLYM A,B:FAIL | |
158 | # | |
159 | # The CURLYM definition would create the states: | |
160 | # CURLYM_A, CURLYM_A_fail, CURLYM_B, CURLYM_B_fail | |
161 | sub parse_state_def { | |
162 | my ( $text, $line_num, $pod_comment )= @_; | |
163 | my ( $type, @lists )= split /\s+/, $text; | |
164 | die "No list? $type" if !@lists; | |
165 | foreach my $list (@lists) { | |
166 | my ( $names, $special )= split /:/, $list, 2; | |
167 | $special ||= ""; | |
168 | foreach my $name ( split /,/, $names ) { | |
169 | my $real= | |
170 | $name eq 'resume' | |
171 | ? "resume_$type" | |
172 | : "${type}_$name"; | |
173 | my @suffix; | |
174 | if ( !$special ) { | |
175 | @suffix= (""); | |
176 | } | |
177 | elsif ( $special =~ /\d/ ) { | |
178 | @suffix= ( 1 .. $special ); | |
179 | } | |
180 | elsif ( $special eq 'FAIL' ) { | |
181 | @suffix= ( "", "_fail" ); | |
182 | } | |
183 | else { | |
184 | die "unknown :type ':$special'"; | |
185 | } | |
186 | foreach my $suffix (@suffix) { | |
187 | my $node= { | |
188 | name => "$real$suffix", | |
189 | optype => "state", | |
190 | type => $type || "", | |
191 | comment => "state for $type", | |
192 | line_num => $line_num, | |
193 | }; | |
194 | register_node($node); | |
03363afd YO |
195 | } |
196 | } | |
03363afd YO |
197 | } |
198 | } | |
d09b2d29 | 199 | |
f9ef50a7 | 200 | sub process_flags { |
f83e001e YO |
201 | my ( $flag, $varname, $comment )= @_; |
202 | $comment= '' unless defined $comment; | |
203 | ||
204 | my @selected; | |
205 | my $bitmap= ''; | |
206 | for my $node (@ops) { | |
207 | my $set= $node->{flags} && $node->{flags} eq $flag ? 1 : 0; | |
208 | ||
209 | # Whilst I could do this with vec, I'd prefer to do longhand the arithmetic | |
210 | # ops in the C code. | |
211 | my $current= do { | |
212 | no warnings; | |
213 | ord substr $bitmap, ( $node->{id} >> 3 ); | |
214 | }; | |
215 | substr( $bitmap, ( $node->{id} >> 3 ), 1 )= | |
216 | chr( $current | ( $set << ( $node->{id} & 7 ) ) ); | |
217 | ||
218 | push @selected, $node->{name} if $set; | |
219 | } | |
220 | my $out_string= join ', ', @selected, 0; | |
221 | $out_string =~ s/(.{1,70},) /$1\n /g; | |
ded4dd2a | 222 | |
f83e001e | 223 | my $out_mask= join ', ', map { sprintf "0x%02X", ord $_ } split '', $bitmap; |
ded4dd2a | 224 | |
f83e001e | 225 | return $comment . <<"EOP"; |
ded4dd2a | 226 | #define REGNODE_\U$varname\E(node) (PL_${varname}_bitmask[(node) >> 3] & (1 << ((node) & 7))) |
e52fc539 | 227 | |
f9ef50a7 | 228 | #ifndef DOINIT |
916e4025 | 229 | EXTCONST U8 PL_${varname}\[] __attribute__deprecated__; |
f9ef50a7 | 230 | #else |
916e4025 | 231 | EXTCONST U8 PL_${varname}\[] __attribute__deprecated__ = { |
f9ef50a7 NC |
232 | $out_string |
233 | }; | |
234 | #endif /* DOINIT */ | |
235 | ||
ded4dd2a NC |
236 | #ifndef DOINIT |
237 | EXTCONST U8 PL_${varname}_bitmask[]; | |
238 | #else | |
239 | EXTCONST U8 PL_${varname}_bitmask[] = { | |
240 | $out_mask | |
241 | }; | |
242 | #endif /* DOINIT */ | |
f9ef50a7 NC |
243 | EOP |
244 | } | |
245 | ||
f83e001e YO |
246 | sub read_definition { |
247 | my ( $file )= @_; | |
248 | my ( $seen_sep, $pod_comment )= ""; | |
249 | open my $in_fh, "<", $file | |
250 | or die "Failed to open '$file' for reading: $!"; | |
251 | while (<$in_fh>) { | |
252 | ||
253 | # Special pod comments | |
254 | if (/^#\* ?/) { $pod_comment .= "# $'"; } | |
255 | ||
256 | # Truly blank lines possibly surrounding pod comments | |
257 | elsif (/^\s*$/) { $pod_comment .= "\n" } | |
258 | ||
259 | next if /\A\s*#/ || /\A\s*\z/; | |
260 | ||
261 | s/\s*\z//; | |
262 | if (/^-+\s*$/) { | |
263 | $seen_sep= 1; | |
264 | next; | |
265 | } | |
266 | ||
267 | if ($seen_sep) { | |
268 | parse_state_def( $_, $., $pod_comment ); | |
269 | } | |
270 | else { | |
271 | parse_opcode_def( $_, $., $pod_comment ); | |
272 | } | |
273 | $pod_comment= ""; | |
274 | } | |
275 | close $in_fh; | |
276 | die "Too many regexp/state opcodes! Maximum is 256, but there are ", 0 + @all, | |
277 | " in file!" | |
278 | if @all > 256; | |
279 | } | |
280 | ||
281 | # use fixed width to keep the diffs between regcomp.pl recompiles | |
282 | # as small as possible. | |
283 | my ( $width, $rwidth, $twidth )= ( 22, 12, 9 ); | |
284 | ||
285 | sub print_state_defs { | |
286 | my ($out)= @_; | |
287 | printf $out <<EOP, | |
6bda09f9 YO |
288 | /* Regops and State definitions */ |
289 | ||
03363afd YO |
290 | #define %*s\t%d |
291 | #define %*s\t%d | |
292 | ||
d09b2d29 | 293 | EOP |
f83e001e YO |
294 | -$width, |
295 | REGNODE_MAX => $#ops, | |
296 | -$width, REGMATCH_STATE_MAX => $#all; | |
297 | ||
298 | my %rev_type_alias= reverse %type_alias; | |
299 | for my $node (@ops) { | |
300 | printf $out "#define\t%*s\t%d\t/* %#04x %s */\n", | |
301 | -$width, $node->{name}, $node->{id}, $node->{id}, $node->{comment}; | |
302 | if ( defined( my $alias= $rev_type_alias{ $node->{name} } ) ) { | |
303 | printf $out "#define\t%*s\t%d\t/* %#04x %s */\n", | |
304 | -$width, $alias, $node->{id}, $node->{id}, "type alias"; | |
305 | } | |
306 | } | |
d3d47aac | 307 | |
f83e001e YO |
308 | print $out "\t/* ------------ States ------------- */\n"; |
309 | for my $node (@states) { | |
310 | printf $out "#define\t%*s\t(REGNODE_MAX + %d)\t/* %s */\n", | |
311 | -$width, $node->{name}, $node->{id} - $#ops, $node->{comment}; | |
312 | } | |
d09b2d29 IZ |
313 | } |
314 | ||
f83e001e YO |
315 | sub print_regkind { |
316 | my ($out)= @_; | |
317 | print $out <<EOP; | |
03363afd | 318 | |
6bda09f9 | 319 | /* PL_regkind[] What type of regop or state is this. */ |
d09b2d29 IZ |
320 | |
321 | #ifndef DOINIT | |
22c35a8c | 322 | EXTCONST U8 PL_regkind[]; |
d09b2d29 | 323 | #else |
22c35a8c | 324 | EXTCONST U8 PL_regkind[] = { |
d09b2d29 | 325 | EOP |
f83e001e YO |
326 | use Data::Dumper; |
327 | foreach my $node (@all) { | |
328 | print Dumper($node) if !defined $node->{type} or !defined( $node->{name} ); | |
329 | printf $out "\t%*s\t/* %*s */\n", | |
330 | -1 - $twidth, "$node->{type},", -$width, $node->{name}; | |
331 | print $out "\t/* ------------ States ------------- */\n" | |
332 | if $node->{id} == $#ops and $node->{id} != $#all; | |
333 | } | |
d09b2d29 | 334 | |
f83e001e | 335 | print $out <<EOP; |
d09b2d29 IZ |
336 | }; |
337 | #endif | |
f83e001e YO |
338 | EOP |
339 | } | |
340 | ||
341 | sub wrap_ifdef_print { | |
342 | my $out= shift; | |
343 | my $token= shift; | |
344 | print $out <<EOP; | |
345 | ||
346 | #ifdef $token | |
347 | EOP | |
348 | $_->($out) for @_; | |
349 | print $out <<EOP; | |
350 | #endif /* $token */ | |
351 | ||
352 | EOP | |
353 | } | |
354 | ||
355 | sub print_regarglen { | |
356 | my ($out)= @_; | |
357 | print $out <<EOP; | |
d09b2d29 | 358 | |
6bda09f9 | 359 | /* regarglen[] - How large is the argument part of the node (in regnodes) */ |
d09b2d29 | 360 | |
29de9391 | 361 | static const U8 regarglen[] = { |
d09b2d29 IZ |
362 | EOP |
363 | ||
f83e001e YO |
364 | foreach my $node (@ops) { |
365 | my $size= 0; | |
484678fc | 366 | $size= "EXTRA_SIZE(struct regnode_$node->{suffix})" if $node->{suffix}; |
d09b2d29 | 367 | |
f83e001e YO |
368 | printf $out "\t%*s\t/* %*s */\n", -37, "$size,", -$rwidth, $node->{name}; |
369 | } | |
370 | ||
371 | print $out <<EOP; | |
d09b2d29 | 372 | }; |
f83e001e YO |
373 | EOP |
374 | } | |
375 | ||
376 | sub print_reg_off_by_arg { | |
377 | my ($out)= @_; | |
378 | print $out <<EOP; | |
d09b2d29 | 379 | |
6bda09f9 YO |
380 | /* reg_off_by_arg[] - Which argument holds the offset to the next node */ |
381 | ||
29de9391 | 382 | static const char reg_off_by_arg[] = { |
d09b2d29 IZ |
383 | EOP |
384 | ||
f83e001e YO |
385 | foreach my $node (@ops) { |
386 | my $size= $node->{longj} || 0; | |
9b155405 | 387 | |
f83e001e YO |
388 | printf $out "\t%d,\t/* %*s */\n", $size, -$rwidth, $node->{name}; |
389 | } | |
d09b2d29 | 390 | |
f83e001e | 391 | print $out <<EOP; |
d09b2d29 | 392 | }; |
9b155405 | 393 | |
f83e001e YO |
394 | EOP |
395 | } | |
396 | ||
397 | sub print_reg_name { | |
398 | my ($out)= @_; | |
399 | print $out <<EOP; | |
13d6edb4 | 400 | |
6bda09f9 YO |
401 | /* reg_name[] - Opcode/state names in string form, for debugging */ |
402 | ||
22429478 | 403 | #ifndef DOINIT |
13d6edb4 | 404 | EXTCONST char * PL_reg_name[]; |
22429478 | 405 | #else |
4764e399 | 406 | EXTCONST char * const PL_reg_name[] = { |
9b155405 IZ |
407 | EOP |
408 | ||
f83e001e YO |
409 | my $ofs= 0; |
410 | my $sym= ""; | |
411 | foreach my $node (@all) { | |
412 | my $size= $node->{longj} || 0; | |
413 | ||
414 | printf $out "\t%*s\t/* $sym%#04x */\n", | |
415 | -3 - $width, qq("$node->{name}",), $node->{id} - $ofs; | |
416 | if ( $node->{id} == $#ops and @ops != @all ) { | |
417 | print $out "\t/* ------------ States ------------- */\n"; | |
418 | $ofs= $#ops; | |
419 | $sym= 'REGNODE_MAX +'; | |
420 | } | |
421 | } | |
9b155405 | 422 | |
f83e001e | 423 | print $out <<EOP; |
9b155405 | 424 | }; |
22429478 | 425 | #endif /* DOINIT */ |
d09b2d29 | 426 | |
337ff307 | 427 | EOP |
f83e001e | 428 | } |
337ff307 | 429 | |
f83e001e YO |
430 | sub print_reg_extflags_name { |
431 | my ($out)= @_; | |
432 | print $out <<EOP; | |
f7819f85 A |
433 | /* PL_reg_extflags_name[] - Opcode/state names in string form, for debugging */ |
434 | ||
435 | #ifndef DOINIT | |
436 | EXTCONST char * PL_reg_extflags_name[]; | |
437 | #else | |
438 | EXTCONST char * const PL_reg_extflags_name[] = { | |
d09b2d29 IZ |
439 | EOP |
440 | ||
f83e001e YO |
441 | my %rxfv; |
442 | my %definitions; # Remember what the symbol definitions are | |
443 | my $val= 0; | |
444 | my %reverse; | |
445 | my $REG_EXTFLAGS_NAME_SIZE= 0; | |
446 | foreach my $file ( "op_reg_common.h", "regexp.h" ) { | |
447 | open my $in_fh, "<", $file or die "Can't read '$file': $!"; | |
448 | while (<$in_fh>) { | |
449 | ||
450 | # optional leading '_'. Return symbol in $1, and strip it from | |
451 | # comment of line | |
452 | if (s/^ \# \s* define \s+ ( _? RXf_ \w+ ) \s+ //xi) { | |
453 | chomp; | |
454 | my $define= $1; | |
455 | my $orig= $_; | |
456 | s{ /\* .*? \*/ }{ }x; # Replace comments by a blank | |
457 | ||
458 | # Replace any prior defined symbols by their values | |
459 | foreach my $key ( keys %definitions ) { | |
460 | s/\b$key\b/$definitions{$key}/g; | |
461 | } | |
5c72e80d | 462 | |
f83e001e YO |
463 | # Remove the U suffix from unsigned int literals |
464 | s/\b([0-9]+)U\b/$1/g; | |
5c72e80d | 465 | |
f83e001e | 466 | my $newval= eval $_; # Get numeric definition |
6a080ccd | 467 | |
f83e001e | 468 | $definitions{$define}= $newval; |
6a080ccd | 469 | |
f83e001e YO |
470 | next unless $_ =~ /<</; # Bit defines use left shift |
471 | if ( $val & $newval ) { | |
472 | my @names= ( $define, $reverse{$newval} ); | |
473 | s/PMf_// for @names; | |
474 | if ( $names[0] ne $names[1] ) { | |
475 | die sprintf | |
476 | "ERROR: both $define and $reverse{$newval} use 0x%08X (%s:%s)", | |
477 | $newval, $orig, $_; | |
478 | } | |
479 | next; | |
6976c986 | 480 | } |
f83e001e YO |
481 | $val |= $newval; |
482 | $rxfv{$define}= $newval; | |
483 | $reverse{$newval}= $define; | |
1850c8f9 | 484 | } |
6a080ccd | 485 | } |
f7819f85 | 486 | } |
f83e001e YO |
487 | my %vrxf= reverse %rxfv; |
488 | printf $out "\t/* Bits in extflags defined: %s */\n", unpack 'B*', pack 'N', | |
489 | $val; | |
490 | my %multibits; | |
491 | for ( 0 .. 31 ) { | |
492 | my $power_of_2= 2**$_; | |
493 | my $n= $vrxf{$power_of_2}; | |
494 | my $extra= ""; | |
495 | if ( !$n ) { | |
496 | ||
497 | # Here, there was no name that matched exactly the bit. It could be | |
498 | # either that it is unused, or the name matches multiple bits. | |
499 | if ( !( $val & $power_of_2 ) ) { | |
500 | $n= "UNUSED_BIT_$_"; | |
501 | } | |
502 | else { | |
503 | ||
504 | # Here, must be because it matches multiple bits. Look through | |
505 | # all possibilities until find one that matches this one. Use | |
506 | # that name, and all the bits it matches | |
507 | foreach my $name ( keys %rxfv ) { | |
508 | if ( $rxfv{$name} & $power_of_2 ) { | |
509 | $n= $name . ( $multibits{$name}++ ); | |
510 | $extra= sprintf qq{ : "%s" - 0x%08x}, $name, | |
511 | $rxfv{$name} | |
512 | if $power_of_2 != $rxfv{$name}; | |
513 | last; | |
514 | } | |
5458d9a0 KW |
515 | } |
516 | } | |
517 | } | |
f83e001e YO |
518 | s/\bRXf_(PMf_)?// for $n, $extra; |
519 | printf $out qq(\t%-20s/* 0x%08x%s */\n), qq("$n",), $power_of_2, $extra; | |
520 | $REG_EXTFLAGS_NAME_SIZE++; | |
5458d9a0 | 521 | } |
f83e001e YO |
522 | |
523 | print $out <<EOP; | |
f7819f85 A |
524 | }; |
525 | #endif /* DOINIT */ | |
526 | ||
adc2d0c9 JH |
527 | #ifdef DEBUGGING |
528 | # define REG_EXTFLAGS_NAME_SIZE $REG_EXTFLAGS_NAME_SIZE | |
529 | #endif | |
f83e001e | 530 | EOP |
adc2d0c9 | 531 | |
337ff307 | 532 | } |
f83e001e YO |
533 | |
534 | sub print_reg_intflags_name { | |
535 | my ($out)= @_; | |
536 | print $out <<EOP; | |
537 | ||
337ff307 YO |
538 | /* PL_reg_intflags_name[] - Opcode/state names in string form, for debugging */ |
539 | ||
540 | #ifndef DOINIT | |
541 | EXTCONST char * PL_reg_intflags_name[]; | |
542 | #else | |
543 | EXTCONST char * const PL_reg_intflags_name[] = { | |
544 | EOP | |
545 | ||
f83e001e YO |
546 | my %rxfv; |
547 | my %definitions; # Remember what the symbol definitions are | |
548 | my $val= 0; | |
549 | my %reverse; | |
550 | my $REG_INTFLAGS_NAME_SIZE= 0; | |
551 | foreach my $file ("regcomp.h") { | |
552 | open my $fh, "<", $file or die "Can't read $file: $!"; | |
553 | while (<$fh>) { | |
554 | ||
555 | # optional leading '_'. Return symbol in $1, and strip it from | |
556 | # comment of line | |
557 | if ( | |
558 | m/^ \# \s* define \s+ ( PREGf_ ( \w+ ) ) \s+ 0x([0-9a-f]+)(?:\s*\/\*(.*)\*\/)?/xi | |
559 | ) | |
560 | { | |
561 | chomp; | |
562 | my $define= $1; | |
563 | my $abbr= $2; | |
564 | my $hex= $3; | |
565 | my $comment= $4; | |
566 | my $val= hex($hex); | |
567 | $comment= $comment ? " - $comment" : ""; | |
568 | ||
569 | printf $out qq(\t%-30s/* 0x%08x - %s%s */\n), qq("$abbr",), | |
570 | $val, $define, $comment; | |
571 | $REG_INTFLAGS_NAME_SIZE++; | |
572 | } | |
337ff307 YO |
573 | } |
574 | } | |
337ff307 | 575 | |
f83e001e | 576 | print $out <<EOP; |
337ff307 YO |
577 | }; |
578 | #endif /* DOINIT */ | |
579 | ||
580 | EOP | |
f83e001e | 581 | print $out <<EOQ; |
adc2d0c9 JH |
582 | #ifdef DEBUGGING |
583 | # define REG_INTFLAGS_NAME_SIZE $REG_INTFLAGS_NAME_SIZE | |
584 | #endif | |
337ff307 | 585 | |
adc2d0c9 JH |
586 | EOQ |
587 | } | |
f9ef50a7 | 588 | |
f83e001e YO |
589 | sub print_process_flags { |
590 | my ($out)= @_; | |
591 | ||
592 | print $out process_flags( 'V', 'varies', <<'EOC'); | |
f9ef50a7 NC |
593 | /* The following have no fixed length. U8 so we can do strchr() on it. */ |
594 | EOC | |
595 | ||
f83e001e | 596 | print $out process_flags( 'S', 'simple', <<'EOC'); |
ce716c52 | 597 | |
f9ef50a7 NC |
598 | /* The following always have a length of 1. U8 we can do strchr() on it. */ |
599 | /* (Note that length 1 means "one character" under UTF8, not "one octet".) */ | |
600 | EOC | |
601 | ||
f83e001e | 602 | } |
65aa4ca7 | 603 | |
f83e001e YO |
604 | sub do_perldebguts { |
605 | my $guts= open_new( 'pod/perldebguts.pod', '>' ); | |
65aa4ca7 | 606 | |
f83e001e YO |
607 | my $node; |
608 | my $code; | |
609 | my $name_fmt= '<' x ( $longest_name_length - 1 ); | |
610 | my $descr_fmt= '<' x ( 58 - $longest_name_length ); | |
611 | eval <<EOD or die $@; | |
65aa4ca7 FC |
612 | format GuTS = |
613 | ^*~~ | |
f83e001e | 614 | \$node->{pod_comment} |
95fe686d | 615 | ^$name_fmt ^<<<<<<<<< ^$descr_fmt~~ |
d1bd48a0 | 616 | \$node->{name}, \$code, defined \$node->{comment} ? \$node->{comment} : '' |
65aa4ca7 | 617 | . |
f83e001e | 618 | 1; |
65aa4ca7 | 619 | EOD |
f83e001e YO |
620 | |
621 | my $old_fh= select($guts); | |
622 | $~= "GuTS"; | |
65aa4ca7 | 623 | |
1ae6ead9 | 624 | open my $oldguts, '<', 'pod/perldebguts.pod' |
65aa4ca7 | 625 | or die "$0 cannot open pod/perldebguts.pod for reading: $!"; |
f83e001e | 626 | while (<$oldguts>) { |
65aa4ca7 FC |
627 | print; |
628 | last if /=for regcomp.pl begin/; | |
629 | } | |
630 | ||
f83e001e | 631 | print <<'END_OF_DESCR'; |
65aa4ca7 | 632 | |
e21ef692 | 633 | # TYPE arg-description [regnode-struct-suffix] [longjump-len] DESCRIPTION |
f83e001e YO |
634 | END_OF_DESCR |
635 | for my $n (@ops) { | |
636 | $node= $n; | |
484678fc | 637 | $code= "$node->{code} " . ( $node->{suffix} || "" ); |
f83e001e YO |
638 | $code .= " $node->{longj}" if $node->{longj}; |
639 | if ( $node->{pod_comment} ||= "" ) { | |
640 | ||
65aa4ca7 | 641 | # Trim multiple blanks |
f83e001e YO |
642 | $node->{pod_comment} =~ s/^\n\n+/\n/; |
643 | $node->{pod_comment} =~ s/\n\n+$/\n\n/; | |
65aa4ca7 FC |
644 | } |
645 | write; | |
646 | } | |
647 | print "\n"; | |
648 | ||
f83e001e | 649 | while (<$oldguts>) { |
65aa4ca7 FC |
650 | last if /=for regcomp.pl end/; |
651 | } | |
4ac5f10b DD |
652 | do { print } while <$oldguts>; #win32 can't unlink an open FH |
653 | close $oldguts or die "Error closing pod/perldebguts.pod: $!"; | |
f83e001e YO |
654 | select $old_fh; |
655 | close_and_rename($guts); | |
656 | } | |
65aa4ca7 | 657 | |
f83e001e YO |
658 | read_definition("regcomp.sym"); |
659 | my $out= open_new( 'regnodes.h', '>', | |
660 | { by => 'regen/regcomp.pl', from => 'regcomp.sym' } ); | |
661 | print_state_defs($out); | |
662 | print_regkind($out); | |
663 | wrap_ifdef_print( | |
664 | $out, | |
665 | "REG_COMP_C", | |
666 | \&print_regarglen, | |
667 | \&print_reg_off_by_arg | |
668 | ); | |
669 | print_reg_name($out); | |
670 | print_reg_extflags_name($out); | |
671 | print_reg_intflags_name($out); | |
672 | print_process_flags($out); | |
673 | read_only_bottom_close_and_rename($out); | |
65aa4ca7 | 674 | |
f83e001e | 675 | do_perldebguts(); |