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 END
 383
 384 # Try to elimiate lots of repeated
 385 # #ifdef PERL_CORE
 386 # foo
 387 # #endif
 388 # #ifdef PERL_CORE
 389 # bar
 390 # #endif
 391 # by tracking state and merging foo and bar into one block.
 392 my $ifdef_state = '';
 393
 394 my @az = ('a'..'z');
 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             my $args = scalar @args;
 407             if ($flags =~ /n/) {
 408                 if ($flags =~ /s/) {
 409                     $ret = hide($func,"S_$func");
 410                 }
 411                 elsif ($flags =~ /p/) {
 412                     $ret = hide($func,"Perl_$func");
 413                 }
 414             }
 415             elsif ($args and $args[$args-1] =~ /\.\.\./) {
 416                 if ($flags =~ /p/) {
 417                     # we're out of luck for varargs functions under CPP
 418                     # So we can only do these macros for no implicit context:
 419                     $ret = "#ifndef PERL_IMPLICIT_CONTEXT\n"
 420                         . hide($func,"Perl_$func") . "#endif\n";
 421                 }
 422             }
 423             else {
 424                 my $alist = join(",", @az[0..$args-1]);
 425                 $ret = "#define $func($alist)";
 426                 my $t = int(length($ret) / 8);
 427                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
 428                 if ($flags =~ /s/) {
 429                     $ret .= "S_$func(aTHX";
 430                 }
 431                 elsif ($flags =~ /p/) {
 432                     $ret .= "Perl_$func(aTHX";
 433                 }
 434                 $ret .= "_ " if $alist;
 435                 $ret .= $alist . ")\n";
 436             }
 437         }
 438         unless ($flags =~ /A/) {
 439             if ($flags =~ /E/) {
 440                 $new_ifdef_state
 441                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
 442             }
 443             else {
 444                 $new_ifdef_state = "#ifdef PERL_CORE\n";
 445             }
 446
 447             if ($new_ifdef_state ne $ifdef_state) {
 448                 $ret = $new_ifdef_state . $ret;
 449             }
 450         }
 451     }
 452     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
 453         # Close the old one ahead of opening the new one.
 454         $ret = "#endif\n$ret";
 455     }
 456     # Remember the new state.
 457     $ifdef_state = $new_ifdef_state;
 458     $ret;
 459 } $em;
 460
 461 if ($ifdef_state) {
 462     print $em "#endif\n";
 463 }
 464
 465 for $sym (sort keys %ppsym) {
 466     $sym =~ s/^Perl_//;
 467     if ($sym =~ /^ck_/) {
 468         print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
 469     }
 470     elsif ($sym =~ /^pp_/) {
 471         print $em hide("$sym()", "Perl_$sym(aTHX)");
 472     }
 473     else {
 474         warn "Illegal symbol '$sym' in pp.sym";
 475     }
 476 }
 477
 478 print $em <<'END';
 479
 480 #endif  /* #ifndef PERL_NO_SHORT_NAMES */
 481
 482 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
 483    disable them.
 484  */
 485
 486 #if !defined(PERL_CORE)
 487 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
 488 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,NULL,PTR2IV(ptr))
 489 #endif
 490
 491 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
 492
 493 /* Compatibility for various misnamed functions.  All functions
 494    in the API that begin with "perl_" (not "Perl_") take an explicit
 495    interpreter context pointer.
 496    The following are not like that, but since they had a "perl_"
 497    prefix in previous versions, we provide compatibility macros.
 498  */
 499 #  define perl_atexit(a,b)              call_atexit(a,b)
 500 END
 501
 502 walk_table {
 503     my ($flags,$retval,$func,@args) = @_;
 504     return unless $func;
 505     return unless $flags =~ /O/;
 506
 507     my $alist = join ",", @az[0..$#args];
 508     my $ret = "#  define perl_$func($alist)";
 509     my $t = (length $ret) >> 3;
 510     $ret .=  "\t" x ($t < 5 ? 5 - $t : 1);
 511     "$ret$func($alist)\n";
 512 } $em;
 513
 514 print $em <<'END';
 515
 516 /* varargs functions can't be handled with CPP macros. :-(
 517    This provides a set of compatibility functions that don't take
 518    an extra argument but grab the context pointer using the macro
 519    dTHX.
 520  */
 521 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
 522 END
 523
 524 foreach (sort keys %has_va) {
 525     next unless $has_nocontext{$_};
 526     next if /printf/; # Not clear to me why these are skipped but they are.
 527     print $em hide($_, "Perl_${_}_nocontext", "  ");
 528 }
 529
 530 print $em <<'END';
 531 #endif
 532
 533 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
 534
 535 #if !defined(PERL_IMPLICIT_CONTEXT)
 536 /* undefined symbols, point them back at the usual ones */
 537 END
 538
 539 foreach (sort keys %has_va) {
 540     next unless $has_nocontext{$_};
 541     next if /printf/; # Not clear to me why these are skipped but they are.
 542     print $em hide("Perl_${_}_nocontext", "Perl_$_", "  ");
 543 }
 544
 545 print $em <<'END';
 546 #endif
 547
 548 /* ex: set ro: */
 549 END
 550
 551 safer_close($em);
 552 rename_if_different('embed.h-new', 'embed.h');
 553
 554 $em = safer_open('embedvar.h-new');
 555
 556 print $em do_not_edit ("embedvar.h"), <<'END';
 557
 558 /* (Doing namespace management portably in C is really gross.) */
 559
 560 /*
 561    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
 562    are supported:
 563      1) none
 564      2) MULTIPLICITY    # supported for compatibility
 565      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
 566
 567    All other combinations of these flags are errors.
 568
 569    only #3 is supported directly, while #2 is a special
 570    case of #3 (supported by redefining vTHX appropriately).
 571 */
 572
 573 #if defined(MULTIPLICITY)
 574 /* cases 2 and 3 above */
 575
 576 #  if defined(PERL_IMPLICIT_CONTEXT)
 577 #    define vTHX        aTHX
 578 #  else
 579 #    define vTHX        PERL_GET_INTERP
 580 #  endif
 581
 582 END
 583
 584 for $sym (sort keys %intrp) {
 585     print $em multon($sym,'I','vTHX->');
 586 }
 587
 588 print $em <<'END';
 589
 590 #else   /* !MULTIPLICITY */
 591
 592 /* case 1 above */
 593
 594 END
 595
 596 for $sym (sort keys %intrp) {
 597     print $em multoff($sym,'I');
 598 }
 599
 600 print $em <<'END';
 601
 602 END
 603
 604 print $em <<'END';
 605
 606 #endif  /* MULTIPLICITY */
 607
 608 #if defined(PERL_GLOBAL_STRUCT)
 609
 610 END
 611
 612 for $sym (sort keys %globvar) {
 613     print $em multon($sym,   'G','my_vars->');
 614     print $em multon("G$sym",'', 'my_vars->');
 615 }
 616
 617 print $em <<'END';
 618
 619 #else /* !PERL_GLOBAL_STRUCT */
 620
 621 END
 622
 623 for $sym (sort keys %globvar) {
 624     print $em multoff($sym,'G');
 625 }
 626
 627 print $em <<'END';
 628
 629 #endif /* PERL_GLOBAL_STRUCT */
 630
 631 /* ex: set ro: */
 632 END
 633
 634 safer_close($em);
 635 rename_if_different('embedvar.h-new', 'embedvar.h');
 636
 637 my $capi = safer_open('perlapi.c-new');
 638 my $capih = safer_open('perlapi.h-new');
 639
 640 print $capih do_not_edit ("perlapi.h"), <<'EOT';
 641
 642 /* declare accessor functions for Perl variables */
 643 #ifndef __perlapi_h__
 644 #define __perlapi_h__
 645
 646 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
 647
 648 START_EXTERN_C
 649
 650 #undef PERLVAR
 651 #undef PERLVARA
 652 #undef PERLVARI
 653 #undef PERLVARIC
 654 #undef PERLVARISC
 655 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
 656 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
 657                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 658 #define PERLVARI(v,t,i) PERLVAR(v,t)
 659 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 660 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)];       \
 661                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 662
 663 #include "perlvars.h"
 664
 665 #undef PERLVAR
 666 #undef PERLVARA
 667 #undef PERLVARI
 668 #undef PERLVARIC
 669 #undef PERLVARISC
 670
 671 END_EXTERN_C
 672
 673 #if defined(PERL_CORE)
 674
 675 /* accessor functions for Perl "global" variables */
 676
 677 /* these need to be mentioned here, or most linkers won't put them in
 678    the perl executable */
 679
 680 #ifndef PERL_NO_FORCE_LINK
 681
 682 START_EXTERN_C
 683
 684 #ifndef DOINIT
 685 EXTCONST void * const PL_force_link_funcs[];
 686 #else
 687 EXTCONST void * const PL_force_link_funcs[] = {
 688 #undef PERLVAR
 689 #undef PERLVARA
 690 #undef PERLVARI
 691 #undef PERLVARIC
 692 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
 693 #define PERLVARA(v,n,t) PERLVAR(v,t)
 694 #define PERLVARI(v,t,i) PERLVAR(v,t)
 695 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 696 #define PERLVARISC(v,i) PERLVAR(v,char)
 697
 698 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
 699  * cannot cast between void pointers and function pointers without
 700  * info level warnings.  The PL_force_link_funcs[] would cause a few
 701  * hundred of those warnings.  In code one can circumnavigate this by using
 702  * unions that overlay the different pointers, but in declarations one
 703  * cannot use this trick.  Therefore we just disable the warning here
 704  * for the duration of the PL_force_link_funcs[] declaration. */
 705
 706 #if defined(__DECC) && defined(__osf__)
 707 #pragma message save
 708 #pragma message disable (nonstandcast)
 709 #endif
 710
 711 #include "perlvars.h"
 712
 713 #if defined(__DECC) && defined(__osf__)
 714 #pragma message restore
 715 #endif
 716
 717 #undef PERLVAR
 718 #undef PERLVARA
 719 #undef PERLVARI
 720 #undef PERLVARIC
 721 #undef PERLVARISC
 722 };
 723 #endif  /* DOINIT */
 724
 725 END_EXTERN_C
 726
 727 #endif  /* PERL_NO_FORCE_LINK */
 728
 729 #else   /* !PERL_CORE */
 730
 731 EOT
 732
 733 foreach $sym (sort keys %globvar) {
 734     print $capih bincompat_var('G',$sym);
 735 }
 736
 737 print $capih <<'EOT';
 738
 739 #endif /* !PERL_CORE */
 740 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
 741
 742 #endif /* __perlapi_h__ */
 743
 744 /* ex: set ro: */
 745 EOT
 746 safer_close($capih);
 747 rename_if_different('perlapi.h-new', 'perlapi.h');
 748
 749 print $capi do_not_edit ("perlapi.c"), <<'EOT';
 750
 751 #include "EXTERN.h"
 752 #include "perl.h"
 753 #include "perlapi.h"
 754
 755 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
 756
 757 /* accessor functions for Perl "global" variables */
 758 START_EXTERN_C
 759
 760 #undef PERLVARI
 761 #define PERLVARI(v,t,i) PERLVAR(v,t)
 762
 763 #undef PERLVAR
 764 #undef PERLVARA
 765 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 766                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 767 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 768                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 769 #undef PERLVARIC
 770 #undef PERLVARISC
 771 #define PERLVARIC(v,t,i)        \
 772                         const t* Perl_##v##_ptr(pTHX)           \
 773                         { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
 774 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)        \
 775                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 776 #include "perlvars.h"
 777
 778 #undef PERLVAR
 779 #undef PERLVARA
 780 #undef PERLVARI
 781 #undef PERLVARIC
 782 #undef PERLVARISC
 783
 784 END_EXTERN_C
 785
 786 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
 787
 788 /* ex: set ro: */
 789 EOT
 790
 791 safer_close($capi);
 792 rename_if_different('perlapi.c-new', 'perlapi.c');
 793
 794 # ex: set ts=8 sts=4 sw=4 noet: