regen/embed.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # Regenerate (overwriting only if changed):
   4 #
   5 #    embed.h
   6 #    embedvar.h
   7 #    global.sym
   8 #    perlapi.c
   9 #    perlapi.h
  10 #    proto.h
  11 #
  12 # from information stored in
  13 #
  14 #    embed.fnc
  15 #    intrpvar.h
  16 #    perlvars.h
  17 #    regen/opcodes
  18 #
  19 # Accepts the standard regen_lib -q and -v args.
  20 #
  21 # This script is normally invoked from regen.pl.
  22
  23 require 5.004;  # keep this compatible, an old perl is all we may have before
  24                 # we build the new one
  25
  26 use strict;
  27
  28 BEGIN {
  29     # Get function prototypes
  30     require 'regen/regen_lib.pl';
  31 }
  32
  33 my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org
  34 my $unflagged_pointers;
  35
  36 #
  37 # See database of global and static function prototypes in embed.fnc
  38 # This is used to generate prototype headers under various configurations,
  39 # export symbols lists for different platforms, and macros to provide an
  40 # implicit interpreter context argument.
  41 #
  42
  43 sub do_not_edit ($)
  44 {
  45     my $file = shift;
  46
  47     my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009';
  48
  49     $years =~ s/1999,/1999,\n  / if length $years > 40;
  50
  51     my $warning = <<EOW;
  52  -*- buffer-read-only: t -*-
  53
  54    $file
  55
  56    Copyright (C) $years, by Larry Wall and others
  57
  58    You may distribute under the terms of either the GNU General Public
  59    License or the Artistic License, as specified in the README file.
  60
  61 !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  62 This file is built by regen/embed.pl from data in embed.fnc,
  63 regen/embed.pl, regen/opcodes intrpvar.h, and perlvars.h.
  64 Any changes made here will be lost!
  65
  66 Edit those files and run 'make regen_headers' to effect changes.
  67
  68 EOW
  69
  70     $warning .= <<EOW if $file eq 'perlapi.c';
  71
  72 Up to the threshold of the door there mounted a flight of twenty-seven
  73 broad stairs, hewn by some unknown art of the same black stone.  This
  74 was the only entrance to the tower; ...
  75
  76     [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
  77
  78
  79 EOW
  80
  81     if ($file =~ m:\.[ch]$:) {
  82         $warning =~ s:^: * :gm;
  83         $warning =~ s: +$::gm;
  84         $warning =~ s: :/:;
  85         $warning =~ s:$:/:;
  86     }
  87     else {
  88         $warning =~ s:^:# :gm;
  89         $warning =~ s: +$::gm;
  90     }
  91     $warning;
  92 } # do_not_edit
  93
  94 open IN, "embed.fnc" or die $!;
  95
  96 my @embed;
  97 my (%has_va, %has_nocontext);
  98
  99 while (<IN>) {
 100     chomp;
 101     next if /^:/;
 102     next if /^$/;
 103     while (s|\\$||) {
 104         $_ .= <IN>;
 105         chomp;
 106     }
 107     s/\s+$//;
 108     my @args;
 109     if (/^\s*(#|$)/) {
 110         @args = $_;
 111     }
 112     else {
 113         @args = split /\s*\|\s*/, $_;
 114         my $func = $args[2];
 115         if ($func) {
 116             ++$has_va{$func} if $args[-1] =~ /\.\.\./;
 117             ++$has_nocontext{$1} if $func =~ /(.*)_nocontext/;
 118         }
 119     }
 120     if (@args == 1 && $args[0] !~ /^#\s*(?:if|ifdef|ifndef|else|endif)/) {
 121         die "Illegal line $. '$args[0]' in embed.fnc";
 122     }
 123     push @embed, \@args;
 124 }
 125
 126 open IN, 'regen/opcodes' or die $!;
 127 {
 128     my %syms;
 129
 130     while (<IN>) {
 131         chop;
 132         next unless $_;
 133         next if /^#/;
 134         my (undef, undef, $check) = split /\t+/, $_;
 135         ++$syms{$check};
 136     }
 137
 138     foreach (keys %syms) {
 139         # These are all indirectly referenced by globals.c.
 140         push @embed, ['pR', 'OP *', $_, 'NN OP *o'];
 141     }
 142 }
 143 close IN;
 144
 145 my (@core, @ext, @api);
 146 {
 147     # Cluster entries in embed.fnc that have the same #ifdef guards.
 148     # Also, split out at the top level the three classes of functions.
 149     my @state;
 150     my %groups;
 151     my $current;
 152     foreach (@embed) {
 153         if (@$_ > 1) {
 154             push @$current, $_;
 155             next;
 156         }
 157         $_->[0] =~ s/^#\s+/#/;
 158         $_->[0] =~ /^\S*/;
 159         $_->[0] =~ s/^#ifdef\s+(\S+)/#if defined($1)/;
 160         $_->[0] =~ s/^#ifndef\s+(\S+)/#if !defined($1)/;
 161         if ($_->[0] =~ /^#if\s*(.*)/) {
 162             push @state, $1;
 163         } elsif ($_->[0] =~ /^#else\s*$/) {
 164             die "Unmatched #else in embed.fnc" unless @state;
 165             $state[-1] = "!($state[-1])";
 166         } elsif ($_->[0] =~ m!^#endif\s*(?:/\*.*\*/)?$!) {
 167             die "Unmatched #endif in embed.fnc" unless @state;
 168             pop @state;
 169         } else {
 170             die "Unhandled pre-processor directive '$_->[0]' in embed.fnc";
 171         }
 172         $current = \%groups;
 173         # Nested #if blocks are effectively &&ed together
 174         # For embed.fnc, ordering withing the && isn't relevant, so we can
 175         # sort them to try to group more functions together.
 176         my @sorted = sort @state;
 177         while (my $directive = shift @sorted) {
 178             $current->{$directive} ||= {};
 179             $current = $current->{$directive};
 180         }
 181         $current->{''} ||= [];
 182         $current = $current->{''};
 183     }
 184
 185     sub add_level {
 186         my ($level, $indent, $wanted) = @_;
 187         my $funcs = $level->{''};
 188         my @entries;
 189         if ($funcs) {
 190             if (!defined $wanted) {
 191                 @entries = @$funcs;
 192             } else {
 193                 foreach (@$funcs) {
 194                     if ($_->[0] =~ /A/) {
 195                         push @entries, $_ if $wanted eq 'A';
 196                     } elsif ($_->[0] =~ /E/) {
 197                         push @entries, $_ if $wanted eq 'E';
 198                     } else {
 199                         push @entries, $_ if $wanted eq '';
 200                     }
 201                 }
 202             }
 203             @entries = sort {$a->[2] cmp $b->[2]} @entries;
 204         }
 205         foreach (sort grep {length $_} keys %$level) {
 206             my @conditional = add_level($level->{$_}, $indent . '  ', $wanted);
 207             push @entries,
 208                 ["#${indent}if $_"], @conditional, ["#${indent}endif"]
 209                     if @conditional;
 210         }
 211         return @entries;
 212     }
 213     @core = add_level(\%groups, '', '');
 214     @ext = add_level(\%groups, '', 'E');
 215     @api = add_level(\%groups, '', 'A');
 216
 217     @embed = add_level(\%groups, '');
 218 }
 219
 220 # walk table providing an array of components in each line to
 221 # subroutine, printing the result
 222 sub walk_table (&@) {
 223     my ($function, $filename, $trailer) = @_;
 224     my $F;
 225     if (ref $filename) {        # filehandle
 226         $F = $filename;
 227     }
 228     else {
 229         $F = safer_open("$filename-new");
 230         print $F do_not_edit ($filename);
 231     }
 232     foreach (@embed) {
 233         my @outs = &{$function}(@$_);
 234         # $function->(@args) is not 5.003
 235         print $F @outs;
 236     }
 237     print $F $trailer if $trailer;
 238     unless (ref $filename) {
 239         safer_close($F);
 240         rename_if_different("$filename-new", $filename);
 241     }
 242 }
 243
 244 # generate proto.h
 245 {
 246     my $pr = safer_open('proto.h-new');
 247     print $pr do_not_edit ("proto.h"), "\nSTART_EXTERN_C\n";
 248     my $ret;
 249
 250     foreach (@embed) {
 251         if (@$_ == 1) {
 252             print $pr "$_->[0]\n";
 253             next;
 254         }
 255
 256         my ($flags,$retval,$plain_func,@args) = @$_;
 257         my @nonnull;
 258         my $has_context = ( $flags !~ /n/ );
 259         my $never_returns = ( $flags =~ /r/ );
 260         my $commented_out = ( $flags =~ /m/ );
 261         my $binarycompat = ( $flags =~ /b/ );
 262         my $is_malloc = ( $flags =~ /a/ );
 263         my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
 264         my @names_of_nn;
 265         my $func;
 266
 267         my $splint_flags = "";
 268         if ( $SPLINT && !$commented_out ) {
 269             $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
 270             if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
 271                 $retval .= " /*\@alt void\@*/";
 272             }
 273         }
 274
 275         if ($flags =~ /s/) {
 276             $retval = "STATIC $splint_flags$retval";
 277             $func = "S_$plain_func";
 278         }
 279         else {
 280             $retval = "PERL_CALLCONV $splint_flags$retval";
 281             if ($flags =~ /[bp]/) {
 282                 $func = "Perl_$plain_func";
 283             } else {
 284                 $func = $plain_func;
 285             }
 286         }
 287         $ret = "$retval\t$func(";
 288         if ( $has_context ) {
 289             $ret .= @args ? "pTHX_ " : "pTHX";
 290         }
 291         if (@args) {
 292             my $n;
 293             for my $arg ( @args ) {
 294                 ++$n;
 295                 if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
 296                     warn "$func: $arg needs NN or NULLOK\n";
 297                     ++$unflagged_pointers;
 298                 }
 299                 my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
 300                 push( @nonnull, $n ) if $nn;
 301
 302                 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
 303
 304                 # Make sure each arg has at least a type and a var name.
 305                 # An arg of "int" is valid C, but want it to be "int foo".
 306                 my $temp_arg = $arg;
 307                 $temp_arg =~ s/\*//g;
 308                 $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
 309                 if ( ($temp_arg ne "...")
 310                      && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
 311                     warn "$func: $arg ($n) doesn't have a name\n";
 312                 }
 313                 if ( $SPLINT && $nullok && !$commented_out ) {
 314                     $arg = '/*@null@*/ ' . $arg;
 315                 }
 316                 if (defined $1 && $nn && !($commented_out && !$binarycompat)) {
 317                     push @names_of_nn, $1;
 318                 }
 319             }
 320             $ret .= join ", ", @args;
 321         }
 322         else {
 323             $ret .= "void" if !$has_context;
 324         }
 325         $ret .= ")";
 326         my @attrs;
 327         if ( $flags =~ /r/ ) {
 328             push @attrs, "__attribute__noreturn__";
 329         }
 330         if ( $flags =~ /D/ ) {
 331             push @attrs, "__attribute__deprecated__";
 332         }
 333         if ( $is_malloc ) {
 334             push @attrs, "__attribute__malloc__";
 335         }
 336         if ( !$can_ignore ) {
 337             push @attrs, "__attribute__warn_unused_result__";
 338         }
 339         if ( $flags =~ /P/ ) {
 340             push @attrs, "__attribute__pure__";
 341         }
 342         if( $flags =~ /f/ ) {
 343             my $prefix  = $has_context ? 'pTHX_' : '';
 344             my $args    = scalar @args;
 345             my $pat     = $args - 1;
 346             my $macro   = @nonnull && $nonnull[-1] == $pat
 347                                 ? '__attribute__format__'
 348                                 : '__attribute__format__null_ok__';
 349             push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
 350                                 $prefix, $pat, $prefix, $args;
 351         }
 352         if ( @nonnull ) {
 353             my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
 354             push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
 355         }
 356         if ( @attrs ) {
 357             $ret .= "\n";
 358             $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
 359         }
 360         $ret .= ";";
 361         $ret = "/* $ret */" if $commented_out;
 362         if (@names_of_nn) {
 363             $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
 364                 . join '; ', map "assert($_)", @names_of_nn;
 365         }
 366         $ret .= @attrs ? "\n\n" : "\n";
 367
 368         print $pr $ret;
 369     }
 370
 371     print $pr <<'EOF';
 372 #ifdef PERL_CORE
 373 #  include "pp_proto.h"
 374 #endif
 375 END_EXTERN_C
 376 /* ex: set ro: */
 377 EOF
 378
 379     safer_close($pr);
 380     rename_if_different('proto.h-new', 'proto.h');
 381 }
 382
 383 # generates global.sym (API export list)
 384 {
 385   my %seen;
 386   sub write_global_sym {
 387       if (@_ > 1) {
 388           my ($flags,$retval,$func,@args) = @_;
 389           if ($flags =~ /[AX]/ && $flags !~ /[xm]/
 390               || $flags =~ /b/) { # public API, so export
 391               # If a function is defined twice, for example before and after
 392               # an #else, only export its name once.
 393               return '' if $seen{$func}++;
 394               $func = "Perl_$func" if $flags =~ /[pbX]/;
 395               return "$func\n";
 396           }
 397       }
 398       return '';
 399   }
 400 }
 401
 402 warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
 403 walk_table(\&write_global_sym, "global.sym", "# ex: set ro:\n");
 404
 405 sub readvars(\%$$@) {
 406     my ($syms, $file,$pre,$keep_pre) = @_;
 407     local (*FILE, $_);
 408     open(FILE, "< $file")
 409         or die "embed.pl: Can't open $file: $!\n";
 410     while (<FILE>) {
 411         s/[ \t]*#.*//;          # Delete comments.
 412         if (/PERLVARA?I?S?C?\($pre(\w+)/) {
 413             my $sym = $1;
 414             $sym = $pre . $sym if $keep_pre;
 415             warn "duplicate symbol $sym while processing $file line $.\n"
 416                 if exists $$syms{$sym};
 417             $$syms{$sym} = $pre || 1;
 418         }
 419     }
 420     close(FILE);
 421 }
 422
 423 my %intrp;
 424 my %globvar;
 425
 426 readvars %intrp,  'intrpvar.h','I';
 427 readvars %globvar, 'perlvars.h','G';
 428
 429 my $sym;
 430
 431 sub undefine ($) {
 432     my ($sym) = @_;
 433     "#undef  $sym\n";
 434 }
 435
 436 sub hide {
 437     my ($from, $to, $indent) = @_;
 438     $indent = '' unless defined $indent;
 439     my $t = int(length("$indent$from") / 8);
 440     "#${indent}define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
 441 }
 442
 443 sub bincompat_var ($$) {
 444     my ($pfx, $sym) = @_;
 445     my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
 446     undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
 447 }
 448
 449 sub multon ($$$) {
 450     my ($sym,$pre,$ptr) = @_;
 451     hide("PL_$sym", "($ptr$pre$sym)");
 452 }
 453
 454 sub multoff ($$) {
 455     my ($sym,$pre) = @_;
 456     return hide("PL_$pre$sym", "PL_$sym");
 457 }
 458
 459 my $em = safer_open('embed.h-new');
 460
 461 print $em do_not_edit ("embed.h"), <<'END';
 462
 463 /* (Doing namespace management portably in C is really gross.) */
 464
 465 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
 466  * (like warn instead of Perl_warn) for the API are not defined.
 467  * Not defining the short forms is a good thing for cleaner embedding. */
 468
 469 #ifndef PERL_NO_SHORT_NAMES
 470
 471 /* Hide global symbols */
 472
 473 END
 474
 475 my @az = ('a'..'z');
 476
 477 sub embed_h {
 478     my ($guard, $funcs) = @_;
 479     print $em "$guard\n" if $guard;
 480
 481     my $lines;
 482     foreach (@$funcs) {
 483         if (@$_ == 1) {
 484             my $cond = $_->[0];
 485             # Indent the conditionals if we are wrapped in an #if/#endif pair.
 486             $cond =~ s/#(.*)/#  $1/ if $guard;
 487             $lines .= "$cond\n";
 488             next;
 489         }
 490         my $ret = "";
 491         my ($flags,$retval,$func,@args) = @$_;
 492         unless ($flags =~ /[om]/) {
 493             my $args = scalar @args;
 494             if ($flags =~ /n/) {
 495                 if ($flags =~ /s/) {
 496                     $ret = hide($func,"S_$func");
 497                 }
 498                 elsif ($flags =~ /p/) {
 499                     $ret = hide($func,"Perl_$func");
 500                 }
 501             }
 502             elsif ($args and $args[$args-1] =~ /\.\.\./) {
 503                 if ($flags =~ /p/) {
 504                     # we're out of luck for varargs functions under CPP
 505                     # So we can only do these macros for no implicit context:
 506                     $ret = "#ifndef PERL_IMPLICIT_CONTEXT\n"
 507                         . hide($func,"Perl_$func") . "#endif\n";
 508                 }
 509             }
 510             else {
 511                 my $alist = join(",", @az[0..$args-1]);
 512                 $ret = "#define $func($alist)";
 513                 my $t = int(length($ret) / 8);
 514                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
 515                 if ($flags =~ /s/) {
 516                     $ret .= "S_$func(aTHX";
 517                 }
 518                 elsif ($flags =~ /p/) {
 519                     $ret .= "Perl_$func(aTHX";
 520                 }
 521                 $ret .= "_ " if $alist;
 522                 $ret .= $alist . ")\n";
 523             }
 524         }
 525         $lines .= $ret;
 526     }
 527     # Prune empty #if/#endif pairs.
 528     while ($lines =~ s/#\s*if[^\n]+\n#\s*endif\n//) {
 529     }
 530     # Merge adjacent blocks.
 531     while ($lines =~ s/(#ifndef PERL_IMPLICIT_CONTEXT
 532 [^\n]+
 533 )#endif
 534 #ifndef PERL_IMPLICIT_CONTEXT
 535 /$1/) {
 536     }
 537
 538     print $em $lines;
 539     print $em "#endif\n" if $guard;
 540 }
 541
 542 embed_h('', \@api);
 543 embed_h('#if defined(PERL_CORE) || defined(PERL_EXT)', \@ext);
 544 embed_h('#ifdef PERL_CORE', \@core);
 545
 546 print $em <<'END';
 547
 548 #endif  /* #ifndef PERL_NO_SHORT_NAMES */
 549
 550 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
 551    disable them.
 552  */
 553
 554 #if !defined(PERL_CORE)
 555 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
 556 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,NULL,PTR2IV(ptr))
 557 #endif
 558
 559 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
 560
 561 /* Compatibility for various misnamed functions.  All functions
 562    in the API that begin with "perl_" (not "Perl_") take an explicit
 563    interpreter context pointer.
 564    The following are not like that, but since they had a "perl_"
 565    prefix in previous versions, we provide compatibility macros.
 566  */
 567 #  define perl_atexit(a,b)              call_atexit(a,b)
 568 END
 569
 570 walk_table {
 571     my ($flags,$retval,$func,@args) = @_;
 572     return unless $func;
 573     return unless $flags =~ /O/;
 574
 575     my $alist = join ",", @az[0..$#args];
 576     my $ret = "#  define perl_$func($alist)";
 577     my $t = (length $ret) >> 3;
 578     $ret .=  "\t" x ($t < 5 ? 5 - $t : 1);
 579     "$ret$func($alist)\n";
 580 } $em;
 581
 582 print $em <<'END';
 583
 584 /* varargs functions can't be handled with CPP macros. :-(
 585    This provides a set of compatibility functions that don't take
 586    an extra argument but grab the context pointer using the macro
 587    dTHX.
 588  */
 589 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
 590 END
 591
 592 foreach (sort keys %has_va) {
 593     next unless $has_nocontext{$_};
 594     next if /printf/; # Not clear to me why these are skipped but they are.
 595     print $em hide($_, "Perl_${_}_nocontext", "  ");
 596 }
 597
 598 print $em <<'END';
 599 #endif
 600
 601 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
 602
 603 #if !defined(PERL_IMPLICIT_CONTEXT)
 604 /* undefined symbols, point them back at the usual ones */
 605 END
 606
 607 foreach (sort keys %has_va) {
 608     next unless $has_nocontext{$_};
 609     next if /printf/; # Not clear to me why these are skipped but they are.
 610     print $em hide("Perl_${_}_nocontext", "Perl_$_", "  ");
 611 }
 612
 613 print $em <<'END';
 614 #endif
 615
 616 /* ex: set ro: */
 617 END
 618
 619 safer_close($em);
 620 rename_if_different('embed.h-new', 'embed.h');
 621
 622 $em = safer_open('embedvar.h-new');
 623
 624 print $em do_not_edit ("embedvar.h"), <<'END';
 625
 626 /* (Doing namespace management portably in C is really gross.) */
 627
 628 /*
 629    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
 630    are supported:
 631      1) none
 632      2) MULTIPLICITY    # supported for compatibility
 633      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
 634
 635    All other combinations of these flags are errors.
 636
 637    only #3 is supported directly, while #2 is a special
 638    case of #3 (supported by redefining vTHX appropriately).
 639 */
 640
 641 #if defined(MULTIPLICITY)
 642 /* cases 2 and 3 above */
 643
 644 #  if defined(PERL_IMPLICIT_CONTEXT)
 645 #    define vTHX        aTHX
 646 #  else
 647 #    define vTHX        PERL_GET_INTERP
 648 #  endif
 649
 650 END
 651
 652 for $sym (sort keys %intrp) {
 653     print $em multon($sym,'I','vTHX->');
 654 }
 655
 656 print $em <<'END';
 657
 658 #else   /* !MULTIPLICITY */
 659
 660 /* case 1 above */
 661
 662 END
 663
 664 for $sym (sort keys %intrp) {
 665     print $em multoff($sym,'I');
 666 }
 667
 668 print $em <<'END';
 669
 670 END
 671
 672 print $em <<'END';
 673
 674 #endif  /* MULTIPLICITY */
 675
 676 #if defined(PERL_GLOBAL_STRUCT)
 677
 678 END
 679
 680 for $sym (sort keys %globvar) {
 681     print $em multon($sym,   'G','my_vars->');
 682     print $em multon("G$sym",'', 'my_vars->');
 683 }
 684
 685 print $em <<'END';
 686
 687 #else /* !PERL_GLOBAL_STRUCT */
 688
 689 END
 690
 691 for $sym (sort keys %globvar) {
 692     print $em multoff($sym,'G');
 693 }
 694
 695 print $em <<'END';
 696
 697 #endif /* PERL_GLOBAL_STRUCT */
 698
 699 /* ex: set ro: */
 700 END
 701
 702 safer_close($em);
 703 rename_if_different('embedvar.h-new', 'embedvar.h');
 704
 705 my $capi = safer_open('perlapi.c-new');
 706 my $capih = safer_open('perlapi.h-new');
 707
 708 print $capih do_not_edit ("perlapi.h"), <<'EOT';
 709
 710 /* declare accessor functions for Perl variables */
 711 #ifndef __perlapi_h__
 712 #define __perlapi_h__
 713
 714 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
 715
 716 START_EXTERN_C
 717
 718 #undef PERLVAR
 719 #undef PERLVARA
 720 #undef PERLVARI
 721 #undef PERLVARIC
 722 #undef PERLVARISC
 723 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
 724 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
 725                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 726 #define PERLVARI(v,t,i) PERLVAR(v,t)
 727 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 728 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)];       \
 729                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 730
 731 #include "perlvars.h"
 732
 733 #undef PERLVAR
 734 #undef PERLVARA
 735 #undef PERLVARI
 736 #undef PERLVARIC
 737 #undef PERLVARISC
 738
 739 END_EXTERN_C
 740
 741 #if defined(PERL_CORE)
 742
 743 /* accessor functions for Perl "global" variables */
 744
 745 /* these need to be mentioned here, or most linkers won't put them in
 746    the perl executable */
 747
 748 #ifndef PERL_NO_FORCE_LINK
 749
 750 START_EXTERN_C
 751
 752 #ifndef DOINIT
 753 EXTCONST void * const PL_force_link_funcs[];
 754 #else
 755 EXTCONST void * const PL_force_link_funcs[] = {
 756 #undef PERLVAR
 757 #undef PERLVARA
 758 #undef PERLVARI
 759 #undef PERLVARIC
 760 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
 761 #define PERLVARA(v,n,t) PERLVAR(v,t)
 762 #define PERLVARI(v,t,i) PERLVAR(v,t)
 763 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 764 #define PERLVARISC(v,i) PERLVAR(v,char)
 765
 766 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
 767  * cannot cast between void pointers and function pointers without
 768  * info level warnings.  The PL_force_link_funcs[] would cause a few
 769  * hundred of those warnings.  In code one can circumnavigate this by using
 770  * unions that overlay the different pointers, but in declarations one
 771  * cannot use this trick.  Therefore we just disable the warning here
 772  * for the duration of the PL_force_link_funcs[] declaration. */
 773
 774 #if defined(__DECC) && defined(__osf__)
 775 #pragma message save
 776 #pragma message disable (nonstandcast)
 777 #endif
 778
 779 #include "perlvars.h"
 780
 781 #if defined(__DECC) && defined(__osf__)
 782 #pragma message restore
 783 #endif
 784
 785 #undef PERLVAR
 786 #undef PERLVARA
 787 #undef PERLVARI
 788 #undef PERLVARIC
 789 #undef PERLVARISC
 790 };
 791 #endif  /* DOINIT */
 792
 793 END_EXTERN_C
 794
 795 #endif  /* PERL_NO_FORCE_LINK */
 796
 797 #else   /* !PERL_CORE */
 798
 799 EOT
 800
 801 foreach $sym (sort keys %globvar) {
 802     print $capih bincompat_var('G',$sym);
 803 }
 804
 805 print $capih <<'EOT';
 806
 807 #endif /* !PERL_CORE */
 808 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
 809
 810 #endif /* __perlapi_h__ */
 811
 812 /* ex: set ro: */
 813 EOT
 814 safer_close($capih);
 815 rename_if_different('perlapi.h-new', 'perlapi.h');
 816
 817 print $capi do_not_edit ("perlapi.c"), <<'EOT';
 818
 819 #include "EXTERN.h"
 820 #include "perl.h"
 821 #include "perlapi.h"
 822
 823 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
 824
 825 /* accessor functions for Perl "global" variables */
 826 START_EXTERN_C
 827
 828 #undef PERLVARI
 829 #define PERLVARI(v,t,i) PERLVAR(v,t)
 830
 831 #undef PERLVAR
 832 #undef PERLVARA
 833 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 834                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 835 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 836                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 837 #undef PERLVARIC
 838 #undef PERLVARISC
 839 #define PERLVARIC(v,t,i)        \
 840                         const t* Perl_##v##_ptr(pTHX)           \
 841                         { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
 842 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)        \
 843                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 844 #include "perlvars.h"
 845
 846 #undef PERLVAR
 847 #undef PERLVARA
 848 #undef PERLVARI
 849 #undef PERLVARIC
 850 #undef PERLVARISC
 851
 852 END_EXTERN_C
 853
 854 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
 855
 856 /* ex: set ro: */
 857 EOT
 858
 859 safer_close($capi);
 860 rename_if_different('perlapi.c-new', 'perlapi.c');
 861
 862 # ex: set ts=8 sts=4 sw=4 noet: