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