Re: [PATCH] sv.c: consting

[perl5.git] / embed.pl

diff --git a/embed.pl b/embed.pl
index 7d4dbc4..97f0d83 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -23,7 +23,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';
 
     $years =~ s/1999,/1999,\n  / if length $years > 40;
 
@@ -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.
@@ -156,13 +156,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 +176,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 +209,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;
        }
@@ -232,10 +240,14 @@ sub write_protos {
            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;
@@ -247,6 +259,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;
@@ -308,7 +324,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;
        }
@@ -329,7 +345,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;
        }
@@ -338,17 +354,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) = @_;
@@ -665,16 +676,6 @@ 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->');
 }
@@ -695,10 +696,6 @@ print EM <<'END';
 
 END
 
-for $sym (sort keys %thread) {
-    print EM multoff($sym,'T');
-}
-
 print EM <<'END';
 
 #endif /* MULTIPLICITY */
@@ -773,7 +770,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"
 
@@ -832,7 +828,6 @@ EXTCONST void * const PL_force_link_funcs[] = {
 #pragma message disable (nonstandcast)
 #endif
 
-#include "thrdvar.h"
 #include "intrpvar.h"
 #include "perlvars.h"
 
@@ -860,10 +855,6 @@ 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);
 }
@@ -906,7 +897,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