$years =~ s/1999,/1999,\n / if length $years > 40;
my $warning = <<EOW;
+ -*- buffer-read-only: t -*-
$file
$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;
if (@_ > 1) {
$functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
}
- } '/dev/null', '';
+ } '/dev/null', '', '';
local $^I = '.bak';
while (<>) {
# if (/^#\s*include\s+"perl.h"/) {
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;
}
$ret .= "void" if !$has_context;
}
$ret .= ")";
- $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
- $ret .= "\n\t\t\t__attribute__((malloc)) __attribute__((warn_unused_result))" if $flags =~ /a/;
- $ret .= "\n\t\t\t__attribute__((pure))" if $flags =~ /P/;
+ 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 = $has_context ? 'pTHX_' : '';
my $args = scalar @args;
- $ret .= sprintf "\n\t\t\t__attribute__format__(__printf__,%s%d,%s%d)",
+ push @attrs, sprintf "__attribute__format__(__printf__,%s%d,%s%d)",
$prefix, $args - 1, $prefix, $args;
}
- $ret .= "\n\t\t\t__attribute__((nonnull))" if $flags =~ /N/;
if ( @nonnull ) {
- my @pos = map { $has_context ? "pTHX_ $_" : $_ } @nonnull;
- $ret .= sprintf( "\n\t\t\t__attribute__((nonnull(%s)))", join( ",", @pos ) );
+ 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;
}
-# 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;
+ }
}
-walk_table(\&write_protos, "proto.h", undef);
-walk_table(\&write_global_sym, "global.sym", undef);
+
+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
# warnhook
# define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
#endif
+/* ex: set ro: */
END
close(EM) or die "Error closing EM: $!";
print EM <<'END';
#endif /* PERL_POLLUTE */
+
+/* ex: set ro: */
END
close(EM) or die "Error closing EM: $!";
#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
#endif /* __perlapi_h__ */
+/* ex: set ro: */
EOT
close CAPIH or die "Error closing CAPIH: $!";
END_EXTERN_C
#endif /* MULTIPLICITY */
+
+/* ex: set ro: */
EOT
close(CAPI) or die "Error closing CAPI: $!";
Perl_dump_indent Perl_dump_vindent
Perl_default_protect Perl_vdefault_protect
);
+
+# ex: set ts=8 sts=4 sw=4 noet: