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