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