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