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