Fwd: CPAN Upload: Y/YV/YVES/ExtUtils-Install-1.45.tar.gz
[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, and perlvars.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,$plain_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         my @names_of_nn;
167         my $func;
168
169         my $splint_flags = "";
170         if ( $SPLINT && !$commented_out ) {
171             $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
172             if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
173                 $retval .= " /*\@alt void\@*/";
174             }
175         }
176
177         if ($flags =~ /s/) {
178             $retval = "STATIC $splint_flags$retval";
179             $func = "S_$plain_func";
180         }
181         else {
182             $retval = "PERL_CALLCONV $splint_flags$retval";
183             if ($flags =~ /[bp]/) {
184                 $func = "Perl_$plain_func";
185             } else {
186                 $func = $plain_func;
187             }
188         }
189         $ret .= "$retval\t$func(";
190         if ( $has_context ) {
191             $ret .= @args ? "pTHX_ " : "pTHX";
192         }
193         if (@args) {
194             my $n;
195             for my $arg ( @args ) {
196                 ++$n;
197                 if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
198                     warn "$func: $arg needs NN or NULLOK\n";
199                     our $unflagged_pointers;
200                     ++$unflagged_pointers;
201                 }
202                 my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
203                 push( @nonnull, $n ) if $nn;
204
205                 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
206
207                 # Make sure each arg has at least a type and a var name.
208                 # An arg of "int" is valid C, but want it to be "int foo".
209                 my $temp_arg = $arg;
210                 $temp_arg =~ s/\*//g;
211                 $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
212                 if ( ($temp_arg ne "...")
213                      && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
214                     warn "$func: $arg ($n) doesn't have a name\n";
215                 }
216                 if ( $SPLINT && $nullok && !$commented_out ) {
217                     $arg = '/*@null@*/ ' . $arg;
218                 }
219                 if (defined $1 && $nn) {
220                     push @names_of_nn, $1;
221                 }
222             }
223             $ret .= join ", ", @args;
224         }
225         else {
226             $ret .= "void" if !$has_context;
227         }
228         $ret .= ")";
229         my @attrs;
230         if ( $flags =~ /r/ ) {
231             push @attrs, "__attribute__noreturn__";
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       my $ret = "";
276       if (@_ > 1) {
277           my ($flags,$retval,$func,@args) = @_;
278           # If a function is defined twice, for example before and after an
279           # #else, only process the flags on the first instance for global.sym
280           return $ret if $seen{$func}++;
281           if ($flags =~ /[AX]/ && $flags !~ /[xm]/
282               || $flags =~ /b/) { # public API, so export
283               $func = "Perl_$func" if $flags =~ /[pbX]/;
284               $ret = "$func\n";
285           }
286       }
287       $ret;
288   }
289 }
290
291
292 our $unflagged_pointers;
293 walk_table(\&write_protos,     "proto.h", undef, "/* ex: set ro: */\n");
294 warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
295 walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
296
297 # XXX others that may need adding
298 #       warnhook
299 #       hints
300 #       copline
301 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
302                  curcop compiling
303                  tainting tainted stack_base stack_sp sv_arenaroot
304                  no_modify
305                  curstash DBsub DBsingle DBassertion debstash
306                  rsfp
307                  stdingv
308                  defgv
309                  errgv
310                  rsfp_filters
311                  perldb
312                  diehook
313                  dirty
314                  perl_destruct_level
315                  ppaddr
316                 );
317
318 sub readsyms (\%$) {
319     my ($syms, $file) = @_;
320     local (*FILE, $_);
321     open(FILE, "< $file")
322         or die "embed.pl: Can't open $file: $!\n";
323     while (<FILE>) {
324         s/[ \t]*#.*//;          # Delete comments.
325         if (/^\s*(\S+)\s*$/) {
326             my $sym = $1;
327             warn "duplicate symbol $sym while processing $file line $.\n"
328                 if exists $$syms{$sym};
329             $$syms{$sym} = 1;
330         }
331     }
332     close(FILE);
333 }
334
335 # Perl_pp_* and Perl_ck_* are in pp.sym
336 readsyms my %ppsym, 'pp.sym';
337
338 sub readvars(\%$$@) {
339     my ($syms, $file,$pre,$keep_pre) = @_;
340     local (*FILE, $_);
341     open(FILE, "< $file")
342         or die "embed.pl: Can't open $file: $!\n";
343     while (<FILE>) {
344         s/[ \t]*#.*//;          # Delete comments.
345         if (/PERLVARA?I?S?C?\($pre(\w+)/) {
346             my $sym = $1;
347             $sym = $pre . $sym if $keep_pre;
348             warn "duplicate symbol $sym while processing $file line $.\n"
349                 if exists $$syms{$sym};
350             $$syms{$sym} = $pre || 1;
351         }
352     }
353     close(FILE);
354 }
355
356 my %intrp;
357 my %globvar;
358
359 readvars %intrp,  'intrpvar.h','I';
360 readvars %globvar, 'perlvars.h','G';
361
362 my $sym;
363
364 sub undefine ($) {
365     my ($sym) = @_;
366     "#undef  $sym\n";
367 }
368
369 sub hide ($$) {
370     my ($from, $to) = @_;
371     my $t = int(length($from) / 8);
372     "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
373 }
374
375 sub bincompat_var ($$) {
376     my ($pfx, $sym) = @_;
377     my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
378     undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
379 }
380
381 sub multon ($$$) {
382     my ($sym,$pre,$ptr) = @_;
383     hide("PL_$sym", "($ptr$pre$sym)");
384 }
385
386 sub multoff ($$) {
387     my ($sym,$pre) = @_;
388     return hide("PL_$pre$sym", "PL_$sym");
389 }
390
391 safer_unlink 'embed.h';
392 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
393 binmode EM;
394
395 print EM do_not_edit ("embed.h"), <<'END';
396
397 /* (Doing namespace management portably in C is really gross.) */
398
399 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
400  * (like warn instead of Perl_warn) for the API are not defined.
401  * Not defining the short forms is a good thing for cleaner embedding. */
402
403 #ifndef PERL_NO_SHORT_NAMES
404
405 /* Hide global symbols */
406
407 #if !defined(PERL_IMPLICIT_CONTEXT)
408
409 END
410
411 # Try to elimiate lots of repeated
412 # #ifdef PERL_CORE
413 # foo
414 # #endif
415 # #ifdef PERL_CORE
416 # bar
417 # #endif
418 # by tracking state and merging foo and bar into one block.
419 my $ifdef_state = '';
420
421 walk_table {
422     my $ret = "";
423     my $new_ifdef_state = '';
424     if (@_ == 1) {
425         my $arg = shift;
426         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
427     }
428     else {
429         my ($flags,$retval,$func,@args) = @_;
430         unless ($flags =~ /[om]/) {
431             if ($flags =~ /s/) {
432                 $ret .= hide($func,"S_$func");
433             }
434             elsif ($flags =~ /p/) {
435                 $ret .= hide($func,"Perl_$func");
436             }
437         }
438         if ($ret ne '' && $flags !~ /A/) {
439             if ($flags =~ /E/) {
440                 $new_ifdef_state
441                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
442             }
443             else {
444                 $new_ifdef_state = "#ifdef PERL_CORE\n";
445             }
446
447             if ($new_ifdef_state ne $ifdef_state) {
448                 $ret = $new_ifdef_state . $ret;
449             }
450         }
451     }
452     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
453         # Close the old one ahead of opening the new one.
454         $ret = "#endif\n$ret";
455     }
456     # Remember the new state.
457     $ifdef_state = $new_ifdef_state;
458     $ret;
459 } \*EM, "";
460
461 if ($ifdef_state) {
462     print EM "#endif\n";
463 }
464
465 for $sym (sort keys %ppsym) {
466     $sym =~ s/^Perl_//;
467     print EM hide($sym, "Perl_$sym");
468 }
469
470 print EM <<'END';
471
472 #else   /* PERL_IMPLICIT_CONTEXT */
473
474 END
475
476 my @az = ('a'..'z');
477
478 $ifdef_state = '';
479 walk_table {
480     my $ret = "";
481     my $new_ifdef_state = '';
482     if (@_ == 1) {
483         my $arg = shift;
484         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
485     }
486     else {
487         my ($flags,$retval,$func,@args) = @_;
488         unless ($flags =~ /[om]/) {
489             my $args = scalar @args;
490             if ($args and $args[$args-1] =~ /\.\.\./) {
491                 # we're out of luck for varargs functions under CPP
492             }
493             elsif ($flags =~ /n/) {
494                 if ($flags =~ /s/) {
495                     $ret .= hide($func,"S_$func");
496                 }
497                 elsif ($flags =~ /p/) {
498                     $ret .= hide($func,"Perl_$func");
499                 }
500             }
501             else {
502                 my $alist = join(",", @az[0..$args-1]);
503                 $ret = "#define $func($alist)";
504                 my $t = int(length($ret) / 8);
505                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
506                 if ($flags =~ /s/) {
507                     $ret .= "S_$func(aTHX";
508                 }
509                 elsif ($flags =~ /p/) {
510                     $ret .= "Perl_$func(aTHX";
511                 }
512                 $ret .= "_ " if $alist;
513                 $ret .= $alist . ")\n";
514             }
515         }
516         unless ($flags =~ /A/) {
517             if ($flags =~ /E/) {
518                 $new_ifdef_state
519                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
520             }
521             else {
522                 $new_ifdef_state = "#ifdef PERL_CORE\n";
523             }
524
525             if ($new_ifdef_state ne $ifdef_state) {
526                 $ret = $new_ifdef_state . $ret;
527             }
528         }
529     }
530     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
531         # Close the old one ahead of opening the new one.
532         $ret = "#endif\n$ret";
533     }
534     # Remember the new state.
535     $ifdef_state = $new_ifdef_state;
536     $ret;
537 } \*EM, "";
538
539 if ($ifdef_state) {
540     print EM "#endif\n";
541 }
542
543 for $sym (sort keys %ppsym) {
544     $sym =~ s/^Perl_//;
545     if ($sym =~ /^ck_/) {
546         print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
547     }
548     elsif ($sym =~ /^pp_/) {
549         print EM hide("$sym()", "Perl_$sym(aTHX)");
550     }
551     else {
552         warn "Illegal symbol '$sym' in pp.sym";
553     }
554 }
555
556 print EM <<'END';
557
558 #endif  /* PERL_IMPLICIT_CONTEXT */
559
560 #endif  /* #ifndef PERL_NO_SHORT_NAMES */
561
562 END
563
564 print EM <<'END';
565
566 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
567    disable them.
568  */
569
570 #if !defined(PERL_CORE)
571 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
572 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,NULL,PTR2IV(ptr))
573 #endif
574
575 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
576
577 /* Compatibility for various misnamed functions.  All functions
578    in the API that begin with "perl_" (not "Perl_") take an explicit
579    interpreter context pointer.
580    The following are not like that, but since they had a "perl_"
581    prefix in previous versions, we provide compatibility macros.
582  */
583 #  define perl_atexit(a,b)              call_atexit(a,b)
584 #  define perl_call_argv(a,b,c)         call_argv(a,b,c)
585 #  define perl_call_pv(a,b)             call_pv(a,b)
586 #  define perl_call_method(a,b)         call_method(a,b)
587 #  define perl_call_sv(a,b)             call_sv(a,b)
588 #  define perl_eval_sv(a,b)             eval_sv(a,b)
589 #  define perl_eval_pv(a,b)             eval_pv(a,b)
590 #  define perl_require_pv(a)            require_pv(a)
591 #  define perl_get_sv(a,b)              get_sv(a,b)
592 #  define perl_get_av(a,b)              get_av(a,b)
593 #  define perl_get_hv(a,b)              get_hv(a,b)
594 #  define perl_get_cv(a,b)              get_cv(a,b)
595 #  define perl_init_i18nl10n(a)         init_i18nl10n(a)
596 #  define perl_init_i18nl14n(a)         init_i18nl14n(a)
597 #  define perl_new_ctype(a)             new_ctype(a)
598 #  define perl_new_collate(a)           new_collate(a)
599 #  define perl_new_numeric(a)           new_numeric(a)
600
601 /* varargs functions can't be handled with CPP macros. :-(
602    This provides a set of compatibility functions that don't take
603    an extra argument but grab the context pointer using the macro
604    dTHX.
605  */
606 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
607 #  define croak                         Perl_croak_nocontext
608 #  define deb                           Perl_deb_nocontext
609 #  define die                           Perl_die_nocontext
610 #  define form                          Perl_form_nocontext
611 #  define load_module                   Perl_load_module_nocontext
612 #  define mess                          Perl_mess_nocontext
613 #  define newSVpvf                      Perl_newSVpvf_nocontext
614 #  define sv_catpvf                     Perl_sv_catpvf_nocontext
615 #  define sv_setpvf                     Perl_sv_setpvf_nocontext
616 #  define warn                          Perl_warn_nocontext
617 #  define warner                        Perl_warner_nocontext
618 #  define sv_catpvf_mg                  Perl_sv_catpvf_mg_nocontext
619 #  define sv_setpvf_mg                  Perl_sv_setpvf_mg_nocontext
620 #endif
621
622 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
623
624 #if !defined(PERL_IMPLICIT_CONTEXT)
625 /* undefined symbols, point them back at the usual ones */
626 #  define Perl_croak_nocontext          Perl_croak
627 #  define Perl_die_nocontext            Perl_die
628 #  define Perl_deb_nocontext            Perl_deb
629 #  define Perl_form_nocontext           Perl_form
630 #  define Perl_load_module_nocontext    Perl_load_module
631 #  define Perl_mess_nocontext           Perl_mess
632 #  define Perl_newSVpvf_nocontext       Perl_newSVpvf
633 #  define Perl_sv_catpvf_nocontext      Perl_sv_catpvf
634 #  define Perl_sv_setpvf_nocontext      Perl_sv_setpvf
635 #  define Perl_warn_nocontext           Perl_warn
636 #  define Perl_warner_nocontext         Perl_warner
637 #  define Perl_sv_catpvf_mg_nocontext   Perl_sv_catpvf_mg
638 #  define Perl_sv_setpvf_mg_nocontext   Perl_sv_setpvf_mg
639 #endif
640
641 /* ex: set ro: */
642 END
643
644 close(EM) or die "Error closing EM: $!";
645
646 safer_unlink 'embedvar.h';
647 open(EM, '> embedvar.h')
648     or die "Can't create embedvar.h: $!\n";
649 binmode EM;
650
651 print EM do_not_edit ("embedvar.h"), <<'END';
652
653 /* (Doing namespace management portably in C is really gross.) */
654
655 /*
656    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
657    are supported:
658      1) none
659      2) MULTIPLICITY    # supported for compatibility
660      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
661
662    All other combinations of these flags are errors.
663
664    only #3 is supported directly, while #2 is a special
665    case of #3 (supported by redefining vTHX appropriately).
666 */
667
668 #if defined(MULTIPLICITY)
669 /* cases 2 and 3 above */
670
671 #  if defined(PERL_IMPLICIT_CONTEXT)
672 #    define vTHX        aTHX
673 #  else
674 #    define vTHX        PERL_GET_INTERP
675 #  endif
676
677 END
678
679 for $sym (sort keys %intrp) {
680     print EM multon($sym,'I','vTHX->');
681 }
682
683 print EM <<'END';
684
685 #else   /* !MULTIPLICITY */
686
687 /* case 1 above */
688
689 END
690
691 for $sym (sort keys %intrp) {
692     print EM multoff($sym,'I');
693 }
694
695 print EM <<'END';
696
697 END
698
699 print EM <<'END';
700
701 #endif  /* MULTIPLICITY */
702
703 #if defined(PERL_GLOBAL_STRUCT)
704
705 END
706
707 for $sym (sort keys %globvar) {
708     print EM multon($sym,   'G','my_vars->');
709     print EM multon("G$sym",'', 'my_vars->');
710 }
711
712 print EM <<'END';
713
714 #else /* !PERL_GLOBAL_STRUCT */
715
716 END
717
718 for $sym (sort keys %globvar) {
719     print EM multoff($sym,'G');
720 }
721
722 print EM <<'END';
723
724 #endif /* PERL_GLOBAL_STRUCT */
725
726 #ifdef PERL_POLLUTE             /* disabled by default in 5.6.0 */
727
728 END
729
730 for $sym (sort @extvars) {
731     print EM hide($sym,"PL_$sym");
732 }
733
734 print EM <<'END';
735
736 #endif /* PERL_POLLUTE */
737
738 /* ex: set ro: */
739 END
740
741 close(EM) or die "Error closing EM: $!";
742
743 safer_unlink 'perlapi.h';
744 safer_unlink 'perlapi.c';
745 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
746 binmode CAPI;
747 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
748 binmode CAPIH;
749
750 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
751
752 /* declare accessor functions for Perl variables */
753 #ifndef __perlapi_h__
754 #define __perlapi_h__
755
756 #if defined (MULTIPLICITY)
757
758 START_EXTERN_C
759
760 #undef PERLVAR
761 #undef PERLVARA
762 #undef PERLVARI
763 #undef PERLVARIC
764 #undef PERLVARISC
765 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
766 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
767                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
768 #define PERLVARI(v,t,i) PERLVAR(v,t)
769 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
770 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)];       \
771                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
772
773 #include "intrpvar.h"
774 #include "perlvars.h"
775
776 #undef PERLVAR
777 #undef PERLVARA
778 #undef PERLVARI
779 #undef PERLVARIC
780 #undef PERLVARISC
781
782 #ifndef PERL_GLOBAL_STRUCT
783 EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
784 EXTERN_C Perl_check_t**  Perl_Gcheck_ptr(pTHX);
785 EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
786 #define Perl_ppaddr_ptr      Perl_Gppaddr_ptr
787 #define Perl_check_ptr       Perl_Gcheck_ptr
788 #define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
789 #endif
790
791 END_EXTERN_C
792
793 #if defined(PERL_CORE)
794
795 /* accessor functions for Perl variables (provide binary compatibility) */
796
797 /* these need to be mentioned here, or most linkers won't put them in
798    the perl executable */
799
800 #ifndef PERL_NO_FORCE_LINK
801
802 START_EXTERN_C
803
804 #ifndef DOINIT
805 EXTCONST void * const PL_force_link_funcs[];
806 #else
807 EXTCONST void * const PL_force_link_funcs[] = {
808 #undef PERLVAR
809 #undef PERLVARA
810 #undef PERLVARI
811 #undef PERLVARIC
812 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
813 #define PERLVARA(v,n,t) PERLVAR(v,t)
814 #define PERLVARI(v,t,i) PERLVAR(v,t)
815 #define PERLVARIC(v,t,i) PERLVAR(v,t)
816 #define PERLVARISC(v,i) PERLVAR(v,char)
817
818 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
819  * cannot cast between void pointers and function pointers without
820  * info level warnings.  The PL_force_link_funcs[] would cause a few
821  * hundred of those warnings.  In code one can circumnavigate this by using
822  * unions that overlay the different pointers, but in declarations one
823  * cannot use this trick.  Therefore we just disable the warning here
824  * for the duration of the PL_force_link_funcs[] declaration. */
825
826 #if defined(__DECC) && defined(__osf__)
827 #pragma message save
828 #pragma message disable (nonstandcast)
829 #endif
830
831 #include "intrpvar.h"
832 #include "perlvars.h"
833
834 #if defined(__DECC) && defined(__osf__)
835 #pragma message restore
836 #endif
837
838 #undef PERLVAR
839 #undef PERLVARA
840 #undef PERLVARI
841 #undef PERLVARIC
842 #undef PERLVARISC
843 };
844 #endif  /* DOINIT */
845
846 END_EXTERN_C
847
848 #endif  /* PERL_NO_FORCE_LINK */
849
850 #else   /* !PERL_CORE */
851
852 EOT
853
854 foreach $sym (sort keys %intrp) {
855     print CAPIH bincompat_var('I',$sym);
856 }
857
858 foreach $sym (sort keys %globvar) {
859     print CAPIH bincompat_var('G',$sym);
860 }
861
862 print CAPIH <<'EOT';
863
864 #endif /* !PERL_CORE */
865 #endif /* MULTIPLICITY */
866
867 #endif /* __perlapi_h__ */
868
869 /* ex: set ro: */
870 EOT
871 close CAPIH or die "Error closing CAPIH: $!";
872
873 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
874
875 #include "EXTERN.h"
876 #include "perl.h"
877 #include "perlapi.h"
878
879 #if defined (MULTIPLICITY)
880
881 /* accessor functions for Perl variables (provides binary compatibility) */
882 START_EXTERN_C
883
884 #undef PERLVAR
885 #undef PERLVARA
886 #undef PERLVARI
887 #undef PERLVARIC
888 #undef PERLVARISC
889
890 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
891                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
892 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
893                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
894
895 #define PERLVARI(v,t,i) PERLVAR(v,t)
896 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
897 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
898                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
899
900 #include "intrpvar.h"
901
902 #undef PERLVAR
903 #undef PERLVARA
904 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
905                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
906 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
907                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
908 #undef PERLVARIC
909 #undef PERLVARISC
910 #define PERLVARIC(v,t,i)        \
911                         const t* Perl_##v##_ptr(pTHX)           \
912                         { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
913 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)        \
914                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
915 #include "perlvars.h"
916
917 #undef PERLVAR
918 #undef PERLVARA
919 #undef PERLVARI
920 #undef PERLVARIC
921 #undef PERLVARISC
922
923 #ifndef PERL_GLOBAL_STRUCT
924 /* A few evil special cases.  Could probably macrofy this. */
925 #undef PL_ppaddr
926 #undef PL_check
927 #undef PL_fold_locale
928 Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
929     static Perl_ppaddr_t* const ppaddr_ptr = PL_ppaddr;
930     PERL_UNUSED_CONTEXT;
931     return (Perl_ppaddr_t**)&ppaddr_ptr;
932 }
933 Perl_check_t**  Perl_Gcheck_ptr(pTHX) {
934     static Perl_check_t* const check_ptr  = PL_check;
935     PERL_UNUSED_CONTEXT;
936     return (Perl_check_t**)&check_ptr;
937 }
938 unsigned char** Perl_Gfold_locale_ptr(pTHX) {
939     static unsigned char* const fold_locale_ptr = PL_fold_locale;
940     PERL_UNUSED_CONTEXT;
941     return (unsigned char**)&fold_locale_ptr;
942 }
943 #endif
944
945 END_EXTERN_C
946
947 #endif /* MULTIPLICITY */
948
949 /* ex: set ro: */
950 EOT
951
952 close(CAPI) or die "Error closing CAPI: $!";
953
954 # functions that take va_list* for implementing vararg functions
955 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
956 # XXX %vfuncs currently unused
957 my %vfuncs = qw(
958     Perl_croak                  Perl_vcroak
959     Perl_warn                   Perl_vwarn
960     Perl_warner                 Perl_vwarner
961     Perl_die                    Perl_vdie
962     Perl_form                   Perl_vform
963     Perl_load_module            Perl_vload_module
964     Perl_mess                   Perl_vmess
965     Perl_deb                    Perl_vdeb
966     Perl_newSVpvf               Perl_vnewSVpvf
967     Perl_sv_setpvf              Perl_sv_vsetpvf
968     Perl_sv_setpvf_mg           Perl_sv_vsetpvf_mg
969     Perl_sv_catpvf              Perl_sv_vcatpvf
970     Perl_sv_catpvf_mg           Perl_sv_vcatpvf_mg
971     Perl_dump_indent            Perl_dump_vindent
972     Perl_default_protect        Perl_vdefault_protect
973 );
974
975 # ex: set ts=8 sts=4 sw=4 noet: