Once more, with feeling.

[p5sagit/p5-mst-13.2.git] / embed.pl

diff --git a/embed.pl b/embed.pl
index fd4a917..2ef42aa 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -194,7 +194,13 @@ sub write_protos {
            my $n;
            for my $arg ( @args ) {
                ++$n;
+               if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
+                   warn "$func: $arg needs NN or NULLOK\n";
+                   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
            }
            $ret .= join ", ", @args;
        }
@@ -204,17 +210,17 @@ sub write_protos {
        $ret .= ")";
        my @attrs;
        if ( $flags =~ /r/ ) {
-           push @attrs, "__attribute__((noreturn))";
+           push @attrs, "__attribute__noreturn__";
        }
        if ( $flags =~ /a/ ) {
-           push @attrs, "__attribute__((malloc))";
+           push @attrs, "__attribute__malloc__";
            $flags .= "R"; # All allocing must check return value
        }
        if ( $flags =~ /R/ ) {
-           push @attrs, "__attribute__((warn_unused_result))";
+           push @attrs, "__attribute__warn_unused_result__";
        }
        if ( $flags =~ /P/ ) {
-           push @attrs, "__attribute__((pure))";
+           push @attrs, "__attribute__pure__";
        }
        if( $flags =~ /f/ ) {
            my $prefix = $has_context ? 'pTHX_' : '';
@@ -224,7 +230,7 @@ sub write_protos {
        }
        if ( @nonnull ) {
            my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
-           push @attrs, sprintf( "__attribute__((nonnull(%s)))", join( ",", @pos ) );
+           push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
        }
        if ( @attrs ) {
            $ret .= "\n";
@@ -237,21 +243,30 @@ sub write_protos {
     $ret;
 }
 
-# generates global.sym (API export list), and populates %global with global symbols
-sub write_global_sym {
-    my $ret = "";
-    if (@_ > 1) {
-       my ($flags,$retval,$func,@args) = @_;
-       if ($flags =~ /[AX]/ && $flags !~ /[xm]/
-           || $flags =~ /b/) { # public API, so export
-           $func = "Perl_$func" if $flags =~ /[pbX]/;
-           $ret = "$func\n";
-       }
-    }
-    $ret;
+# generates global.sym (API export list)
+{
+  my %seen;
+  sub write_global_sym {
+      my $ret = "";
+      if (@_ > 1) {
+         my ($flags,$retval,$func,@args) = @_;
+         # If a function is defined twice, for example before and after an
+         # #else, only process the flags on the first instance for global.sym
+         return $ret if $seen{$func}++;
+         if ($flags =~ /[AX]/ && $flags !~ /[xm]/
+             || $flags =~ /b/) { # public API, so export
+             $func = "Perl_$func" if $flags =~ /[pbX]/;
+             $ret = "$func\n";
+         }
+      }
+      $ret;
+  }
 }
 
+
+our $unflagged_pointers;
 walk_table(\&write_protos,     "proto.h", undef, "/* ex: set ro: */\n");
+warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
 walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
 
 # XXX others that may need adding
@@ -794,10 +809,27 @@ EXTCONST void * const PL_force_link_funcs[] = {
 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 #define PERLVARISC(v,i) PERLVAR(v,char)
 
+/* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
+ * cannot cast between void pointers and function pointers without
+ * info level warnings.  The PL_force_link_funcs[] would cause a few
+ * hundred of those warnings.  In code one can circumnavigate this by using
+ * unions that overlay the different pointers, but in declarations one
+ * cannot use this trick.  Therefore we just disable the warning here
+ * for the duration of the PL_force_link_funcs[] declaration. */
+
+#if defined(__DECC) && defined(__osf__)
+#pragma message save
+#pragma message disable (nonstandcast)
+#endif
+
 #include "thrdvar.h"
 #include "intrpvar.h"
 #include "perlvars.h"
 
+#if defined(__DECC) && defined(__osf__)
+#pragma message restore
+#endif
+
 #undef PERLVAR
 #undef PERLVARA
 #undef PERLVARI
@@ -936,3 +968,5 @@ my %vfuncs = qw(
     Perl_dump_indent           Perl_dump_vindent
     Perl_default_protect       Perl_vdefault_protect
 );
+
+# ex: set ts=8 sts=4 sw=4 noet: