Re: [PATCH] Cleanup regexp flags and structure

[perl5.git] / embed.pl

diff --git a/embed.pl b/embed.pl
index 5aee84f..90b5f79 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -3,11 +3,15 @@
 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,
@@ -155,13 +159,25 @@ sub write_protos {
        my ($flags,$retval,$func,@args) = @_;
        my @nonnull;
        my $has_context = ( $flags !~ /n/ );
-       $ret .= '/* ' if $flags =~ /m/;
+       my $never_returns = ( $flags =~ /r/ );
+       my $commented_out = ( $flags =~ /m/ );
+       my $is_malloc = ( $flags =~ /a/ );
+       my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
+
+       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";
+           $retval = "STATIC $splint_flags$retval";
            $func = "S_$func";
        }
        else {
-           $retval = "PERL_CALLCONV $retval";
+           $retval = "PERL_CALLCONV $splint_flags$retval";
            if ($flags =~ /p/) {
                $func = "Perl_$func";
            }
@@ -179,8 +195,10 @@ 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".
@@ -190,6 +208,9 @@ sub write_protos {
                if ( ($temp_arg ne "...") && ($temp_arg !~ /\w+\s+\w+/) ) {
                    warn "$func: $arg doesn't have a name\n";
                }
+               if ( $SPLINT && $nullok && !$commented_out ) {
+                   $arg = '/*@null@*/ ' . $arg;
+               }
            }
            $ret .= join ", ", @args;
        }
@@ -201,21 +222,24 @@ sub write_protos {
        if ( $flags =~ /r/ ) {
            push @attrs, "__attribute__noreturn__";
        }
-       if ( $flags =~ /a/ ) {
+       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 +250,7 @@ sub write_protos {
            $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
        }
        $ret .= ";";
-       $ret .= ' */' if $flags =~ /m/;
+       $ret = "/* $ret */" if $commented_out;
        $ret .= @attrs ? "\n\n" : "\n";
     }
     $ret;
@@ -319,6 +343,7 @@ sub readvars(\%$$@) {
 
 my %intrp;
 my %thread;
+my %globvar;
 
 readvars %intrp,  'intrpvar.h','I';
 readvars %thread, 'thrdvar.h','T';
@@ -915,17 +940,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;
 }