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