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,
sub do_not_edit ($)
{
my $file = shift;
+
+ 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;
+
my $warning = <<EOW;
+ -*- buffer-read-only: t -*-
$file
- Copyright (c) 1997-2003, Larry Wall
+ Copyright (C) $years, by Larry Wall and others
You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the README file.
!!!!!!! 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.
EOW
+ $warning .= <<EOW if $file eq 'perlapi.c';
+
+Up to the threshold of the door there mounted a flight of twenty-seven
+broad stairs, hewn by some unknown art of the same black stone. This
+was the only entrance to the tower.
+
+
+EOW
+
if ($file =~ m:\.[ch]$:) {
$warning =~ s:^: * :gm;
$warning =~ s: +$::gm;
$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;
}
print $F $leader if $leader;
$_ .= <IN>;
chomp;
}
+ s/\s+$//;
my @args;
if (/^\s*(#|$)/) {
@args = $_;
else {
@args = split /\s*\|\s*/, $_;
}
- my @outs = &{$function}(@args);
- print $F @outs; # $function->(@args) is not 5.003
+ my @outs = &{$function}(@args);
+ print $F @outs; # $function->(@args) is not 5.003
}
print $F $trailer if $trailer;
unless (ref $filename) {
sub munge_c_files () {
my $functions = {};
unless (@ARGV) {
- warn "\@ARGV empty, nothing to do\n";
+ warn "\@ARGV empty, nothing to do\n";
return;
}
walk_table {
if (@_ > 1) {
$functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
}
- } '/dev/null', '';
+ } '/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) = @_;
- $ret .= '/* ' if $flags =~ /m/;
+ 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 ) {
+ $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(";
- unless ($flags =~ /n/) {
- $ret .= "pTHX";
- $ret .= "_ " if @args;
+ if ( $has_context ) {
+ $ret .= @args ? "pTHX_ " : "pTHX";
}
if (@args) {
+ 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;
+ }
+ 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;
}
else {
- $ret .= "void" if $flags =~ /n/;
+ $ret .= "void" if !$has_context;
}
$ret .= ")";
- $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
+ my @attrs;
+ if ( $flags =~ /r/ ) {
+ push @attrs, "__attribute__noreturn__";
+ }
+ if ( $is_malloc ) {
+ push @attrs, "__attribute__malloc__";
+ }
+ if ( !$can_ignore ) {
+ push @attrs, "__attribute__warn_unused_result__";
+ }
+ if ( $flags =~ /P/ ) {
+ push @attrs, "__attribute__pure__";
+ }
if( $flags =~ /f/ ) {
- my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
- my $args = scalar @args;
- $ret .= "\n#ifdef CHECK_FORMAT\n";
- $ret .= sprintf " __attribute__((format(printf,%s%d,%s%d)))",
- $prefix, $args - 1, $prefix, $args;
- $ret .= "\n#endif\n";
+ 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;
+ 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 = "/* $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 =~ /A/ && $flags !~ /[xm]/) { # public API, so export
- $func = "Perl_$func" if $flags =~ /p/;
- $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
# hints
# copline
my @extvars = qw(sv_undef sv_yes sv_no na dowarn
- curcop compiling
- tainting tainted stack_base stack_sp sv_arenaroot
+ curcop compiling
+ tainting tainted stack_base stack_sp sv_arenaroot
no_modify
- curstash DBsub DBsingle DBassertion debstash
- rsfp
- stdingv
+ curstash DBsub DBsingle DBassertion debstash
+ rsfp
+ stdingv
defgv
errgv
rsfp_filters
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;
}
or die "embed.pl: Can't open $file: $!\n";
while (<FILE>) {
s/[ \t]*#.*//; # Delete comments.
- if (/PERLVARA?I?C?\($pre(\w+)/) {
+ 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) = @_;
safer_unlink 'embed.h';
open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
+binmode EM;
print EM do_not_edit ("embed.h"), <<'END';
END
+# Try to elimiate lots of repeated
+# #ifdef PERL_CORE
+# foo
+# #endif
+# #ifdef PERL_CORE
+# bar
+# #endif
+# by tracking state and merging foo and bar into one block.
+my $ifdef_state = '';
+
walk_table {
my $ret = "";
+ my $new_ifdef_state = '';
if (@_ == 1) {
my $arg = shift;
$ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
}
if ($ret ne '' && $flags !~ /A/) {
if ($flags =~ /E/) {
- $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
- } else {
- $ret = "#ifdef PERL_CORE\n$ret#endif\n";
+ $new_ifdef_state
+ = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
+ }
+ else {
+ $new_ifdef_state = "#ifdef PERL_CORE\n";
+ }
+
+ if ($new_ifdef_state ne $ifdef_state) {
+ $ret = $new_ifdef_state . $ret;
}
}
}
+ if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
+ # Close the old one ahead of opening the new one.
+ $ret = "#endif\n$ret";
+ }
+ # Remember the new state.
+ $ifdef_state = $new_ifdef_state;
$ret;
} \*EM, "";
+if ($ifdef_state) {
+ print EM "#endif\n";
+}
+
for $sym (sort keys %ppsym) {
$sym =~ s/^Perl_//;
print EM hide($sym, "Perl_$sym");
my @az = ('a'..'z');
+$ifdef_state = '';
walk_table {
my $ret = "";
+ my $new_ifdef_state = '';
if (@_ == 1) {
my $arg = shift;
$ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
$ret .= $alist . ")\n";
}
}
- unless ($flags =~ /A/) {
+ unless ($flags =~ /A/) {
if ($flags =~ /E/) {
- $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
- } else {
- $ret = "#ifdef PERL_CORE\n$ret#endif\n";
+ $new_ifdef_state
+ = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
+ }
+ else {
+ $new_ifdef_state = "#ifdef PERL_CORE\n";
+ }
+
+ if ($new_ifdef_state ne $ifdef_state) {
+ $ret = $new_ifdef_state . $ret;
}
}
}
+ if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
+ # Close the old one ahead of opening the new one.
+ $ret = "#endif\n$ret";
+ }
+ # Remember the new state.
+ $ifdef_state = $new_ifdef_state;
$ret;
} \*EM, "";
+if ($ifdef_state) {
+ print EM "#endif\n";
+}
+
for $sym (sort keys %ppsym) {
$sym =~ s/^Perl_//;
if ($sym =~ /^ck_/) {
#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)
# define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
#endif
+/* ex: set ro: */
END
close(EM) or die "Error closing EM: $!";
safer_unlink 'embedvar.h';
open(EM, '> embedvar.h')
or die "Can't create embedvar.h: $!\n";
+binmode EM;
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->');
}
END
-for $sym (sort keys %thread) {
- print EM multoff($sym,'T');
-}
-
print EM <<'END';
#endif /* MULTIPLICITY */
END
for $sym (sort keys %globvar) {
- print EM multon($sym,'G','PL_Vars.');
+ print EM multon($sym, 'G','my_vars->');
+ print EM multon("G$sym",'', 'my_vars->');
}
print EM <<'END';
print EM <<'END';
#endif /* PERL_POLLUTE */
+
+/* ex: set ro: */
END
close(EM) or die "Error closing EM: $!";
safer_unlink 'perlapi.h';
safer_unlink 'perlapi.c';
open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
+binmode CAPI;
open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
+binmode CAPIH;
print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
+#undef PERLVARISC
#define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
#define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
#define PERLVARI(v,t,i) PERLVAR(v,t)
#define PERLVARIC(v,t,i) PERLVAR(v, const t)
+#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"
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
+#undef PERLVARISC
+
+#ifndef PERL_GLOBAL_STRUCT
+EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
+EXTERN_C Perl_check_t** Perl_Gcheck_ptr(pTHX);
+EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
+#define Perl_ppaddr_ptr Perl_Gppaddr_ptr
+#define Perl_check_ptr Perl_Gcheck_ptr
+#define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
+#endif
END_EXTERN_C
START_EXTERN_C
#ifndef DOINIT
-EXT void *PL_force_link_funcs[];
+EXTCONST void * const PL_force_link_funcs[];
#else
-EXT void *PL_force_link_funcs[] = {
+EXTCONST void * const PL_force_link_funcs[] = {
#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#define PERLVARA(v,n,t) PERLVAR(v,t)
#define PERLVARI(v,t,i) PERLVAR(v,t)
#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
#undef PERLVARIC
+#undef PERLVARISC
};
#endif /* DOINIT */
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);
}
#endif /* __perlapi_h__ */
+/* ex: set ro: */
EOT
close CAPIH or die "Error closing CAPIH: $!";
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
+#undef PERLVARISC
#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
- { return &(aTHX->v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
- { 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; 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) \
- { return &(PL_##v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
- { return &(PL_##v); }
+ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
#undef PERLVARIC
-#define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \
- { return (const t *)&(PL_##v); }
+#undef PERLVARISC
+#define PERLVARIC(v,t,i) \
+ const t* Perl_##v##_ptr(pTHX) \
+ { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
+#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
+ { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
#include "perlvars.h"
#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
+#undef PERLVARISC
+
+#ifndef PERL_GLOBAL_STRUCT
+/* A few evil special cases. Could probably macrofy this. */
+#undef PL_ppaddr
+#undef PL_check
+#undef PL_fold_locale
+Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
+ 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 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 unsigned char* const fold_locale_ptr = PL_fold_locale;
+ PERL_UNUSED_CONTEXT;
+ return (unsigned char**)&fold_locale_ptr;
+}
+#endif
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: