locale.c: Silence HP-UX compiler warning

[perl5.git] / regen / embed.pl

diff --git a/regen/embed.pl b/regen/embed.pl
index 629bb84..3db9c41 100755 (executable)
--- a/regen/embed.pl
+++ b/regen/embed.pl
@@ -40,6 +40,15 @@ my $unflagged_pointers;
 # implicit interpreter context argument.
 #
 
+sub full_name ($$) { # Returns the function name with potentially the
+                    # prefixes 'S_' or 'Perl_'
+    my ($func, $flags) = @_;
+
+    return "S_$func" if $flags =~ /[si]/;
+    return "Perl_$func" if $flags =~ /[bp]/;
+    return $func;
+}
+
 sub open_print_header {
     my ($file, $quote) = @_;
 
@@ -103,7 +112,6 @@ my ($embed, $core, $ext, $api) = setup_embed();
                $type = $1 eq 's' ? "STATIC" : "PERL_STATIC_INLINE";
            }
            $retval = "$type $splint_flags$retval";
-           $func = "S_$plain_func";
        }
        else {
            if ($never_returns) {
@@ -112,13 +120,8 @@ my ($embed, $core, $ext, $api) = setup_embed();
            else {
                $retval = "PERL_CALLCONV $splint_flags$retval";
            }
-           if ($flags =~ /[bp]/) {
-               $func = "Perl_$plain_func";
-           }
-           else {
-               $func = $plain_func;
-           }
        }
+       $func = full_name($plain_func, $flags);
        $ret = "$retval\t$func(";
        if ( $has_context ) {
            $ret .= @args ? "pTHX_ " : "pTHX";
@@ -176,17 +179,32 @@ my ($embed, $core, $ext, $api) = setup_embed();
        }
        if( $flags =~ /f/ ) {
            my $prefix  = $has_context ? 'pTHX_' : '';
-           my $args    = scalar @args;
-           my $pat     = $args - 1;
-           my $macro   = @nonnull && $nonnull[-1] == $pat  
+           my ($args, $pat);
+           if ($args[-1] eq '...') {
+               $args   = scalar @args;
+               $pat    = $args - 1;
+               $args   = $prefix . $args;
+           }
+           else {
+               # don't check args, and guess which arg is the pattern
+               # (one of 'fmt', 'pat', 'f'),
+               $args = 0;
+               my @fmts = grep $args[$_] =~ /\b(f|pat|fmt)$/, 0..$#args;
+               if (@fmts != 1) {
+                   die "embed.pl: '$plain_func': can't determine pattern arg\n";
+               }
+               $pat = $fmts[0] + 1;
+           }
+           my $macro   = grep($_ == $pat, @nonnull)
                                ? '__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;
-           push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
+           if ($plain_func =~ /strftime/) {
+               push @attrs, sprintf "%s(__strftime__,%s1,0)", $macro, $prefix;
+           }
+           else {
+               push @attrs, sprintf "%s(__printf__,%s%d,%s)", $macro,
+                                   $prefix, $pat, $args;
+           }
        }
        if ( @attrs ) {
            $ret .= "\n";
@@ -282,19 +300,14 @@ sub embed_h {
        unless ($flags =~ /[om]/) {
            my $args = scalar @args;
            if ($flags =~ /n/) {
-               if ($flags =~ /[si]/) {
-                   $ret = hide($func,"S_$func");
-               }
-               elsif ($flags =~ /p/) {
-                   $ret = hide($func,"Perl_$func");
-               }
+               $ret = hide($func, full_name($func, $flags));
            }
            elsif ($args and $args[$args-1] =~ /\.\.\./) {
                if ($flags =~ /p/) {
                    # we're out of luck for varargs functions under CPP
                    # So we can only do these macros for no implicit context:
                    $ret = "#ifndef PERL_IMPLICIT_CONTEXT\n"
-                       . hide($func,"Perl_$func") . "#endif\n";
+                       . hide($func, full_name($func, $flags)) . "#endif\n";
                }
            }
            else {
@@ -302,12 +315,7 @@ sub embed_h {
                $ret = "#define $func($alist)";
                my $t = int(length($ret) / 8);
                $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
-               if ($flags =~ /[si]/) {
-                   $ret .= "S_$func(aTHX";
-               }
-               elsif ($flags =~ /p/) {
-                   $ret .= "Perl_$func(aTHX";
-               }
+               $ret .= full_name($func, $flags) . "(aTHX";
                $ret .= "_ " if $alist;
                $ret .= $alist . ")\n";
            }