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