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,
{
my $file = shift;
- my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005';
+ 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;
!!!!!!! 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.
} '/dev/null', '', '';
local $^I = '.bak';
while (<>) {
-# if (/^#\s*include\s+"perl.h"/) {
-# my $file = uc $ARGV;
-# $file =~ s/\./_/g;
-# print "#define PERL_IN_$file\n";
-# }
-# s{^(\w+)\s*\(}
-# {
-# my $f = $1;
-# my $repl = "$f(";
-# if (exists $functions->{$f}) {
-# my $flags = $functions->{$f}[0];
-# $repl = "Perl_$repl" if $flags =~ /p/;
-# unless ($flags =~ /n/) {
-# $repl .= "pTHX";
-# $repl .= "_ " if @{$functions->{$f}} > 3;
-# }
-# warn("$ARGV:$.:$repl\n");
-# }
-# $repl;
-# }e;
s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
{
my $repl = $1;
$ret .= "$arg\n";
}
else {
- my ($flags,$retval,$func,@args) = @_;
+ my ($flags,$retval,$plain_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 @names_of_nn;
+ my $func;
+
+ 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";
- $func = "S_$func";
+ $retval = "STATIC $splint_flags$retval";
+ $func = "S_$plain_func";
}
else {
- $retval = "PERL_CALLCONV $retval";
- if ($flags =~ /p/) {
- $func = "Perl_$func";
+ $retval = "PERL_CALLCONV $splint_flags$retval";
+ if ($flags =~ /[bp]/) {
+ $func = "Perl_$plain_func";
+ } else {
+ $func = $plain_func;
}
}
$ret .= "$retval\t$func(";
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".
+ 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+)(?:\[\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;
}
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;
$ret .= join( "\n", map { "\t\t\t$_" } @attrs );
}
$ret .= ";";
- $ret .= ' */' if $flags =~ /m/;
+ $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;
}
-# 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;
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;
}
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;
}
}
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) = @_;
#if !defined(PERL_CORE)
# define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
-# define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr))
+# define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr))
#endif
#if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
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->');
}
END
-for $sym (sort keys %thread) {
- print EM multoff($sym,'T');
-}
-
print EM <<'END';
#endif /* MULTIPLICITY */
#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"
#pragma message disable (nonstandcast)
#endif
-#include "thrdvar.h"
#include "intrpvar.h"
#include "perlvars.h"
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);
}
#undef PERLVARISC
#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(aTHX->v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(aTHX->v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
#define PERLVARI(v,t,i) PERLVAR(v,t)
#define PERLVARIC(v,t,i) PERLVAR(v, const t)
#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(aTHX->v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
-#include "thrdvar.h"
#include "intrpvar.h"
#undef PERLVAR
#undef PERLVARA
#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(PL_##v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(PL_##v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
#undef PERLVARIC
#undef PERLVARISC
#define PERLVARIC(v,t,i) \
const t* Perl_##v##_ptr(pTHX) \
- { return (const t *)&(PL_##v); }
+ { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
- { dVAR; return &(PL_##v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
#include "perlvars.h"
#undef PERLVAR
#undef PL_check
#undef PL_fold_locale
Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
- static const Perl_ppaddr_t* 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* 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* 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;
}
#endif