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