This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regen/regcomp.pl: Rename variable
[perl5.git] / regen / regcomp.pl
CommitLineData
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
21BEGIN {
22 # Get function prototypes
3d7c117d 23 require './regen/regen_lib.pl';
36bb303b 24}
03363afd 25use 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
65my @all; # all opcodes/state
66my %all; # hash of all opcode/state names
67
68my @ops; # array of just opcodes
69my @states; # array of just states
70
71my $longest_name_length= 0; # track lengths of names for nicer reports
72my (%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.
77sub 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
112sub 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
161sub 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 200sub 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 229EXTCONST U8 PL_${varname}\[] __attribute__deprecated__;
f9ef50a7 230#else
916e4025 231EXTCONST U8 PL_${varname}\[] __attribute__deprecated__ = {
f9ef50a7
NC
232 $out_string
233};
234#endif /* DOINIT */
235
ded4dd2a
NC
236#ifndef DOINIT
237EXTCONST U8 PL_${varname}_bitmask[];
238#else
239EXTCONST U8 PL_${varname}_bitmask[] = {
240 $out_mask
241};
242#endif /* DOINIT */
f9ef50a7
NC
243EOP
244}
245
f83e001e
YO
246sub 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.
283my ( $width, $rwidth, $twidth )= ( 22, 12, 9 );
284
285sub 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 293EOP
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
315sub 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 322EXTCONST U8 PL_regkind[];
d09b2d29 323#else
22c35a8c 324EXTCONST U8 PL_regkind[] = {
d09b2d29 325EOP
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
338EOP
339}
340
341sub wrap_ifdef_print {
342 my $out= shift;
343 my $token= shift;
344 print $out <<EOP;
345
346#ifdef $token
347EOP
348 $_->($out) for @_;
349 print $out <<EOP;
350#endif /* $token */
351
352EOP
353}
354
355sub 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 361static const U8 regarglen[] = {
d09b2d29
IZ
362EOP
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
373EOP
374}
375
376sub 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 382static const char reg_off_by_arg[] = {
d09b2d29
IZ
383EOP
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
394EOP
395}
396
397sub 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 404EXTCONST char * PL_reg_name[];
22429478 405#else
4764e399 406EXTCONST char * const PL_reg_name[] = {
9b155405
IZ
407EOP
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 427EOP
f83e001e 428}
337ff307 429
f83e001e
YO
430sub 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
436EXTCONST char * PL_reg_extflags_name[];
437#else
438EXTCONST char * const PL_reg_extflags_name[] = {
d09b2d29
IZ
439EOP
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 530EOP
adc2d0c9 531
337ff307 532}
f83e001e
YO
533
534sub 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
541EXTCONST char * PL_reg_intflags_name[];
542#else
543EXTCONST char * const PL_reg_intflags_name[] = {
544EOP
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
580EOP
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
586EOQ
587}
f9ef50a7 588
f83e001e
YO
589sub 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. */
594EOC
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".) */
600EOC
601
f83e001e 602}
65aa4ca7 603
f83e001e
YO
604sub 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
612format 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 6181;
65aa4ca7 619EOD
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
634END_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
658read_definition("regcomp.sym");
659my $out= open_new( 'regnodes.h', '>',
660 { by => 'regen/regcomp.pl', from => 'regcomp.sym' } );
661print_state_defs($out);
662print_regkind($out);
663wrap_ifdef_print(
664 $out,
665 "REG_COMP_C",
666 \&print_regarglen,
667 \&print_reg_off_by_arg
668);
669print_reg_name($out);
670print_reg_extflags_name($out);
671print_reg_intflags_name($out);
672print_process_flags($out);
673read_only_bottom_close_and_rename($out);
65aa4ca7 674
f83e001e 675do_perldebguts();