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