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