embed.pl

   1 #!/usr/bin/perl -w
   2
   3 require 5.003;  # keep this compatible, an old perl is all we may have before
   4                 # we build the new one
   5
   6 use strict;
   7
   8 BEGIN {
   9     # Get function prototypes
  10     require 'regen_lib.pl';
  11 }
  12
  13 my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org
  14
  15 #
  16 # See database of global and static function prototypes in embed.fnc
  17 # This is used to generate prototype headers under various configurations,
  18 # export symbols lists for different platforms, and macros to provide an
  19 # implicit interpreter context argument.
  20 #
  21
  22 sub do_not_edit ($)
  23 {
  24     my $file = shift;
  25
  26     my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007';
  27
  28     $years =~ s/1999,/1999,\n  / if length $years > 40;
  29
  30     my $warning = <<EOW;
  31  -*- buffer-read-only: t -*-
  32
  33    $file
  34
  35    Copyright (C) $years, by Larry Wall and others
  36
  37    You may distribute under the terms of either the GNU General Public
  38    License or the Artistic License, as specified in the README file.
  39
  40 !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  41 This file is built by embed.pl from data in embed.fnc, embed.pl,
  42 pp.sym, intrpvar.h, and perlvars.h.
  43 Any changes made here will be lost!
  44
  45 Edit those files and run 'make regen_headers' to effect changes.
  46
  47 EOW
  48
  49     $warning .= <<EOW if $file eq 'perlapi.c';
  50
  51 Up to the threshold of the door there mounted a flight of twenty-seven
  52 broad stairs, hewn by some unknown art of the same black stone.  This
  53 was the only entrance to the tower.
  54
  55
  56 EOW
  57
  58     if ($file =~ m:\.[ch]$:) {
  59         $warning =~ s:^: * :gm;
  60         $warning =~ s: +$::gm;
  61         $warning =~ s: :/:;
  62         $warning =~ s:$:/:;
  63     }
  64     else {
  65         $warning =~ s:^:# :gm;
  66         $warning =~ s: +$::gm;
  67     }
  68     $warning;
  69 } # do_not_edit
  70
  71 open IN, "embed.fnc" or die $!;
  72
  73 # walk table providing an array of components in each line to
  74 # subroutine, printing the result
  75 sub walk_table (&@) {
  76     my $function = shift;
  77     my $filename = shift || '-';
  78     my $leader = shift;
  79     defined $leader or $leader = do_not_edit ($filename);
  80     my $trailer = shift;
  81     my $F;
  82     if (ref $filename) {        # filehandle
  83         $F = $filename;
  84     }
  85     else {
  86         # safer_unlink $filename if $filename ne '/dev/null';
  87         $F = safer_open("$filename-new");
  88     }
  89     print $F $leader if $leader;
  90     seek IN, 0, 0;              # so we may restart
  91     while (<IN>) {
  92         chomp;
  93         next if /^:/;
  94         while (s|\\$||) {
  95             $_ .= <IN>;
  96             chomp;
  97         }
  98         s/\s+$//;
  99         my @args;
 100         if (/^\s*(#|$)/) {
 101             @args = $_;
 102         }
 103         else {
 104             @args = split /\s*\|\s*/, $_;
 105         }
 106         my @outs = &{$function}(@args);
 107         print $F @outs; # $function->(@args) is not 5.003
 108     }
 109     print $F $trailer if $trailer;
 110     unless (ref $filename) {
 111         safer_close($F);
 112         rename_if_different("$filename-new", $filename);
 113     }
 114 }
 115
 116 sub munge_c_files () {
 117     my $functions = {};
 118     unless (@ARGV) {
 119         warn "\@ARGV empty, nothing to do\n";
 120         return;
 121     }
 122     walk_table {
 123         if (@_ > 1) {
 124             $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
 125         }
 126     } '/dev/null', '', '';
 127     local $^I = '.bak';
 128     while (<>) {
 129         s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
 130          {
 131             my $repl = $1;
 132             my $f = $2;
 133             if (exists $functions->{$f}) {
 134                 $repl .= "aTHX_ ";
 135                 warn("$ARGV:$.:$`#$repl#$'");
 136             }
 137             $repl;
 138          }eg;
 139         print;
 140         close ARGV if eof;      # restart $.
 141     }
 142     exit;
 143 }
 144
 145 #munge_c_files();
 146
 147 # generate proto.h
 148 my $wrote_protected = 0;
 149
 150 sub write_protos {
 151     my $ret = "";
 152     if (@_ == 1) {
 153         my $arg = shift;
 154         $ret .= "$arg\n";
 155     }
 156     else {
 157         my ($flags,$retval,$plain_func,@args) = @_;
 158         my @nonnull;
 159         my $has_context = ( $flags !~ /n/ );
 160         my $never_returns = ( $flags =~ /r/ );
 161         my $commented_out = ( $flags =~ /m/ );
 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                     our $unflagged_pointers;
 198                     ++$unflagged_pointers;
 199                 }
 200                 my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
 201                 push( @nonnull, $n ) if $nn;
 202
 203                 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
 204
 205                 # Make sure each arg has at least a type and a var name.
 206                 # An arg of "int" is valid C, but want it to be "int foo".
 207                 my $temp_arg = $arg;
 208                 $temp_arg =~ s/\*//g;
 209                 $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
 210                 if ( ($temp_arg ne "...")
 211                      && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
 212                     warn "$func: $arg ($n) doesn't have a name\n";
 213                 }
 214                 if ( $SPLINT && $nullok && !$commented_out ) {
 215                     $arg = '/*@null@*/ ' . $arg;
 216                 }
 217                 if (defined $1 && $nn) {
 218                     push @names_of_nn, $1;
 219                 }
 220             }
 221             $ret .= join ", ", @args;
 222         }
 223         else {
 224             $ret .= "void" if !$has_context;
 225         }
 226         $ret .= ")";
 227         my @attrs;
 228         if ( $flags =~ /r/ ) {
 229             push @attrs, "__attribute__noreturn__";
 230         }
 231         if ( $is_malloc ) {
 232             push @attrs, "__attribute__malloc__";
 233         }
 234         if ( !$can_ignore ) {
 235             push @attrs, "__attribute__warn_unused_result__";
 236         }
 237         if ( $flags =~ /P/ ) {
 238             push @attrs, "__attribute__pure__";
 239         }
 240         if( $flags =~ /f/ ) {
 241             my $prefix  = $has_context ? 'pTHX_' : '';
 242             my $args    = scalar @args;
 243             my $pat     = $args - 1;
 244             my $macro   = @nonnull && $nonnull[-1] == $pat
 245                                 ? '__attribute__format__'
 246                                 : '__attribute__format__null_ok__';
 247             push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
 248                                 $prefix, $pat, $prefix, $args;
 249         }
 250         if ( @nonnull ) {
 251             my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
 252             push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
 253         }
 254         if ( @attrs ) {
 255             $ret .= "\n";
 256             $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
 257         }
 258         $ret .= ";";
 259         $ret = "/* $ret */" if $commented_out;
 260         if (@names_of_nn) {
 261             $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
 262                 . join '; ', map "assert($_)", @names_of_nn;
 263         }
 264         $ret .= @attrs ? "\n\n" : "\n";
 265     }
 266     $ret;
 267 }
 268
 269 # generates global.sym (API export list)
 270 {
 271   my %seen;
 272   sub write_global_sym {
 273       my $ret = "";
 274       if (@_ > 1) {
 275           my ($flags,$retval,$func,@args) = @_;
 276           # If a function is defined twice, for example before and after an
 277           # #else, only process the flags on the first instance for global.sym
 278           return $ret if $seen{$func}++;
 279           if ($flags =~ /[AX]/ && $flags !~ /[xm]/
 280               || $flags =~ /b/) { # public API, so export
 281               $func = "Perl_$func" if $flags =~ /[pbX]/;
 282               $ret = "$func\n";
 283           }
 284       }
 285       $ret;
 286   }
 287 }
 288
 289
 290 our $unflagged_pointers;
 291 walk_table(\&write_protos,     "proto.h", undef, "/* ex: set ro: */\n");
 292 warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
 293 walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
 294
 295 # XXX others that may need adding
 296 #       warnhook
 297 #       hints
 298 #       copline
 299 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
 300                  curcop compiling
 301                  tainting tainted stack_base stack_sp sv_arenaroot
 302                  no_modify
 303                  curstash DBsub DBsingle DBassertion debstash
 304                  rsfp
 305                  stdingv
 306                  defgv
 307                  errgv
 308                  rsfp_filters
 309                  perldb
 310                  diehook
 311                  dirty
 312                  perl_destruct_level
 313                  ppaddr
 314                 );
 315
 316 sub readsyms (\%$) {
 317     my ($syms, $file) = @_;
 318     local (*FILE, $_);
 319     open(FILE, "< $file")
 320         or die "embed.pl: Can't open $file: $!\n";
 321     while (<FILE>) {
 322         s/[ \t]*#.*//;          # Delete comments.
 323         if (/^\s*(\S+)\s*$/) {
 324             my $sym = $1;
 325             warn "duplicate symbol $sym while processing $file line $.\n"
 326                 if exists $$syms{$sym};
 327             $$syms{$sym} = 1;
 328         }
 329     }
 330     close(FILE);
 331 }
 332
 333 # Perl_pp_* and Perl_ck_* are in pp.sym
 334 readsyms my %ppsym, 'pp.sym';
 335
 336 sub readvars(\%$$@) {
 337     my ($syms, $file,$pre,$keep_pre) = @_;
 338     local (*FILE, $_);
 339     open(FILE, "< $file")
 340         or die "embed.pl: Can't open $file: $!\n";
 341     while (<FILE>) {
 342         s/[ \t]*#.*//;          # Delete comments.
 343         if (/PERLVARA?I?S?C?\($pre(\w+)/) {
 344             my $sym = $1;
 345             $sym = $pre . $sym if $keep_pre;
 346             warn "duplicate symbol $sym while processing $file line $.\n"
 347                 if exists $$syms{$sym};
 348             $$syms{$sym} = $pre || 1;
 349         }
 350     }
 351     close(FILE);
 352 }
 353
 354 my %intrp;
 355 my %globvar;
 356
 357 readvars %intrp,  'intrpvar.h','I';
 358 readvars %globvar, 'perlvars.h','G';
 359
 360 my $sym;
 361
 362 sub undefine ($) {
 363     my ($sym) = @_;
 364     "#undef  $sym\n";
 365 }
 366
 367 sub hide ($$) {
 368     my ($from, $to) = @_;
 369     my $t = int(length($from) / 8);
 370     "#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 #if !defined(PERL_IMPLICIT_CONTEXT)
 404
 405 END
 406
 407 # Try to elimiate lots of repeated
 408 # #ifdef PERL_CORE
 409 # foo
 410 # #endif
 411 # #ifdef PERL_CORE
 412 # bar
 413 # #endif
 414 # by tracking state and merging foo and bar into one block.
 415 my $ifdef_state = '';
 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             if ($flags =~ /s/) {
 428                 $ret .= hide($func,"S_$func");
 429             }
 430             elsif ($flags =~ /p/) {
 431                 $ret .= hide($func,"Perl_$func");
 432             }
 433         }
 434         if ($ret ne '' && $flags !~ /A/) {
 435             if ($flags =~ /E/) {
 436                 $new_ifdef_state
 437                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
 438             }
 439             else {
 440                 $new_ifdef_state = "#ifdef PERL_CORE\n";
 441             }
 442
 443             if ($new_ifdef_state ne $ifdef_state) {
 444                 $ret = $new_ifdef_state . $ret;
 445             }
 446         }
 447     }
 448     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
 449         # Close the old one ahead of opening the new one.
 450         $ret = "#endif\n$ret";
 451     }
 452     # Remember the new state.
 453     $ifdef_state = $new_ifdef_state;
 454     $ret;
 455 } $em, "";
 456
 457 if ($ifdef_state) {
 458     print $em "#endif\n";
 459 }
 460
 461 for $sym (sort keys %ppsym) {
 462     $sym =~ s/^Perl_//;
 463     print $em hide($sym, "Perl_$sym");
 464 }
 465
 466 print $em <<'END';
 467
 468 #else   /* PERL_IMPLICIT_CONTEXT */
 469
 470 END
 471
 472 my @az = ('a'..'z');
 473
 474 $ifdef_state = '';
 475 walk_table {
 476     my $ret = "";
 477     my $new_ifdef_state = '';
 478     if (@_ == 1) {
 479         my $arg = shift;
 480         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
 481     }
 482     else {
 483         my ($flags,$retval,$func,@args) = @_;
 484         unless ($flags =~ /[om]/) {
 485             my $args = scalar @args;
 486             if ($args and $args[$args-1] =~ /\.\.\./) {
 487                 # we're out of luck for varargs functions under CPP
 488             }
 489             elsif ($flags =~ /n/) {
 490                 if ($flags =~ /s/) {
 491                     $ret .= hide($func,"S_$func");
 492                 }
 493                 elsif ($flags =~ /p/) {
 494                     $ret .= hide($func,"Perl_$func");
 495                 }
 496             }
 497             else {
 498                 my $alist = join(",", @az[0..$args-1]);
 499                 $ret = "#define $func($alist)";
 500                 my $t = int(length($ret) / 8);
 501                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
 502                 if ($flags =~ /s/) {
 503                     $ret .= "S_$func(aTHX";
 504                 }
 505                 elsif ($flags =~ /p/) {
 506                     $ret .= "Perl_$func(aTHX";
 507                 }
 508                 $ret .= "_ " if $alist;
 509                 $ret .= $alist . ")\n";
 510             }
 511         }
 512         unless ($flags =~ /A/) {
 513             if ($flags =~ /E/) {
 514                 $new_ifdef_state
 515                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
 516             }
 517             else {
 518                 $new_ifdef_state = "#ifdef PERL_CORE\n";
 519             }
 520
 521             if ($new_ifdef_state ne $ifdef_state) {
 522                 $ret = $new_ifdef_state . $ret;
 523             }
 524         }
 525     }
 526     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
 527         # Close the old one ahead of opening the new one.
 528         $ret = "#endif\n$ret";
 529     }
 530     # Remember the new state.
 531     $ifdef_state = $new_ifdef_state;
 532     $ret;
 533 } $em, "";
 534
 535 if ($ifdef_state) {
 536     print $em "#endif\n";
 537 }
 538
 539 for $sym (sort keys %ppsym) {
 540     $sym =~ s/^Perl_//;
 541     if ($sym =~ /^ck_/) {
 542         print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
 543     }
 544     elsif ($sym =~ /^pp_/) {
 545         print $em hide("$sym()", "Perl_$sym(aTHX)");
 546     }
 547     else {
 548         warn "Illegal symbol '$sym' in pp.sym";
 549     }
 550 }
 551
 552 print $em <<'END';
 553
 554 #endif  /* PERL_IMPLICIT_CONTEXT */
 555
 556 #endif  /* #ifndef PERL_NO_SHORT_NAMES */
 557
 558 END
 559
 560 print $em <<'END';
 561
 562 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
 563    disable them.
 564  */
 565
 566 #if !defined(PERL_CORE)
 567 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
 568 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,NULL,PTR2IV(ptr))
 569 #endif
 570
 571 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
 572
 573 /* Compatibility for various misnamed functions.  All functions
 574    in the API that begin with "perl_" (not "Perl_") take an explicit
 575    interpreter context pointer.
 576    The following are not like that, but since they had a "perl_"
 577    prefix in previous versions, we provide compatibility macros.
 578  */
 579 #  define perl_atexit(a,b)              call_atexit(a,b)
 580 #  define perl_call_argv(a,b,c)         call_argv(a,b,c)
 581 #  define perl_call_pv(a,b)             call_pv(a,b)
 582 #  define perl_call_method(a,b)         call_method(a,b)
 583 #  define perl_call_sv(a,b)             call_sv(a,b)
 584 #  define perl_eval_sv(a,b)             eval_sv(a,b)
 585 #  define perl_eval_pv(a,b)             eval_pv(a,b)
 586 #  define perl_require_pv(a)            require_pv(a)
 587 #  define perl_get_sv(a,b)              get_sv(a,b)
 588 #  define perl_get_av(a,b)              get_av(a,b)
 589 #  define perl_get_hv(a,b)              get_hv(a,b)
 590 #  define perl_get_cv(a,b)              get_cv(a,b)
 591 #  define perl_init_i18nl10n(a)         init_i18nl10n(a)
 592 #  define perl_init_i18nl14n(a)         init_i18nl14n(a)
 593 #  define perl_new_ctype(a)             new_ctype(a)
 594 #  define perl_new_collate(a)           new_collate(a)
 595 #  define perl_new_numeric(a)           new_numeric(a)
 596
 597 /* varargs functions can't be handled with CPP macros. :-(
 598    This provides a set of compatibility functions that don't take
 599    an extra argument but grab the context pointer using the macro
 600    dTHX.
 601  */
 602 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
 603 #  define croak                         Perl_croak_nocontext
 604 #  define deb                           Perl_deb_nocontext
 605 #  define die                           Perl_die_nocontext
 606 #  define form                          Perl_form_nocontext
 607 #  define load_module                   Perl_load_module_nocontext
 608 #  define mess                          Perl_mess_nocontext
 609 #  define newSVpvf                      Perl_newSVpvf_nocontext
 610 #  define sv_catpvf                     Perl_sv_catpvf_nocontext
 611 #  define sv_setpvf                     Perl_sv_setpvf_nocontext
 612 #  define warn                          Perl_warn_nocontext
 613 #  define warner                        Perl_warner_nocontext
 614 #  define sv_catpvf_mg                  Perl_sv_catpvf_mg_nocontext
 615 #  define sv_setpvf_mg                  Perl_sv_setpvf_mg_nocontext
 616 #endif
 617
 618 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
 619
 620 #if !defined(PERL_IMPLICIT_CONTEXT)
 621 /* undefined symbols, point them back at the usual ones */
 622 #  define Perl_croak_nocontext          Perl_croak
 623 #  define Perl_die_nocontext            Perl_die
 624 #  define Perl_deb_nocontext            Perl_deb
 625 #  define Perl_form_nocontext           Perl_form
 626 #  define Perl_load_module_nocontext    Perl_load_module
 627 #  define Perl_mess_nocontext           Perl_mess
 628 #  define Perl_newSVpvf_nocontext       Perl_newSVpvf
 629 #  define Perl_sv_catpvf_nocontext      Perl_sv_catpvf
 630 #  define Perl_sv_setpvf_nocontext      Perl_sv_setpvf
 631 #  define Perl_warn_nocontext           Perl_warn
 632 #  define Perl_warner_nocontext         Perl_warner
 633 #  define Perl_sv_catpvf_mg_nocontext   Perl_sv_catpvf_mg
 634 #  define Perl_sv_setpvf_mg_nocontext   Perl_sv_setpvf_mg
 635 #endif
 636
 637 /* ex: set ro: */
 638 END
 639
 640 safer_close($em);
 641 rename_if_different('embed.h-new', 'embed.h');
 642
 643 $em = safer_open('embedvar.h-new');
 644
 645 print $em do_not_edit ("embedvar.h"), <<'END';
 646
 647 /* (Doing namespace management portably in C is really gross.) */
 648
 649 /*
 650    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
 651    are supported:
 652      1) none
 653      2) MULTIPLICITY    # supported for compatibility
 654      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
 655
 656    All other combinations of these flags are errors.
 657
 658    only #3 is supported directly, while #2 is a special
 659    case of #3 (supported by redefining vTHX appropriately).
 660 */
 661
 662 #if defined(MULTIPLICITY)
 663 /* cases 2 and 3 above */
 664
 665 #  if defined(PERL_IMPLICIT_CONTEXT)
 666 #    define vTHX        aTHX
 667 #  else
 668 #    define vTHX        PERL_GET_INTERP
 669 #  endif
 670
 671 END
 672
 673 for $sym (sort keys %intrp) {
 674     print $em multon($sym,'I','vTHX->');
 675 }
 676
 677 print $em <<'END';
 678
 679 #else   /* !MULTIPLICITY */
 680
 681 /* case 1 above */
 682
 683 END
 684
 685 for $sym (sort keys %intrp) {
 686     print $em multoff($sym,'I');
 687 }
 688
 689 print $em <<'END';
 690
 691 END
 692
 693 print $em <<'END';
 694
 695 #endif  /* MULTIPLICITY */
 696
 697 #if defined(PERL_GLOBAL_STRUCT)
 698
 699 END
 700
 701 for $sym (sort keys %globvar) {
 702     print $em multon($sym,   'G','my_vars->');
 703     print $em multon("G$sym",'', 'my_vars->');
 704 }
 705
 706 print $em <<'END';
 707
 708 #else /* !PERL_GLOBAL_STRUCT */
 709
 710 END
 711
 712 for $sym (sort keys %globvar) {
 713     print $em multoff($sym,'G');
 714 }
 715
 716 print $em <<'END';
 717
 718 #endif /* PERL_GLOBAL_STRUCT */
 719
 720 #ifdef PERL_POLLUTE             /* disabled by default in 5.6.0 */
 721
 722 END
 723
 724 for $sym (sort @extvars) {
 725     print $em hide($sym,"PL_$sym");
 726 }
 727
 728 print $em <<'END';
 729
 730 #endif /* PERL_POLLUTE */
 731
 732 /* ex: set ro: */
 733 END
 734
 735 safer_close($em);
 736 rename_if_different('embedvar.h-new', 'embedvar.h');
 737
 738 my $capi = safer_open('perlapi.c-new');
 739 my $capih = safer_open('perlapi.h-new');
 740
 741 print $capih do_not_edit ("perlapi.h"), <<'EOT';
 742
 743 /* declare accessor functions for Perl variables */
 744 #ifndef __perlapi_h__
 745 #define __perlapi_h__
 746
 747 #if defined (MULTIPLICITY)
 748
 749 START_EXTERN_C
 750
 751 #undef PERLVAR
 752 #undef PERLVARA
 753 #undef PERLVARI
 754 #undef PERLVARIC
 755 #undef PERLVARISC
 756 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
 757 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
 758                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 759 #define PERLVARI(v,t,i) PERLVAR(v,t)
 760 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 761 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)];       \
 762                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 763
 764 #include "intrpvar.h"
 765 #include "perlvars.h"
 766
 767 #undef PERLVAR
 768 #undef PERLVARA
 769 #undef PERLVARI
 770 #undef PERLVARIC
 771 #undef PERLVARISC
 772
 773 #ifndef PERL_GLOBAL_STRUCT
 774 EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
 775 EXTERN_C Perl_check_t**  Perl_Gcheck_ptr(pTHX);
 776 EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
 777 #define Perl_ppaddr_ptr      Perl_Gppaddr_ptr
 778 #define Perl_check_ptr       Perl_Gcheck_ptr
 779 #define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
 780 #endif
 781
 782 END_EXTERN_C
 783
 784 #if defined(PERL_CORE)
 785
 786 /* accessor functions for Perl variables (provide binary compatibility) */
 787
 788 /* these need to be mentioned here, or most linkers won't put them in
 789    the perl executable */
 790
 791 #ifndef PERL_NO_FORCE_LINK
 792
 793 START_EXTERN_C
 794
 795 #ifndef DOINIT
 796 EXTCONST void * const PL_force_link_funcs[];
 797 #else
 798 EXTCONST void * const PL_force_link_funcs[] = {
 799 #undef PERLVAR
 800 #undef PERLVARA
 801 #undef PERLVARI
 802 #undef PERLVARIC
 803 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
 804 #define PERLVARA(v,n,t) PERLVAR(v,t)
 805 #define PERLVARI(v,t,i) PERLVAR(v,t)
 806 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 807 #define PERLVARISC(v,i) PERLVAR(v,char)
 808
 809 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
 810  * cannot cast between void pointers and function pointers without
 811  * info level warnings.  The PL_force_link_funcs[] would cause a few
 812  * hundred of those warnings.  In code one can circumnavigate this by using
 813  * unions that overlay the different pointers, but in declarations one
 814  * cannot use this trick.  Therefore we just disable the warning here
 815  * for the duration of the PL_force_link_funcs[] declaration. */
 816
 817 #if defined(__DECC) && defined(__osf__)
 818 #pragma message save
 819 #pragma message disable (nonstandcast)
 820 #endif
 821
 822 #include "intrpvar.h"
 823 #include "perlvars.h"
 824
 825 #if defined(__DECC) && defined(__osf__)
 826 #pragma message restore
 827 #endif
 828
 829 #undef PERLVAR
 830 #undef PERLVARA
 831 #undef PERLVARI
 832 #undef PERLVARIC
 833 #undef PERLVARISC
 834 };
 835 #endif  /* DOINIT */
 836
 837 END_EXTERN_C
 838
 839 #endif  /* PERL_NO_FORCE_LINK */
 840
 841 #else   /* !PERL_CORE */
 842
 843 EOT
 844
 845 foreach $sym (sort keys %intrp) {
 846     print $capih bincompat_var('I',$sym);
 847 }
 848
 849 foreach $sym (sort keys %globvar) {
 850     print $capih bincompat_var('G',$sym);
 851 }
 852
 853 print $capih <<'EOT';
 854
 855 #endif /* !PERL_CORE */
 856 #endif /* MULTIPLICITY */
 857
 858 #endif /* __perlapi_h__ */
 859
 860 /* ex: set ro: */
 861 EOT
 862 safer_close($capih);
 863 rename_if_different('perlapi.h-new', 'perlapi.h');
 864
 865 print $capi do_not_edit ("perlapi.c"), <<'EOT';
 866
 867 #include "EXTERN.h"
 868 #include "perl.h"
 869 #include "perlapi.h"
 870
 871 #if defined (MULTIPLICITY)
 872
 873 /* accessor functions for Perl variables (provides binary compatibility) */
 874 START_EXTERN_C
 875
 876 #undef PERLVAR
 877 #undef PERLVARA
 878 #undef PERLVARI
 879 #undef PERLVARIC
 880 #undef PERLVARISC
 881
 882 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 883                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
 884 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 885                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
 886
 887 #define PERLVARI(v,t,i) PERLVAR(v,t)
 888 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 889 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 890                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
 891
 892 #include "intrpvar.h"
 893
 894 #undef PERLVAR
 895 #undef PERLVARA
 896 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 897                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 898 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 899                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 900 #undef PERLVARIC
 901 #undef PERLVARISC
 902 #define PERLVARIC(v,t,i)        \
 903                         const t* Perl_##v##_ptr(pTHX)           \
 904                         { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
 905 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)        \
 906                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 907 #include "perlvars.h"
 908
 909 #undef PERLVAR
 910 #undef PERLVARA
 911 #undef PERLVARI
 912 #undef PERLVARIC
 913 #undef PERLVARISC
 914
 915 #ifndef PERL_GLOBAL_STRUCT
 916 /* A few evil special cases.  Could probably macrofy this. */
 917 #undef PL_ppaddr
 918 #undef PL_check
 919 #undef PL_fold_locale
 920 Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
 921     static Perl_ppaddr_t* const ppaddr_ptr = PL_ppaddr;
 922     PERL_UNUSED_CONTEXT;
 923     return (Perl_ppaddr_t**)&ppaddr_ptr;
 924 }
 925 Perl_check_t**  Perl_Gcheck_ptr(pTHX) {
 926     static Perl_check_t* const check_ptr  = PL_check;
 927     PERL_UNUSED_CONTEXT;
 928     return (Perl_check_t**)&check_ptr;
 929 }
 930 unsigned char** Perl_Gfold_locale_ptr(pTHX) {
 931     static unsigned char* const fold_locale_ptr = PL_fold_locale;
 932     PERL_UNUSED_CONTEXT;
 933     return (unsigned char**)&fold_locale_ptr;
 934 }
 935 #endif
 936
 937 END_EXTERN_C
 938
 939 #endif /* MULTIPLICITY */
 940
 941 /* ex: set ro: */
 942 EOT
 943
 944 safer_close($capi);
 945 rename_if_different('perlapi.c-new', 'perlapi.c');
 946
 947 # functions that take va_list* for implementing vararg functions
 948 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
 949 # XXX %vfuncs currently unused
 950 my %vfuncs = qw(
 951     Perl_croak                  Perl_vcroak
 952     Perl_warn                   Perl_vwarn
 953     Perl_warner                 Perl_vwarner
 954     Perl_die                    Perl_vdie
 955     Perl_form                   Perl_vform
 956     Perl_load_module            Perl_vload_module
 957     Perl_mess                   Perl_vmess
 958     Perl_deb                    Perl_vdeb
 959     Perl_newSVpvf               Perl_vnewSVpvf
 960     Perl_sv_setpvf              Perl_sv_vsetpvf
 961     Perl_sv_setpvf_mg           Perl_sv_vsetpvf_mg
 962     Perl_sv_catpvf              Perl_sv_vcatpvf
 963     Perl_sv_catpvf_mg           Perl_sv_vcatpvf_mg
 964     Perl_dump_indent            Perl_dump_vindent
 965     Perl_default_protect        Perl_vdefault_protect
 966 );
 967
 968 # ex: set ts=8 sts=4 sw=4 noet: