perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

Commit	Line	Data
	1	#!/usr/bin/perl -w
	2	#
	3	# Regenerate (overwriting only if changed):
	4	#
	5	# embed.h
	6	# embedvar.h
	7	# global.sym
	8	# perlapi.c
	9	# perlapi.h
	10	# proto.h
	11	#
	12	# from information stored in
	13	#
	14	# embed.fnc
	15	# intrpvar.h
	16	# perlvars.h
	17	# pp.sym (which has been generated by opcode.pl)
	18	#
	19	# plus from the values hardcoded into this script in @extvars.
	20	#
	21	# Accepts the standard regen_lib -q and -v args.
	22	#
	23	# This script is normally invoked from regen.pl.
	24
	25	require 5.003; # keep this compatible, an old perl is all we may have before
	26	# we build the new one
	27
	28	use strict;
	29
	30	BEGIN {
	31	# Get function prototypes
	32	require 'regen_lib.pl';
	33	}
	34
	35	my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org
	36
	37	#
	38	# See database of global and static function prototypes in embed.fnc
	39	# This is used to generate prototype headers under various configurations,
	40	# export symbols lists for different platforms, and macros to provide an
	41	# implicit interpreter context argument.
	42	#
	43
	44	sub do_not_edit ($)
	45	{
	46	my $file = shift;
	47
	48	my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009';
	49
	50	$years =~ s/1999,/1999,\n / if length $years > 40;
	51
	52	my $warning = <<EOW;
	53	-- buffer-read-only: t --
	54
	55	$file
	56
	57	Copyright (C) $years, by Larry Wall and others
	58
	59	You may distribute under the terms of either the GNU General Public
	60	License or the Artistic License, as specified in the README file.
	61
	62	!!!!!!! DO NOT EDIT THIS FILE !!!!!!!
	63	This file is built by embed.pl from data in embed.fnc, embed.pl,
	64	pp.sym, intrpvar.h, and perlvars.h.
	65	Any changes made here will be lost!
	66
	67	Edit those files and run 'make regen_headers' to effect changes.
	68
	69	EOW
	70
	71	$warning .= <<EOW if $file eq 'perlapi.c';
	72
	73	Up to the threshold of the door there mounted a flight of twenty-seven
	74	broad stairs, hewn by some unknown art of the same black stone. This
	75	was the only entrance to the tower; ...
	76
	77	[p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
	78
	79
	80	EOW
	81
	82	if ($file =~ m:\.[ch]$:) {
	83	$warning =~ s:^: * :gm;
	84	$warning =~ s: +$::gm;
	85	$warning =~ s: :/:;
	86	$warning =~ s:$:/:;
	87	}
	88	else {
	89	$warning =~ s:^:# :gm;
	90	$warning =~ s: +$::gm;
	91	}
	92	$warning;
	93	} # do_not_edit
	94
	95	open IN, "embed.fnc" or die $!;
	96
	97	# walk table providing an array of components in each line to
	98	# subroutine, printing the result
	99	sub walk_table (&@) {
	100	my $function = shift;
	101	my $filename = shift \|\| '-';
	102	my $leader = shift;
	103	defined $leader or $leader = do_not_edit ($filename);
	104	my $trailer = shift;
	105	my $F;
	106	if (ref $filename) { # filehandle
	107	$F = $filename;
	108	}
	109	else {
	110	# safer_unlink $filename if $filename ne '/dev/null';
	111	$F = safer_open("$filename-new");
	112	}
	113	print $F $leader if $leader;
	114	seek IN, 0, 0; # so we may restart
	115	while (<IN>) {
	116	chomp;
	117	next if /^:/;
	118	while (s\|\\$\|\|) {
	119	$_ .= <IN>;
	120	chomp;
	121	}
	122	s/\s+$//;
	123	my @args;
	124	if (/^\s*(#\|$)/) {
	125	@args = $_;
	126	}
	127	else {
	128	@args = split /\s\\|\s/, $_;
	129	}
	130	my @outs = &{$function}(@args);
	131	print $F @outs; # $function->(@args) is not 5.003
	132	}
	133	print $F $trailer if $trailer;
	134	unless (ref $filename) {
	135	safer_close($F);
	136	rename_if_different("$filename-new", $filename);
	137	}
	138	}
	139
	140	sub munge_c_files () {
	141	my $functions = {};
	142	unless (@ARGV) {
	143	warn "\@ARGV empty, nothing to do\n";
	144	return;
	145	}
	146	walk_table {
	147	if (@_ > 1) {
	148	$functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
	149	}
	150	} '/dev/null', '', '';
	151	local $^I = '.bak';
	152	while (<>) {
	153	s{(\b(\w+)[ \t]\([ \t](?!aTHX))}
	154	{
	155	my $repl = $1;
	156	my $f = $2;
	157	if (exists $functions->{$f}) {
	158	$repl .= "aTHX_ ";
	159	warn("$ARGV:$.:$`#$repl#$'");
	160	}
	161	$repl;
	162	}eg;
	163	print;
	164	close ARGV if eof; # restart $.
	165	}
	166	exit;
	167	}
	168
	169	#munge_c_files();
	170
	171	# generate proto.h
	172	my $wrote_protected = 0;
	173
	174	sub write_protos {
	175	my $ret = "";
	176	if (@_ == 1) {
	177	my $arg = shift;
	178	$ret .= "$arg\n";
	179	}
	180	else {
	181	my ($flags,$retval,$plain_func,@args) = @_;
	182	my @nonnull;
	183	my $has_context = ( $flags !~ /n/ );
	184	my $never_returns = ( $flags =~ /r/ );
	185	my $commented_out = ( $flags =~ /m/ );
	186	my $binarycompat = ( $flags =~ /b/ );
	187	my $is_malloc = ( $flags =~ /a/ );
	188	my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
	189	my @names_of_nn;
	190	my $func;
	191
	192	my $splint_flags = "";
	193	if ( $SPLINT && !$commented_out ) {
	194	$splint_flags .= '/@noreturn@/ ' if $never_returns;
	195	if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
	196	$retval .= " /\@alt void\@/";
	197	}
	198	}
	199
	200	if ($flags =~ /s/) {
	201	$retval = "STATIC $splint_flags$retval";
	202	$func = "S_$plain_func";
	203	}
	204	else {
	205	$retval = "PERL_CALLCONV $splint_flags$retval";
	206	if ($flags =~ /[bp]/) {
	207	$func = "Perl_$plain_func";
	208	} else {
	209	$func = $plain_func;
	210	}
	211	}
	212	$ret .= "$retval\t$func(";
	213	if ( $has_context ) {
	214	$ret .= @args ? "pTHX_ " : "pTHX";
	215	}
	216	if (@args) {
	217	my $n;
	218	for my $arg ( @args ) {
	219	++$n;
	220	if ( $arg =~ /\*/ && $arg !~ /\b(NN\|NULLOK)\b/ ) {
	221	warn "$func: $arg needs NN or NULLOK\n";
	222	our $unflagged_pointers;
	223	++$unflagged_pointers;
	224	}
	225	my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
	226	push( @nonnull, $n ) if $nn;
	227
	228	my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
	229
	230	# Make sure each arg has at least a type and a var name.
	231	# An arg of "int" is valid C, but want it to be "int foo".
	232	my $temp_arg = $arg;
	233	$temp_arg =~ s/\*//g;
	234	$temp_arg =~ s/\s\bstruct\b\s/ /g;
	235	if ( ($temp_arg ne "...")
	236	&& ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
	237	warn "$func: $arg ($n) doesn't have a name\n";
	238	}
	239	if ( $SPLINT && $nullok && !$commented_out ) {
	240	$arg = '/@null@/ ' . $arg;
	241	}
	242	if (defined $1 && $nn && !($commented_out && !$binarycompat)) {
	243	push @names_of_nn, $1;
	244	}
	245	}
	246	$ret .= join ", ", @args;
	247	}
	248	else {
	249	$ret .= "void" if !$has_context;
	250	}
	251	$ret .= ")";
	252	my @attrs;
	253	if ( $flags =~ /r/ ) {
	254	push @attrs, "__attribute__noreturn__";
	255	}
	256	if ( $flags =~ /D/ ) {
	257	push @attrs, "__attribute__deprecated__";
	258	}
	259	if ( $is_malloc ) {
	260	push @attrs, "__attribute__malloc__";
	261	}
	262	if ( !$can_ignore ) {
	263	push @attrs, "__attribute__warn_unused_result__";
	264	}
	265	if ( $flags =~ /P/ ) {
	266	push @attrs, "__attribute__pure__";
	267	}
	268	if( $flags =~ /f/ ) {
	269	my $prefix = $has_context ? 'pTHX_' : '';
	270	my $args = scalar @args;
	271	my $pat = $args - 1;
	272	my $macro = @nonnull && $nonnull[-1] == $pat
	273	? '__attribute__format__'
	274	: '__attribute__format__null_ok__';
	275	push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
	276	$prefix, $pat, $prefix, $args;
	277	}
	278	if ( @nonnull ) {
	279	my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
	280	push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
	281	}
	282	if ( @attrs ) {
	283	$ret .= "\n";
	284	$ret .= join( "\n", map { "\t\t\t$_" } @attrs );
	285	}
	286	$ret .= ";";
	287	$ret = "/* $ret */" if $commented_out;
	288	if (@names_of_nn) {
	289	$ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
	290	. join '; ', map "assert($_)", @names_of_nn;
	291	}
	292	$ret .= @attrs ? "\n\n" : "\n";
	293	}
	294	$ret;
	295	}
	296
	297	# generates global.sym (API export list)
	298	{
	299	my %seen;
	300	sub write_global_sym {
	301	my $ret = "";
	302	if (@_ > 1) {
	303	my ($flags,$retval,$func,@args) = @_;
	304	# If a function is defined twice, for example before and after an
	305	# #else, only process the flags on the first instance for global.sym
	306	return $ret if $seen{$func}++;
	307	if ($flags =~ /[AX]/ && $flags !~ /[xm]/
	308	\|\| $flags =~ /b/) { # public API, so export
	309	$func = "Perl_$func" if $flags =~ /[pbX]/;
	310	$ret = "$func\n";
	311	}
	312	}
	313	$ret;
	314	}
	315	}
	316
	317
	318	our $unflagged_pointers;
	319	walk_table(\&write_protos, "proto.h", undef, "/* ex: set ro: */\n");
	320	warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
	321	walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
	322
	323	# XXX others that may need adding
	324	# warnhook
	325	# hints
	326	# copline
	327	my @extvars = qw(sv_undef sv_yes sv_no na dowarn
	328	curcop compiling
	329	tainting tainted stack_base stack_sp sv_arenaroot
	330	no_modify
	331	curstash DBsub DBsingle DBassertion debstash
	332	rsfp
	333	stdingv
	334	defgv
	335	errgv
	336	rsfp_filters
	337	perldb
	338	diehook
	339	dirty
	340	perl_destruct_level
	341	ppaddr
	342	);
	343
	344	sub readsyms (\%$) {
	345	my ($syms, $file) = @_;
	346	local (*FILE, $_);
	347	open(FILE, "< $file")
	348	or die "embed.pl: Can't open $file: $!\n";
	349	while (<FILE>) {
	350	s/[ \t]#.//; # Delete comments.
	351	if (/^\s(\S+)\s$/) {
	352	my $sym = $1;
	353	warn "duplicate symbol $sym while processing $file line $.\n"
	354	if exists $$syms{$sym};
	355	$$syms{$sym} = 1;
	356	}
	357	}
	358	close(FILE);
	359	}
	360
	361	# Perl_pp_* and Perl_ck_* are in pp.sym
	362	readsyms my %ppsym, 'pp.sym';
	363
	364	sub readvars(\%$$@) {
	365	my ($syms, $file,$pre,$keep_pre) = @_;
	366	local (*FILE, $_);
	367	open(FILE, "< $file")
	368	or die "embed.pl: Can't open $file: $!\n";
	369	while (<FILE>) {
	370	s/[ \t]#.//; # Delete comments.
	371	if (/PERLVARA?I?S?C?\($pre(\w+)/) {
	372	my $sym = $1;
	373	$sym = $pre . $sym if $keep_pre;
	374	warn "duplicate symbol $sym while processing $file line $.\n"
	375	if exists $$syms{$sym};
	376	$$syms{$sym} = $pre \|\| 1;
	377	}
	378	}
	379	close(FILE);
	380	}
	381
	382	my %intrp;
	383	my %globvar;
	384
	385	readvars %intrp, 'intrpvar.h','I';
	386	readvars %globvar, 'perlvars.h','G';
	387
	388	my $sym;
	389
	390	sub undefine ($) {
	391	my ($sym) = @_;
	392	"#undef $sym\n";
	393	}
	394
	395	sub hide ($$) {
	396	my ($from, $to) = @_;
	397	my $t = int(length($from) / 8);
	398	"#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
	399	}
	400
	401	sub bincompat_var ($$) {
	402	my ($pfx, $sym) = @_;
	403	my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
	404	undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
	405	}
	406
	407	sub multon ($$$) {
	408	my ($sym,$pre,$ptr) = @_;
	409	hide("PL_$sym", "($ptr$pre$sym)");
	410	}
	411
	412	sub multoff ($$) {
	413	my ($sym,$pre) = @_;
	414	return hide("PL_$pre$sym", "PL_$sym");
	415	}
	416
	417	my $em = safer_open('embed.h-new');
	418
	419	print $em do_not_edit ("embed.h"), <<'END';
	420
	421	/* (Doing namespace management portably in C is really gross.) */
	422
	423	/* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
	424	* (like warn instead of Perl_warn) for the API are not defined.
	425	* Not defining the short forms is a good thing for cleaner embedding. */
	426
	427	#ifndef PERL_NO_SHORT_NAMES
	428
	429	/* Hide global symbols */
	430
	431	#if !defined(PERL_IMPLICIT_CONTEXT)
	432
	433	END
	434
	435	# Try to elimiate lots of repeated
	436	# #ifdef PERL_CORE
	437	# foo
	438	# #endif
	439	# #ifdef PERL_CORE
	440	# bar
	441	# #endif
	442	# by tracking state and merging foo and bar into one block.
	443	my $ifdef_state = '';
	444
	445	walk_table {
	446	my $ret = "";
	447	my $new_ifdef_state = '';
	448	if (@_ == 1) {
	449	my $arg = shift;
	450	$ret .= "$arg\n" if $arg =~ /^#\s*(if\|ifn?def\|else\|endif)\b/;
	451	}
	452	else {
	453	my ($flags,$retval,$func,@args) = @_;
	454	unless ($flags =~ /[om]/) {
	455	if ($flags =~ /s/) {
	456	$ret .= hide($func,"S_$func");
	457	}
	458	elsif ($flags =~ /p/) {
	459	$ret .= hide($func,"Perl_$func");
	460	}
	461	}
	462	if ($ret ne '' && $flags !~ /A/) {
	463	if ($flags =~ /E/) {
	464	$new_ifdef_state
	465	= "#if defined(PERL_CORE) \|\| defined(PERL_EXT)\n";
	466	}
	467	else {
	468	$new_ifdef_state = "#ifdef PERL_CORE\n";
	469	}
	470
	471	if ($new_ifdef_state ne $ifdef_state) {
	472	$ret = $new_ifdef_state . $ret;
	473	}
	474	}
	475	}
	476	if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
	477	# Close the old one ahead of opening the new one.
	478	$ret = "#endif\n$ret";
	479	}
	480	# Remember the new state.
	481	$ifdef_state = $new_ifdef_state;
	482	$ret;
	483	} $em, "";
	484
	485	if ($ifdef_state) {
	486	print $em "#endif\n";
	487	}
	488
	489	for $sym (sort keys %ppsym) {
	490	$sym =~ s/^Perl_//;
	491	print $em hide($sym, "Perl_$sym");
	492	}
	493
	494	print $em <<'END';
	495
	496	#else /* PERL_IMPLICIT_CONTEXT */
	497
	498	END
	499
	500	my @az = ('a'..'z');
	501
	502	$ifdef_state = '';
	503	walk_table {
	504	my $ret = "";
	505	my $new_ifdef_state = '';
	506	if (@_ == 1) {
	507	my $arg = shift;
	508	$ret .= "$arg\n" if $arg =~ /^#\s*(if\|ifn?def\|else\|endif)\b/;
	509	}
	510	else {
	511	my ($flags,$retval,$func,@args) = @_;
	512	unless ($flags =~ /[om]/) {
	513	my $args = scalar @args;
	514	if ($args and $args[$args-1] =~ /\.\.\./) {
	515	# we're out of luck for varargs functions under CPP
	516	}
	517	elsif ($flags =~ /n/) {
	518	if ($flags =~ /s/) {
	519	$ret .= hide($func,"S_$func");
	520	}
	521	elsif ($flags =~ /p/) {
	522	$ret .= hide($func,"Perl_$func");
	523	}
	524	}
	525	else {
	526	my $alist = join(",", @az[0..$args-1]);
	527	$ret = "#define $func($alist)";
	528	my $t = int(length($ret) / 8);
	529	$ret .= "\t" x ($t < 4 ? 4 - $t : 1);
	530	if ($flags =~ /s/) {
	531	$ret .= "S_$func(aTHX";
	532	}
	533	elsif ($flags =~ /p/) {
	534	$ret .= "Perl_$func(aTHX";
	535	}
	536	$ret .= "_ " if $alist;
	537	$ret .= $alist . ")\n";
	538	}
	539	}
	540	unless ($flags =~ /A/) {
	541	if ($flags =~ /E/) {
	542	$new_ifdef_state
	543	= "#if defined(PERL_CORE) \|\| defined(PERL_EXT)\n";
	544	}
	545	else {
	546	$new_ifdef_state = "#ifdef PERL_CORE\n";
	547	}
	548
	549	if ($new_ifdef_state ne $ifdef_state) {
	550	$ret = $new_ifdef_state . $ret;
	551	}
	552	}
	553	}
	554	if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
	555	# Close the old one ahead of opening the new one.
	556	$ret = "#endif\n$ret";
	557	}
	558	# Remember the new state.
	559	$ifdef_state = $new_ifdef_state;
	560	$ret;
	561	} $em, "";
	562
	563	if ($ifdef_state) {
	564	print $em "#endif\n";
	565	}
	566
	567	for $sym (sort keys %ppsym) {
	568	$sym =~ s/^Perl_//;
	569	if ($sym =~ /^ck_/) {
	570	print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
	571	}
	572	elsif ($sym =~ /^pp_/) {
	573	print $em hide("$sym()", "Perl_$sym(aTHX)");
	574	}
	575	else {
	576	warn "Illegal symbol '$sym' in pp.sym";
	577	}
	578	}
	579
	580	print $em <<'END';
	581
	582	#endif /* PERL_IMPLICIT_CONTEXT */
	583
	584	#endif /* #ifndef PERL_NO_SHORT_NAMES */
	585
	586	END
	587
	588	print $em <<'END';
	589
	590	/* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
	591	disable them.
	592	*/
	593
	594	#if !defined(PERL_CORE)
	595	# define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
	596	# define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr))
	597	#endif
	598
	599	#if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
	600
	601	/* Compatibility for various misnamed functions. All functions
	602	in the API that begin with "perl_" (not "Perl_") take an explicit
	603	interpreter context pointer.
	604	The following are not like that, but since they had a "perl_"
	605	prefix in previous versions, we provide compatibility macros.
	606	*/
	607	# define perl_atexit(a,b) call_atexit(a,b)
	608	# define perl_call_argv(a,b,c) call_argv(a,b,c)
	609	# define perl_call_pv(a,b) call_pv(a,b)
	610	# define perl_call_method(a,b) call_method(a,b)
	611	# define perl_call_sv(a,b) call_sv(a,b)
	612	# define perl_eval_sv(a,b) eval_sv(a,b)
	613	# define perl_eval_pv(a,b) eval_pv(a,b)
	614	# define perl_require_pv(a) require_pv(a)
	615	# define perl_get_sv(a,b) get_sv(a,b)
	616	# define perl_get_av(a,b) get_av(a,b)
	617	# define perl_get_hv(a,b) get_hv(a,b)
	618	# define perl_get_cv(a,b) get_cv(a,b)
	619	# define perl_init_i18nl10n(a) init_i18nl10n(a)
	620	# define perl_init_i18nl14n(a) init_i18nl14n(a)
	621	# define perl_new_ctype(a) new_ctype(a)
	622	# define perl_new_collate(a) new_collate(a)
	623	# define perl_new_numeric(a) new_numeric(a)
	624
	625	/* varargs functions can't be handled with CPP macros. :-(
	626	This provides a set of compatibility functions that don't take
	627	an extra argument but grab the context pointer using the macro
	628	dTHX.
	629	*/
	630	#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
	631	# define croak Perl_croak_nocontext
	632	# define deb Perl_deb_nocontext
	633	# define die Perl_die_nocontext
	634	# define form Perl_form_nocontext
	635	# define load_module Perl_load_module_nocontext
	636	# define mess Perl_mess_nocontext
	637	# define newSVpvf Perl_newSVpvf_nocontext
	638	# define sv_catpvf Perl_sv_catpvf_nocontext
	639	# define sv_setpvf Perl_sv_setpvf_nocontext
	640	# define warn Perl_warn_nocontext
	641	# define warner Perl_warner_nocontext
	642	# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
	643	# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
	644	#endif
	645
	646	#endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
	647
	648	#if !defined(PERL_IMPLICIT_CONTEXT)
	649	/* undefined symbols, point them back at the usual ones */
	650	# define Perl_croak_nocontext Perl_croak
	651	# define Perl_die_nocontext Perl_die
	652	# define Perl_deb_nocontext Perl_deb
	653	# define Perl_form_nocontext Perl_form
	654	# define Perl_load_module_nocontext Perl_load_module
	655	# define Perl_mess_nocontext Perl_mess
	656	# define Perl_newSVpvf_nocontext Perl_newSVpvf
	657	# define Perl_sv_catpvf_nocontext Perl_sv_catpvf
	658	# define Perl_sv_setpvf_nocontext Perl_sv_setpvf
	659	# define Perl_warn_nocontext Perl_warn
	660	# define Perl_warner_nocontext Perl_warner
	661	# define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
	662	# define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
	663	#endif
	664
	665	/* ex: set ro: */
	666	END
	667
	668	safer_close($em);
	669	rename_if_different('embed.h-new', 'embed.h');
	670
	671	$em = safer_open('embedvar.h-new');
	672
	673	print $em do_not_edit ("embedvar.h"), <<'END';
	674
	675	/* (Doing namespace management portably in C is really gross.) */
	676
	677	/*
	678	The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
	679	are supported:
	680	1) none
	681	2) MULTIPLICITY # supported for compatibility
	682	3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
	683
	684	All other combinations of these flags are errors.
	685
	686	only #3 is supported directly, while #2 is a special
	687	case of #3 (supported by redefining vTHX appropriately).
	688	*/
	689
	690	#if defined(MULTIPLICITY)
	691	/* cases 2 and 3 above */
	692
	693	# if defined(PERL_IMPLICIT_CONTEXT)
	694	# define vTHX aTHX
	695	# else
	696	# define vTHX PERL_GET_INTERP
	697	# endif
	698
	699	END
	700
	701	for $sym (sort keys %intrp) {
	702	print $em multon($sym,'I','vTHX->');
	703	}
	704
	705	print $em <<'END';
	706
	707	#else /* !MULTIPLICITY */
	708
	709	/* case 1 above */
	710
	711	END
	712
	713	for $sym (sort keys %intrp) {
	714	print $em multoff($sym,'I');
	715	}
	716
	717	print $em <<'END';
	718
	719	END
	720
	721	print $em <<'END';
	722
	723	#endif /* MULTIPLICITY */
	724
	725	#if defined(PERL_GLOBAL_STRUCT)
	726
	727	END
	728
	729	for $sym (sort keys %globvar) {
	730	print $em multon($sym, 'G','my_vars->');
	731	print $em multon("G$sym",'', 'my_vars->');
	732	}
	733
	734	print $em <<'END';
	735
	736	#else /* !PERL_GLOBAL_STRUCT */
	737
	738	END
	739
	740	for $sym (sort keys %globvar) {
	741	print $em multoff($sym,'G');
	742	}
	743
	744	print $em <<'END';
	745
	746	#endif /* PERL_GLOBAL_STRUCT */
	747
	748	#ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
	749
	750	END
	751
	752	for $sym (sort @extvars) {
	753	print $em hide($sym,"PL_$sym");
	754	}
	755
	756	print $em <<'END';
	757
	758	#endif /* PERL_POLLUTE */
	759
	760	/* ex: set ro: */
	761	END
	762
	763	safer_close($em);
	764	rename_if_different('embedvar.h-new', 'embedvar.h');
	765
	766	my $capi = safer_open('perlapi.c-new');
	767	my $capih = safer_open('perlapi.h-new');
	768
	769	print $capih do_not_edit ("perlapi.h"), <<'EOT';
	770
	771	/* declare accessor functions for Perl variables */
	772	#ifndef __perlapi_h__
	773	#define __perlapi_h__
	774
	775	#if defined (MULTIPLICITY)
	776
	777	START_EXTERN_C
	778
	779	#undef PERLVAR
	780	#undef PERLVARA
	781	#undef PERLVARI
	782	#undef PERLVARIC
	783	#undef PERLVARISC
	784	#define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
	785	#define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
	786	EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
	787	#define PERLVARI(v,t,i) PERLVAR(v,t)
	788	#define PERLVARIC(v,t,i) PERLVAR(v, const t)
	789	#define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \
	790	EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
	791
	792	#include "intrpvar.h"
	793	#include "perlvars.h"
	794
	795	#undef PERLVAR
	796	#undef PERLVARA
	797	#undef PERLVARI
	798	#undef PERLVARIC
	799	#undef PERLVARISC
	800
	801	#ifndef PERL_GLOBAL_STRUCT
	802	EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
	803	EXTERN_C Perl_check_t** Perl_Gcheck_ptr(pTHX);
	804	EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
	805	#define Perl_ppaddr_ptr Perl_Gppaddr_ptr
	806	#define Perl_check_ptr Perl_Gcheck_ptr
	807	#define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
	808	#endif
	809
	810	END_EXTERN_C
	811
	812	#if defined(PERL_CORE)
	813
	814	/* accessor functions for Perl variables (provide binary compatibility) */
	815
	816	/* these need to be mentioned here, or most linkers won't put them in
	817	the perl executable */
	818
	819	#ifndef PERL_NO_FORCE_LINK
	820
	821	START_EXTERN_C
	822
	823	#ifndef DOINIT
	824	EXTCONST void * const PL_force_link_funcs[];
	825	#else
	826	EXTCONST void * const PL_force_link_funcs[] = {
	827	#undef PERLVAR
	828	#undef PERLVARA
	829	#undef PERLVARI
	830	#undef PERLVARIC
	831	#define PERLVAR(v,t) (void*)Perl_##v##_ptr,
	832	#define PERLVARA(v,n,t) PERLVAR(v,t)
	833	#define PERLVARI(v,t,i) PERLVAR(v,t)
	834	#define PERLVARIC(v,t,i) PERLVAR(v,t)
	835	#define PERLVARISC(v,i) PERLVAR(v,char)
	836
	837	/* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
	838	* cannot cast between void pointers and function pointers without
	839	* info level warnings. The PL_force_link_funcs[] would cause a few
	840	* hundred of those warnings. In code one can circumnavigate this by using
	841	* unions that overlay the different pointers, but in declarations one
	842	* cannot use this trick. Therefore we just disable the warning here
	843	* for the duration of the PL_force_link_funcs[] declaration. */
	844
	845	#if defined(__DECC) && defined(__osf__)
	846	#pragma message save
	847	#pragma message disable (nonstandcast)
	848	#endif
	849
	850	#include "intrpvar.h"
	851	#include "perlvars.h"
	852
	853	#if defined(__DECC) && defined(__osf__)
	854	#pragma message restore
	855	#endif
	856
	857	#undef PERLVAR
	858	#undef PERLVARA
	859	#undef PERLVARI
	860	#undef PERLVARIC
	861	#undef PERLVARISC
	862	};
	863	#endif /* DOINIT */
	864
	865	END_EXTERN_C
	866
	867	#endif /* PERL_NO_FORCE_LINK */
	868
	869	#else /* !PERL_CORE */
	870
	871	EOT
	872
	873	foreach $sym (sort keys %intrp) {
	874	print $capih bincompat_var('I',$sym);
	875	}
	876
	877	foreach $sym (sort keys %globvar) {
	878	print $capih bincompat_var('G',$sym);
	879	}
	880
	881	print $capih <<'EOT';
	882
	883	#endif /* !PERL_CORE */
	884	#endif /* MULTIPLICITY */
	885
	886	#endif /* __perlapi_h__ */
	887
	888	/* ex: set ro: */
	889	EOT
	890	safer_close($capih);
	891	rename_if_different('perlapi.h-new', 'perlapi.h');
	892
	893	print $capi do_not_edit ("perlapi.c"), <<'EOT';
	894
	895	#include "EXTERN.h"
	896	#include "perl.h"
	897	#include "perlapi.h"
	898
	899	#if defined (MULTIPLICITY)
	900
	901	/* accessor functions for Perl variables (provides binary compatibility) */
	902	START_EXTERN_C
	903
	904	#undef PERLVAR
	905	#undef PERLVARA
	906	#undef PERLVARI
	907	#undef PERLVARIC
	908	#undef PERLVARISC
	909
	910	#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
	911	{ dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
	912	#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
	913	{ dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
	914
	915	#define PERLVARI(v,t,i) PERLVAR(v,t)
	916	#define PERLVARIC(v,t,i) PERLVAR(v, const t)
	917	#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
	918	{ dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
	919
	920	#include "intrpvar.h"
	921
	922	#undef PERLVAR
	923	#undef PERLVARA
	924	#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
	925	{ dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
	926	#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
	927	{ dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
	928	#undef PERLVARIC
	929	#undef PERLVARISC
	930	#define PERLVARIC(v,t,i) \
	931	const t* Perl_##v##_ptr(pTHX) \
	932	{ PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
	933	#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
	934	{ dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
	935	#include "perlvars.h"
	936
	937	#undef PERLVAR
	938	#undef PERLVARA
	939	#undef PERLVARI
	940	#undef PERLVARIC
	941	#undef PERLVARISC
	942
	943	#ifndef PERL_GLOBAL_STRUCT
	944	/* A few evil special cases. Could probably macrofy this. */
	945	#undef PL_ppaddr
	946	#undef PL_check
	947	#undef PL_fold_locale
	948	Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
	949	static Perl_ppaddr_t* const ppaddr_ptr = PL_ppaddr;
	950	PERL_UNUSED_CONTEXT;
	951	return (Perl_ppaddr_t**)&ppaddr_ptr;
	952	}
	953	Perl_check_t** Perl_Gcheck_ptr(pTHX) {
	954	static Perl_check_t* const check_ptr = PL_check;
	955	PERL_UNUSED_CONTEXT;
	956	return (Perl_check_t**)&check_ptr;
	957	}
	958	unsigned char** Perl_Gfold_locale_ptr(pTHX) {
	959	static unsigned char* const fold_locale_ptr = PL_fold_locale;
	960	PERL_UNUSED_CONTEXT;
	961	return (unsigned char**)&fold_locale_ptr;
	962	}
	963	#endif
	964
	965	END_EXTERN_C
	966
	967	#endif /* MULTIPLICITY */
	968
	969	/* ex: set ro: */
	970	EOT
	971
	972	safer_close($capi);
	973	rename_if_different('perlapi.c-new', 'perlapi.c');
	974
	975	# functions that take va_list* for implementing vararg functions
	976	# NOTE: makedef.pl must be updated if you add symbols to %vfuncs
	977	# XXX %vfuncs currently unused
	978	my %vfuncs = qw(
	979	Perl_croak Perl_vcroak
	980	Perl_warn Perl_vwarn
	981	Perl_warner Perl_vwarner
	982	Perl_die Perl_vdie
	983	Perl_form Perl_vform
	984	Perl_load_module Perl_vload_module
	985	Perl_mess Perl_vmess
	986	Perl_deb Perl_vdeb
	987	Perl_newSVpvf Perl_vnewSVpvf
	988	Perl_sv_setpvf Perl_sv_vsetpvf
	989	Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
	990	Perl_sv_catpvf Perl_sv_vcatpvf
	991	Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
	992	Perl_dump_indent Perl_dump_vindent
	993	Perl_default_protect Perl_vdefault_protect
	994	);
	995
	996	# ex: set ts=8 sts=4 sw=4 noet: