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