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