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