source: trunk/third/perl/embed.pl @ 20075

Revision 20075, 19.2 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.
  • Property svn:executable set to *
Line 
1#!/usr/bin/perl -w
2
3require 5.003;  # keep this compatible, an old perl is all we may have before
4                # we build the new one
5
6BEGIN {
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
18sub 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   !!!!!!!
50This file is built by embed.pl from data in embed.fnc, embed.pl,
51pp.sym, intrpvar.h, perlvars.h and thrdvar.h.
52Any changes made here will be lost!
53
54Edit those files and run 'make regen_headers' to effect changes.
55
56EOW
57
58    $warning .= <<EOW if $file eq 'perlapi.c';
59
60Up to the threshold of the door there mounted a flight of twenty-seven
61broad stairs, hewn by some unknown art of the same black stone.  This
62was the only entrance to the tower.
63
64
65EOW
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
80open IN, "embed.fnc" or die $!;
81
82# walk table providing an array of components in each line to
83# subroutine, printing the result
84sub 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
125sub 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
177my $wrote_protected = 0;
178
179sub 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
225sub 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
238walk_table(\&write_protos,     "proto.h", undef);
239walk_table(\&write_global_sym, "global.sym", undef);
240
241# XXX others that may need adding
242#       warnhook
243#       hints
244#       copline
245my @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 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
262sub 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
280readsyms my %ppsym, 'pp.sym';
281
282sub 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
300my %intrp;
301my %thread;
302
303readvars %intrp,  'intrpvar.h','I';
304readvars %thread, 'thrdvar.h','T';
305readvars %globvar, 'perlvars.h','G';
306
307my $sym;
308foreach $sym (sort keys %thread) {
309  warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
310}
311
312sub undefine ($) {
313    my ($sym) = @_;
314    "#undef  $sym\n";
315}
316
317sub 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
323sub 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
329sub multon ($$$) {
330    my ($sym,$pre,$ptr) = @_;
331    hide("PL_$sym", "($ptr$pre$sym)");
332}
333
334sub multoff ($$) {
335    my ($sym,$pre) = @_;
336    return hide("PL_$pre$sym", "PL_$sym");
337}
338
339safer_unlink 'embed.h';
340open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
341
342print 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
356END
357
358walk_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
385for $sym (sort keys %ppsym) {
386    $sym =~ s/^Perl_//;
387    print EM hide($sym, "Perl_$sym");
388}
389
390print EM <<'END';
391
392#else   /* PERL_IMPLICIT_CONTEXT */
393
394END
395
396my @az = ('a'..'z');
397
398walk_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
445for $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
458print EM <<'END';
459
460#endif  /* PERL_IMPLICIT_CONTEXT */
461
462#endif  /* #ifndef PERL_NO_SHORT_NAMES */
463
464END
465
466print 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
543END
544
545close(EM) or die "Error closing EM: $!";
546
547safer_unlink 'embedvar.h';
548open(EM, '> embedvar.h')
549    or die "Can't create embedvar.h: $!\n";
550
551print 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, USE_5005THREADS
557   and PERL_IMPLICIT_CONTEXT are supported:
558     1) none
559     2) MULTIPLICITY    # supported for compatibility
560     3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
561     4) USE_5005THREADS && PERL_IMPLICIT_CONTEXT
562     5) MULTIPLICITY && USE_5005THREADS && PERL_IMPLICIT_CONTEXT
563
564   All other combinations of these flags are errors.
565
566   #3, #4, #5, and #6 are supported directly, while #2 is a special
567   case of #3 (supported by redefining vTHX appropriately).
568*/
569
570#if defined(MULTIPLICITY)
571/* cases 2, 3 and 5 above */
572
573#  if defined(PERL_IMPLICIT_CONTEXT)
574#    define vTHX        aTHX
575#  else
576#    define vTHX        PERL_GET_INTERP
577#  endif
578
579END
580
581for $sym (sort keys %thread) {
582    print EM multon($sym,'T','vTHX->');
583}
584
585print EM <<'END';
586
587#  if defined(USE_5005THREADS)
588/* case 5 above */
589
590END
591
592for $sym (sort keys %intrp) {
593    print EM multon($sym,'I','PERL_GET_INTERP->');
594}
595
596print EM <<'END';
597
598#  else         /* !USE_5005THREADS */
599/* cases 2 and 3 above */
600
601END
602
603for $sym (sort keys %intrp) {
604    print EM multon($sym,'I','vTHX->');
605}
606
607print EM <<'END';
608
609#  endif        /* USE_5005THREADS */
610
611#else   /* !MULTIPLICITY */
612
613/* cases 1 and 4 above */
614
615END
616
617for $sym (sort keys %intrp) {
618    print EM multoff($sym,'I');
619}
620
621print EM <<'END';
622
623#  if defined(USE_5005THREADS)
624/* case 4 above */
625
626END
627
628for $sym (sort keys %thread) {
629    print EM multon($sym,'T','aTHX->');
630}
631
632print EM <<'END';
633
634#  else /* !USE_5005THREADS */
635/* case 1 above */
636
637END
638
639for $sym (sort keys %thread) {
640    print EM multoff($sym,'T');
641}
642
643print EM <<'END';
644
645#  endif        /* USE_5005THREADS */
646#endif  /* MULTIPLICITY */
647
648#if defined(PERL_GLOBAL_STRUCT)
649
650END
651
652for $sym (sort keys %globvar) {
653    print EM multon($sym,'G','PL_Vars.');
654}
655
656print EM <<'END';
657
658#else /* !PERL_GLOBAL_STRUCT */
659
660END
661
662for $sym (sort keys %globvar) {
663    print EM multoff($sym,'G');
664}
665
666print EM <<'END';
667
668#endif /* PERL_GLOBAL_STRUCT */
669
670#ifdef PERL_POLLUTE             /* disabled by default in 5.6.0 */
671
672END
673
674for $sym (sort @extvars) {
675    print EM hide($sym,"PL_$sym");
676}
677
678print EM <<'END';
679
680#endif /* PERL_POLLUTE */
681END
682
683close(EM) or die "Error closing EM: $!";
684
685safer_unlink 'perlapi.h';
686safer_unlink 'perlapi.c';
687open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
688open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
689
690print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
691
692/* declare accessor functions for Perl variables */
693#ifndef __perlapi_h__
694#define __perlapi_h__
695
696#if defined (MULTIPLICITY)
697
698START_EXTERN_C
699
700#undef PERLVAR
701#undef PERLVARA
702#undef PERLVARI
703#undef PERLVARIC
704#define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
705#define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
706                        EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
707#define PERLVARI(v,t,i) PERLVAR(v,t)
708#define PERLVARIC(v,t,i) PERLVAR(v, const t)
709
710#include "thrdvar.h"
711#include "intrpvar.h"
712#include "perlvars.h"
713
714#undef PERLVAR
715#undef PERLVARA
716#undef PERLVARI
717#undef PERLVARIC
718
719END_EXTERN_C
720
721#if defined(PERL_CORE)
722
723/* accessor functions for Perl variables (provide binary compatibility) */
724
725/* these need to be mentioned here, or most linkers won't put them in
726   the perl executable */
727
728#ifndef PERL_NO_FORCE_LINK
729
730START_EXTERN_C
731
732#ifndef DOINIT
733EXT void *PL_force_link_funcs[];
734#else
735EXT void *PL_force_link_funcs[] = {
736#undef PERLVAR
737#undef PERLVARA
738#undef PERLVARI
739#undef PERLVARIC
740#define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
741#define PERLVARA(v,n,t) PERLVAR(v,t)
742#define PERLVARI(v,t,i) PERLVAR(v,t)
743#define PERLVARIC(v,t,i) PERLVAR(v,t)
744
745#include "thrdvar.h"
746#include "intrpvar.h"
747#include "perlvars.h"
748
749#undef PERLVAR
750#undef PERLVARA
751#undef PERLVARI
752#undef PERLVARIC
753};
754#endif  /* DOINIT */
755
756END_EXTERN_C
757
758#endif  /* PERL_NO_FORCE_LINK */
759
760#else   /* !PERL_CORE */
761
762EOT
763
764foreach $sym (sort keys %intrp) {
765    print CAPIH bincompat_var('I',$sym);
766}
767
768foreach $sym (sort keys %thread) {
769    print CAPIH bincompat_var('T',$sym);
770}
771
772foreach $sym (sort keys %globvar) {
773    print CAPIH bincompat_var('G',$sym);
774}
775
776print CAPIH <<'EOT';
777
778#endif /* !PERL_CORE */
779#endif /* MULTIPLICITY */
780
781#endif /* __perlapi_h__ */
782
783EOT
784close CAPIH or die "Error closing CAPIH: $!";
785
786print CAPI do_not_edit ("perlapi.c"), <<'EOT';
787
788#include "EXTERN.h"
789#include "perl.h"
790#include "perlapi.h"
791
792#if defined (MULTIPLICITY)
793
794/* accessor functions for Perl variables (provides binary compatibility) */
795START_EXTERN_C
796
797#undef PERLVAR
798#undef PERLVARA
799#undef PERLVARI
800#undef PERLVARIC
801
802#define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
803                        { return &(aTHX->v); }
804#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
805                        { return &(aTHX->v); }
806
807#define PERLVARI(v,t,i) PERLVAR(v,t)
808#define PERLVARIC(v,t,i) PERLVAR(v, const t)
809
810#include "thrdvar.h"
811#include "intrpvar.h"
812
813#undef PERLVAR
814#undef PERLVARA
815#define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
816                        { return &(PL_##v); }
817#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
818                        { return &(PL_##v); }
819#undef PERLVARIC
820#define PERLVARIC(v,t,i)        const t* Perl_##v##_ptr(pTHX)           \
821                        { return (const t *)&(PL_##v); }
822#include "perlvars.h"
823
824#undef PERLVAR
825#undef PERLVARA
826#undef PERLVARI
827#undef PERLVARIC
828
829END_EXTERN_C
830
831#endif /* MULTIPLICITY */
832EOT
833
834close(CAPI) or die "Error closing CAPI: $!";
835
836# functions that take va_list* for implementing vararg functions
837# NOTE: makedef.pl must be updated if you add symbols to %vfuncs
838# XXX %vfuncs currently unused
839my %vfuncs = qw(
840    Perl_croak                  Perl_vcroak
841    Perl_warn                   Perl_vwarn
842    Perl_warner                 Perl_vwarner
843    Perl_die                    Perl_vdie
844    Perl_form                   Perl_vform
845    Perl_load_module            Perl_vload_module
846    Perl_mess                   Perl_vmess
847    Perl_deb                    Perl_vdeb
848    Perl_newSVpvf               Perl_vnewSVpvf
849    Perl_sv_setpvf              Perl_sv_vsetpvf
850    Perl_sv_setpvf_mg           Perl_sv_vsetpvf_mg
851    Perl_sv_catpvf              Perl_sv_vcatpvf
852    Perl_sv_catpvf_mg           Perl_sv_vcatpvf_mg
853    Perl_dump_indent            Perl_dump_vindent
854    Perl_default_protect        Perl_vdefault_protect
855);
Note: See TracBrowser for help on using the repository browser.