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