X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=embed.pl;h=b9d2010d49f79915ba7d8d41618d1bb6e3a93b19;hb=e27835eefa408ae52d4ae22eec67eea282a87949;hp=53a32da4bc799b54b3748109acd446dbf239c9f2;hpb=7272f7c1c568f39f233065b3b8585640a398a76e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/embed.pl b/embed.pl
index 53a32da..b9d2010 100755
--- a/embed.pl
+++ b/embed.pl
@@ -39,7 +39,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.
@@ -79,15 +79,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
@@ -111,7 +108,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);
     }
 }
 
@@ -156,13 +154,15 @@ 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/ );
 	my $never_returns = ( $flags =~ /r/ );
 	my $commented_out = ( $flags =~ /m/ );
 	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 ) {
@@ -174,12 +174,14 @@ sub write_protos {
 
 	if ($flags =~ /s/) {
 	    $retval = "STATIC $splint_flags$retval";
-	    $func = "S_$func";
+	    $func = "S_$plain_func";
 	}
 	else {
 	    $retval = "PERL_CALLCONV $splint_flags$retval";
-	    if ($flags =~ /p/) {
-		$func = "Perl_$func";
+	    if ($flags =~ /[bp]/) {
+		$func = "Perl_$plain_func";
+	    } else {
+		$func = $plain_func;
 	    }
 	}
 	$ret .= "$retval\t$func(";
@@ -205,12 +207,16 @@ sub write_protos {
 		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) {
+		    push @names_of_nn, $1;
+		}
 	    }
 	    $ret .= join ", ", @args;
 	}
@@ -251,6 +257,10 @@ sub write_protos {
 	}
 	$ret .= ";";
 	$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;
@@ -312,7 +322,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;
 	}
@@ -333,7 +343,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;
 	}
@@ -342,17 +352,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) = @_;
@@ -381,11 +386,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.) */
 
@@ -449,18 +452,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 */
 
@@ -527,26 +530,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 */
 
@@ -554,7 +557,7 @@ print EM <<'END';
 
 END
 
-print EM <<'END';
+print $em <<'END';
 
 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
    disable them.
@@ -634,14 +637,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.) */
 
@@ -669,21 +670,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 */
 
@@ -692,18 +683,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 */
 
@@ -712,21 +699,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 */
 
@@ -735,26 +722,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__
@@ -777,7 +761,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"
 
@@ -836,7 +819,6 @@ EXTCONST void * const PL_force_link_funcs[] = {
 #pragma message disable (nonstandcast)
 #endif
 
-#include "thrdvar.h"
 #include "intrpvar.h"
 #include "perlvars.h"
 
@@ -861,18 +843,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 */
@@ -881,9 +859,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"
@@ -910,7 +889,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
@@ -963,7 +941,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