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