Fix breakages caused by #31130:
[perl.git] / embed.pl
1 #!/usr/bin/perl -w
2
3 require 5.003;  # keep this compatible, an old perl is all we may have before
4                 # we build the new one
5
6 use strict;
7
8 BEGIN {
9     # Get function prototypes
10     require 'regen_lib.pl';
11 }
12
13 my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org
14
15 #
16 # See database of global and static function prototypes in embed.fnc
17 # This is used to generate prototype headers under various configurations,
18 # export symbols lists for different platforms, and macros to provide an
19 # implicit interpreter context argument.
20 #
21
22 sub do_not_edit ($)
23 {
24     my $file = shift;
25
26     my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007';
27
28     $years =~ s/1999,/1999,\n  / if length $years > 40;
29
30     my $warning = <<EOW;
31  -*- buffer-read-only: t -*-
32
33    $file
34
35    Copyright (C) $years, by Larry Wall and others
36
37    You may distribute under the terms of either the GNU General Public
38    License or the Artistic License, as specified in the README file.
39
40 !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
41 This file is built by embed.pl from data in embed.fnc, embed.pl,
42 pp.sym, intrpvar.h, perlvars.h and thrdvar.h.
43 Any changes made here will be lost!
44
45 Edit those files and run 'make regen_headers' to effect changes.
46
47 EOW
48
49     $warning .= <<EOW if $file eq 'perlapi.c';
50
51 Up to the threshold of the door there mounted a flight of twenty-seven
52 broad stairs, hewn by some unknown art of the same black stone.  This
53 was the only entrance to the tower.
54
55
56 EOW
57
58     if ($file =~ m:\.[ch]$:) {
59         $warning =~ s:^: * :gm;
60         $warning =~ s: +$::gm;
61         $warning =~ s: :/:;
62         $warning =~ s:$:/:;
63     }
64     else {
65         $warning =~ s:^:# :gm;
66         $warning =~ s: +$::gm;
67     }
68     $warning;
69 } # do_not_edit
70
71 open IN, "embed.fnc" or die $!;
72
73 # walk table providing an array of components in each line to
74 # subroutine, printing the result
75 sub walk_table (&@) {
76     my $function = shift;
77     my $filename = shift || '-';
78     my $leader = shift;
79     defined $leader or $leader = do_not_edit ($filename);
80     my $trailer = shift;
81     my $F;
82     local *F;
83     if (ref $filename) {        # filehandle
84         $F = $filename;
85     }
86     else {
87         safer_unlink $filename if $filename ne '/dev/null';
88         open F, ">$filename" or die "Can't open $filename: $!";
89         binmode F;
90         $F = \*F;
91     }
92     print $F $leader if $leader;
93     seek IN, 0, 0;              # so we may restart
94     while (<IN>) {
95         chomp;
96         next if /^:/;
97         while (s|\\$||) {
98             $_ .= <IN>;
99             chomp;
100         }
101         s/\s+$//;
102         my @args;
103         if (/^\s*(#|$)/) {
104             @args = $_;
105         }
106         else {
107             @args = split /\s*\|\s*/, $_;
108         }
109         my @outs = &{$function}(@args);
110         print $F @outs; # $function->(@args) is not 5.003
111     }
112     print $F $trailer if $trailer;
113     unless (ref $filename) {
114         close $F or die "Error closing $filename: $!";
115     }
116 }
117
118 sub munge_c_files () {
119     my $functions = {};
120     unless (@ARGV) {
121         warn "\@ARGV empty, nothing to do\n";
122         return;
123     }
124     walk_table {
125         if (@_ > 1) {
126             $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
127         }
128     } '/dev/null', '', '';
129     local $^I = '.bak';
130     while (<>) {
131         s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
132          {
133             my $repl = $1;
134             my $f = $2;
135             if (exists $functions->{$f}) {
136                 $repl .= "aTHX_ ";
137                 warn("$ARGV:$.:$`#$repl#$'");
138             }
139             $repl;
140          }eg;
141         print;
142         close ARGV if eof;      # restart $.
143     }
144     exit;
145 }
146
147 #munge_c_files();
148
149 # generate proto.h
150 my $wrote_protected = 0;
151
152 sub write_protos {
153     my $ret = "";
154     if (@_ == 1) {
155         my $arg = shift;
156         $ret .= "$arg\n";
157     }
158     else {
159         my ($flags,$retval,$func,@args) = @_;
160         my @nonnull;
161         my $has_context = ( $flags !~ /n/ );
162         my $never_returns = ( $flags =~ /r/ );
163         my $commented_out = ( $flags =~ /m/ );
164         my $is_malloc = ( $flags =~ /a/ );
165         my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
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_$func";
178         }
179         else {
180             $retval = "PERL_CALLCONV $splint_flags$retval";
181             if ($flags =~ /p/) {
182                 $func = "Perl_$func";
183             }
184         }
185         $ret .= "$retval\t$func(";
186         if ( $has_context ) {
187             $ret .= @args ? "pTHX_ " : "pTHX";
188         }
189         if (@args) {
190             my $n;
191             for my $arg ( @args ) {
192                 ++$n;
193                 if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
194                     warn "$func: $arg needs NN or NULLOK\n";
195                     our $unflagged_pointers;
196                     ++$unflagged_pointers;
197                 }
198                 my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
199                 push( @nonnull, $n ) if $nn;
200
201                 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
202
203                 # Make sure each arg has at least a type and a var name.
204                 # An arg of "int" is valid C, but want it to be "int foo".
205                 my $temp_arg = $arg;
206                 $temp_arg =~ s/\*//g;
207                 $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
208                 if ( ($temp_arg ne "...") && ($temp_arg !~ /\w+\s+\w+/) ) {
209                     warn "$func: $arg doesn't have a name\n";
210                 }
211                 if ( $SPLINT && $nullok && !$commented_out ) {
212                     $arg = '/*@null@*/ ' . $arg;
213                 }
214             }
215             $ret .= join ", ", @args;
216         }
217         else {
218             $ret .= "void" if !$has_context;
219         }
220         $ret .= ")";
221         my @attrs;
222         if ( $flags =~ /r/ ) {
223             push @attrs, "__attribute__noreturn__";
224         }
225         if ( $is_malloc ) {
226             push @attrs, "__attribute__malloc__";
227         }
228         if ( !$can_ignore ) {
229             push @attrs, "__attribute__warn_unused_result__";
230         }
231         if ( $flags =~ /P/ ) {
232             push @attrs, "__attribute__pure__";
233         }
234         if( $flags =~ /f/ ) {
235             my $prefix  = $has_context ? 'pTHX_' : '';
236             my $args    = scalar @args;
237             my $pat     = $args - 1;
238             my $macro   = @nonnull && $nonnull[-1] == $pat  
239                                 ? '__attribute__format__'
240                                 : '__attribute__format__null_ok__';
241             push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
242                                 $prefix, $pat, $prefix, $args;
243         }
244         if ( @nonnull ) {
245             my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
246             push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
247         }
248         if ( @attrs ) {
249             $ret .= "\n";
250             $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
251         }
252         $ret .= ";";
253         $ret = "/* $ret */" if $commented_out;
254         $ret .= @attrs ? "\n\n" : "\n";
255     }
256     $ret;
257 }
258
259 # generates global.sym (API export list)
260 {
261   my %seen;
262   sub write_global_sym {
263       my $ret = "";
264       if (@_ > 1) {
265           my ($flags,$retval,$func,@args) = @_;
266           # If a function is defined twice, for example before and after an
267           # #else, only process the flags on the first instance for global.sym
268           return $ret if $seen{$func}++;
269           if ($flags =~ /[AX]/ && $flags !~ /[xm]/
270               || $flags =~ /b/) { # public API, so export
271               $func = "Perl_$func" if $flags =~ /[pbX]/;
272               $ret = "$func\n";
273           }
274       }
275       $ret;
276   }
277 }
278
279
280 our $unflagged_pointers;
281 walk_table(\&write_protos,     "proto.h", undef, "/* ex: set ro: */\n");
282 warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
283 walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
284
285 # XXX others that may need adding
286 #       warnhook
287 #       hints
288 #       copline
289 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
290                  curcop compiling
291                  tainting tainted stack_base stack_sp sv_arenaroot
292                  no_modify
293                  curstash DBsub DBsingle DBassertion debstash
294                  rsfp
295                  stdingv
296                  defgv
297                  errgv
298                  rsfp_filters
299                  perldb
300                  diehook
301                  dirty
302                  perl_destruct_level
303                  ppaddr
304                 );
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\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\n"
337                 if exists $$syms{$sym};
338             $$syms{$sym} = $pre || 1;
339         }
340     }
341     close(FILE);
342 }
343
344 my %intrp;
345 my %thread;
346 my %globvar;
347
348 readvars %intrp,  'intrpvar.h','I';
349 readvars %thread, 'thrdvar.h','T';
350 readvars %globvar, 'perlvars.h','G';
351
352 my $sym;
353 foreach $sym (sort keys %thread) {
354   warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
355 }
356
357 sub undefine ($) {
358     my ($sym) = @_;
359     "#undef  $sym\n";
360 }
361
362 sub hide ($$) {
363     my ($from, $to) = @_;
364     my $t = int(length($from) / 8);
365     "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
366 }
367
368 sub bincompat_var ($$) {
369     my ($pfx, $sym) = @_;
370     my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
371     undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
372 }
373
374 sub multon ($$$) {
375     my ($sym,$pre,$ptr) = @_;
376     hide("PL_$sym", "($ptr$pre$sym)");
377 }
378
379 sub multoff ($$) {
380     my ($sym,$pre) = @_;
381     return hide("PL_$pre$sym", "PL_$sym");
382 }
383
384 safer_unlink 'embed.h';
385 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
386 binmode EM;
387
388 print EM do_not_edit ("embed.h"), <<'END';
389
390 /* (Doing namespace management portably in C is really gross.) */
391
392 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
393  * (like warn instead of Perl_warn) for the API are not defined.
394  * Not defining the short forms is a good thing for cleaner embedding. */
395
396 #ifndef PERL_NO_SHORT_NAMES
397
398 /* Hide global symbols */
399
400 #if !defined(PERL_IMPLICIT_CONTEXT)
401
402 END
403
404 # Try to elimiate lots of repeated
405 # #ifdef PERL_CORE
406 # foo
407 # #endif
408 # #ifdef PERL_CORE
409 # bar
410 # #endif
411 # by tracking state and merging foo and bar into one block.
412 my $ifdef_state = '';
413
414 walk_table {
415     my $ret = "";
416     my $new_ifdef_state = '';
417     if (@_ == 1) {
418         my $arg = shift;
419         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
420     }
421     else {
422         my ($flags,$retval,$func,@args) = @_;
423         unless ($flags =~ /[om]/) {
424             if ($flags =~ /s/) {
425                 $ret .= hide($func,"S_$func");
426             }
427             elsif ($flags =~ /p/) {
428                 $ret .= hide($func,"Perl_$func");
429             }
430         }
431         if ($ret ne '' && $flags !~ /A/) {
432             if ($flags =~ /E/) {
433                 $new_ifdef_state
434                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
435             }
436             else {
437                 $new_ifdef_state = "#ifdef PERL_CORE\n";
438             }
439
440             if ($new_ifdef_state ne $ifdef_state) {
441                 $ret = $new_ifdef_state . $ret;
442             }
443         }
444     }
445     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
446         # Close the old one ahead of opening the new one.
447         $ret = "#endif\n$ret";
448     }
449     # Remember the new state.
450     $ifdef_state = $new_ifdef_state;
451     $ret;
452 } \*EM, "";
453
454 if ($ifdef_state) {
455     print EM "#endif\n";
456 }
457
458 for $sym (sort keys %ppsym) {
459     $sym =~ s/^Perl_//;
460     print EM hide($sym, "Perl_$sym");
461 }
462
463 print EM <<'END';
464
465 #else   /* PERL_IMPLICIT_CONTEXT */
466
467 END
468
469 my @az = ('a'..'z');
470
471 $ifdef_state = '';
472 walk_table {
473     my $ret = "";
474     my $new_ifdef_state = '';
475     if (@_ == 1) {
476         my $arg = shift;
477         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
478     }
479     else {
480         my ($flags,$retval,$func,@args) = @_;
481         unless ($flags =~ /[om]/) {
482             my $args = scalar @args;
483             if ($args and $args[$args-1] =~ /\.\.\./) {
484                 # we're out of luck for varargs functions under CPP
485             }
486             elsif ($flags =~ /n/) {
487                 if ($flags =~ /s/) {
488                     $ret .= hide($func,"S_$func");
489                 }
490                 elsif ($flags =~ /p/) {
491                     $ret .= hide($func,"Perl_$func");
492                 }
493             }
494             else {
495                 my $alist = join(",", @az[0..$args-1]);
496                 $ret = "#define $func($alist)";
497                 my $t = int(length($ret) / 8);
498                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
499                 if ($flags =~ /s/) {
500                     $ret .= "S_$func(aTHX";
501                 }
502                 elsif ($flags =~ /p/) {
503                     $ret .= "Perl_$func(aTHX";
504                 }
505                 $ret .= "_ " if $alist;
506                 $ret .= $alist . ")\n";
507             }
508         }
509         unless ($flags =~ /A/) {
510             if ($flags =~ /E/) {
511                 $new_ifdef_state
512                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
513             }
514             else {
515                 $new_ifdef_state = "#ifdef PERL_CORE\n";
516             }
517
518             if ($new_ifdef_state ne $ifdef_state) {
519                 $ret = $new_ifdef_state . $ret;
520             }
521         }
522     }
523     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
524         # Close the old one ahead of opening the new one.
525         $ret = "#endif\n$ret";
526     }
527     # Remember the new state.
528     $ifdef_state = $new_ifdef_state;
529     $ret;
530 } \*EM, "";
531
532 if ($ifdef_state) {
533     print EM "#endif\n";
534 }
535
536 for $sym (sort keys %ppsym) {
537     $sym =~ s/^Perl_//;
538     if ($sym =~ /^ck_/) {
539         print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
540     }
541     elsif ($sym =~ /^pp_/) {
542         print EM hide("$sym()", "Perl_$sym(aTHX)");
543     }
544     else {
545         warn "Illegal symbol '$sym' in pp.sym";
546     }
547 }
548
549 print EM <<'END';
550
551 #endif  /* PERL_IMPLICIT_CONTEXT */
552
553 #endif  /* #ifndef PERL_NO_SHORT_NAMES */
554
555 END
556
557 print EM <<'END';
558
559 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
560    disable them.
561  */
562
563 #if !defined(PERL_CORE)
564 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
565 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,NULL,PTR2IV(ptr))
566 #endif
567
568 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
569
570 /* Compatibility for various misnamed functions.  All functions
571    in the API that begin with "perl_" (not "Perl_") take an explicit
572    interpreter context pointer.
573    The following are not like that, but since they had a "perl_"
574    prefix in previous versions, we provide compatibility macros.
575  */
576 #  define perl_atexit(a,b)              call_atexit(a,b)
577 #  define perl_call_argv(a,b,c)         call_argv(a,b,c)
578 #  define perl_call_pv(a,b)             call_pv(a,b)
579 #  define perl_call_method(a,b)         call_method(a,b)
580 #  define perl_call_sv(a,b)             call_sv(a,b)
581 #  define perl_eval_sv(a,b)             eval_sv(a,b)
582 #  define perl_eval_pv(a,b)             eval_pv(a,b)
583 #  define perl_require_pv(a)            require_pv(a)
584 #  define perl_get_sv(a,b)              get_sv(a,b)
585 #  define perl_get_av(a,b)              get_av(a,b)
586 #  define perl_get_hv(a,b)              get_hv(a,b)
587 #  define perl_get_cv(a,b)              get_cv(a,b)
588 #  define perl_init_i18nl10n(a)         init_i18nl10n(a)
589 #  define perl_init_i18nl14n(a)         init_i18nl14n(a)
590 #  define perl_new_ctype(a)             new_ctype(a)
591 #  define perl_new_collate(a)           new_collate(a)
592 #  define perl_new_numeric(a)           new_numeric(a)
593
594 /* varargs functions can't be handled with CPP macros. :-(
595    This provides a set of compatibility functions that don't take
596    an extra argument but grab the context pointer using the macro
597    dTHX.
598  */
599 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
600 #  define croak                         Perl_croak_nocontext
601 #  define deb                           Perl_deb_nocontext
602 #  define die                           Perl_die_nocontext
603 #  define form                          Perl_form_nocontext
604 #  define load_module                   Perl_load_module_nocontext
605 #  define mess                          Perl_mess_nocontext
606 #  define newSVpvf                      Perl_newSVpvf_nocontext
607 #  define sv_catpvf                     Perl_sv_catpvf_nocontext
608 #  define sv_setpvf                     Perl_sv_setpvf_nocontext
609 #  define warn                          Perl_warn_nocontext
610 #  define warner                        Perl_warner_nocontext
611 #  define sv_catpvf_mg                  Perl_sv_catpvf_mg_nocontext
612 #  define sv_setpvf_mg                  Perl_sv_setpvf_mg_nocontext
613 #endif
614
615 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
616
617 #if !defined(PERL_IMPLICIT_CONTEXT)
618 /* undefined symbols, point them back at the usual ones */
619 #  define Perl_croak_nocontext          Perl_croak
620 #  define Perl_die_nocontext            Perl_die
621 #  define Perl_deb_nocontext            Perl_deb
622 #  define Perl_form_nocontext           Perl_form
623 #  define Perl_load_module_nocontext    Perl_load_module
624 #  define Perl_mess_nocontext           Perl_mess
625 #  define Perl_newSVpvf_nocontext       Perl_newSVpvf
626 #  define Perl_sv_catpvf_nocontext      Perl_sv_catpvf
627 #  define Perl_sv_setpvf_nocontext      Perl_sv_setpvf
628 #  define Perl_warn_nocontext           Perl_warn
629 #  define Perl_warner_nocontext         Perl_warner
630 #  define Perl_sv_catpvf_mg_nocontext   Perl_sv_catpvf_mg
631 #  define Perl_sv_setpvf_mg_nocontext   Perl_sv_setpvf_mg
632 #endif
633
634 /* ex: set ro: */
635 END
636
637 close(EM) or die "Error closing EM: $!";
638
639 safer_unlink 'embedvar.h';
640 open(EM, '> embedvar.h')
641     or die "Can't create embedvar.h: $!\n";
642 binmode EM;
643
644 print EM do_not_edit ("embedvar.h"), <<'END';
645
646 /* (Doing namespace management portably in C is really gross.) */
647
648 /*
649    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
650    are supported:
651      1) none
652      2) MULTIPLICITY    # supported for compatibility
653      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
654
655    All other combinations of these flags are errors.
656
657    only #3 is supported directly, while #2 is a special
658    case of #3 (supported by redefining vTHX appropriately).
659 */
660
661 #if defined(MULTIPLICITY)
662 /* cases 2 and 3 above */
663
664 #  if defined(PERL_IMPLICIT_CONTEXT)
665 #    define vTHX        aTHX
666 #  else
667 #    define vTHX        PERL_GET_INTERP
668 #  endif
669
670 END
671
672 for $sym (sort keys %thread) {
673     print EM multon($sym,'T','vTHX->');
674 }
675
676 print EM <<'END';
677
678 /* cases 2 and 3 above */
679
680 END
681
682 for $sym (sort keys %intrp) {
683     print EM multon($sym,'I','vTHX->');
684 }
685
686 print EM <<'END';
687
688 #else   /* !MULTIPLICITY */
689
690 /* case 1 above */
691
692 END
693
694 for $sym (sort keys %intrp) {
695     print EM multoff($sym,'I');
696 }
697
698 print EM <<'END';
699
700 END
701
702 for $sym (sort keys %thread) {
703     print EM multoff($sym,'T');
704 }
705
706 print EM <<'END';
707
708 #endif  /* MULTIPLICITY */
709
710 #if defined(PERL_GLOBAL_STRUCT)
711
712 END
713
714 for $sym (sort keys %globvar) {
715     print EM multon($sym,   'G','my_vars->');
716     print EM multon("G$sym",'', 'my_vars->');
717 }
718
719 print EM <<'END';
720
721 #else /* !PERL_GLOBAL_STRUCT */
722
723 END
724
725 for $sym (sort keys %globvar) {
726     print EM multoff($sym,'G');
727 }
728
729 print EM <<'END';
730
731 #endif /* PERL_GLOBAL_STRUCT */
732
733 #ifdef PERL_POLLUTE             /* disabled by default in 5.6.0 */
734
735 END
736
737 for $sym (sort @extvars) {
738     print EM hide($sym,"PL_$sym");
739 }
740
741 print EM <<'END';
742
743 #endif /* PERL_POLLUTE */
744
745 /* ex: set ro: */
746 END
747
748 close(EM) or die "Error closing EM: $!";
749
750 safer_unlink 'perlapi.h';
751 safer_unlink 'perlapi.c';
752 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
753 binmode CAPI;
754 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
755 binmode CAPIH;
756
757 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
758
759 /* declare accessor functions for Perl variables */
760 #ifndef __perlapi_h__
761 #define __perlapi_h__
762
763 #if defined (MULTIPLICITY)
764
765 START_EXTERN_C
766
767 #undef PERLVAR
768 #undef PERLVARA
769 #undef PERLVARI
770 #undef PERLVARIC
771 #undef PERLVARISC
772 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
773 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
774                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
775 #define PERLVARI(v,t,i) PERLVAR(v,t)
776 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
777 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)];       \
778                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
779
780 #include "thrdvar.h"
781 #include "intrpvar.h"
782 #include "perlvars.h"
783
784 #undef PERLVAR
785 #undef PERLVARA
786 #undef PERLVARI
787 #undef PERLVARIC
788 #undef PERLVARISC
789
790 #ifndef PERL_GLOBAL_STRUCT
791 EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
792 EXTERN_C Perl_check_t**  Perl_Gcheck_ptr(pTHX);
793 EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
794 #define Perl_ppaddr_ptr      Perl_Gppaddr_ptr
795 #define Perl_check_ptr       Perl_Gcheck_ptr
796 #define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
797 #endif
798
799 END_EXTERN_C
800
801 #if defined(PERL_CORE)
802
803 /* accessor functions for Perl variables (provide binary compatibility) */
804
805 /* these need to be mentioned here, or most linkers won't put them in
806    the perl executable */
807
808 #ifndef PERL_NO_FORCE_LINK
809
810 START_EXTERN_C
811
812 #ifndef DOINIT
813 EXTCONST void * const PL_force_link_funcs[];
814 #else
815 EXTCONST void * const PL_force_link_funcs[] = {
816 #undef PERLVAR
817 #undef PERLVARA
818 #undef PERLVARI
819 #undef PERLVARIC
820 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
821 #define PERLVARA(v,n,t) PERLVAR(v,t)
822 #define PERLVARI(v,t,i) PERLVAR(v,t)
823 #define PERLVARIC(v,t,i) PERLVAR(v,t)
824 #define PERLVARISC(v,i) PERLVAR(v,char)
825
826 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
827  * cannot cast between void pointers and function pointers without
828  * info level warnings.  The PL_force_link_funcs[] would cause a few
829  * hundred of those warnings.  In code one can circumnavigate this by using
830  * unions that overlay the different pointers, but in declarations one
831  * cannot use this trick.  Therefore we just disable the warning here
832  * for the duration of the PL_force_link_funcs[] declaration. */
833
834 #if defined(__DECC) && defined(__osf__)
835 #pragma message save
836 #pragma message disable (nonstandcast)
837 #endif
838
839 #include "thrdvar.h"
840 #include "intrpvar.h"
841 #include "perlvars.h"
842
843 #if defined(__DECC) && defined(__osf__)
844 #pragma message restore
845 #endif
846
847 #undef PERLVAR
848 #undef PERLVARA
849 #undef PERLVARI
850 #undef PERLVARIC
851 #undef PERLVARISC
852 };
853 #endif  /* DOINIT */
854
855 END_EXTERN_C
856
857 #endif  /* PERL_NO_FORCE_LINK */
858
859 #else   /* !PERL_CORE */
860
861 EOT
862
863 foreach $sym (sort keys %intrp) {
864     print CAPIH bincompat_var('I',$sym);
865 }
866
867 foreach $sym (sort keys %thread) {
868     print CAPIH bincompat_var('T',$sym);
869 }
870
871 foreach $sym (sort keys %globvar) {
872     print CAPIH bincompat_var('G',$sym);
873 }
874
875 print CAPIH <<'EOT';
876
877 #endif /* !PERL_CORE */
878 #endif /* MULTIPLICITY */
879
880 #endif /* __perlapi_h__ */
881
882 /* ex: set ro: */
883 EOT
884 close CAPIH or die "Error closing CAPIH: $!";
885
886 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
887
888 #include "EXTERN.h"
889 #include "perl.h"
890 #include "perlapi.h"
891
892 #if defined (MULTIPLICITY)
893
894 /* accessor functions for Perl variables (provides binary compatibility) */
895 START_EXTERN_C
896
897 #undef PERLVAR
898 #undef PERLVARA
899 #undef PERLVARI
900 #undef PERLVARIC
901 #undef PERLVARISC
902
903 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
904                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
905 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
906                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
907
908 #define PERLVARI(v,t,i) PERLVAR(v,t)
909 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
910 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
911                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
912
913 #include "thrdvar.h"
914 #include "intrpvar.h"
915
916 #undef PERLVAR
917 #undef PERLVARA
918 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
919                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
920 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
921                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
922 #undef PERLVARIC
923 #undef PERLVARISC
924 #define PERLVARIC(v,t,i)        \
925                         const t* Perl_##v##_ptr(pTHX)           \
926                         { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
927 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)        \
928                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
929 #include "perlvars.h"
930
931 #undef PERLVAR
932 #undef PERLVARA
933 #undef PERLVARI
934 #undef PERLVARIC
935 #undef PERLVARISC
936
937 #ifndef PERL_GLOBAL_STRUCT
938 /* A few evil special cases.  Could probably macrofy this. */
939 #undef PL_ppaddr
940 #undef PL_check
941 #undef PL_fold_locale
942 Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
943     static Perl_ppaddr_t* const ppaddr_ptr = PL_ppaddr;
944     PERL_UNUSED_CONTEXT;
945     return (Perl_ppaddr_t**)&ppaddr_ptr;
946 }
947 Perl_check_t**  Perl_Gcheck_ptr(pTHX) {
948     static Perl_check_t* const check_ptr  = PL_check;
949     PERL_UNUSED_CONTEXT;
950     return (Perl_check_t**)&check_ptr;
951 }
952 unsigned char** Perl_Gfold_locale_ptr(pTHX) {
953     static unsigned char* const fold_locale_ptr = PL_fold_locale;
954     PERL_UNUSED_CONTEXT;
955     return (unsigned char**)&fold_locale_ptr;
956 }
957 #endif
958
959 END_EXTERN_C
960
961 #endif /* MULTIPLICITY */
962
963 /* ex: set ro: */
964 EOT
965
966 close(CAPI) or die "Error closing CAPI: $!";
967
968 # functions that take va_list* for implementing vararg functions
969 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
970 # XXX %vfuncs currently unused
971 my %vfuncs = qw(
972     Perl_croak                  Perl_vcroak
973     Perl_warn                   Perl_vwarn
974     Perl_warner                 Perl_vwarner
975     Perl_die                    Perl_vdie
976     Perl_form                   Perl_vform
977     Perl_load_module            Perl_vload_module
978     Perl_mess                   Perl_vmess
979     Perl_deb                    Perl_vdeb
980     Perl_newSVpvf               Perl_vnewSVpvf
981     Perl_sv_setpvf              Perl_sv_vsetpvf
982     Perl_sv_setpvf_mg           Perl_sv_vsetpvf_mg
983     Perl_sv_catpvf              Perl_sv_vcatpvf
984     Perl_sv_catpvf_mg           Perl_sv_vcatpvf_mg
985     Perl_dump_indent            Perl_dump_vindent
986     Perl_default_protect        Perl_vdefault_protect
987 );
988
989 # ex: set ts=8 sts=4 sw=4 noet: