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