[p5sagit/p5-mst-13.2.git] / embed.pl

#!/usr/bin/perl -w

require 5.003;	# keep this compatible, an old perl is all we may have before
                # we build the new one

#
# See database of global and static function prototypes in embed.fnc
# This is used to generate prototype headers under various configurations,
# export symbols lists for different platforms, and macros to provide an
# implicit interpreter context argument.
#

sub do_not_edit ($)
{
    my $file = shift;
    my $warning = <<EOW;

   $file

   Copyright (c) 1997-2002, Larry Wall

   You may distribute under the terms of either the GNU General Public
   License or the Artistic License, as specified in the README file.

!!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
This file is built by embed.pl from data in embed.fnc, embed.pl,
pp.sym, intrpvar.h, perlvars.h and thrdvar.h.
Any changes made here will be lost!

Edit those files and run 'make regen_headers' to effect changes.

EOW

    if ($file =~ m:\.[ch]$:) {
	$warning =~ s:^: * :gm;
	$warning =~ s: +$::gm;
	$warning =~ s: :/:;
	$warning =~ s:$:/:;
    }
    else {
	$warning =~ s:^:# :gm;
	$warning =~ s: +$::gm;
    }
    $warning;
} # do_not_edit

open IN, "embed.fnc" or die $!;

# walk table providing an array of components in each line to
# subroutine, printing the result
sub walk_table (&@) {
    my $function = shift;
    my $filename = shift || '-';
    my $leader = shift;
    defined $leader or $leader = do_not_edit ($filename);
    my $trailer = shift;
    my $F;
    local *F;
    if (ref $filename) {	# filehandle
	$F = $filename;
    }
    else {
	unlink $filename;
	open F, ">$filename" or die "Can't open $filename: $!";
	$F = \*F;
    }
    print $F $leader if $leader;
    seek IN, 0, 0;		# so we may restart
    while (<IN>) {
	chomp;
	next if /^:/;
	while (s|\\$||) {
	    $_ .= <IN>;
	    chomp;
	}
	my @args;
	if (/^\s*(#|$)/) {
	    @args = $_;
	}
	else {
	    @args = split /\s*\|\s*/, $_;
	}
        my @outs = &{$function}(@args);
        print $F @outs; # $function->(@args) is not 5.003
    }
    print $F $trailer if $trailer;
    close $F unless ref $filename;
}

sub munge_c_files () {
    my $functions = {};
    unless (@ARGV) {
        warn "\@ARGV empty, nothing to do\n";
	return;
    }
    walk_table {
	if (@_ > 1) {
	    $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
	}
    } '/dev/null', '';
    local $^I = '.bak';
    while (<>) {
#	if (/^#\s*include\s+"perl.h"/) {
#	    my $file = uc $ARGV;
#	    $file =~ s/\./_/g;
#	    print "#define PERL_IN_$file\n";
#	}
#	s{^(\w+)\s*\(}
#	 {
#	    my $f = $1;
#	    my $repl = "$f(";
#	    if (exists $functions->{$f}) {
#		my $flags = $functions->{$f}[0];
#		$repl = "Perl_$repl" if $flags =~ /p/;
#		unless ($flags =~ /n/) {
#		    $repl .= "pTHX";
#		    $repl .= "_ " if @{$functions->{$f}} > 3;
#		}
#		warn("$ARGV:$.:$repl\n");
#	    }
#	    $repl;
#	 }e;
	s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
	 {
	    my $repl = $1;
	    my $f = $2;
	    if (exists $functions->{$f}) {
		$repl .= "aTHX_ ";
		warn("$ARGV:$.:$`#$repl#$'");
	    }
	    $repl;
	 }eg;
	print;
	close ARGV if eof;	# restart $.
    }
    exit;
}

#munge_c_files();

# generate proto.h
my $wrote_protected = 0;

sub write_protos {
    my $ret = "";
    if (@_ == 1) {
	my $arg = shift;
	$ret .= "$arg\n";
    }
    else {
	my ($flags,$retval,$func,@args) = @_;
	$ret .= '/* ' if $flags =~ /m/;
	if ($flags =~ /s/) {
	    $retval = "STATIC $retval";
	    $func = "S_$func";
	}
	else {
	    $retval = "PERL_CALLCONV $retval";
	    if ($flags =~ /p/) {
		$func = "Perl_$func";
	    }
	}
	$ret .= "$retval\t$func(";
	unless ($flags =~ /n/) {
	    $ret .= "pTHX";
	    $ret .= "_ " if @args;
	}
	if (@args) {
	    $ret .= join ", ", @args;
	}
	else {
	    $ret .= "void" if $flags =~ /n/;
	}
	$ret .= ")";
	$ret .= " __attribute__((noreturn))" if $flags =~ /r/;
	if( $flags =~ /f/ ) {
	    my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
	    my $args = scalar @args;
	    $ret .= "\n#ifdef CHECK_FORMAT\n";
	    $ret .= sprintf " __attribute__((format(printf,%s%d,%s%d)))",
				    $prefix, $args - 1, $prefix, $args;
	    $ret .= "\n#endif\n";
	}
	$ret .= ";";
	$ret .= ' */' if $flags =~ /m/;
	$ret .= "\n";
    }
    $ret;
}

# generates global.sym (API export list), and populates %global with global symbols
sub write_global_sym {
    my $ret = "";
    if (@_ > 1) {
	my ($flags,$retval,$func,@args) = @_;
	if ($flags =~ /A/ && $flags !~ /[xm]/) { # public API, so export
	    $func = "Perl_$func" if $flags =~ /p/;
	    $ret = "$func\n";
	}
    }
    $ret;
}

walk_table(\&write_protos,     "proto.h", undef);
walk_table(\&write_global_sym, "global.sym", undef);

# XXX others that may need adding
#       warnhook
#       hints
#       copline
my @extvars = qw(sv_undef sv_yes sv_no na dowarn
                 curcop compiling
                 tainting tainted stack_base stack_sp sv_arenaroot
		 no_modify
                 curstash DBsub DBsingle debstash
                 rsfp
                 stdingv
		 defgv
		 errgv
		 rsfp_filters
		 perldb
		 diehook
		 dirty
		 perl_destruct_level
		 ppaddr
                );

sub readsyms (\%$) {
    my ($syms, $file) = @_;
    local (*FILE, $_);
    open(FILE, "< $file")
	or die "embed.pl: Can't open $file: $!\n";
    while (<FILE>) {
	s/[ \t]*#.*//;		# Delete comments.
	if (/^\s*(\S+)\s*$/) {
	    my $sym = $1;
	    warn "duplicate symbol $sym while processing $file\n"
		if exists $$syms{$sym};
	    $$syms{$sym} = 1;
	}
    }
    close(FILE);
}

# Perl_pp_* and Perl_ck_* are in pp.sym
readsyms my %ppsym, 'pp.sym';

sub readvars(\%$$@) {
    my ($syms, $file,$pre,$keep_pre) = @_;
    local (*FILE, $_);
    open(FILE, "< $file")
	or die "embed.pl: Can't open $file: $!\n";
    while (<FILE>) {
	s/[ \t]*#.*//;		# Delete comments.
	if (/PERLVARA?I?C?\($pre(\w+)/) {
	    my $sym = $1;
	    $sym = $pre . $sym if $keep_pre;
	    warn "duplicate symbol $sym while processing $file\n"
		if exists $$syms{$sym};
	    $$syms{$sym} = $pre || 1;
	}
    }
    close(FILE);
}

my %intrp;
my %thread;

readvars %intrp,  'intrpvar.h','I';
readvars %thread, 'thrdvar.h','T';
readvars %globvar, 'perlvars.h','G';

my $sym;
foreach $sym (sort keys %thread) {
  warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
}

sub undefine ($) {
    my ($sym) = @_;
    "#undef  $sym\n";
}

sub hide ($$) {
    my ($from, $to) = @_;
    my $t = int(length($from) / 8);
    "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
}

sub bincompat_var ($$) {
    my ($pfx, $sym) = @_;
    my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
    undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
}

sub multon ($$$) {
    my ($sym,$pre,$ptr) = @_;
    hide("PL_$sym", "($ptr$pre$sym)");
}

sub multoff ($$) {
    my ($sym,$pre) = @_;
    return hide("PL_$pre$sym", "PL_$sym");
}

unlink 'embed.h';
open(EM, '> embed.h') or die "Can't create embed.h: $!\n";

print EM do_not_edit ("embed.h"), <<'END';

/* (Doing namespace management portably in C is really gross.) */

/* NO_EMBED is no longer supported. i.e. EMBED is always active. */

/* Hide global symbols */

#if !defined(PERL_IMPLICIT_CONTEXT)

END

walk_table {
    my $ret = "";
    if (@_ == 1) {
	my $arg = shift;
	$ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
    }
    else {
	my ($flags,$retval,$func,@args) = @_;
	unless ($flags =~ /[om]/) {
	    if ($flags =~ /s/) {
		$ret .= hide($func,"S_$func");
	    }
	    elsif ($flags =~ /p/) {
		$ret .= hide($func,"Perl_$func");
	    }
	}
    }
    $ret;
} \*EM, "";

for $sym (sort keys %ppsym) {
    $sym =~ s/^Perl_//;
    print EM hide($sym, "Perl_$sym");
}

print EM <<'END';

#else	/* PERL_IMPLICIT_CONTEXT */

END

my @az = ('a'..'z');

walk_table {
    my $ret = "";
    if (@_ == 1) {
	my $arg = shift;
	$ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
    }
    else {
	my ($flags,$retval,$func,@args) = @_;
	unless ($flags =~ /[om]/) {
	    my $args = scalar @args;
	    if ($args and $args[$args-1] =~ /\.\.\./) {
	        # we're out of luck for varargs functions under CPP
	    }
	    elsif ($flags =~ /n/) {
		if ($flags =~ /s/) {
		    $ret .= hide($func,"S_$func");
		}
		elsif ($flags =~ /p/) {
		    $ret .= hide($func,"Perl_$func");
		}
	    }
	    else {
		my $alist = join(",", @az[0..$args-1]);
		$ret = "#define $func($alist)";
		my $t = int(length($ret) / 8);
		$ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
		if ($flags =~ /s/) {
		    $ret .= "S_$func(aTHX";
		}
		elsif ($flags =~ /p/) {
		    $ret .= "Perl_$func(aTHX";
		}
		$ret .= "_ " if $alist;
		$ret .= $alist . ")\n";
	    }
	}
    }
    $ret;
} \*EM, "";

for $sym (sort keys %ppsym) {
    $sym =~ s/^Perl_//;
    if ($sym =~ /^ck_/) {
	print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
    }
    elsif ($sym =~ /^pp_/) {
	print EM hide("$sym()", "Perl_$sym(aTHX)");
    }
    else {
	warn "Illegal symbol '$sym' in pp.sym";
    }
}

print EM <<'END';

#endif	/* PERL_IMPLICIT_CONTEXT */

END

print EM <<'END';

/* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
   disable them.
 */

#if !defined(PERL_CORE)
#  define sv_setptrobj(rv,ptr,name)	sv_setref_iv(rv,name,PTR2IV(ptr))
#  define sv_setptrref(rv,ptr)		sv_setref_iv(rv,Nullch,PTR2IV(ptr))
#endif

#if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)

/* Compatibility for various misnamed functions.  All functions
   in the API that begin with "perl_" (not "Perl_") take an explicit
   interpreter context pointer.
   The following are not like that, but since they had a "perl_"
   prefix in previous versions, we provide compatibility macros.
 */
#  define perl_atexit(a,b)		call_atexit(a,b)
#  define perl_call_argv(a,b,c)		call_argv(a,b,c)
#  define perl_call_pv(a,b)		call_pv(a,b)
#  define perl_call_method(a,b)		call_method(a,b)
#  define perl_call_sv(a,b)		call_sv(a,b)
#  define perl_eval_sv(a,b)		eval_sv(a,b)
#  define perl_eval_pv(a,b)		eval_pv(a,b)
#  define perl_require_pv(a)		require_pv(a)
#  define perl_get_sv(a,b)		get_sv(a,b)
#  define perl_get_av(a,b)		get_av(a,b)
#  define perl_get_hv(a,b)		get_hv(a,b)
#  define perl_get_cv(a,b)		get_cv(a,b)
#  define perl_init_i18nl10n(a)		init_i18nl10n(a)
#  define perl_init_i18nl14n(a)		init_i18nl14n(a)
#  define perl_new_ctype(a)		new_ctype(a)
#  define perl_new_collate(a)		new_collate(a)
#  define perl_new_numeric(a)		new_numeric(a)

/* varargs functions can't be handled with CPP macros. :-(
   This provides a set of compatibility functions that don't take
   an extra argument but grab the context pointer using the macro
   dTHX.
 */
#if defined(PERL_IMPLICIT_CONTEXT)
#  define croak				Perl_croak_nocontext
#  define deb				Perl_deb_nocontext
#  define die				Perl_die_nocontext
#  define form				Perl_form_nocontext
#  define load_module			Perl_load_module_nocontext
#  define mess				Perl_mess_nocontext
#  define newSVpvf			Perl_newSVpvf_nocontext
#  define sv_catpvf			Perl_sv_catpvf_nocontext
#  define sv_setpvf			Perl_sv_setpvf_nocontext
#  define warn				Perl_warn_nocontext
#  define warner			Perl_warner_nocontext
#  define sv_catpvf_mg			Perl_sv_catpvf_mg_nocontext
#  define sv_setpvf_mg			Perl_sv_setpvf_mg_nocontext
#endif

#endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */

#if !defined(PERL_IMPLICIT_CONTEXT)
/* undefined symbols, point them back at the usual ones */
#  define Perl_croak_nocontext		Perl_croak
#  define Perl_die_nocontext		Perl_die
#  define Perl_deb_nocontext		Perl_deb
#  define Perl_form_nocontext		Perl_form
#  define Perl_load_module_nocontext	Perl_load_module
#  define Perl_mess_nocontext		Perl_mess
#  define Perl_newSVpvf_nocontext	Perl_newSVpvf
#  define Perl_sv_catpvf_nocontext	Perl_sv_catpvf
#  define Perl_sv_setpvf_nocontext	Perl_sv_setpvf
#  define Perl_warn_nocontext		Perl_warn
#  define Perl_warner_nocontext		Perl_warner
#  define Perl_sv_catpvf_mg_nocontext	Perl_sv_catpvf_mg
#  define Perl_sv_setpvf_mg_nocontext	Perl_sv_setpvf_mg
#endif

END

close(EM);

unlink 'embedvar.h';
open(EM, '> embedvar.h')
    or die "Can't create embedvar.h: $!\n";

print EM do_not_edit ("embedvar.h"), <<'END';

/* (Doing namespace management portably in C is really gross.) */

/*
   The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
   are supported:
     1) none
     2) MULTIPLICITY	# supported for compatibility
     3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT

   All other combinations of these flags are errors.

   only #3 is supported directly, while #2 is a special
   case of #3 (supported by redefining vTHX appropriately).
*/

#if defined(MULTIPLICITY)
/* cases 2 and 3 above */

#  if defined(PERL_IMPLICIT_CONTEXT)
#    define vTHX	aTHX
#  else
#    define vTHX	PERL_GET_INTERP
#  endif

END

for $sym (sort keys %thread) {
    print EM multon($sym,'T','vTHX->');
}

print EM <<'END';

/* cases 2 and 3 above */

END

for $sym (sort keys %intrp) {
    print EM multon($sym,'I','vTHX->');
}

print EM <<'END';

#else	/* !MULTIPLICITY */

/* case 1 above */

END

for $sym (sort keys %intrp) {
    print EM multoff($sym,'I');
}

print EM <<'END';

END

for $sym (sort keys %thread) {
    print EM multoff($sym,'T');
}

print EM <<'END';

#endif	/* MULTIPLICITY */

#if defined(PERL_GLOBAL_STRUCT)

END

for $sym (sort keys %globvar) {
    print EM multon($sym,'G','PL_Vars.');
}

print EM <<'END';

#else /* !PERL_GLOBAL_STRUCT */

END

for $sym (sort keys %globvar) {
    print EM multoff($sym,'G');
}

print EM <<'END';

#endif /* PERL_GLOBAL_STRUCT */

#ifdef PERL_POLLUTE		/* disabled by default in 5.6.0 */

END

for $sym (sort @extvars) {
    print EM hide($sym,"PL_$sym");
}

print EM <<'END';

#endif /* PERL_POLLUTE */
END

close(EM);

unlink 'perlapi.h';
unlink 'perlapi.c';
open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";

print CAPIH do_not_edit ("perlapi.h"), <<'EOT';

/* declare accessor functions for Perl variables */
#ifndef __perlapi_h__
#define __perlapi_h__

#if defined (MULTIPLICITY)

START_EXTERN_C

#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
#define PERLVAR(v,t)	EXTERN_C t* Perl_##v##_ptr(pTHX);
#define PERLVARA(v,n,t)	typedef t PL_##v##_t[n];			\
			EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
#define PERLVARI(v,t,i)	PERLVAR(v,t)
#define PERLVARIC(v,t,i) PERLVAR(v, const t)

#include "thrdvar.h"
#include "intrpvar.h"
#include "perlvars.h"

#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC

END_EXTERN_C

#if defined(PERL_CORE)

/* accessor functions for Perl variables (provide binary compatibility) */

/* these need to be mentioned here, or most linkers won't put them in
   the perl executable */

#ifndef PERL_NO_FORCE_LINK

START_EXTERN_C

#ifndef DOINIT
EXT void *PL_force_link_funcs[];
#else
EXT void *PL_force_link_funcs[] = {
#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
#define PERLVAR(v,t)	(void*)Perl_##v##_ptr,
#define PERLVARA(v,n,t)	PERLVAR(v,t)
#define PERLVARI(v,t,i)	PERLVAR(v,t)
#define PERLVARIC(v,t,i) PERLVAR(v,t)

#include "thrdvar.h"
#include "intrpvar.h"
#include "perlvars.h"

#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
};
#endif	/* DOINIT */

END_EXTERN_C

#endif	/* PERL_NO_FORCE_LINK */

#else	/* !PERL_CORE */

EOT

foreach $sym (sort keys %intrp) {
    print CAPIH bincompat_var('I',$sym);
}

foreach $sym (sort keys %thread) {
    print CAPIH bincompat_var('T',$sym);
}

foreach $sym (sort keys %globvar) {
    print CAPIH bincompat_var('G',$sym);
}

print CAPIH <<'EOT';

#endif /* !PERL_CORE */
#endif /* MULTIPLICITY */

#endif /* __perlapi_h__ */

EOT
close CAPIH;

print CAPI do_not_edit ("perlapi.c"), <<'EOT';

#include "EXTERN.h"
#include "perl.h"
#include "perlapi.h"

#if defined (MULTIPLICITY)

/* accessor functions for Perl variables (provides binary compatibility) */
START_EXTERN_C

#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC

#define PERLVAR(v,t)	t* Perl_##v##_ptr(pTHX)				\
			{ return &(aTHX->v); }
#define PERLVARA(v,n,t)	PL_##v##_t* Perl_##v##_ptr(pTHX)		\
			{ return &(aTHX->v); }

#define PERLVARI(v,t,i)	PERLVAR(v,t)
#define PERLVARIC(v,t,i) PERLVAR(v, const t)

#include "thrdvar.h"
#include "intrpvar.h"

#undef PERLVAR
#undef PERLVARA
#define PERLVAR(v,t)	t* Perl_##v##_ptr(pTHX)				\
			{ return &(PL_##v); }
#define PERLVARA(v,n,t)	PL_##v##_t* Perl_##v##_ptr(pTHX)		\
			{ return &(PL_##v); }
#undef PERLVARIC
#define PERLVARIC(v,t,i)	const t* Perl_##v##_ptr(pTHX)		\
			{ return (const t *)&(PL_##v); }
#include "perlvars.h"

#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC

END_EXTERN_C

#endif /* MULTIPLICITY */
EOT

close(CAPI);

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