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