X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1b6737cc10a847650f574c35f419cbd680a5a5ef..60666776a83addda0a7fcb957c6b5007b8e030f3:/embed.pl diff --git a/embed.pl b/embed.pl index 778090f..22d8780 100755 --- a/embed.pl +++ b/embed.pl @@ -1,13 +1,38 @@ #!/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, @@ -19,7 +44,7 @@ sub do_not_edit ($) { 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; @@ -35,7 +60,7 @@ sub do_not_edit ($) !!!!!!! 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. @@ -46,7 +71,9 @@ EOW 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 @@ -66,127 +93,98 @@ EOW open IN, "embed.fnc" or die $!; +my @embed; +my (%has_va, %has_nocontext); + +while () { + chomp; + next if /^:/; + while (s|\\$||) { + $_ .= ; + 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 () { - chomp; - next if /^:/; - while (s|\\$||) { - $_ .= ; - 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"; } @@ -194,8 +192,30 @@ sub write_protos { 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; } @@ -207,21 +227,27 @@ sub write_protos { 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; @@ -232,49 +258,38 @@ sub write_protos { $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) = @_; @@ -285,7 +300,7 @@ sub readsyms (\%$) { 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; } @@ -306,7 +321,7 @@ sub readvars(\%$$@) { 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; } @@ -315,26 +330,23 @@ sub readvars(\%$$@) { } 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 ($$) { @@ -353,11 +365,9 @@ sub multoff ($$) { 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.) */ @@ -388,16 +398,16 @@ walk_table { 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/) { @@ -421,18 +431,18 @@ walk_table { # 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 */ @@ -446,23 +456,23 @@ walk_table { 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)"; @@ -499,26 +509,26 @@ walk_table { # 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 */ @@ -526,7 +536,7 @@ print EM <<'END'; END -print EM <<'END'; +print $em <<'END'; /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to disable them. @@ -534,7 +544,7 @@ print EM <<'END'; #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) @@ -546,22 +556,21 @@ print EM <<'END'; 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 @@ -569,51 +578,41 @@ print EM <<'END'; 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.) */ @@ -641,21 +640,11 @@ print EM do_not_edit ("embedvar.h"), <<'END'; 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 */ @@ -664,18 +653,14 @@ print EM <<'END'; 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 */ @@ -684,55 +669,40 @@ print EM <<'END'; 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 @@ -749,8 +719,6 @@ 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 @@ -759,20 +727,11 @@ START_EXTERN_C #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 */ @@ -808,8 +767,6 @@ EXTCONST void * const PL_force_link_funcs[] = { #pragma message disable (nonstandcast) #endif -#include "thrdvar.h" -#include "intrpvar.h" #include "perlvars.h" #if defined(__DECC) && defined(__osf__) @@ -832,72 +789,49 @@ END_EXTERN_C 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 @@ -906,53 +840,14 @@ START_EXTERN_C #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: