X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=embed.pl;h=9c55cb4b6596077e3b7a8a5f1dee05c0168c1762;hb=434477a5e20cf332e549a03f5cfa9d6f98829ecc;hp=5aee84fdb72dd142cc84dd35fdce42255bfe1dd7;hpb=96a5add60f1f39d38341c09c11f0542e68f782b0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/embed.pl b/embed.pl index 5aee84f..9c55cb4 100755 --- a/embed.pl +++ b/embed.pl @@ -1,13 +1,39 @@ #!/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) +# +# plus from the values hardcoded into this script in @extvars. +# +# 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 # 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 + # # See database of global and static function prototypes in embed.fnc # This is used to generate prototype headers under various configurations, @@ -19,7 +45,7 @@ sub do_not_edit ($) { my $file = shift; - my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006'; + 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 +61,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 +72,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 @@ -75,15 +103,12 @@ sub walk_table (&@) { defined $leader or $leader = do_not_edit ($filename); my $trailer = shift; 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; + # safer_unlink $filename if $filename ne '/dev/null'; + $F = safer_open("$filename-new"); } print $F $leader if $leader; seek IN, 0, 0; # so we may restart @@ -107,7 +132,8 @@ sub walk_table (&@) { } print $F $trailer if $trailer; unless (ref $filename) { - close $F or die "Error closing $filename: $!"; + safer_close($F); + rename_if_different("$filename-new", $filename); } } @@ -152,18 +178,35 @@ sub write_protos { $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("; @@ -179,16 +222,25 @@ sub write_protos { our $unflagged_pointers; ++$unflagged_pointers; } - push( @nonnull, $n ) if ( $arg =~ s/\s*\bNN\b\s+// ); - $arg =~ s/\s*\bNULLOK\b\s+//; # strip NULLOK with no effect + 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+/) ) { - warn "$func: $arg doesn't have a name\n"; + 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; @@ -201,21 +253,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; @@ -226,7 +284,11 @@ 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; @@ -288,7 +350,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; } @@ -309,7 +371,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; } @@ -318,16 +380,12 @@ 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) = @_; @@ -356,11 +414,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.) */ @@ -424,18 +480,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 */ @@ -502,26 +558,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 */ @@ -529,7 +585,7 @@ print EM <<'END'; END -print EM <<'END'; +print $em <<'END'; /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to disable them. @@ -609,14 +665,12 @@ print EM <<'END'; /* 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.) */ @@ -644,21 +698,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 */ @@ -667,18 +711,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 */ @@ -687,21 +727,21 @@ 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 */ @@ -710,26 +750,23 @@ print EM <<'END'; END for $sym (sort @extvars) { - print EM hide($sym,"PL_$sym"); + print $em hide($sym,"PL_$sym"); } -print EM <<'END'; +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__ @@ -752,7 +789,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" @@ -811,7 +847,6 @@ EXTCONST void * const PL_force_link_funcs[] = { #pragma message disable (nonstandcast) #endif -#include "thrdvar.h" #include "intrpvar.h" #include "perlvars.h" @@ -836,18 +871,14 @@ 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); + print $capih bincompat_var('I',$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 */ @@ -856,9 +887,10 @@ print CAPIH <<'EOT'; /* 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" @@ -885,7 +917,6 @@ START_EXTERN_C #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \ { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); } -#include "thrdvar.h" #include "intrpvar.h" #undef PERLVAR @@ -915,17 +946,17 @@ START_EXTERN_C #undef PL_check #undef PL_fold_locale Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) { - static const Perl_ppaddr_t* const ppaddr_ptr = PL_ppaddr; + static Perl_ppaddr_t* const ppaddr_ptr = PL_ppaddr; PERL_UNUSED_CONTEXT; return (Perl_ppaddr_t**)&ppaddr_ptr; } Perl_check_t** Perl_Gcheck_ptr(pTHX) { - static const Perl_check_t* const check_ptr = PL_check; + static Perl_check_t* const check_ptr = PL_check; PERL_UNUSED_CONTEXT; return (Perl_check_t**)&check_ptr; } unsigned char** Perl_Gfold_locale_ptr(pTHX) { - static const unsigned char* const fold_locale_ptr = PL_fold_locale; + static unsigned char* const fold_locale_ptr = PL_fold_locale; PERL_UNUSED_CONTEXT; return (unsigned char**)&fold_locale_ptr; } @@ -938,7 +969,8 @@ END_EXTERN_C /* ex: set ro: */ EOT -close(CAPI) or die "Error closing CAPI: $!"; +safer_close($capi); +rename_if_different('perlapi.c-new', 'perlapi.c'); # functions that take va_list* for implementing vararg functions # NOTE: makedef.pl must be updated if you add symbols to %vfuncs