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