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