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