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