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