X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=embed.pl;h=c917dfba092a69bc990a8830ed31ed7688d2b6b1;hb=d6802e4345360e741b212b52b6af4a704cfce207;hp=612e19c44555ea15d35e7d8cc8758e22cae04017;hpb=da4ddda1308ab0218fa0865029c9475e5cfe8bc6;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/embed.pl b/embed.pl
index 612e19c..c917dfb 100755
--- a/embed.pl
+++ b/embed.pl
@@ -18,12 +18,13 @@ BEGIN {
 sub do_not_edit ($)
 {
     my $file = shift;
-    
+
     my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005';
 
     $years =~ s/1999,/1999,\n  / if length $years > 40;
 
     my $warning = <<EOW;
+ -*- buffer-read-only: t -*-
 
    $file
 
@@ -79,7 +80,7 @@ sub walk_table (&@) {
 	$F = $filename;
     }
     else {
-	safer_unlink $filename;
+	safer_unlink $filename if $filename ne '/dev/null';
 	open F, ">$filename" or die "Can't open $filename: $!";
 	binmode F;
 	$F = \*F;
@@ -101,8 +102,8 @@ sub walk_table (&@) {
 	else {
 	    @args = split /\s*\|\s*/, $_;
 	}
-        my @outs = &{$function}(@args);
-        print $F @outs; # $function->(@args) is not 5.003
+	my @outs = &{$function}(@args);
+	print $F @outs; # $function->(@args) is not 5.003
     }
     print $F $trailer if $trailer;
     unless (ref $filename) {
@@ -113,14 +114,14 @@ sub walk_table (&@) {
 sub munge_c_files () {
     my $functions = {};
     unless (@ARGV) {
-        warn "\@ARGV empty, nothing to do\n";
+	warn "\@ARGV empty, nothing to do\n";
 	return;
     }
     walk_table {
 	if (@_ > 1) {
 	    $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
 	}
-    } '/dev/null', '';
+    } '/dev/null', '', '';
     local $^I = '.bak';
     while (<>) {
 #	if (/^#\s*include\s+"perl.h"/) {
@@ -172,6 +173,8 @@ sub write_protos {
     }
     else {
 	my ($flags,$retval,$func,@args) = @_;
+	my @nonnull;
+	my $has_context = ( $flags !~ /n/ );
 	$ret .= '/* ' if $flags =~ /m/;
 	if ($flags =~ /s/) {
 	    $retval = "STATIC $retval";
@@ -184,27 +187,52 @@ sub write_protos {
 	    }
 	}
 	$ret .= "$retval\t$func(";
-	unless ($flags =~ /n/) {
-	    $ret .= "pTHX";
-	    $ret .= "_ " if @args;
+	if ( $has_context ) {
+	    $ret .= @args ? "pTHX_ " : "pTHX";
 	}
 	if (@args) {
+	    my $n;
+	    for my $arg ( @args ) {
+		++$n;
+		push( @nonnull, $n ) if ( $arg =~ s/\s*\bNN\b\s+// );
+	    }
 	    $ret .= join ", ", @args;
 	}
 	else {
-	    $ret .= "void" if $flags =~ /n/;
+	    $ret .= "void" if !$has_context;
 	}
 	$ret .= ")";
-	$ret .= " __attribute__((noreturn))" if $flags =~ /r/;
+	my @attrs;
+	if ( $flags =~ /r/ ) {
+	    push @attrs, "__attribute__noreturn__";
+	}
+	if ( $flags =~ /a/ ) {
+	    push @attrs, "__attribute__malloc__";
+	    $flags .= "R"; # All allocing must check return value
+	}
+	if ( $flags =~ /R/ ) {
+	    push @attrs, "__attribute__warn_unused_result__";
+	}
+	if ( $flags =~ /P/ ) {
+	    push @attrs, "__attribute__pure__";
+	}
 	if( $flags =~ /f/ ) {
-	    my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
+	    my $prefix = $has_context ? 'pTHX_' : '';
 	    my $args = scalar @args;
-	    $ret .= sprintf "\n\t__attribute__format__(__printf__,%s%d,%s%d)",
+	    push @attrs, sprintf "__attribute__format__(__printf__,%s%d,%s%d)",
 				    $prefix, $args - 1, $prefix, $args;
 	}
+	if ( @nonnull ) {
+	    my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
+	    push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
+	}
+	if ( @attrs ) {
+	    $ret .= "\n";
+	    $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
+	}
 	$ret .= ";";
 	$ret .= ' */' if $flags =~ /m/;
-	$ret .= "\n";
+	$ret .= @attrs ? "\n\n" : "\n";
     }
     $ret;
 }
@@ -223,20 +251,20 @@ sub write_global_sym {
     $ret;
 }
 
-walk_table(\&write_protos,     "proto.h", undef);
-walk_table(\&write_global_sym, "global.sym", undef);
+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
+		 curcop compiling
+		 tainting tainted stack_base stack_sp sv_arenaroot
 		 no_modify
-                 curstash DBsub DBsingle DBassertion debstash
-                 rsfp
-                 stdingv
+		 curstash DBsub DBsingle DBassertion debstash
+		 rsfp
+		 stdingv
 		 defgv
 		 errgv
 		 rsfp_filters
@@ -574,6 +602,7 @@ print EM <<'END';
 #  define Perl_sv_setpvf_mg_nocontext	Perl_sv_setpvf_mg
 #endif
 
+/* ex: set ro: */
 END
 
 close(EM) or die "Error closing EM: $!";
@@ -683,6 +712,8 @@ for $sym (sort @extvars) {
 print EM <<'END';
 
 #endif /* PERL_POLLUTE */
+
+/* ex: set ro: */
 END
 
 close(EM) or die "Error closing EM: $!";
@@ -802,6 +833,7 @@ print CAPIH <<'EOT';
 
 #endif /* __perlapi_h__ */
 
+/* ex: set ro: */
 EOT
 close CAPIH or die "Error closing CAPIH: $!";
 
@@ -878,6 +910,8 @@ unsigned char** Perl_Gfold_locale_ptr(pTHX) {
 END_EXTERN_C
 
 #endif /* MULTIPLICITY */
+
+/* ex: set ro: */
 EOT
 
 close(CAPI) or die "Error closing CAPI: $!";