#!/usr/bin/perl -w
+#
+# Regenerate (overwriting only if changed):
+#
+# embed.h
+# embedvar.h
+# global.sym
+# perlapi.c
+# perlapi.h
+# proto.h
+#
+# from information stored in
+#
+# embed.fnc
+# intrpvar.h
+# perlvars.h
+# pp.sym (which has been generated by opcode.pl)
+#
+# Accepts the standard regen_lib -q and -v args.
+#
+# This script is normally invoked from regen.pl.
-require 5.003; # keep this compatible, an old perl is all we may have before
+require 5.004; # keep this compatible, an old perl is all we may have before
# we build the new one
+use strict;
+
BEGIN {
# Get function prototypes
require 'regen_lib.pl';
}
+my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org
+my $unflagged_pointers;
+
#
# See database of global and static function prototypes in embed.fnc
# This is used to generate prototype headers under various configurations,
{
my $file = shift;
- my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005';
+ my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009';
$years =~ s/1999,/1999,\n / if length $years > 40;
!!!!!!! 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.
+pp.sym, intrpvar.h, and perlvars.h.
Any changes made here will be lost!
Edit those files and run 'make regen_headers' to effect changes.
Up to the threshold of the door there mounted a flight of twenty-seven
broad stairs, hewn by some unknown art of the same black stone. This
-was the only entrance to the tower.
+was the only entrance to the tower; ...
+
+ [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
EOW
open IN, "embed.fnc" or die $!;
+my @embed;
+my (%has_va, %has_nocontext);
+
+while (<IN>) {
+ chomp;
+ next if /^:/;
+ while (s|\\$||) {
+ $_ .= <IN>;
+ chomp;
+ }
+ s/\s+$//;
+ my @args;
+ if (/^\s*(#|$)/) {
+ @args = $_;
+ }
+ else {
+ @args = split /\s*\|\s*/, $_;
+ my $func = $args[2];
+ if ($func) {
+ ++$has_va{$func} if $args[-1] =~ /\.\.\./;
+ ++$has_nocontext{$1} if $func =~ /(.*)_nocontext/;
+ }
+ }
+ push @embed, \@args;
+}
+
# 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 ($function, $filename, $trailer) = @_;
my $F;
- local *F;
if (ref $filename) { # filehandle
$F = $filename;
}
else {
- safer_unlink $filename if $filename ne '/dev/null';
- open F, ">$filename" or die "Can't open $filename: $!";
- binmode F;
- $F = \*F;
+ $F = safer_open("$filename-new");
+ print $F do_not_edit ($filename);
}
- print $F $leader if $leader;
- seek IN, 0, 0; # so we may restart
- while (<IN>) {
- chomp;
- next if /^:/;
- while (s|\\$||) {
- $_ .= <IN>;
- chomp;
- }
- s/\s+$//;
- my @args;
- if (/^\s*(#|$)/) {
- @args = $_;
- }
- else {
- @args = split /\s*\|\s*/, $_;
- }
- my @outs = &{$function}(@args);
- print $F @outs; # $function->(@args) is not 5.003
+ foreach (@embed) {
+ my @outs = &{$function}(@$_);
+ # $function->(@args) is not 5.003
+ print $F @outs;
}
print $F $trailer if $trailer;
unless (ref $filename) {
- close $F or die "Error closing $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 $.
+ safer_close($F);
+ rename_if_different("$filename-new", $filename);
}
- exit;
}
-#munge_c_files();
-
# generate proto.h
my $wrote_protected = 0;
sub write_protos {
- my $ret = "";
+ my $ret;
if (@_ == 1) {
my $arg = shift;
- $ret .= "$arg\n";
+ $ret = "$arg\n";
}
else {
- my ($flags,$retval,$func,@args) = @_;
+ my ($flags,$retval,$plain_func,@args) = @_;
my @nonnull;
my $has_context = ( $flags !~ /n/ );
- $ret .= '/* ' if $flags =~ /m/;
+ my $never_returns = ( $flags =~ /r/ );
+ my $commented_out = ( $flags =~ /m/ );
+ my $binarycompat = ( $flags =~ /b/ );
+ my $is_malloc = ( $flags =~ /a/ );
+ my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
+ my @names_of_nn;
+ my $func;
+
+ my $splint_flags = "";
+ if ( $SPLINT && !$commented_out ) {
+ $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
+ if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
+ $retval .= " /*\@alt void\@*/";
+ }
+ }
+
if ($flags =~ /s/) {
- $retval = "STATIC $retval";
- $func = "S_$func";
+ $retval = "STATIC $splint_flags$retval";
+ $func = "S_$plain_func";
}
else {
- $retval = "PERL_CALLCONV $retval";
- if ($flags =~ /p/) {
- $func = "Perl_$func";
+ $retval = "PERL_CALLCONV $splint_flags$retval";
+ if ($flags =~ /[bp]/) {
+ $func = "Perl_$plain_func";
+ } else {
+ $func = $plain_func;
}
}
- $ret .= "$retval\t$func(";
+ $ret = "$retval\t$func(";
if ( $has_context ) {
$ret .= @args ? "pTHX_ " : "pTHX";
}
my $n;
for my $arg ( @args ) {
++$n;
- push( @nonnull, $n ) if ( $arg =~ s/\s*\bNN\b\s+// );
- $arg =~ s/\s*\bNULLOK\b\s+//; # strip NULLOK with no effect
+ if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
+ warn "$func: $arg needs NN or NULLOK\n";
+ ++$unflagged_pointers;
+ }
+ my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
+ push( @nonnull, $n ) if $nn;
+
+ my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
+
+ # Make sure each arg has at least a type and a var name.
+ # An arg of "int" is valid C, but want it to be "int foo".
+ my $temp_arg = $arg;
+ $temp_arg =~ s/\*//g;
+ $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
+ if ( ($temp_arg ne "...")
+ && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
+ warn "$func: $arg ($n) doesn't have a name\n";
+ }
+ if ( $SPLINT && $nullok && !$commented_out ) {
+ $arg = '/*@null@*/ ' . $arg;
+ }
+ if (defined $1 && $nn && !($commented_out && !$binarycompat)) {
+ push @names_of_nn, $1;
+ }
}
$ret .= join ", ", @args;
}
if ( $flags =~ /r/ ) {
push @attrs, "__attribute__noreturn__";
}
- if ( $flags =~ /a/ ) {
+ if ( $flags =~ /D/ ) {
+ push @attrs, "__attribute__deprecated__";
+ }
+ if ( $is_malloc ) {
push @attrs, "__attribute__malloc__";
- $flags .= "R"; # All allocing must check return value
}
- if ( $flags =~ /R/ ) {
+ if ( !$can_ignore ) {
push @attrs, "__attribute__warn_unused_result__";
}
if ( $flags =~ /P/ ) {
push @attrs, "__attribute__pure__";
}
if( $flags =~ /f/ ) {
- my $prefix = $has_context ? 'pTHX_' : '';
- my $args = scalar @args;
- push @attrs, sprintf "__attribute__format__(__printf__,%s%d,%s%d)",
- $prefix, $args - 1, $prefix, $args;
+ my $prefix = $has_context ? 'pTHX_' : '';
+ my $args = scalar @args;
+ my $pat = $args - 1;
+ my $macro = @nonnull && $nonnull[-1] == $pat
+ ? '__attribute__format__'
+ : '__attribute__format__null_ok__';
+ push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
+ $prefix, $pat, $prefix, $args;
}
if ( @nonnull ) {
my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
$ret .= join( "\n", map { "\t\t\t$_" } @attrs );
}
$ret .= ";";
- $ret .= ' */' if $flags =~ /m/;
+ $ret = "/* $ret */" if $commented_out;
+ if (@names_of_nn) {
+ $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
+ . join '; ', map "assert($_)", @names_of_nn;
+ }
$ret .= @attrs ? "\n\n" : "\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 =~ /[AX]/ && $flags !~ /[xm]/
- || $flags =~ /b/) { # public API, so export
- $func = "Perl_$func" if $flags =~ /[pbX]/;
- $ret = "$func\n";
- }
- }
- $ret;
+# generates global.sym (API export list)
+{
+ my %seen;
+ sub write_global_sym {
+ if (@_ > 1) {
+ my ($flags,$retval,$func,@args) = @_;
+ # If a function is defined twice, for example before and after an
+ # #else, only process the flags on the first instance for global.sym
+ return '' if $seen{$func}++;
+ if ($flags =~ /[AX]/ && $flags !~ /[xm]/
+ || $flags =~ /b/) { # public API, so export
+ $func = "Perl_$func" if $flags =~ /[pbX]/;
+ return "$func\n";
+ }
+ }
+ return '';
+ }
}
-walk_table(\&write_protos, "proto.h", undef, "/* ex: set ro: */\n");
-walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
-
-# 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 DBassertion debstash
- rsfp
- stdingv
- defgv
- errgv
- rsfp_filters
- perldb
- diehook
- dirty
- perl_destruct_level
- ppaddr
- );
+walk_table(\&write_protos, "proto.h", "/* ex: set ro: */\n");
+warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
+walk_table(\&write_global_sym, "global.sym", "# ex: set ro:\n");
sub readsyms (\%$) {
my ($syms, $file) = @_;
s/[ \t]*#.*//; # Delete comments.
if (/^\s*(\S+)\s*$/) {
my $sym = $1;
- warn "duplicate symbol $sym while processing $file\n"
+ warn "duplicate symbol $sym while processing $file line $.\n"
if exists $$syms{$sym};
$$syms{$sym} = 1;
}
if (/PERLVARA?I?S?C?\($pre(\w+)/) {
my $sym = $1;
$sym = $pre . $sym if $keep_pre;
- warn "duplicate symbol $sym while processing $file\n"
+ warn "duplicate symbol $sym while processing $file line $.\n"
if exists $$syms{$sym};
$$syms{$sym} = $pre || 1;
}
}
my %intrp;
-my %thread;
+my %globvar;
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 hide {
+ my ($from, $to, $indent) = @_;
+ $indent = '' unless defined $indent;
+ my $t = int(length("$indent$from") / 8);
+ "#${indent}define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
}
sub bincompat_var ($$) {
return hide("PL_$pre$sym", "PL_$sym");
}
-safer_unlink 'embed.h';
-open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
-binmode EM;
+my $em = safer_open('embed.h-new');
-print EM do_not_edit ("embed.h"), <<'END';
+print $em do_not_edit ("embed.h"), <<'END';
/* (Doing namespace management portably in C is really gross.) */
my $new_ifdef_state = '';
if (@_ == 1) {
my $arg = shift;
- $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
+ $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");
+ $ret = hide($func,"S_$func");
}
elsif ($flags =~ /p/) {
- $ret .= hide($func,"Perl_$func");
+ $ret = hide($func,"Perl_$func");
}
}
if ($ret ne '' && $flags !~ /A/) {
# Remember the new state.
$ifdef_state = $new_ifdef_state;
$ret;
-} \*EM, "";
+} $em;
if ($ifdef_state) {
- print EM "#endif\n";
+ print $em "#endif\n";
}
for $sym (sort keys %ppsym) {
$sym =~ s/^Perl_//;
- print EM hide($sym, "Perl_$sym");
+ print $em hide($sym, "Perl_$sym");
}
-print EM <<'END';
+print $em <<'END';
#else /* PERL_IMPLICIT_CONTEXT */
my $new_ifdef_state = '';
if (@_ == 1) {
my $arg = shift;
- $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
+ $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 =~ /n/) {
if ($flags =~ /s/) {
- $ret .= hide($func,"S_$func");
+ $ret = hide($func,"S_$func");
}
elsif ($flags =~ /p/) {
- $ret .= hide($func,"Perl_$func");
+ $ret = hide($func,"Perl_$func");
}
}
+ elsif ($args and $args[$args-1] =~ /\.\.\./) {
+ # we're out of luck for varargs functions under CPP
+ }
else {
my $alist = join(",", @az[0..$args-1]);
$ret = "#define $func($alist)";
# Remember the new state.
$ifdef_state = $new_ifdef_state;
$ret;
-} \*EM, "";
+} $em;
if ($ifdef_state) {
- print EM "#endif\n";
+ print $em "#endif\n";
}
for $sym (sort keys %ppsym) {
$sym =~ s/^Perl_//;
if ($sym =~ /^ck_/) {
- print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
+ print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
}
elsif ($sym =~ /^pp_/) {
- print EM hide("$sym()", "Perl_$sym(aTHX)");
+ print $em hide("$sym()", "Perl_$sym(aTHX)");
}
else {
warn "Illegal symbol '$sym' in pp.sym";
}
}
-print EM <<'END';
+print $em <<'END';
#endif /* PERL_IMPLICIT_CONTEXT */
END
-print EM <<'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))
+# define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr))
#endif
#if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
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)
+END
+
+walk_table {
+ my ($flags,$retval,$func,@args) = @_;
+ return unless $func;
+ return unless $flags =~ /O/;
+
+ my $alist = join ",", @az[0..$#args];
+ my $ret = "# define perl_$func($alist)";
+ my $t = (length $ret) >> 3;
+ $ret .= "\t" x ($t < 5 ? 5 - $t : 1);
+ "$ret$func($alist)\n";
+} $em;
+
+print $em <<'END';
/* varargs functions can't be handled with CPP macros. :-(
This provides a set of compatibility functions that don't take
dTHX.
*/
#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
-# 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
+END
+
+foreach (sort keys %has_va) {
+ next unless $has_nocontext{$_};
+ next if /printf/; # Not clear to me why these are skipped but they are.
+ print $em hide($_, "Perl_${_}_nocontext", " ");
+}
+
+print $em <<'END';
#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
+END
+
+foreach (sort keys %has_va) {
+ next unless $has_nocontext{$_};
+ next if /printf/; # Not clear to me why these are skipped but they are.
+ print $em hide("Perl_${_}_nocontext", "Perl_$_", " ");
+}
+
+print $em <<'END';
#endif
/* ex: set ro: */
END
-close(EM) or die "Error closing EM: $!";
+safer_close($em);
+rename_if_different('embed.h-new', 'embed.h');
-safer_unlink 'embedvar.h';
-open(EM, '> embedvar.h')
- or die "Can't create embedvar.h: $!\n";
-binmode EM;
+$em = safer_open('embedvar.h-new');
-print EM do_not_edit ("embedvar.h"), <<'END';
+print $em do_not_edit ("embedvar.h"), <<'END';
/* (Doing namespace management portably in C is really gross.) */
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 multon($sym,'I','vTHX->');
}
-print EM <<'END';
+print $em <<'END';
#else /* !MULTIPLICITY */
END
for $sym (sort keys %intrp) {
- print EM multoff($sym,'I');
+ print $em multoff($sym,'I');
}
-print EM <<'END';
+print $em <<'END';
END
-for $sym (sort keys %thread) {
- print EM multoff($sym,'T');
-}
-
-print EM <<'END';
+print $em <<'END';
#endif /* MULTIPLICITY */
END
for $sym (sort keys %globvar) {
- print EM multon($sym, 'G','my_vars->');
- print EM multon("G$sym",'', 'my_vars->');
+ print $em multon($sym, 'G','my_vars->');
+ print $em multon("G$sym",'', 'my_vars->');
}
-print EM <<'END';
+print $em <<'END';
#else /* !PERL_GLOBAL_STRUCT */
END
for $sym (sort keys %globvar) {
- print EM multoff($sym,'G');
+ print $em multoff($sym,'G');
}
-print EM <<'END';
+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 */
-
/* ex: set ro: */
END
-close(EM) or die "Error closing EM: $!";
+safer_close($em);
+rename_if_different('embedvar.h-new', 'embedvar.h');
-safer_unlink 'perlapi.h';
-safer_unlink 'perlapi.c';
-open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
-binmode CAPI;
-open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
-binmode CAPIH;
+my $capi = safer_open('perlapi.c-new');
+my $capih = safer_open('perlapi.h-new');
-print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
+print $capih do_not_edit ("perlapi.h"), <<'EOT';
/* declare accessor functions for Perl variables */
#ifndef __perlapi_h__
#define __perlapi_h__
-#if defined (MULTIPLICITY)
+#if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
START_EXTERN_C
#define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \
EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
-#include "thrdvar.h"
-#include "intrpvar.h"
#include "perlvars.h"
#undef PERLVAR
#undef PERLVARIC
#undef PERLVARISC
-#ifndef PERL_GLOBAL_STRUCT
-EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
-EXTERN_C Perl_check_t** Perl_Gcheck_ptr(pTHX);
-EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
-#define Perl_ppaddr_ptr Perl_Gppaddr_ptr
-#define Perl_check_ptr Perl_Gcheck_ptr
-#define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
-#endif
-
END_EXTERN_C
#if defined(PERL_CORE)
-/* accessor functions for Perl variables (provide binary compatibility) */
+/* accessor functions for Perl "global" variables */
/* these need to be mentioned here, or most linkers won't put them in
the perl executable */
#pragma message disable (nonstandcast)
#endif
-#include "thrdvar.h"
-#include "intrpvar.h"
#include "perlvars.h"
#if defined(__DECC) && defined(__osf__)
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 bincompat_var('G',$sym);
}
-print CAPIH <<'EOT';
+print $capih <<'EOT';
#endif /* !PERL_CORE */
-#endif /* MULTIPLICITY */
+#endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
#endif /* __perlapi_h__ */
/* ex: set ro: */
EOT
-close CAPIH or die "Error closing CAPIH: $!";
+safer_close($capih);
+rename_if_different('perlapi.h-new', 'perlapi.h');
-print CAPI do_not_edit ("perlapi.c"), <<'EOT';
+print $capi do_not_edit ("perlapi.c"), <<'EOT';
#include "EXTERN.h"
#include "perl.h"
#include "perlapi.h"
-#if defined (MULTIPLICITY)
+#if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
-/* accessor functions for Perl variables (provides binary compatibility) */
+/* accessor functions for Perl "global" variables */
START_EXTERN_C
-#undef PERLVAR
-#undef PERLVARA
#undef PERLVARI
-#undef PERLVARIC
-#undef PERLVARISC
-
-#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(aTHX->v); }
-#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(aTHX->v); }
-
-#define PERLVARI(v,t,i) PERLVAR(v,t)
-#define PERLVARIC(v,t,i) PERLVAR(v, const t)
-#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(aTHX->v); }
-
-#include "thrdvar.h"
-#include "intrpvar.h"
+#define PERLVARI(v,t,i) PERLVAR(v,t)
#undef PERLVAR
#undef PERLVARA
#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(PL_##v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(PL_##v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
#undef PERLVARIC
#undef PERLVARISC
#define PERLVARIC(v,t,i) \
const t* Perl_##v##_ptr(pTHX) \
- { return (const t *)&(PL_##v); }
+ { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(PL_##v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
#include "perlvars.h"
#undef PERLVAR
#undef PERLVARIC
#undef PERLVARISC
-#ifndef PERL_GLOBAL_STRUCT
-/* A few evil special cases. Could probably macrofy this. */
-#undef PL_ppaddr
-#undef PL_check
-#undef PL_fold_locale
-Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
- static const Perl_ppaddr_t* ppaddr_ptr = PL_ppaddr;
- return (Perl_ppaddr_t**)&ppaddr_ptr;
-}
-Perl_check_t** Perl_Gcheck_ptr(pTHX) {
- static const Perl_check_t* check_ptr = PL_check;
- return (Perl_check_t**)&check_ptr;
-}
-unsigned char** Perl_Gfold_locale_ptr(pTHX) {
- static const unsigned char* fold_locale_ptr = PL_fold_locale;
- return (unsigned char**)&fold_locale_ptr;
-}
-#endif
-
END_EXTERN_C
-#endif /* MULTIPLICITY */
+#endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
/* ex: set ro: */
EOT
-close(CAPI) or die "Error closing 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
-);
+safer_close($capi);
+rename_if_different('perlapi.c-new', 'perlapi.c');
# ex: set ts=8 sts=4 sw=4 noet:
https://perl5.git.perl.org / perl5.git / blobdiff