regen/embed.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # Regenerate (overwriting only if changed):
   4 #
   5 #    embed.h
   6 #    embedvar.h
   7 #    proto.h
   8 #
   9 # from information stored in
  10 #
  11 #    embed.fnc
  12 #    intrpvar.h
  13 #    perlvars.h
  14 #    regen/opcodes
  15 #
  16 # Accepts the standard regen_lib -q and -v args.
  17 #
  18 # This script is normally invoked from regen.pl.
  19
  20 require 5.004;  # keep this compatible, an old perl is all we may have before
  21                 # we build the new one
  22
  23 use strict;
  24
  25 BEGIN {
  26     # Get function prototypes
  27     require './regen/regen_lib.pl';
  28     require './regen/embed_lib.pl';
  29 }
  30
  31 my $unflagged_pointers;
  32 my @az = ('a'..'z');
  33
  34 #
  35 # See database of global and static function prototypes in embed.fnc
  36 # This is used to generate prototype headers under various configurations,
  37 # export symbols lists for different platforms, and macros to provide an
  38 # implicit interpreter context argument.
  39 #
  40
  41 my $error_count = 0;
  42 sub die_at_end ($) { # Keeps going for now, but makes sure the regen doesn't
  43                      # succeed.
  44     warn shift;
  45     $error_count++;
  46 }
  47
  48 sub full_name ($$) { # Returns the function name with potentially the
  49                      # prefixes 'S_' or 'Perl_'
  50     my ($func, $flags) = @_;
  51
  52     return "Perl_$func" if $flags =~ /[ps]/;
  53     return "S_$func" if $flags =~ /[SIi]/;
  54     return $func;
  55 }
  56
  57 sub open_print_header {
  58     my ($file, $quote) = @_;
  59
  60     return open_new($file, '>',
  61                     { file => $file, style => '*', by => 'regen/embed.pl',
  62                       from => [
  63                                'embed.fnc',
  64                                'intrpvar.h',
  65                                'perlvars.h',
  66                                'regen/opcodes',
  67                                'regen/embed.pl',
  68                                'regen/embed_lib.pl',
  69                                'regen/HeaderParser.pm',
  70                            ],
  71                       final => "\nEdit those files and run 'make regen_headers' to effect changes.\n",
  72                       copyright => [1993 .. 2022],
  73                       quote => $quote });
  74 }
  75
  76
  77 sub open_buf_out {
  78     $_[0] //= "";
  79     open my $fh,">", \$_[0]
  80         or die "Failed to open buffer: $!";
  81     return $fh;
  82 }
  83
  84 # generate proto.h
  85 sub generate_proto_h {
  86     my ($all)= @_;
  87     my $pr = open_buf_out(my $proto_buffer);
  88     my $ret;
  89
  90     foreach (@$all) {
  91         if ($_->{type} ne "content") {
  92             print $pr "$_->{line}";
  93             next;
  94         }
  95         my $embed= $_->{embed}
  96             or next;
  97
  98         my $level= $_->{level};
  99         my $ind= $level ? " " : "";
 100         $ind .= "  " x ($level-1) if $level>1;
 101         my $inner_ind= $ind ? "  " : " ";
 102
 103         my ($flags,$retval,$plain_func,$args) = @{$embed}{qw(flags return_type name args)};
 104         if ($flags =~ / ( [^AabCDdEefFGhIiMmNnOoPpRrSsTUuWXx;] ) /x) {
 105             die_at_end "flag $1 is not legal (for function $plain_func)";
 106         }
 107         my @nonnull;
 108         my $args_assert_line = ( $flags !~ /G/ );
 109         my $has_depth = ( $flags =~ /W/ );
 110         my $has_context = ( $flags !~ /T/ );
 111         my $never_returns = ( $flags =~ /r/ );
 112         my $binarycompat = ( $flags =~ /b/ );
 113         my $commented_out = ( $flags =~ /m/ );
 114         my $is_malloc = ( $flags =~ /a/ );
 115         my $can_ignore = ( $flags !~ /R/ ) && ( $flags !~ /P/ ) && !$is_malloc;
 116         my @names_of_nn;
 117         my $func;
 118
 119         if (! $can_ignore && $retval eq 'void') {
 120             warn "It is nonsensical to require the return value of a void function ($plain_func) to be checked";
 121         }
 122
 123         die_at_end "$plain_func: S and p flags are mutually exclusive"
 124                                             if $flags =~ /S/ && $flags =~ /p/;
 125         die_at_end "$plain_func: m and $1 flags are mutually exclusive"
 126                                         if $flags =~ /m/ && $flags =~ /([pS])/;
 127
 128         die_at_end "$plain_func: u flag only usable with m" if $flags =~ /u/
 129                                                             && $flags !~ /m/;
 130
 131         my $static_inline = 0;
 132         if ($flags =~ /([SsIi])/) {
 133             my $type;
 134             if ($never_returns) {
 135                 $type = {
 136                     'S' => 'PERL_STATIC_NO_RET',
 137                     's' => 'PERL_STATIC_NO_RET',
 138                     'i' => 'PERL_STATIC_INLINE_NO_RET',
 139                     'I' => 'PERL_STATIC_FORCE_INLINE_NO_RET'
 140                 }->{$1};
 141             }
 142             else {
 143                 $type = {
 144                     'S' => 'STATIC',
 145                     's' => 'STATIC',
 146                     'i' => 'PERL_STATIC_INLINE',
 147                     'I' => 'PERL_STATIC_FORCE_INLINE'
 148                 }->{$1};
 149             }
 150             $retval = "$type $retval";
 151             die_at_end "Don't declare static function '$plain_func' pure" if $flags =~ /P/;
 152             $static_inline = $type =~ /^PERL_STATIC(?:_FORCE)?_INLINE/;
 153         }
 154         else {
 155             if ($never_returns) {
 156                 $retval = "PERL_CALLCONV_NO_RET $retval";
 157             }
 158             else {
 159                 $retval = "PERL_CALLCONV $retval";
 160             }
 161         }
 162
 163         $func = full_name($plain_func, $flags);
 164
 165         die_at_end "For '$plain_func', M flag requires p flag"
 166                                             if $flags =~ /M/ && $flags !~ /p/;
 167         my $C_required_flags = '[pIimbs]';
 168         die_at_end
 169             "For '$plain_func', C flag requires one of $C_required_flags] flags"
 170                                                 if $flags =~ /C/
 171                                                 && ($flags !~ /$C_required_flags/
 172
 173                                                    # Notwithstanding the
 174                                                    # above, if the name won't
 175                                                    # clash with a user name,
 176                                                    # it's ok.
 177                                                 && $plain_func !~ /^[Pp]erl/);
 178
 179         die_at_end "For '$plain_func', X flag requires one of [Iip] flags"
 180                                             if $flags =~ /X/ && $flags !~ /[Iip]/;
 181         die_at_end "For '$plain_func', X and m flags are mutually exclusive"
 182                                             if $flags =~ /X/ && $flags =~ /m/;
 183         die_at_end "For '$plain_func', [Ii] with [ACX] requires p flag"
 184                         if $flags =~ /[Ii]/ && $flags =~ /[ACX]/ && $flags !~ /p/;
 185         die_at_end "For '$plain_func', b and m flags are mutually exclusive"
 186                  . " (try M flag)" if $flags =~ /b/ && $flags =~ /m/;
 187         die_at_end "For '$plain_func', b flag without M flag requires D flag"
 188                             if $flags =~ /b/ && $flags !~ /M/ && $flags !~ /D/;
 189         die_at_end "For '$plain_func', I and i flags are mutually exclusive"
 190                                             if $flags =~ /I/ && $flags =~ /i/;
 191
 192         $ret = "";
 193         $ret .= "$retval\n";
 194         $ret .= "$func(";
 195         if ( $has_context ) {
 196             $ret .= @$args ? "pTHX_ " : "pTHX";
 197         }
 198         if (@$args) {
 199             die_at_end "n flag is contradicted by having arguments"
 200                                                                 if $flags =~ /n/;
 201             my $n;
 202             for my $arg ( @$args ) {
 203                 ++$n;
 204                 if ($arg =~ / ^ " (.+) " $ /x) {    # Handle literal string
 205                     my $name = $1;
 206
 207                     # Make the string a legal C identifier; 'p' is arbitrary,
 208                     # and is because C reserves leading underscores
 209                     $name =~ s/^\W/p/a;
 210                     $name =~ s/\W/_/ag;
 211
 212                     $arg = "const char * const $name";
 213                     die_at_end 'm flag required for "literal" argument'
 214                                                             unless $flags =~ /m/;
 215                 }
 216                 elsif (   $args_assert_line
 217                        && $arg =~ /\*/
 218                        && $arg !~ /\b(NN|NULLOK)\b/ )
 219                 {
 220                     warn "$func: $arg needs NN or NULLOK\n";
 221                     ++$unflagged_pointers;
 222                 }
 223                 my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
 224                 push( @nonnull, $n ) if $nn;
 225                 my $nz = ( $arg =~ s/\s*\bNZ\b\s+// );
 226
 227                 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
 228
 229                 # Make sure each arg has at least a type and a var name.
 230                 # An arg of "int" is valid C, but want it to be "int foo".
 231                 my $temp_arg = $arg;
 232                 $temp_arg =~ s/\*//g;
 233                 $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
 234                 if ( ($temp_arg ne "...")
 235                      && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
 236                     die_at_end "$func: $arg ($n) doesn't have a name\n";
 237                 }
 238                 if (defined $1 && ($nn||$nz) && !($commented_out && !$binarycompat)) {
 239                     push @names_of_nn, $1;
 240                 }
 241             }
 242             $ret .= join ", ", @$args;
 243         }
 244         else {
 245             $ret .= "void" if !$has_context;
 246         }
 247         $ret .= " _pDEPTH" if $has_depth;
 248         $ret .= ")";
 249         my @attrs;
 250         if ( $flags =~ /r/ ) {
 251             push @attrs, "__attribute__noreturn__";
 252         }
 253         if ( $flags =~ /D/ ) {
 254             push @attrs, "__attribute__deprecated__";
 255         }
 256         if ( $is_malloc ) {
 257             push @attrs, "__attribute__malloc__";
 258         }
 259         if ( !$can_ignore ) {
 260             push @attrs, "__attribute__warn_unused_result__";
 261         }
 262         if ( $flags =~ /P/ ) {
 263             push @attrs, "__attribute__pure__";
 264         }
 265         if ( $flags =~ /I/ ) {
 266             push @attrs, "__attribute__always_inline__";
 267         }
 268         # roughly the inverse of the rules used in makedef.pl
 269         if ( $flags !~ /[ACeIimSX]/ ) {
 270             push @attrs, '__attribute__visibility__("hidden")'
 271         }
 272         if( $flags =~ /f/ ) {
 273             my $prefix  = $has_context ? 'pTHX_' : '';
 274             my ($argc, $pat);
 275             if (!defined $args->[1]) {
 276                 use Data::Dumper;
 277                 die Dumper($_);
 278             }
 279             if ($args->[-1] eq '...') {
 280                 $argc   = scalar @$args;
 281                 $pat    = $argc - 1;
 282                 $argc   = $prefix . $argc;
 283             }
 284             else {
 285                 # don't check args, and guess which arg is the pattern
 286                 # (one of 'fmt', 'pat', 'f'),
 287                 $argc = 0;
 288                 my @fmts = grep $args->[$_] =~ /\b(f|pat|fmt)$/, 0..$#$args;
 289                 if (@fmts != 1) {
 290                     die "embed.pl: '$plain_func': can't determine pattern arg\n";
 291                 }
 292                 $pat = $fmts[0] + 1;
 293             }
 294             my $macro   = grep($_ == $pat, @nonnull)
 295                                 ? '__attribute__format__'
 296                                 : '__attribute__format__null_ok__';
 297             if ($plain_func =~ /strftime/) {
 298                 push @attrs, sprintf "%s(__strftime__,%s1,0)", $macro, $prefix;
 299             }
 300             else {
 301                 push @attrs, sprintf "%s(__printf__,%s%d,%s)", $macro,
 302                                     $prefix, $pat, $argc;
 303             }
 304         }
 305         elsif ((grep { $_ eq '...' } @$args) && $flags !~ /F/) {
 306             die_at_end "$plain_func: Function with '...' arguments must have"
 307                      . " f or F flag";
 308         }
 309         if ( @attrs ) {
 310             $ret .= "\n";
 311             $ret .= join( "\n", map { (" " x 8) . $_ } @attrs );
 312         }
 313         $ret .= ";";
 314         $ret = "/* $ret */" if $commented_out;
 315
 316         if ($args_assert_line || @names_of_nn) {
 317             $ret .= "\n#${ind}define PERL_ARGS_ASSERT_\U$plain_func\E";
 318             if (@names_of_nn) {
 319                 $ret .= " \\\n";
 320                 my $def = " " x 8;
 321                 foreach my $ix (0..$#names_of_nn) {
 322                     $def .= "assert($names_of_nn[$ix])";
 323                     if ($ix == $#names_of_nn) {
 324                         $def .= "\n";
 325                     } elsif (length $def > 70) {
 326                         $ret .= $def . "; \\\n";
 327                         $def = " " x 8;
 328                     } else {
 329                         $def .= "; ";
 330                     }
 331                 }
 332                 $ret .= $def;
 333             }
 334         }
 335         $ret .= "\n";
 336
 337         $ret = "#${ind}ifndef PERL_NO_INLINE_FUNCTIONS\n$ret\n#${ind}endif"
 338             if $static_inline;
 339         $ret = "#${ind}ifndef NO_MATHOMS\n$ret\n#${ind}endif"
 340             if $binarycompat;
 341
 342         $ret .= @attrs ? "\n\n" : "\n";
 343
 344         print $pr $ret;
 345     }
 346
 347
 348     close $pr;
 349
 350     my $clean= normalize_group_content($proto_buffer);
 351
 352     my $fh = open_print_header("proto.h");
 353     print $fh <<~"EOF";
 354     START_EXTERN_C
 355     $clean
 356     #ifdef PERL_CORE
 357     #  include "pp_proto.h"
 358     #endif
 359     END_EXTERN_C
 360     EOF
 361
 362     read_only_bottom_close_and_rename($fh) if ! $error_count;
 363 }
 364
 365 {
 366     my $hp= HeaderParser->new();
 367     sub normalize_group_content {
 368         open my $in, "<", \$_[0]
 369             or die "Failed to open buffer: $!";
 370         $hp->parse_fh($in);
 371         my $ppc= sub {
 372             my ($self, $line_data)= @_;
 373             # re-align defines so that the definitions line up at the 48th col
 374             # as much as possible.
 375             if ($line_data->{sub_type} eq "#define") {
 376                 $line_data->{line}=~s/^(\s*#\s*define\s+\S+?(?:\([^()]*\))?\s)(\s*)(\S+)/
 377                     sprintf "%-48s%s", $1, $3/e;
 378             }
 379         };
 380         my $clean= $hp->lines_as_str($hp->group_content(),$ppc);
 381         return $clean;
 382     }
 383 }
 384
 385 sub normalize_and_print {
 386     my ($file, $buffer)= @_;
 387     my $fh = open_print_header($file);
 388     print $fh normalize_group_content($buffer);
 389     read_only_bottom_close_and_rename($fh);
 390 }
 391
 392
 393 sub readvars {
 394     my ($file, $pre) = @_;
 395     my $hp= HeaderParser->new()->read_file($file);
 396     my %seen;
 397     foreach my $line_data (@{$hp->lines}) {
 398         #next unless $line_data->is_content;
 399         my $line= $line_data->line;
 400         if ($line=~m/^\s*PERLVARA?I?C?\(\s*$pre\s*,\s*(\w+)/){
 401             $seen{$1}++
 402                 and
 403                 die_at_end "duplicate symbol $1 while processing $file line "
 404                        . ($line_data->start_line_num) . "\n"
 405         }
 406     }
 407     my @keys= sort { lc($a) cmp lc($b) ||
 408                         $a  cmp    $b }
 409               keys %seen;
 410     return @keys;
 411 }
 412
 413 sub add_indent {
 414     #my ($ret, $add, $width)= @_;
 415     my $width= $_[2] || 48;
 416     $_[0] .= " " x ($width-length($_[0])) if length($_[0])<$width;
 417     $_[0] .= " " unless $_[0]=~/\s\z/;
 418     if (defined $_[1]) {
 419         $_[0] .= $_[1];
 420     }
 421     return $_[0];
 422 }
 423
 424 sub indent_define {
 425     my ($from, $to, $indent, $width) = @_;
 426     $indent = '' unless defined $indent;
 427     my $ret= "#${indent}define $from";
 428     add_indent($ret,"$to\n",$width);
 429 }
 430
 431 sub multon {
 432     my ($sym,$pre,$ptr,$ind) = @_;
 433     $ind//="";
 434     indent_define("PL_$sym", "($ptr$pre$sym)", $ind);
 435 }
 436
 437 sub embed_h {
 438     my ($em, $guard, $funcs) = @_;
 439
 440     my $lines;
 441     foreach (@$funcs) {
 442         if ($_->{type} ne "content") {
 443             $lines .= $_->{line};
 444             next;
 445         }
 446         my $level= $_->{level};
 447         my $embed= $_->{embed} or next;
 448         my ($flags,$retval,$func,$args) = @{$embed}{qw(flags return_type name args)};
 449         my $ret = "";
 450         my $ind= $level ? " " : "";
 451         $ind .= "  " x ($level-1) if $level>1;
 452         my $inner_ind= $ind ? "  " : " ";
 453         unless ($flags =~ /[omM]/) {
 454             my $argc = scalar @$args;
 455             if ($flags =~ /T/) {
 456                 my $full_name = full_name($func, $flags);
 457                 next if $full_name eq $func;    # Don't output a no-op.
 458                 $ret = indent_define($func, $full_name, $ind);
 459             }
 460             else {
 461                 my $use_va_list = $argc && $args->[-1] =~ /\.\.\./;
 462
 463                 if($use_va_list) {
 464                     # CPP has trouble with empty __VA_ARGS__ and comma joining,
 465                     # so we'll have to eat an extra params here.
 466                     if($argc < 2) {
 467                         die "Cannot use ... as the only parameter to a macro ($func)\n";
 468                     }
 469                     $argc -= 2;
 470                 }
 471
 472                 my $paramlist   = join(",", @az[0..$argc-1],
 473                     $use_va_list ? ("...") : ());
 474                 my $replacelist = join(",", @az[0..$argc-1],
 475                     $use_va_list ? ("__VA_ARGS__") : ());
 476                 $ret = "#${ind}define $func($paramlist) ";
 477                 add_indent($ret,full_name($func, $flags) . "(aTHX");
 478                 $ret .= "_ " if $replacelist;
 479                 $ret .= $replacelist;
 480                 if ($flags =~ /W/) {
 481                     if ($replacelist) {
 482                         $ret .= " _aDEPTH";
 483                     } else {
 484                         die "Can't use W without other args (currently)";
 485                     }
 486                 }
 487                 $ret .= ")\n";
 488                 if($use_va_list) {
 489                     # Make them available to !MULTIPLICITY or PERL_CORE
 490                     $ret = "#${ind}if !defined(MULTIPLICITY) || defined(PERL_CORE)\n" .
 491                            $ret .
 492                            "#${ind}endif\n";
 493                 }
 494             }
 495             $ret = "#${ind}ifndef NO_MATHOMS\n$ret#${ind}endif\n" if $flags =~ /b/;
 496         }
 497         $lines .= $ret;
 498     }
 499     # remove empty blocks
 500     1 while $lines =~ s/^#\s*if.*\n#\s*endif.*\n//mg
 501          or $lines =~ s/^(#\s*if)\s+(.*)\n#else.*\n/$1 !($2)\n/mg;
 502     if ($guard) {
 503         print $em "$guard /* guard */\n";
 504         $lines=~s/^#(\s*)/"#".(length($1)?"  ":" ").$1/mge;
 505     }
 506     print $em $lines;
 507     print $em "#endif\n" if $guard;
 508 }
 509
 510 sub generate_embed_h {
 511     my ($all, $api, $ext, $core)= @_;
 512
 513     my $em= open_buf_out(my $embed_buffer);
 514
 515     print $em <<~'END';
 516     /* (Doing namespace management portably in C is really gross.) */
 517
 518     /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
 519      * (like warn instead of Perl_warn) for the API are not defined.
 520      * Not defining the short forms is a good thing for cleaner embedding.
 521      * BEWARE that a bunch of macros don't have long names, so either must be
 522      * added or don't use them if you define this symbol */
 523
 524     #ifndef PERL_NO_SHORT_NAMES
 525
 526     /* Hide global symbols */
 527
 528     END
 529
 530     embed_h($em, '', $api);
 531     embed_h($em, '#if defined(PERL_CORE) || defined(PERL_EXT)', $ext);
 532     embed_h($em, '#if defined(PERL_CORE)', $core);
 533
 534     print $em <<~'END';
 535
 536     #endif      /* #ifndef PERL_NO_SHORT_NAMES */
 537
 538     #if !defined(PERL_CORE)
 539     /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
 540      * disable them.
 541      */
 542     #  define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
 543     #  define sv_setptrref(rv,ptr)              sv_setref_iv(rv,NULL,PTR2IV(ptr))
 544     #endif
 545
 546     #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
 547
 548     /* Compatibility for various misnamed functions.  All functions
 549        in the API that begin with "perl_" (not "Perl_") take an explicit
 550        interpreter context pointer.
 551        The following are not like that, but since they had a "perl_"
 552        prefix in previous versions, we provide compatibility macros.
 553      */
 554     #  define perl_atexit(a,b)          call_atexit(a,b)
 555     END
 556
 557     foreach (@$all) {
 558         my $embed= $_->{embed} or next;
 559         my ($flags, $retval, $func, $args) = @{$embed}{qw(flags return_type name args)};
 560         next unless $flags =~ /O/;
 561
 562         my $alist = join ",", @az[0..$#$args];
 563         my $ret = "#  define perl_$func($alist) ";
 564         print $em add_indent($ret,"$func($alist)\n");
 565     }
 566
 567     my @nocontext;
 568     {
 569         my (%has_va, %has_nocontext);
 570         foreach (@$all) {
 571             my $embed= $_->{embed}
 572                 or next;
 573             ++$has_va{$embed->{name}} if @{$embed->{args}} and $embed->{args}[-1] =~ /\.\.\./;
 574             ++$has_nocontext{$1} if $embed->{name} =~ /(.*)_nocontext/;
 575         }
 576
 577         @nocontext = sort grep {
 578             $has_nocontext{$_}
 579                 && !/printf/ # Not clear to me why these are skipped but they are.
 580         } keys %has_va;
 581     }
 582
 583     print $em <<~'END';
 584
 585     /* varargs functions can't be handled with CPP macros. :-(
 586        This provides a set of compatibility functions that don't take
 587        an extra argument but grab the context pointer using the macro
 588        dTHX.
 589      */
 590     #if defined(MULTIPLICITY) && !defined(PERL_NO_SHORT_NAMES)
 591     END
 592
 593     foreach (@nocontext) {
 594         print $em indent_define($_, "Perl_${_}_nocontext", "  ");
 595     }
 596
 597     print $em <<~'END';
 598     #endif
 599
 600     #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
 601
 602     #if !defined(MULTIPLICITY)
 603     /* undefined symbols, point them back at the usual ones */
 604     END
 605
 606     foreach (@nocontext) {
 607         print $em indent_define("Perl_${_}_nocontext", "Perl_$_", "  ");
 608     }
 609
 610     print $em "#endif\n";
 611     close $em;
 612
 613     normalize_and_print('embed.h',$embed_buffer)
 614         unless $error_count;
 615 }
 616
 617 sub generate_embedvar_h {
 618     my $em = open_buf_out(my $embedvar_buffer);
 619
 620     print $em "#if defined(MULTIPLICITY)\n",
 621               indent_define("vTHX","aTHX"," ");
 622
 623
 624     my @intrp = readvars 'intrpvar.h','I';
 625     #my @globvar = readvars 'perlvars.h','G';
 626
 627
 628     for my $sym (@intrp) {
 629         my $ind = " ";
 630         if ($sym eq 'sawampersand') {
 631             print $em "# if !defined(PL_sawampersand)\n";
 632             $ind = "   ";
 633         }
 634         my $line = multon($sym, 'I', 'vTHX->', $ind);
 635         print $em $line;
 636         if ($sym eq 'sawampersand') {
 637             print $em "# endif /* !defined(PL_sawampersand) */\n";
 638         }
 639     }
 640
 641     print $em "#endif       /* MULTIPLICITY */\n";
 642     close $em;
 643
 644     normalize_and_print('embedvar.h',$embedvar_buffer)
 645         unless $error_count;
 646 }
 647
 648 sub update_headers {
 649     my ($all, $api, $ext, $core) = setup_embed(); # see regen/embed_lib.pl
 650     generate_proto_h($all);
 651     die_at_end "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
 652     generate_embed_h($all, $api, $ext, $core);
 653     generate_embedvar_h();
 654     die "$error_count errors found" if $error_count;
 655 }
 656
 657 update_headers() unless caller;
 658
 659 # ex: set ts=8 sts=4 sw=4 noet: