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