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