Ensure regen.pl and the scripts that it calls can be run by older perls.
[perl.git] / embed.pl
1 #!/usr/bin/perl -w
2
3 # Regenerate (overwriting only if changed):
4 #
5 #    embed.h
6 #    embedvar.h
7 #    global.sym
8 #    perlapi.c
9 #    perlapi.h
10 #    proto.h
11 #
12 # from information stored in
13 #
14 #    embed.fnc
15 #    intrpvar.h
16 #    perlvars.h
17 #    pp.sym     (which has been generated by opcode.pl)
18 #
19 # plus from the values hardcoded into this script in @extvars.
20 #
21 # Accepts the standard regen_lib -q and -v args.
22 #
23 # This script is normally invoked from regen.pl.
24
25 require 5.004;  # keep this compatible, an old perl is all we may have before
26                 # we build the new one
27
28 use strict;
29
30 BEGIN {
31     # Get function prototypes
32     require 'regen_lib.pl';
33 }
34
35 my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org
36 my $unflagged_pointers;
37
38 #
39 # See database of global and static function prototypes in embed.fnc
40 # This is used to generate prototype headers under various configurations,
41 # export symbols lists for different platforms, and macros to provide an
42 # implicit interpreter context argument.
43 #
44
45 sub do_not_edit ($)
46 {
47     my $file = shift;
48
49     my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009';
50
51     $years =~ s/1999,/1999,\n  / if length $years > 40;
52
53     my $warning = <<EOW;
54  -*- buffer-read-only: t -*-
55
56    $file
57
58    Copyright (C) $years, by Larry Wall and others
59
60    You may distribute under the terms of either the GNU General Public
61    License or the Artistic License, as specified in the README file.
62
63 !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
64 This file is built by embed.pl from data in embed.fnc, embed.pl,
65 pp.sym, intrpvar.h, and perlvars.h.
66 Any changes made here will be lost!
67
68 Edit those files and run 'make regen_headers' to effect changes.
69
70 EOW
71
72     $warning .= <<EOW if $file eq 'perlapi.c';
73
74 Up to the threshold of the door there mounted a flight of twenty-seven
75 broad stairs, hewn by some unknown art of the same black stone.  This
76 was the only entrance to the tower; ...
77
78     [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
79
80
81 EOW
82
83     if ($file =~ m:\.[ch]$:) {
84         $warning =~ s:^: * :gm;
85         $warning =~ s: +$::gm;
86         $warning =~ s: :/:;
87         $warning =~ s:$:/:;
88     }
89     else {
90         $warning =~ s:^:# :gm;
91         $warning =~ s: +$::gm;
92     }
93     $warning;
94 } # do_not_edit
95
96 open IN, "embed.fnc" or die $!;
97
98 my @embed;
99 my (%has_va, %has_nocontext);
100
101 while (<IN>) {
102     chomp;
103     next if /^:/;
104     while (s|\\$||) {
105         $_ .= <IN>;
106         chomp;
107     }
108     s/\s+$//;
109     my @args;
110     if (/^\s*(#|$)/) {
111         @args = $_;
112     }
113     else {
114         @args = split /\s*\|\s*/, $_;
115         my $func = $args[2];
116         if ($func) {
117             ++$has_va{$func} if $args[-1] =~ /\.\.\./;
118             ++$has_nocontext{$1} if $func =~ /(.*)_nocontext/;
119         }
120     }
121     push @embed, \@args;
122 }
123
124 # walk table providing an array of components in each line to
125 # subroutine, printing the result
126 sub walk_table (&@) {
127     my ($function, $filename, $leader, $trailer) = @_;
128     defined $leader or $leader = do_not_edit ($filename);
129     my $F;
130     if (ref $filename) {        # filehandle
131         $F = $filename;
132     }
133     else {
134         # safer_unlink $filename if $filename ne '/dev/null';
135         $F = safer_open("$filename-new");
136     }
137     print $F $leader if $leader;
138     foreach (@embed) {
139         my @outs = &{$function}(@$_);
140         print $F @outs; # $function->(@args) is not 5.003
141     }
142     print $F $trailer if $trailer;
143     unless (ref $filename) {
144         safer_close($F);
145         rename_if_different("$filename-new", $filename);
146     }
147 }
148
149 sub munge_c_files () {
150     my $functions = {};
151     unless (@ARGV) {
152         warn "\@ARGV empty, nothing to do\n";
153         return;
154     }
155     walk_table {
156         if (@_ > 1) {
157             $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
158         }
159     } '/dev/null', '', '';
160     local $^I = '.bak';
161     while (<>) {
162         s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
163          {
164             my $repl = $1;
165             my $f = $2;
166             if (exists $functions->{$f}) {
167                 $repl .= "aTHX_ ";
168                 warn("$ARGV:$.:$`#$repl#$'");
169             }
170             $repl;
171          }eg;
172         print;
173         close ARGV if eof;      # restart $.
174     }
175     exit;
176 }
177
178 #munge_c_files();
179
180 # generate proto.h
181 my $wrote_protected = 0;
182
183 sub write_protos {
184     my $ret = "";
185     if (@_ == 1) {
186         my $arg = shift;
187         $ret .= "$arg\n";
188     }
189     else {
190         my ($flags,$retval,$plain_func,@args) = @_;
191         my @nonnull;
192         my $has_context = ( $flags !~ /n/ );
193         my $never_returns = ( $flags =~ /r/ );
194         my $commented_out = ( $flags =~ /m/ );
195         my $binarycompat = ( $flags =~ /b/ );
196         my $is_malloc = ( $flags =~ /a/ );
197         my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
198         my @names_of_nn;
199         my $func;
200
201         my $splint_flags = "";
202         if ( $SPLINT && !$commented_out ) {
203             $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
204             if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
205                 $retval .= " /*\@alt void\@*/";
206             }
207         }
208
209         if ($flags =~ /s/) {
210             $retval = "STATIC $splint_flags$retval";
211             $func = "S_$plain_func";
212         }
213         else {
214             $retval = "PERL_CALLCONV $splint_flags$retval";
215             if ($flags =~ /[bp]/) {
216                 $func = "Perl_$plain_func";
217             } else {
218                 $func = $plain_func;
219             }
220         }
221         $ret .= "$retval\t$func(";
222         if ( $has_context ) {
223             $ret .= @args ? "pTHX_ " : "pTHX";
224         }
225         if (@args) {
226             my $n;
227             for my $arg ( @args ) {
228                 ++$n;
229                 if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
230                     warn "$func: $arg needs NN or NULLOK\n";
231                     ++$unflagged_pointers;
232                 }
233                 my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
234                 push( @nonnull, $n ) if $nn;
235
236                 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
237
238                 # Make sure each arg has at least a type and a var name.
239                 # An arg of "int" is valid C, but want it to be "int foo".
240                 my $temp_arg = $arg;
241                 $temp_arg =~ s/\*//g;
242                 $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
243                 if ( ($temp_arg ne "...")
244                      && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
245                     warn "$func: $arg ($n) doesn't have a name\n";
246                 }
247                 if ( $SPLINT && $nullok && !$commented_out ) {
248                     $arg = '/*@null@*/ ' . $arg;
249                 }
250                 if (defined $1 && $nn && !($commented_out && !$binarycompat)) {
251                     push @names_of_nn, $1;
252                 }
253             }
254             $ret .= join ", ", @args;
255         }
256         else {
257             $ret .= "void" if !$has_context;
258         }
259         $ret .= ")";
260         my @attrs;
261         if ( $flags =~ /r/ ) {
262             push @attrs, "__attribute__noreturn__";
263         }
264         if ( $flags =~ /D/ ) {
265             push @attrs, "__attribute__deprecated__";
266         }
267         if ( $is_malloc ) {
268             push @attrs, "__attribute__malloc__";
269         }
270         if ( !$can_ignore ) {
271             push @attrs, "__attribute__warn_unused_result__";
272         }
273         if ( $flags =~ /P/ ) {
274             push @attrs, "__attribute__pure__";
275         }
276         if( $flags =~ /f/ ) {
277             my $prefix  = $has_context ? 'pTHX_' : '';
278             my $args    = scalar @args;
279             my $pat     = $args - 1;
280             my $macro   = @nonnull && $nonnull[-1] == $pat  
281                                 ? '__attribute__format__'
282                                 : '__attribute__format__null_ok__';
283             push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
284                                 $prefix, $pat, $prefix, $args;
285         }
286         if ( @nonnull ) {
287             my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
288             push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
289         }
290         if ( @attrs ) {
291             $ret .= "\n";
292             $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
293         }
294         $ret .= ";";
295         $ret = "/* $ret */" if $commented_out;
296         if (@names_of_nn) {
297             $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
298                 . join '; ', map "assert($_)", @names_of_nn;
299         }
300         $ret .= @attrs ? "\n\n" : "\n";
301     }
302     $ret;
303 }
304
305 # generates global.sym (API export list)
306 {
307   my %seen;
308   sub write_global_sym {
309       my $ret = "";
310       if (@_ > 1) {
311           my ($flags,$retval,$func,@args) = @_;
312           # If a function is defined twice, for example before and after an
313           # #else, only process the flags on the first instance for global.sym
314           return $ret if $seen{$func}++;
315           if ($flags =~ /[AX]/ && $flags !~ /[xm]/
316               || $flags =~ /b/) { # public API, so export
317               $func = "Perl_$func" if $flags =~ /[pbX]/;
318               $ret = "$func\n";
319           }
320       }
321       $ret;
322   }
323 }
324
325 walk_table(\&write_protos,     "proto.h", undef, "/* ex: set ro: */\n");
326 warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
327 walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
328
329 # XXX others that may need adding
330 #       warnhook
331 #       hints
332 #       copline
333 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
334                  curcop compiling
335                  tainting tainted stack_base stack_sp sv_arenaroot
336                  no_modify
337                  curstash DBsub DBsingle DBassertion debstash
338                  rsfp
339                  stdingv
340                  defgv
341                  errgv
342                  rsfp_filters
343                  perldb
344                  diehook
345                  dirty
346                  perl_destruct_level
347                  ppaddr
348                 );
349
350 sub readsyms (\%$) {
351     my ($syms, $file) = @_;
352     local (*FILE, $_);
353     open(FILE, "< $file")
354         or die "embed.pl: Can't open $file: $!\n";
355     while (<FILE>) {
356         s/[ \t]*#.*//;          # Delete comments.
357         if (/^\s*(\S+)\s*$/) {
358             my $sym = $1;
359             warn "duplicate symbol $sym while processing $file line $.\n"
360                 if exists $$syms{$sym};
361             $$syms{$sym} = 1;
362         }
363     }
364     close(FILE);
365 }
366
367 # Perl_pp_* and Perl_ck_* are in pp.sym
368 readsyms my %ppsym, 'pp.sym';
369
370 sub readvars(\%$$@) {
371     my ($syms, $file,$pre,$keep_pre) = @_;
372     local (*FILE, $_);
373     open(FILE, "< $file")
374         or die "embed.pl: Can't open $file: $!\n";
375     while (<FILE>) {
376         s/[ \t]*#.*//;          # Delete comments.
377         if (/PERLVARA?I?S?C?\($pre(\w+)/) {
378             my $sym = $1;
379             $sym = $pre . $sym if $keep_pre;
380             warn "duplicate symbol $sym while processing $file line $.\n"
381                 if exists $$syms{$sym};
382             $$syms{$sym} = $pre || 1;
383         }
384     }
385     close(FILE);
386 }
387
388 my %intrp;
389 my %globvar;
390
391 readvars %intrp,  'intrpvar.h','I';
392 readvars %globvar, 'perlvars.h','G';
393
394 my $sym;
395
396 sub undefine ($) {
397     my ($sym) = @_;
398     "#undef  $sym\n";
399 }
400
401 sub hide {
402     my ($from, $to, $indent) = @_;
403     $indent = '' unless defined $indent;
404     my $t = int(length("$indent$from") / 8);
405     "#${indent}define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
406 }
407
408 sub bincompat_var ($$) {
409     my ($pfx, $sym) = @_;
410     my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
411     undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
412 }
413
414 sub multon ($$$) {
415     my ($sym,$pre,$ptr) = @_;
416     hide("PL_$sym", "($ptr$pre$sym)");
417 }
418
419 sub multoff ($$) {
420     my ($sym,$pre) = @_;
421     return hide("PL_$pre$sym", "PL_$sym");
422 }
423
424 my $em = safer_open('embed.h-new');
425
426 print $em do_not_edit ("embed.h"), <<'END';
427
428 /* (Doing namespace management portably in C is really gross.) */
429
430 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
431  * (like warn instead of Perl_warn) for the API are not defined.
432  * Not defining the short forms is a good thing for cleaner embedding. */
433
434 #ifndef PERL_NO_SHORT_NAMES
435
436 /* Hide global symbols */
437
438 #if !defined(PERL_IMPLICIT_CONTEXT)
439
440 END
441
442 # Try to elimiate lots of repeated
443 # #ifdef PERL_CORE
444 # foo
445 # #endif
446 # #ifdef PERL_CORE
447 # bar
448 # #endif
449 # by tracking state and merging foo and bar into one block.
450 my $ifdef_state = '';
451
452 walk_table {
453     my $ret = "";
454     my $new_ifdef_state = '';
455     if (@_ == 1) {
456         my $arg = shift;
457         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
458     }
459     else {
460         my ($flags,$retval,$func,@args) = @_;
461         unless ($flags =~ /[om]/) {
462             if ($flags =~ /s/) {
463                 $ret .= hide($func,"S_$func");
464             }
465             elsif ($flags =~ /p/) {
466                 $ret .= hide($func,"Perl_$func");
467             }
468         }
469         if ($ret ne '' && $flags !~ /A/) {
470             if ($flags =~ /E/) {
471                 $new_ifdef_state
472                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
473             }
474             else {
475                 $new_ifdef_state = "#ifdef PERL_CORE\n";
476             }
477
478             if ($new_ifdef_state ne $ifdef_state) {
479                 $ret = $new_ifdef_state . $ret;
480             }
481         }
482     }
483     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
484         # Close the old one ahead of opening the new one.
485         $ret = "#endif\n$ret";
486     }
487     # Remember the new state.
488     $ifdef_state = $new_ifdef_state;
489     $ret;
490 } $em, "";
491
492 if ($ifdef_state) {
493     print $em "#endif\n";
494 }
495
496 for $sym (sort keys %ppsym) {
497     $sym =~ s/^Perl_//;
498     print $em hide($sym, "Perl_$sym");
499 }
500
501 print $em <<'END';
502
503 #else   /* PERL_IMPLICIT_CONTEXT */
504
505 END
506
507 my @az = ('a'..'z');
508
509 $ifdef_state = '';
510 walk_table {
511     my $ret = "";
512     my $new_ifdef_state = '';
513     if (@_ == 1) {
514         my $arg = shift;
515         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
516     }
517     else {
518         my ($flags,$retval,$func,@args) = @_;
519         unless ($flags =~ /[om]/) {
520             my $args = scalar @args;
521             if ($args and $args[$args-1] =~ /\.\.\./) {
522                 # we're out of luck for varargs functions under CPP
523             }
524             elsif ($flags =~ /n/) {
525                 if ($flags =~ /s/) {
526                     $ret .= hide($func,"S_$func");
527                 }
528                 elsif ($flags =~ /p/) {
529                     $ret .= hide($func,"Perl_$func");
530                 }
531             }
532             else {
533                 my $alist = join(",", @az[0..$args-1]);
534                 $ret = "#define $func($alist)";
535                 my $t = int(length($ret) / 8);
536                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
537                 if ($flags =~ /s/) {
538                     $ret .= "S_$func(aTHX";
539                 }
540                 elsif ($flags =~ /p/) {
541                     $ret .= "Perl_$func(aTHX";
542                 }
543                 $ret .= "_ " if $alist;
544                 $ret .= $alist . ")\n";
545             }
546         }
547         unless ($flags =~ /A/) {
548             if ($flags =~ /E/) {
549                 $new_ifdef_state
550                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
551             }
552             else {
553                 $new_ifdef_state = "#ifdef PERL_CORE\n";
554             }
555
556             if ($new_ifdef_state ne $ifdef_state) {
557                 $ret = $new_ifdef_state . $ret;
558             }
559         }
560     }
561     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
562         # Close the old one ahead of opening the new one.
563         $ret = "#endif\n$ret";
564     }
565     # Remember the new state.
566     $ifdef_state = $new_ifdef_state;
567     $ret;
568 } $em, "";
569
570 if ($ifdef_state) {
571     print $em "#endif\n";
572 }
573
574 for $sym (sort keys %ppsym) {
575     $sym =~ s/^Perl_//;
576     if ($sym =~ /^ck_/) {
577         print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
578     }
579     elsif ($sym =~ /^pp_/) {
580         print $em hide("$sym()", "Perl_$sym(aTHX)");
581     }
582     else {
583         warn "Illegal symbol '$sym' in pp.sym";
584     }
585 }
586
587 print $em <<'END';
588
589 #endif  /* PERL_IMPLICIT_CONTEXT */
590
591 #endif  /* #ifndef PERL_NO_SHORT_NAMES */
592
593 END
594
595 print $em <<'END';
596
597 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
598    disable them.
599  */
600
601 #if !defined(PERL_CORE)
602 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
603 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,NULL,PTR2IV(ptr))
604 #endif
605
606 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
607
608 /* Compatibility for various misnamed functions.  All functions
609    in the API that begin with "perl_" (not "Perl_") take an explicit
610    interpreter context pointer.
611    The following are not like that, but since they had a "perl_"
612    prefix in previous versions, we provide compatibility macros.
613  */
614 #  define perl_atexit(a,b)              call_atexit(a,b)
615 END
616
617 walk_table {
618     my ($flags,$retval,$func,@args) = @_;
619     return unless $func;
620     return unless $flags =~ /O/;
621
622     my $alist = join ",", @az[0..$#args];
623     my $ret = "#  define perl_$func($alist)";
624     my $t = (length $ret) >> 3;
625     $ret .=  "\t" x ($t < 5 ? 5 - $t : 1);
626     "$ret$func($alist)\n";
627 } $em, "";
628
629 print $em <<'END';
630
631 /* varargs functions can't be handled with CPP macros. :-(
632    This provides a set of compatibility functions that don't take
633    an extra argument but grab the context pointer using the macro
634    dTHX.
635  */
636 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
637 END
638
639 foreach (sort keys %has_va) {
640     next unless $has_nocontext{$_};
641     next if /printf/; # Not clear to me why these are skipped but they are.
642     print $em hide($_, "Perl_${_}_nocontext", "  ");
643 }
644
645 print $em <<'END';
646 #endif
647
648 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
649
650 #if !defined(PERL_IMPLICIT_CONTEXT)
651 /* undefined symbols, point them back at the usual ones */
652 END
653
654 foreach (sort keys %has_va) {
655     next unless $has_nocontext{$_};
656     next if /printf/; # Not clear to me why these are skipped but they are.
657     print $em hide("Perl_${_}_nocontext", "Perl_$_", "  ");
658 }
659
660 print $em <<'END';
661 #endif
662
663 /* ex: set ro: */
664 END
665
666 safer_close($em);
667 rename_if_different('embed.h-new', 'embed.h');
668
669 $em = safer_open('embedvar.h-new');
670
671 print $em do_not_edit ("embedvar.h"), <<'END';
672
673 /* (Doing namespace management portably in C is really gross.) */
674
675 /*
676    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
677    are supported:
678      1) none
679      2) MULTIPLICITY    # supported for compatibility
680      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
681
682    All other combinations of these flags are errors.
683
684    only #3 is supported directly, while #2 is a special
685    case of #3 (supported by redefining vTHX appropriately).
686 */
687
688 #if defined(MULTIPLICITY)
689 /* cases 2 and 3 above */
690
691 #  if defined(PERL_IMPLICIT_CONTEXT)
692 #    define vTHX        aTHX
693 #  else
694 #    define vTHX        PERL_GET_INTERP
695 #  endif
696
697 END
698
699 for $sym (sort keys %intrp) {
700     print $em multon($sym,'I','vTHX->');
701 }
702
703 print $em <<'END';
704
705 #else   /* !MULTIPLICITY */
706
707 /* case 1 above */
708
709 END
710
711 for $sym (sort keys %intrp) {
712     print $em multoff($sym,'I');
713 }
714
715 print $em <<'END';
716
717 END
718
719 print $em <<'END';
720
721 #endif  /* MULTIPLICITY */
722
723 #if defined(PERL_GLOBAL_STRUCT)
724
725 END
726
727 for $sym (sort keys %globvar) {
728     print $em multon($sym,   'G','my_vars->');
729     print $em multon("G$sym",'', 'my_vars->');
730 }
731
732 print $em <<'END';
733
734 #else /* !PERL_GLOBAL_STRUCT */
735
736 END
737
738 for $sym (sort keys %globvar) {
739     print $em multoff($sym,'G');
740 }
741
742 print $em <<'END';
743
744 #endif /* PERL_GLOBAL_STRUCT */
745
746 /* ex: set ro: */
747 END
748
749 safer_close($em);
750 rename_if_different('embedvar.h-new', 'embedvar.h');
751
752 my $capi = safer_open('perlapi.c-new');
753 my $capih = safer_open('perlapi.h-new');
754
755 print $capih do_not_edit ("perlapi.h"), <<'EOT';
756
757 /* declare accessor functions for Perl variables */
758 #ifndef __perlapi_h__
759 #define __perlapi_h__
760
761 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
762
763 START_EXTERN_C
764
765 #undef PERLVAR
766 #undef PERLVARA
767 #undef PERLVARI
768 #undef PERLVARIC
769 #undef PERLVARISC
770 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
771 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
772                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
773 #define PERLVARI(v,t,i) PERLVAR(v,t)
774 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
775 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)];       \
776                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
777
778 #include "perlvars.h"
779
780 #undef PERLVAR
781 #undef PERLVARA
782 #undef PERLVARI
783 #undef PERLVARIC
784 #undef PERLVARISC
785
786 END_EXTERN_C
787
788 #if defined(PERL_CORE)
789
790 /* accessor functions for Perl "global" variables */
791
792 /* these need to be mentioned here, or most linkers won't put them in
793    the perl executable */
794
795 #ifndef PERL_NO_FORCE_LINK
796
797 START_EXTERN_C
798
799 #ifndef DOINIT
800 EXTCONST void * const PL_force_link_funcs[];
801 #else
802 EXTCONST void * const PL_force_link_funcs[] = {
803 #undef PERLVAR
804 #undef PERLVARA
805 #undef PERLVARI
806 #undef PERLVARIC
807 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
808 #define PERLVARA(v,n,t) PERLVAR(v,t)
809 #define PERLVARI(v,t,i) PERLVAR(v,t)
810 #define PERLVARIC(v,t,i) PERLVAR(v,t)
811 #define PERLVARISC(v,i) PERLVAR(v,char)
812
813 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
814  * cannot cast between void pointers and function pointers without
815  * info level warnings.  The PL_force_link_funcs[] would cause a few
816  * hundred of those warnings.  In code one can circumnavigate this by using
817  * unions that overlay the different pointers, but in declarations one
818  * cannot use this trick.  Therefore we just disable the warning here
819  * for the duration of the PL_force_link_funcs[] declaration. */
820
821 #if defined(__DECC) && defined(__osf__)
822 #pragma message save
823 #pragma message disable (nonstandcast)
824 #endif
825
826 #include "perlvars.h"
827
828 #if defined(__DECC) && defined(__osf__)
829 #pragma message restore
830 #endif
831
832 #undef PERLVAR
833 #undef PERLVARA
834 #undef PERLVARI
835 #undef PERLVARIC
836 #undef PERLVARISC
837 };
838 #endif  /* DOINIT */
839
840 END_EXTERN_C
841
842 #endif  /* PERL_NO_FORCE_LINK */
843
844 #else   /* !PERL_CORE */
845
846 EOT
847
848 foreach $sym (sort keys %globvar) {
849     print $capih bincompat_var('G',$sym);
850 }
851
852 print $capih <<'EOT';
853
854 #endif /* !PERL_CORE */
855 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
856
857 #endif /* __perlapi_h__ */
858
859 /* ex: set ro: */
860 EOT
861 safer_close($capih);
862 rename_if_different('perlapi.h-new', 'perlapi.h');
863
864 print $capi do_not_edit ("perlapi.c"), <<'EOT';
865
866 #include "EXTERN.h"
867 #include "perl.h"
868 #include "perlapi.h"
869
870 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
871
872 /* accessor functions for Perl "global" variables */
873 START_EXTERN_C
874
875 #undef PERLVARI
876 #define PERLVARI(v,t,i) PERLVAR(v,t)
877
878 #undef PERLVAR
879 #undef PERLVARA
880 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
881                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
882 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
883                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
884 #undef PERLVARIC
885 #undef PERLVARISC
886 #define PERLVARIC(v,t,i)        \
887                         const t* Perl_##v##_ptr(pTHX)           \
888                         { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
889 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)        \
890                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
891 #include "perlvars.h"
892
893 #undef PERLVAR
894 #undef PERLVARA
895 #undef PERLVARI
896 #undef PERLVARIC
897 #undef PERLVARISC
898
899 END_EXTERN_C
900
901 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
902
903 /* ex: set ro: */
904 EOT
905
906 safer_close($capi);
907 rename_if_different('perlapi.c-new', 'perlapi.c');
908
909 # ex: set ts=8 sts=4 sw=4 noet: