Remove Encode::Tcl::Extended, suggested by
[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 at the __END__.
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 /* provide binary compatible (but inconsistent) names */
322 #if defined(PERL_BINCOMPAT_5005)
323 #  define  Perl_call_atexit             perl_atexit
324 #  define  Perl_eval_sv                 perl_eval_sv
325 #  define  Perl_eval_pv                 perl_eval_pv
326 #  define  Perl_call_argv               perl_call_argv
327 #  define  Perl_call_method             perl_call_method
328 #  define  Perl_call_pv                 perl_call_pv
329 #  define  Perl_call_sv                 perl_call_sv
330 #  define  Perl_get_av                  perl_get_av
331 #  define  Perl_get_cv                  perl_get_cv
332 #  define  Perl_get_hv                  perl_get_hv
333 #  define  Perl_get_sv                  perl_get_sv
334 #  define  Perl_init_i18nl10n           perl_init_i18nl10n
335 #  define  Perl_init_i18nl14n           perl_init_i18nl14n
336 #  define  Perl_new_collate             perl_new_collate
337 #  define  Perl_new_ctype               perl_new_ctype
338 #  define  Perl_new_numeric             perl_new_numeric
339 #  define  Perl_require_pv              perl_require_pv
340 #  define  Perl_safesyscalloc           Perl_safecalloc
341 #  define  Perl_safesysfree             Perl_safefree
342 #  define  Perl_safesysmalloc           Perl_safemalloc
343 #  define  Perl_safesysrealloc          Perl_saferealloc
344 #  define  Perl_set_numeric_local       perl_set_numeric_local
345 #  define  Perl_set_numeric_standard    perl_set_numeric_standard
346 /* malloc() pollution was the default in earlier versions, so enable
347  * it for bincompat; but not for systems that used to do prevent that,
348  * or when they ask for {HIDE,EMBED}MYMALLOC */
349 #  if !defined(EMBEDMYMALLOC) && !defined(HIDEMYMALLOC)
350 #    if !defined(NeXT) && !defined(__NeXT) && !defined(__MACHTEN__) && \
351         !defined(__QNX__)
352 #      define  PERL_POLLUTE_MALLOC
353 #    endif
354 #  endif
355 #endif
356
357 /* Hide global symbols */
358
359 #if !defined(PERL_IMPLICIT_CONTEXT)
360
361 END
362
363 walk_table {
364     my $ret = "";
365     if (@_ == 1) {
366         my $arg = shift;
367         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
368     }
369     else {
370         my ($flags,$retval,$func,@args) = @_;
371         unless ($flags =~ /[om]/) {
372             if ($flags =~ /s/) {
373                 $ret .= hide($func,"S_$func");
374             }
375             elsif ($flags =~ /p/) {
376                 $ret .= hide($func,"Perl_$func");
377             }
378         }
379     }
380     $ret;
381 } \*EM;
382
383 for $sym (sort keys %ppsym) {
384     $sym =~ s/^Perl_//;
385     print EM hide($sym, "Perl_$sym");
386 }
387
388 print EM <<'END';
389
390 #else   /* PERL_IMPLICIT_CONTEXT */
391
392 END
393
394 my @az = ('a'..'z');
395
396 walk_table {
397     my $ret = "";
398     if (@_ == 1) {
399         my $arg = shift;
400         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
401     }
402     else {
403         my ($flags,$retval,$func,@args) = @_;
404         unless ($flags =~ /[om]/) {
405             my $args = scalar @args;
406             if ($args and $args[$args-1] =~ /\.\.\./) {
407                 # we're out of luck for varargs functions under CPP
408             }
409             elsif ($flags =~ /n/) {
410                 if ($flags =~ /s/) {
411                     $ret .= hide($func,"S_$func");
412                 }
413                 elsif ($flags =~ /p/) {
414                     $ret .= hide($func,"Perl_$func");
415                 }
416             }
417             else {
418                 my $alist = join(",", @az[0..$args-1]);
419                 $ret = "#define $func($alist)";
420                 my $t = int(length($ret) / 8);
421                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
422                 if ($flags =~ /s/) {
423                     $ret .= "S_$func(aTHX";
424                 }
425                 elsif ($flags =~ /p/) {
426                     $ret .= "Perl_$func(aTHX";
427                 }
428                 $ret .= "_ " if $alist;
429                 $ret .= $alist . ")\n";
430             }
431         }
432     }
433     $ret;
434 } \*EM;
435
436 for $sym (sort keys %ppsym) {
437     $sym =~ s/^Perl_//;
438     if ($sym =~ /^ck_/) {
439         print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
440     }
441     elsif ($sym =~ /^pp_/) {
442         print EM hide("$sym()", "Perl_$sym(aTHX)");
443     }
444     else {
445         warn "Illegal symbol '$sym' in pp.sym";
446     }
447 }
448
449 print EM <<'END';
450
451 #endif  /* PERL_IMPLICIT_CONTEXT */
452
453 END
454
455 print EM <<'END';
456
457 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
458    disable them.
459  */
460
461 #if !defined(PERL_CORE)
462 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
463 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,Nullch,PTR2IV(ptr))
464 #endif
465
466 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) && !defined(PERL_BINCOMPAT_5005)
467
468 /* Compatibility for various misnamed functions.  All functions
469    in the API that begin with "perl_" (not "Perl_") take an explicit
470    interpreter context pointer.
471    The following are not like that, but since they had a "perl_"
472    prefix in previous versions, we provide compatibility macros.
473  */
474 #  define perl_atexit(a,b)              call_atexit(a,b)
475 #  define perl_call_argv(a,b,c)         call_argv(a,b,c)
476 #  define perl_call_pv(a,b)             call_pv(a,b)
477 #  define perl_call_method(a,b)         call_method(a,b)
478 #  define perl_call_sv(a,b)             call_sv(a,b)
479 #  define perl_eval_sv(a,b)             eval_sv(a,b)
480 #  define perl_eval_pv(a,b)             eval_pv(a,b)
481 #  define perl_require_pv(a)            require_pv(a)
482 #  define perl_get_sv(a,b)              get_sv(a,b)
483 #  define perl_get_av(a,b)              get_av(a,b)
484 #  define perl_get_hv(a,b)              get_hv(a,b)
485 #  define perl_get_cv(a,b)              get_cv(a,b)
486 #  define perl_init_i18nl10n(a)         init_i18nl10n(a)
487 #  define perl_init_i18nl14n(a)         init_i18nl14n(a)
488 #  define perl_new_ctype(a)             new_ctype(a)
489 #  define perl_new_collate(a)           new_collate(a)
490 #  define perl_new_numeric(a)           new_numeric(a)
491
492 /* varargs functions can't be handled with CPP macros. :-(
493    This provides a set of compatibility functions that don't take
494    an extra argument but grab the context pointer using the macro
495    dTHX.
496  */
497 #if defined(PERL_IMPLICIT_CONTEXT)
498 #  define croak                         Perl_croak_nocontext
499 #  define deb                           Perl_deb_nocontext
500 #  define die                           Perl_die_nocontext
501 #  define form                          Perl_form_nocontext
502 #  define load_module                   Perl_load_module_nocontext
503 #  define mess                          Perl_mess_nocontext
504 #  define newSVpvf                      Perl_newSVpvf_nocontext
505 #  define sv_catpvf                     Perl_sv_catpvf_nocontext
506 #  define sv_setpvf                     Perl_sv_setpvf_nocontext
507 #  define warn                          Perl_warn_nocontext
508 #  define warner                        Perl_warner_nocontext
509 #  define sv_catpvf_mg                  Perl_sv_catpvf_mg_nocontext
510 #  define sv_setpvf_mg                  Perl_sv_setpvf_mg_nocontext
511 #endif
512
513 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
514
515 #if !defined(PERL_IMPLICIT_CONTEXT)
516 /* undefined symbols, point them back at the usual ones */
517 #  define Perl_croak_nocontext          Perl_croak
518 #  define Perl_die_nocontext            Perl_die
519 #  define Perl_deb_nocontext            Perl_deb
520 #  define Perl_form_nocontext           Perl_form
521 #  define Perl_load_module_nocontext    Perl_load_module
522 #  define Perl_mess_nocontext           Perl_mess
523 #  define Perl_newSVpvf_nocontext       Perl_newSVpvf
524 #  define Perl_sv_catpvf_nocontext      Perl_sv_catpvf
525 #  define Perl_sv_setpvf_nocontext      Perl_sv_setpvf
526 #  define Perl_warn_nocontext           Perl_warn
527 #  define Perl_warner_nocontext         Perl_warner
528 #  define Perl_sv_catpvf_mg_nocontext   Perl_sv_catpvf_mg
529 #  define Perl_sv_setpvf_mg_nocontext   Perl_sv_setpvf_mg
530 #endif
531
532 END
533
534 close(EM);
535
536 unlink 'embedvar.h';
537 open(EM, '> embedvar.h')
538     or die "Can't create embedvar.h: $!\n";
539
540 print EM <<'END';
541 /*
542  *    embedvar.h
543  *
544  *    Copyright (c) 1997-2002, Larry Wall
545  *
546  *    You may distribute under the terms of either the GNU General Public
547  *    License or the Artistic License, as specified in the README file.
548  *
549  *
550  * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
551  *  This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
552  *  perlvars.h and thrdvar.h.  Any changes made here will be lost!
553  */
554
555 /* (Doing namespace management portably in C is really gross.) */
556
557 /*
558    The following combinations of MULTIPLICITY, USE_5005THREADS
559    and PERL_IMPLICIT_CONTEXT are supported:
560      1) none
561      2) MULTIPLICITY    # supported for compatibility
562      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
563      4) USE_5005THREADS && PERL_IMPLICIT_CONTEXT
564      5) MULTIPLICITY && USE_5005THREADS && PERL_IMPLICIT_CONTEXT
565
566    All other combinations of these flags are errors.
567
568    #3, #4, #5, and #6 are supported directly, while #2 is a special
569    case of #3 (supported by redefining vTHX appropriately).
570 */
571
572 #if defined(MULTIPLICITY)
573 /* cases 2, 3 and 5 above */
574
575 #  if defined(PERL_IMPLICIT_CONTEXT)
576 #    define vTHX        aTHX
577 #  else
578 #    define vTHX        PERL_GET_INTERP
579 #  endif
580
581 END
582
583 for $sym (sort keys %thread) {
584     print EM multon($sym,'T','vTHX->');
585 }
586
587 print EM <<'END';
588
589 #  if defined(USE_5005THREADS)
590 /* case 5 above */
591
592 END
593
594 for $sym (sort keys %intrp) {
595     print EM multon($sym,'I','PERL_GET_INTERP->');
596 }
597
598 print EM <<'END';
599
600 #  else         /* !USE_5005THREADS */
601 /* cases 2 and 3 above */
602
603 END
604
605 for $sym (sort keys %intrp) {
606     print EM multon($sym,'I','vTHX->');
607 }
608
609 print EM <<'END';
610
611 #  endif        /* USE_5005THREADS */
612
613 #else   /* !MULTIPLICITY */
614
615 /* cases 1 and 4 above */
616
617 END
618
619 for $sym (sort keys %intrp) {
620     print EM multoff($sym,'I');
621 }
622
623 print EM <<'END';
624
625 #  if defined(USE_5005THREADS)
626 /* case 4 above */
627
628 END
629
630 for $sym (sort keys %thread) {
631     print EM multon($sym,'T','aTHX->');
632 }
633
634 print EM <<'END';
635
636 #  else /* !USE_5005THREADS */
637 /* case 1 above */
638
639 END
640
641 for $sym (sort keys %thread) {
642     print EM multoff($sym,'T');
643 }
644
645 print EM <<'END';
646
647 #  endif        /* USE_5005THREADS */
648 #endif  /* MULTIPLICITY */
649
650 #if defined(PERL_GLOBAL_STRUCT)
651
652 END
653
654 for $sym (sort keys %globvar) {
655     print EM multon($sym,'G','PL_Vars.');
656 }
657
658 print EM <<'END';
659
660 #else /* !PERL_GLOBAL_STRUCT */
661
662 END
663
664 for $sym (sort keys %globvar) {
665     print EM multoff($sym,'G');
666 }
667
668 print EM <<'END';
669
670 #endif /* PERL_GLOBAL_STRUCT */
671
672 #ifdef PERL_POLLUTE             /* disabled by default in 5.6.0 */
673
674 END
675
676 for $sym (sort @extvars) {
677     print EM hide($sym,"PL_$sym");
678 }
679
680 print EM <<'END';
681
682 #endif /* PERL_POLLUTE */
683 END
684
685 close(EM);
686
687 unlink 'perlapi.h';
688 unlink 'perlapi.c';
689 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
690 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
691
692 print CAPIH <<'EOT';
693 /*
694  *    perlapi.h
695  *
696  *    Copyright (c) 1997-2002, Larry Wall
697  *
698  *    You may distribute under the terms of either the GNU General Public
699  *    License or the Artistic License, as specified in the README file.
700  *
701  *
702  * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
703  *  This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
704  *  perlvars.h and thrdvar.h.  Any changes made here will be lost!
705  */
706
707 /* declare accessor functions for Perl variables */
708 #ifndef __perlapi_h__
709 #define __perlapi_h__
710
711 #if defined (MULTIPLICITY)
712
713 START_EXTERN_C
714
715 #undef PERLVAR
716 #undef PERLVARA
717 #undef PERLVARI
718 #undef PERLVARIC
719 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
720 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
721                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
722 #define PERLVARI(v,t,i) PERLVAR(v,t)
723 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
724
725 #include "thrdvar.h"
726 #include "intrpvar.h"
727 #include "perlvars.h"
728
729 #undef PERLVAR
730 #undef PERLVARA
731 #undef PERLVARI
732 #undef PERLVARIC
733
734 END_EXTERN_C
735
736 #if defined(PERL_CORE)
737
738 /* accessor functions for Perl variables (provide binary compatibility) */
739
740 /* these need to be mentioned here, or most linkers won't put them in
741    the perl executable */
742
743 #ifndef PERL_NO_FORCE_LINK
744
745 START_EXTERN_C
746
747 #ifndef DOINIT
748 EXT void *PL_force_link_funcs[];
749 #else
750 EXT void *PL_force_link_funcs[] = {
751 #undef PERLVAR
752 #undef PERLVARA
753 #undef PERLVARI
754 #undef PERLVARIC
755 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
756 #define PERLVARA(v,n,t) PERLVAR(v,t)
757 #define PERLVARI(v,t,i) PERLVAR(v,t)
758 #define PERLVARIC(v,t,i) PERLVAR(v,t)
759
760 #include "thrdvar.h"
761 #include "intrpvar.h"
762 #include "perlvars.h"
763
764 #undef PERLVAR
765 #undef PERLVARA
766 #undef PERLVARI
767 #undef PERLVARIC
768 };
769 #endif  /* DOINIT */
770
771 END_EXTERN_C
772
773 #endif  /* PERL_NO_FORCE_LINK */
774
775 #else   /* !PERL_CORE */
776
777 EOT
778
779 foreach $sym (sort keys %intrp) {
780     print CAPIH bincompat_var('I',$sym);
781 }
782
783 foreach $sym (sort keys %thread) {
784     print CAPIH bincompat_var('T',$sym);
785 }
786
787 foreach $sym (sort keys %globvar) {
788     print CAPIH bincompat_var('G',$sym);
789 }
790
791 print CAPIH <<'EOT';
792
793 #endif /* !PERL_CORE */
794 #endif /* MULTIPLICITY */
795
796 #endif /* __perlapi_h__ */
797
798 EOT
799 close CAPIH;
800
801 print CAPI <<'EOT';
802 /*
803  *    perlapi.c
804  *
805  *    Copyright (c) 1997-2002, Larry Wall
806  *
807  *    You may distribute under the terms of either the GNU General Public
808  *    License or the Artistic License, as specified in the README file.
809  *
810  *
811  * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
812  *  This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
813  *  perlvars.h and thrdvar.h.  Any changes made here will be lost!
814  */
815
816 #include "EXTERN.h"
817 #include "perl.h"
818 #include "perlapi.h"
819
820 #if defined (MULTIPLICITY)
821
822 /* accessor functions for Perl variables (provides binary compatibility) */
823 START_EXTERN_C
824
825 #undef PERLVAR
826 #undef PERLVARA
827 #undef PERLVARI
828 #undef PERLVARIC
829
830 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
831                         { return &(aTHX->v); }
832 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
833                         { return &(aTHX->v); }
834
835 #define PERLVARI(v,t,i) PERLVAR(v,t)
836 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
837
838 #include "thrdvar.h"
839 #include "intrpvar.h"
840
841 #undef PERLVAR
842 #undef PERLVARA
843 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
844                         { return &(PL_##v); }
845 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
846                         { return &(PL_##v); }
847 #undef PERLVARIC
848 #define PERLVARIC(v,t,i)        const t* Perl_##v##_ptr(pTHX)           \
849                         { return (const t *)&(PL_##v); }
850 #include "perlvars.h"
851
852 #undef PERLVAR
853 #undef PERLVARA
854 #undef PERLVARI
855 #undef PERLVARIC
856
857 END_EXTERN_C
858
859 #endif /* MULTIPLICITY */
860 EOT
861
862 close(CAPI);
863
864 # functions that take va_list* for implementing vararg functions
865 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
866 # XXX %vfuncs currently unused
867 my %vfuncs = qw(
868     Perl_croak                  Perl_vcroak
869     Perl_warn                   Perl_vwarn
870     Perl_warner                 Perl_vwarner
871     Perl_die                    Perl_vdie
872     Perl_form                   Perl_vform
873     Perl_load_module            Perl_vload_module
874     Perl_mess                   Perl_vmess
875     Perl_deb                    Perl_vdeb
876     Perl_newSVpvf               Perl_vnewSVpvf
877     Perl_sv_setpvf              Perl_sv_vsetpvf
878     Perl_sv_setpvf_mg           Perl_sv_vsetpvf_mg
879     Perl_sv_catpvf              Perl_sv_vcatpvf
880     Perl_sv_catpvf_mg           Perl_sv_vcatpvf_mg
881     Perl_dump_indent            Perl_dump_vindent
882     Perl_default_protect        Perl_vdefault_protect
883 );