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