2f2fde65931e2d26dba318689124b6b218ef45e8
[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 {
291     my $pr = safer_open('proto.h-new');
292
293     print $pr do_not_edit ("proto.h"), "\nSTART_EXTERN_C\n";
294
295     walk_table(\&write_protos, $pr);
296
297     print $pr "END_EXTERN_C\n/* ex: set ro: */\n";
298
299     safer_close($pr);
300     rename_if_different('proto.h-new', 'proto.h');
301 }
302
303 warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
304 walk_table(\&write_global_sym, "global.sym", "# ex: set ro:\n");
305
306 sub readsyms (\%$) {
307     my ($syms, $file) = @_;
308     local (*FILE, $_);
309     open(FILE, "< $file")
310         or die "embed.pl: Can't open $file: $!\n";
311     while (<FILE>) {
312         s/[ \t]*#.*//;          # Delete comments.
313         if (/^\s*(\S+)\s*$/) {
314             my $sym = $1;
315             warn "duplicate symbol $sym while processing $file line $.\n"
316                 if exists $$syms{$sym};
317             $$syms{$sym} = 1;
318         }
319     }
320     close(FILE);
321 }
322
323 # Perl_pp_* and Perl_ck_* are in pp.sym
324 readsyms my %ppsym, 'pp.sym';
325
326 sub readvars(\%$$@) {
327     my ($syms, $file,$pre,$keep_pre) = @_;
328     local (*FILE, $_);
329     open(FILE, "< $file")
330         or die "embed.pl: Can't open $file: $!\n";
331     while (<FILE>) {
332         s/[ \t]*#.*//;          # Delete comments.
333         if (/PERLVARA?I?S?C?\($pre(\w+)/) {
334             my $sym = $1;
335             $sym = $pre . $sym if $keep_pre;
336             warn "duplicate symbol $sym while processing $file line $.\n"
337                 if exists $$syms{$sym};
338             $$syms{$sym} = $pre || 1;
339         }
340     }
341     close(FILE);
342 }
343
344 my %intrp;
345 my %globvar;
346
347 readvars %intrp,  'intrpvar.h','I';
348 readvars %globvar, 'perlvars.h','G';
349
350 my $sym;
351
352 sub undefine ($) {
353     my ($sym) = @_;
354     "#undef  $sym\n";
355 }
356
357 sub hide {
358     my ($from, $to, $indent) = @_;
359     $indent = '' unless defined $indent;
360     my $t = int(length("$indent$from") / 8);
361     "#${indent}define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
362 }
363
364 sub bincompat_var ($$) {
365     my ($pfx, $sym) = @_;
366     my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
367     undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
368 }
369
370 sub multon ($$$) {
371     my ($sym,$pre,$ptr) = @_;
372     hide("PL_$sym", "($ptr$pre$sym)");
373 }
374
375 sub multoff ($$) {
376     my ($sym,$pre) = @_;
377     return hide("PL_$pre$sym", "PL_$sym");
378 }
379
380 my $em = safer_open('embed.h-new');
381
382 print $em do_not_edit ("embed.h"), <<'END';
383
384 /* (Doing namespace management portably in C is really gross.) */
385
386 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
387  * (like warn instead of Perl_warn) for the API are not defined.
388  * Not defining the short forms is a good thing for cleaner embedding. */
389
390 #ifndef PERL_NO_SHORT_NAMES
391
392 /* Hide global symbols */
393
394 END
395
396 # Try to elimiate lots of repeated
397 # #ifdef PERL_CORE
398 # foo
399 # #endif
400 # #ifdef PERL_CORE
401 # bar
402 # #endif
403 # by tracking state and merging foo and bar into one block.
404 my $ifdef_state = '';
405
406 my @az = ('a'..'z');
407
408 walk_table {
409     my $ret = "";
410     my $new_ifdef_state = '';
411     if (@_ == 1) {
412         my $arg = shift;
413         $ret = "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
414     }
415     else {
416         my ($flags,$retval,$func,@args) = @_;
417         unless ($flags =~ /[om]/) {
418             my $args = scalar @args;
419             if ($flags =~ /n/) {
420                 if ($flags =~ /s/) {
421                     $ret = hide($func,"S_$func");
422                 }
423                 elsif ($flags =~ /p/) {
424                     $ret = hide($func,"Perl_$func");
425                 }
426             }
427             elsif ($args and $args[$args-1] =~ /\.\.\./) {
428                 if ($flags =~ /p/) {
429                     # we're out of luck for varargs functions under CPP
430                     # So we can only do these macros for no implicit context:
431                     $ret = "#ifndef PERL_IMPLICIT_CONTEXT\n"
432                         . hide($func,"Perl_$func") . "#endif\n";
433                 }
434             }
435             else {
436                 my $alist = join(",", @az[0..$args-1]);
437                 $ret = "#define $func($alist)";
438                 my $t = int(length($ret) / 8);
439                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
440                 if ($flags =~ /s/) {
441                     $ret .= "S_$func(aTHX";
442                 }
443                 elsif ($flags =~ /p/) {
444                     $ret .= "Perl_$func(aTHX";
445                 }
446                 $ret .= "_ " if $alist;
447                 $ret .= $alist . ")\n";
448             }
449         }
450         unless ($flags =~ /A/) {
451             if ($flags =~ /E/) {
452                 $new_ifdef_state
453                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
454             }
455             else {
456                 $new_ifdef_state = "#ifdef PERL_CORE\n";
457             }
458
459             if ($new_ifdef_state ne $ifdef_state) {
460                 $ret = $new_ifdef_state . $ret;
461             }
462         }
463     }
464     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
465         # Close the old one ahead of opening the new one.
466         $ret = "#endif\n$ret";
467     }
468     # Remember the new state.
469     $ifdef_state = $new_ifdef_state;
470     $ret;
471 } $em;
472
473 if ($ifdef_state) {
474     print $em "#endif\n";
475 }
476
477 for $sym (sort keys %ppsym) {
478     $sym =~ s/^Perl_//;
479     if ($sym =~ /^ck_/) {
480         print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
481     }
482     elsif ($sym =~ /^pp_/) {
483         print $em hide("$sym()", "Perl_$sym(aTHX)");
484     }
485     else {
486         warn "Illegal symbol '$sym' in pp.sym";
487     }
488 }
489
490 print $em <<'END';
491
492 #endif  /* #ifndef PERL_NO_SHORT_NAMES */
493
494 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
495    disable them.
496  */
497
498 #if !defined(PERL_CORE)
499 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
500 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,NULL,PTR2IV(ptr))
501 #endif
502
503 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
504
505 /* Compatibility for various misnamed functions.  All functions
506    in the API that begin with "perl_" (not "Perl_") take an explicit
507    interpreter context pointer.
508    The following are not like that, but since they had a "perl_"
509    prefix in previous versions, we provide compatibility macros.
510  */
511 #  define perl_atexit(a,b)              call_atexit(a,b)
512 END
513
514 walk_table {
515     my ($flags,$retval,$func,@args) = @_;
516     return unless $func;
517     return unless $flags =~ /O/;
518
519     my $alist = join ",", @az[0..$#args];
520     my $ret = "#  define perl_$func($alist)";
521     my $t = (length $ret) >> 3;
522     $ret .=  "\t" x ($t < 5 ? 5 - $t : 1);
523     "$ret$func($alist)\n";
524 } $em;
525
526 print $em <<'END';
527
528 /* varargs functions can't be handled with CPP macros. :-(
529    This provides a set of compatibility functions that don't take
530    an extra argument but grab the context pointer using the macro
531    dTHX.
532  */
533 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
534 END
535
536 foreach (sort keys %has_va) {
537     next unless $has_nocontext{$_};
538     next if /printf/; # Not clear to me why these are skipped but they are.
539     print $em hide($_, "Perl_${_}_nocontext", "  ");
540 }
541
542 print $em <<'END';
543 #endif
544
545 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
546
547 #if !defined(PERL_IMPLICIT_CONTEXT)
548 /* undefined symbols, point them back at the usual ones */
549 END
550
551 foreach (sort keys %has_va) {
552     next unless $has_nocontext{$_};
553     next if /printf/; # Not clear to me why these are skipped but they are.
554     print $em hide("Perl_${_}_nocontext", "Perl_$_", "  ");
555 }
556
557 print $em <<'END';
558 #endif
559
560 /* ex: set ro: */
561 END
562
563 safer_close($em);
564 rename_if_different('embed.h-new', 'embed.h');
565
566 $em = safer_open('embedvar.h-new');
567
568 print $em do_not_edit ("embedvar.h"), <<'END';
569
570 /* (Doing namespace management portably in C is really gross.) */
571
572 /*
573    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
574    are supported:
575      1) none
576      2) MULTIPLICITY    # supported for compatibility
577      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
578
579    All other combinations of these flags are errors.
580
581    only #3 is supported directly, while #2 is a special
582    case of #3 (supported by redefining vTHX appropriately).
583 */
584
585 #if defined(MULTIPLICITY)
586 /* cases 2 and 3 above */
587
588 #  if defined(PERL_IMPLICIT_CONTEXT)
589 #    define vTHX        aTHX
590 #  else
591 #    define vTHX        PERL_GET_INTERP
592 #  endif
593
594 END
595
596 for $sym (sort keys %intrp) {
597     print $em multon($sym,'I','vTHX->');
598 }
599
600 print $em <<'END';
601
602 #else   /* !MULTIPLICITY */
603
604 /* case 1 above */
605
606 END
607
608 for $sym (sort keys %intrp) {
609     print $em multoff($sym,'I');
610 }
611
612 print $em <<'END';
613
614 END
615
616 print $em <<'END';
617
618 #endif  /* MULTIPLICITY */
619
620 #if defined(PERL_GLOBAL_STRUCT)
621
622 END
623
624 for $sym (sort keys %globvar) {
625     print $em multon($sym,   'G','my_vars->');
626     print $em multon("G$sym",'', 'my_vars->');
627 }
628
629 print $em <<'END';
630
631 #else /* !PERL_GLOBAL_STRUCT */
632
633 END
634
635 for $sym (sort keys %globvar) {
636     print $em multoff($sym,'G');
637 }
638
639 print $em <<'END';
640
641 #endif /* PERL_GLOBAL_STRUCT */
642
643 /* ex: set ro: */
644 END
645
646 safer_close($em);
647 rename_if_different('embedvar.h-new', 'embedvar.h');
648
649 my $capi = safer_open('perlapi.c-new');
650 my $capih = safer_open('perlapi.h-new');
651
652 print $capih do_not_edit ("perlapi.h"), <<'EOT';
653
654 /* declare accessor functions for Perl variables */
655 #ifndef __perlapi_h__
656 #define __perlapi_h__
657
658 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
659
660 START_EXTERN_C
661
662 #undef PERLVAR
663 #undef PERLVARA
664 #undef PERLVARI
665 #undef PERLVARIC
666 #undef PERLVARISC
667 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
668 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
669                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
670 #define PERLVARI(v,t,i) PERLVAR(v,t)
671 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
672 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)];       \
673                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
674
675 #include "perlvars.h"
676
677 #undef PERLVAR
678 #undef PERLVARA
679 #undef PERLVARI
680 #undef PERLVARIC
681 #undef PERLVARISC
682
683 END_EXTERN_C
684
685 #if defined(PERL_CORE)
686
687 /* accessor functions for Perl "global" variables */
688
689 /* these need to be mentioned here, or most linkers won't put them in
690    the perl executable */
691
692 #ifndef PERL_NO_FORCE_LINK
693
694 START_EXTERN_C
695
696 #ifndef DOINIT
697 EXTCONST void * const PL_force_link_funcs[];
698 #else
699 EXTCONST void * const PL_force_link_funcs[] = {
700 #undef PERLVAR
701 #undef PERLVARA
702 #undef PERLVARI
703 #undef PERLVARIC
704 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
705 #define PERLVARA(v,n,t) PERLVAR(v,t)
706 #define PERLVARI(v,t,i) PERLVAR(v,t)
707 #define PERLVARIC(v,t,i) PERLVAR(v,t)
708 #define PERLVARISC(v,i) PERLVAR(v,char)
709
710 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
711  * cannot cast between void pointers and function pointers without
712  * info level warnings.  The PL_force_link_funcs[] would cause a few
713  * hundred of those warnings.  In code one can circumnavigate this by using
714  * unions that overlay the different pointers, but in declarations one
715  * cannot use this trick.  Therefore we just disable the warning here
716  * for the duration of the PL_force_link_funcs[] declaration. */
717
718 #if defined(__DECC) && defined(__osf__)
719 #pragma message save
720 #pragma message disable (nonstandcast)
721 #endif
722
723 #include "perlvars.h"
724
725 #if defined(__DECC) && defined(__osf__)
726 #pragma message restore
727 #endif
728
729 #undef PERLVAR
730 #undef PERLVARA
731 #undef PERLVARI
732 #undef PERLVARIC
733 #undef PERLVARISC
734 };
735 #endif  /* DOINIT */
736
737 END_EXTERN_C
738
739 #endif  /* PERL_NO_FORCE_LINK */
740
741 #else   /* !PERL_CORE */
742
743 EOT
744
745 foreach $sym (sort keys %globvar) {
746     print $capih bincompat_var('G',$sym);
747 }
748
749 print $capih <<'EOT';
750
751 #endif /* !PERL_CORE */
752 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
753
754 #endif /* __perlapi_h__ */
755
756 /* ex: set ro: */
757 EOT
758 safer_close($capih);
759 rename_if_different('perlapi.h-new', 'perlapi.h');
760
761 print $capi do_not_edit ("perlapi.c"), <<'EOT';
762
763 #include "EXTERN.h"
764 #include "perl.h"
765 #include "perlapi.h"
766
767 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
768
769 /* accessor functions for Perl "global" variables */
770 START_EXTERN_C
771
772 #undef PERLVARI
773 #define PERLVARI(v,t,i) PERLVAR(v,t)
774
775 #undef PERLVAR
776 #undef PERLVARA
777 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
778                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
779 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
780                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
781 #undef PERLVARIC
782 #undef PERLVARISC
783 #define PERLVARIC(v,t,i)        \
784                         const t* Perl_##v##_ptr(pTHX)           \
785                         { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
786 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)        \
787                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
788 #include "perlvars.h"
789
790 #undef PERLVAR
791 #undef PERLVARA
792 #undef PERLVARI
793 #undef PERLVARIC
794 #undef PERLVARISC
795
796 END_EXTERN_C
797
798 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
799
800 /* ex: set ro: */
801 EOT
802
803 safer_close($capi);
804 rename_if_different('perlapi.c-new', 'perlapi.c');
805
806 # ex: set ts=8 sts=4 sw=4 noet: