regen/regcomp.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # Regenerate (overwriting only if changed):
   4 #
   5 #    pod/perldebguts.pod
   6 #    regnodes.h
   7 #
   8 # from information stored in
   9 #
  10 #    regcomp.sym
  11 #    regexp.h
  12 #
  13 # pod/perldebguts.pod is not completely regenerated.  Only the table of
  14 # regexp nodes is replaced; other parts remain unchanged.
  15 #
  16 # Accepts the standard regen_lib -q and -v args.
  17 #
  18 # This script is normally invoked from regen.pl.
  19
  20 BEGIN {
  21     # Get function prototypes
  22     require 'regen/regen_lib.pl';
  23 }
  24 use strict;
  25
  26 open DESC, 'regcomp.sym';
  27
  28 my $ind = 0;
  29 my (@name,@rest,@type,@code,@args,@flags,@longj,@cmnt);
  30 my ($longest_name_length,$desc,$lastregop) = 0;
  31 my (%seen_op, %type_alias);
  32 while (<DESC>) {
  33     # Special pod comments
  34     if (/^#\* ?/) { $cmnt[$ind] .= "# $'"; }
  35     # Truly blank lines possibly surrounding pod comments
  36     elsif (/^\s*$/) { $cmnt[$ind] .= "\n" }
  37
  38     next if /^(?:#|\s*$)/;
  39     chomp; # No \z in 5.004
  40     s/\s*$//;
  41     if (/^-+\s*$/) {
  42         $lastregop= $ind;
  43         next;
  44     }
  45     unless ($lastregop) {
  46         ($name[$ind], $desc, $rest[$ind]) = /^(\S+)\s+([^\t]+?)\s*;\s*(.*)/;
  47
  48         if (defined $seen_op{$name[$ind]}) {
  49             die "Duplicate regop $name[$ind] in regcomp.sym line $. previously defined on line $seen_op{$name[$ind]}\n";
  50         } else {
  51             $seen_op{$name[$ind]}= $.;
  52         }
  53
  54         ($type[$ind], $code[$ind], $args[$ind], $flags[$ind], $longj[$ind])
  55           = split /[,\s]\s*/, $desc;
  56
  57         if (!defined $seen_op{$type[$ind]} and !defined $type_alias{$type[$ind]}) {
  58             #warn "Regop type '$type[$ind]' from regcomp.sym line $. is not an existing regop, and will be aliased to $name[$ind]\n"
  59             #    if -t STDERR;
  60             $type_alias{$type[$ind]}= $name[$ind];
  61         }
  62
  63         $longest_name_length = length $name[$ind]
  64           if length $name[$ind] > $longest_name_length;
  65         ++$ind;
  66     } else {
  67         my ($type,@lists)=split /\s+/, $_;
  68         die "No list? $type" if !@lists;
  69         foreach my $list (@lists) {
  70             my ($names,$special)=split /:/, $list , 2;
  71             $special ||= "";
  72             foreach my $name (split /,/,$names) {
  73                 my $real= $name eq 'resume'
  74                         ? "resume_$type"
  75                         : "${type}_$name";
  76                 my @suffix;
  77                 if (!$special) {
  78                    @suffix=("");
  79                 } elsif ($special=~/\d/) {
  80                     @suffix=(1..$special);
  81                 } elsif ($special eq 'FAIL') {
  82                     @suffix=("","_fail");
  83                 } else {
  84                     die "unknown :type ':$special'";
  85                 }
  86                 foreach my $suffix (@suffix) {
  87                     $name[$ind]="$real$suffix";
  88                     $type[$ind]=$type;
  89                     $rest[$ind]="state for $type";
  90                     ++$ind;
  91                 }
  92             }
  93         }
  94
  95     }
  96 }
  97 # use fixed width to keep the diffs between regcomp.pl recompiles
  98 # as small as possible.
  99 my ($width,$rwidth,$twidth)=(22,12,9);
 100 $lastregop ||= $ind;
 101 my $tot = $ind;
 102 close DESC;
 103 die "Too many regexp/state opcodes! Maximum is 256, but there are $lastregop in file!"
 104     if $lastregop>256;
 105
 106 sub process_flags {
 107   my ($flag, $varname, $comment) = @_;
 108   $comment = '' unless defined $comment;
 109
 110   $ind = 0;
 111   my @selected;
 112   my $bitmap = '';
 113   do {
 114     my $set = $flags[$ind] && $flags[$ind] eq $flag ? 1 : 0;
 115     # Whilst I could do this with vec, I'd prefer to do longhand the arithmetic
 116     # ops in the C code.
 117     my $current = do {
 118       local $^W;
 119       ord do {
 120         substr $bitmap, ($ind >> 3);
 121       }
 122     };
 123     substr($bitmap, ($ind >> 3), 1) = chr($current | ($set << ($ind & 7)));
 124
 125     push @selected, $name[$ind] if $set;
 126   } while (++$ind < $lastregop);
 127   my $out_string = join ', ', @selected, 0;
 128   $out_string =~ s/(.{1,70},) /$1\n    /g;
 129
 130   my $out_mask = join ', ', map {sprintf "0x%02X", ord $_} split '', $bitmap;
 131
 132   return $comment . <<"EOP";
 133 #define REGNODE_\U$varname\E(node) (PL_${varname}_bitmask[(node) >> 3] & (1 << ((node) & 7)))
 134
 135 #ifndef DOINIT
 136 EXTCONST U8 PL_${varname}\[] __attribute__deprecated__;
 137 #else
 138 EXTCONST U8 PL_${varname}\[] __attribute__deprecated__ = {
 139     $out_string
 140 };
 141 #endif /* DOINIT */
 142
 143 #ifndef DOINIT
 144 EXTCONST U8 PL_${varname}_bitmask[];
 145 #else
 146 EXTCONST U8 PL_${varname}_bitmask[] = {
 147     $out_mask
 148 };
 149 #endif /* DOINIT */
 150 EOP
 151 }
 152
 153 my $out = open_new('regnodes.h', '>',
 154                    { by => 'regen/regcomp.pl', from => 'regcomp.sym' });
 155 printf $out <<EOP,
 156 /* Regops and State definitions */
 157
 158 #define %*s\t%d
 159 #define %*s\t%d
 160
 161 EOP
 162     -$width, REGNODE_MAX        => $lastregop - 1,
 163     -$width, REGMATCH_STATE_MAX => $tot - 1
 164 ;
 165
 166 my %rev_type_alias= reverse %type_alias;
 167 for ($ind=0; $ind < $lastregop ; ++$ind) {
 168   printf $out "#define\t%*s\t%d\t/* %#04x %s */\n",
 169     -$width, $name[$ind], $ind, $ind, $rest[$ind];
 170   if (defined(my $alias= $rev_type_alias{$name[$ind]})) {
 171       printf $out "#define\t%*s\t%d\t/* %#04x %s */\n",
 172             -$width, $alias, $ind, $ind, "type alias";
 173   }
 174
 175 }
 176 print $out "\t/* ------------ States ------------- */\n";
 177 for ( ; $ind < $tot ; $ind++) {
 178   printf $out "#define\t%*s\t(REGNODE_MAX + %d)\t/* %s */\n",
 179     -$width, $name[$ind], $ind - $lastregop + 1, $rest[$ind];
 180 }
 181
 182 print $out <<EOP;
 183
 184 /* PL_regkind[] What type of regop or state is this. */
 185
 186 #ifndef DOINIT
 187 EXTCONST U8 PL_regkind[];
 188 #else
 189 EXTCONST U8 PL_regkind[] = {
 190 EOP
 191
 192 $ind = 0;
 193 do {
 194   printf $out "\t%*s\t/* %*s */\n",
 195              -1-$twidth, "$type[$ind],", -$width, $name[$ind];
 196   print $out "\t/* ------------ States ------------- */\n"
 197     if $ind + 1 == $lastregop and $lastregop != $tot;
 198 } while (++$ind < $tot);
 199
 200 print $out <<EOP;
 201 };
 202 #endif
 203
 204 /* regarglen[] - How large is the argument part of the node (in regnodes) */
 205
 206 #ifdef REG_COMP_C
 207 static const U8 regarglen[] = {
 208 EOP
 209
 210 $ind = 0;
 211 do {
 212   my $size = 0;
 213   $size = "EXTRA_SIZE(struct regnode_$args[$ind])" if $args[$ind];
 214
 215   printf $out "\t%*s\t/* %*s */\n",
 216         -37, "$size,",-$rwidth,$name[$ind];
 217 } while (++$ind < $lastregop);
 218
 219 print $out <<EOP;
 220 };
 221
 222 /* reg_off_by_arg[] - Which argument holds the offset to the next node */
 223
 224 static const char reg_off_by_arg[] = {
 225 EOP
 226
 227 $ind = 0;
 228 do {
 229   my $size = $longj[$ind] || 0;
 230
 231   printf $out "\t%d,\t/* %*s */\n",
 232         $size, -$rwidth, $name[$ind]
 233 } while (++$ind < $lastregop);
 234
 235 print $out <<EOP;
 236 };
 237
 238 #endif /* REG_COMP_C */
 239
 240 /* reg_name[] - Opcode/state names in string form, for debugging */
 241
 242 #ifndef DOINIT
 243 EXTCONST char * PL_reg_name[];
 244 #else
 245 EXTCONST char * const PL_reg_name[] = {
 246 EOP
 247
 248 $ind = 0;
 249 my $ofs = 0;
 250 my $sym = "";
 251 do {
 252   my $size = $longj[$ind] || 0;
 253
 254   printf $out "\t%*s\t/* $sym%#04x */\n",
 255         -3-$width,qq("$name[$ind]",), $ind - $ofs;
 256   if ($ind + 1 == $lastregop and $lastregop != $tot) {
 257     print $out "\t/* ------------ States ------------- */\n";
 258     $ofs = $lastregop - 1;
 259     $sym = 'REGNODE_MAX +';
 260   }
 261
 262 } while (++$ind < $tot);
 263
 264 print $out <<EOP;
 265 };
 266 #endif /* DOINIT */
 267
 268 EOP
 269
 270 {
 271 print $out <<EOP;
 272 /* PL_reg_extflags_name[] - Opcode/state names in string form, for debugging */
 273
 274 #ifndef DOINIT
 275 EXTCONST char * PL_reg_extflags_name[];
 276 #else
 277 EXTCONST char * const PL_reg_extflags_name[] = {
 278 EOP
 279
 280 my %rxfv;
 281 my %definitions;    # Remember what the symbol definitions are
 282 my $val = 0;
 283 my %reverse;
 284 my $REG_EXTFLAGS_NAME_SIZE = 0;
 285 foreach my $file ("op_reg_common.h", "regexp.h") {
 286     open FH,"<$file" or die "Can't read $file: $!";
 287     while (<FH>) {
 288
 289         # optional leading '_'.  Return symbol in $1, and strip it from
 290         # rest of line
 291         if (s/^ \# \s* define \s+ ( _? RXf_ \w+ ) \s+ //xi) {
 292             chomp;
 293             my $define = $1;
 294             my $orig= $_;
 295             s{ /\* .*? \*/ }{ }x;    # Replace comments by a blank
 296
 297             # Replace any prior defined symbols by their values
 298             foreach my $key (keys %definitions) {
 299                 s/\b$key\b/$definitions{$key}/g;
 300             }
 301
 302             # Remove the U suffix from unsigned int literals
 303             s/\b([0-9]+)U\b/$1/g;
 304
 305             my $newval = eval $_;   # Get numeric definition
 306
 307             $definitions{$define} = $newval;
 308
 309             next unless $_ =~ /<</; # Bit defines use left shift
 310             if($val & $newval) {
 311                 my @names=($define, $reverse{$newval});
 312                 s/PMf_// for @names;
 313                 if ($names[0] ne $names[1]) {
 314                     die sprintf "ERROR: both $define and $reverse{$newval} use 0x%08X (%s:%s)", $newval, $orig, $_;
 315                 }
 316                 next;
 317             }
 318             $val|=$newval;
 319             $rxfv{$define}= $newval;
 320             $reverse{$newval} = $define;
 321         }
 322     }
 323 }
 324 my %vrxf=reverse %rxfv;
 325 printf $out "\t/* Bits in extflags defined: %s */\n", unpack 'B*', pack 'N', $val;
 326 my %multibits;
 327 for (0..31) {
 328     my $power_of_2 = 2**$_;
 329     my $n=$vrxf{$power_of_2};
 330     my $extra = "";
 331     if (! $n) {
 332
 333         # Here, there was no name that matched exactly the bit.  It could be
 334         # either that it is unused, or the name matches multiple bits.
 335         if (! ($val & $power_of_2)) {
 336             $n = "UNUSED_BIT_$_";
 337         }
 338         else {
 339
 340             # Here, must be because it matches multiple bits.  Look through
 341             # all possibilities until find one that matches this one.  Use
 342             # that name, and all the bits it matches
 343             foreach my $name (keys %rxfv) {
 344                 if ($rxfv{$name} & $power_of_2) {
 345                     $n = $name . ( $multibits{$name}++ );
 346                     $extra= sprintf qq{ : "%s" - 0x%08x}, $name, $rxfv{$name}
 347                         if $power_of_2 != $rxfv{$name};
 348                     last;
 349                 }
 350             }
 351         }
 352     }
 353     s/\bRXf_(PMf_)?// for $n, $extra;
 354     printf $out qq(\t%-20s/* 0x%08x%s */\n),
 355         qq("$n",),$power_of_2, $extra;
 356     $REG_EXTFLAGS_NAME_SIZE++;
 357 }
 358
 359 print $out <<EOP;
 360 };
 361 #endif /* DOINIT */
 362
 363 EOP
 364 print $out <<EOQ
 365 #ifdef DEBUGGING
 366 #  define REG_EXTFLAGS_NAME_SIZE $REG_EXTFLAGS_NAME_SIZE
 367 #endif
 368
 369 EOQ
 370 }
 371 {
 372 print $out <<EOP;
 373 /* PL_reg_intflags_name[] - Opcode/state names in string form, for debugging */
 374
 375 #ifndef DOINIT
 376 EXTCONST char * PL_reg_intflags_name[];
 377 #else
 378 EXTCONST char * const PL_reg_intflags_name[] = {
 379 EOP
 380
 381 my %rxfv;
 382 my %definitions;    # Remember what the symbol definitions are
 383 my $val = 0;
 384 my %reverse;
 385 my $REG_INTFLAGS_NAME_SIZE = 0;
 386 foreach my $file ("regcomp.h") {
 387     open my $fh, "<", $file or die "Can't read $file: $!";
 388     while (<$fh>) {
 389         # optional leading '_'.  Return symbol in $1, and strip it from
 390         # rest of line
 391         if (m/^ \# \s* define \s+ ( PREGf_ ( \w+ ) ) \s+ 0x([0-9a-f]+)(?:\s*\/\*(.*)\*\/)?/xi) {
 392             chomp;
 393             my $define = $1;
 394             my $abbr= $2;
 395             my $hex= $3;
 396             my $comment= $4;
 397             my $val= hex($hex);
 398             $comment= $comment ? " - $comment" : "";
 399
 400             printf $out qq(\t%-30s/* 0x%08x - %s%s */\n), qq("$abbr",), $val, $define, $comment;
 401             $REG_INTFLAGS_NAME_SIZE++;
 402         }
 403     }
 404 }
 405
 406 print $out <<EOP;
 407 };
 408 #endif /* DOINIT */
 409
 410 EOP
 411 print $out <<EOQ;
 412 #ifdef DEBUGGING
 413 #  define REG_INTFLAGS_NAME_SIZE $REG_INTFLAGS_NAME_SIZE
 414 #endif
 415
 416 EOQ
 417 }
 418
 419 print $out process_flags('V', 'varies', <<'EOC');
 420 /* The following have no fixed length. U8 so we can do strchr() on it. */
 421 EOC
 422
 423 print $out process_flags('S', 'simple', <<'EOC');
 424
 425 /* The following always have a length of 1. U8 we can do strchr() on it. */
 426 /* (Note that length 1 means "one character" under UTF8, not "one octet".) */
 427 EOC
 428
 429 read_only_bottom_close_and_rename($out);
 430
 431 my $guts = open_new('pod/perldebguts.pod', '>');
 432
 433 my $code;
 434 my $name_fmt = '<' x ($longest_name_length-1);
 435 my $descr_fmt = '<' x (58-$longest_name_length);
 436 eval <<EOD;
 437 format GuTS =
 438  ^*~~
 439  \$cmnt[\$_]
 440  ^$name_fmt ^<<<<<<<<< ^$descr_fmt~~
 441  \$name[\$_], \$code,  \$rest[\$_]
 442 .
 443 EOD
 444
 445 select +(select($guts), do {
 446     $~ = "GuTS";
 447
 448     open my $oldguts, "pod/perldebguts.pod"
 449         or die "$0 cannot open pod/perldebguts.pod for reading: $!";
 450     while(<$oldguts>) {
 451         print;
 452         last if /=for regcomp.pl begin/;
 453     }
 454
 455     print <<'end';
 456
 457  # TYPE arg-description [num-args] [longjump-len] DESCRIPTION
 458 end
 459     for (0..$lastregop-1) {
 460         $code = "$code[$_] ".($args[$_]||"");
 461         $code .= " $longj[$_]" if $longj[$_];
 462         if ($cmnt[$_] ||= "") {
 463             # Trim multiple blanks
 464             $cmnt[$_] =~ s/^\n\n+/\n/; $cmnt[$_] =~ s/\n\n+$/\n\n/
 465         }
 466         write;
 467     }
 468     print "\n";
 469
 470     while(<$oldguts>) {
 471         last if /=for regcomp.pl end/;
 472     }
 473     do { print } while <$oldguts>;
 474
 475 })[0];
 476
 477 close_and_rename($guts);