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