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