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