This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
move version details to version::Internals and other clean up
[perl5.git] / embed.pl
diff --git a/embed.pl b/embed.pl
index 50ec17f..9c55cb4 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1,13 +1,39 @@
 #!/usr/bin/perl -w
 #!/usr/bin/perl -w
+# 
+# Regenerate (overwriting only if changed):
+#
+#    embed.h
+#    embedvar.h
+#    global.sym
+#    perlapi.c
+#    perlapi.h
+#    proto.h
+#
+# from information stored in
+#
+#    embed.fnc
+#    intrpvar.h
+#    perlvars.h
+#    pp.sym     (which has been generated by opcode.pl)
+#
+# plus from the values hardcoded into this script in @extvars.
+#
+# Accepts the standard regen_lib -q and -v args.
+#
+# This script is normally invoked from regen.pl.
 
 require 5.003; # keep this compatible, an old perl is all we may have before
                 # we build the new one
 
 
 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';
 }
 
 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,
 #
 # See database of global and static function prototypes in embed.fnc
 # This is used to generate prototype headers under various configurations,
@@ -19,11 +45,12 @@ sub do_not_edit ($)
 {
     my $file = shift;
 
 {
     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, 2008, 2009';
 
     $years =~ s/1999,/1999,\n  / if length $years > 40;
 
     my $warning = <<EOW;
 
     $years =~ s/1999,/1999,\n  / if length $years > 40;
 
     my $warning = <<EOW;
+ -*- buffer-read-only: t -*-
 
    $file
 
 
    $file
 
@@ -34,7 +61,7 @@ sub do_not_edit ($)
 
 !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 This file is built by embed.pl from data in embed.fnc, embed.pl,
 
 !!!!!!!   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.
 Any changes made here will be lost!
 
 Edit those files and run 'make regen_headers' to effect changes.
@@ -45,7 +72,9 @@ EOW
 
 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
 
 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.
+was the only entrance to the tower; ...
+
+    [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
 
 
 EOW
 
 
 EOW
@@ -74,15 +103,12 @@ sub walk_table (&@) {
     defined $leader or $leader = do_not_edit ($filename);
     my $trailer = shift;
     my $F;
     defined $leader or $leader = do_not_edit ($filename);
     my $trailer = shift;
     my $F;
-    local *F;
     if (ref $filename) {       # filehandle
        $F = $filename;
     }
     else {
     if (ref $filename) {       # filehandle
        $F = $filename;
     }
     else {
-       safer_unlink $filename;
-       open F, ">$filename" or die "Can't open $filename: $!";
-       binmode F;
-       $F = \*F;
+       # safer_unlink $filename if $filename ne '/dev/null';
+       $F = safer_open("$filename-new");
     }
     print $F $leader if $leader;
     seek IN, 0, 0;             # so we may restart
     }
     print $F $leader if $leader;
     seek IN, 0, 0;             # so we may restart
@@ -106,7 +132,8 @@ sub walk_table (&@) {
     }
     print $F $trailer if $trailer;
     unless (ref $filename) {
     }
     print $F $trailer if $trailer;
     unless (ref $filename) {
-       close $F or die "Error closing $filename: $!";
+       safer_close($F);
+       rename_if_different("$filename-new", $filename);
     }
 }
 
     }
 }
 
@@ -120,29 +147,9 @@ sub munge_c_files () {
        if (@_ > 1) {
            $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
        }
        if (@_ > 1) {
            $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
        }
-    } '/dev/null', '';
+    } '/dev/null', '', '';
     local $^I = '.bak';
     while (<>) {
     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;
        s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
         {
            my $repl = $1;
@@ -171,18 +178,35 @@ sub write_protos {
        $ret .= "$arg\n";
     }
     else {
        $ret .= "$arg\n";
     }
     else {
-       my ($flags,$retval,$func,@args) = @_;
+       my ($flags,$retval,$plain_func,@args) = @_;
        my @nonnull;
        my $has_context = ( $flags !~ /n/ );
        my @nonnull;
        my $has_context = ( $flags !~ /n/ );
-       $ret .= '/* ' if $flags =~ /m/;
+       my $never_returns = ( $flags =~ /r/ );
+       my $commented_out = ( $flags =~ /m/ );
+       my $binarycompat = ( $flags =~ /b/ );
+       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/) {
        if ($flags =~ /s/) {
-           $retval = "STATIC $retval";
-           $func = "S_$func";
+           $retval = "STATIC $splint_flags$retval";
+           $func = "S_$plain_func";
        }
        else {
        }
        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(";
            }
        }
        $ret .= "$retval\t$func(";
@@ -193,7 +217,31 @@ sub write_protos {
            my $n;
            for my $arg ( @args ) {
                ++$n;
            my $n;
            for my $arg ( @args ) {
                ++$n;
-               push( @nonnull, $n ) if ( $arg =~ s/\s*\bNN\b\s+// );
+               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 && !($commented_out && !$binarycompat)) {
+                   push @names_of_nn, $1;
+               }
            }
            $ret .= join ", ", @args;
        }
            }
            $ret .= join ", ", @args;
        }
@@ -201,43 +249,76 @@ sub write_protos {
            $ret .= "void" if !$has_context;
        }
        $ret .= ")";
            $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 =~ /D/ ) {
+           push @attrs, "__attribute__deprecated__";
+       }
+       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/ ) {
        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)",
-                                   $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;
        }
        }
-       $ret .= "\n\t\t\t__attribute__((nonnull))" if $flags =~ /N/;
        if ( @nonnull ) {
            my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
        if ( @nonnull ) {
            my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
-           $ret .= sprintf( "\n\t\t\t__attribute__((nonnull(%s)))", join( ",", @pos ) );
+           push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
+       }
+       if ( @attrs ) {
+           $ret .= "\n";
+           $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
        }
        $ret .= ";";
        }
        $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;
 }
 
     }
     $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
 
 # XXX others that may need adding
 #       warnhook
@@ -269,7 +350,7 @@ sub readsyms (\%$) {
        s/[ \t]*#.*//;          # Delete comments.
        if (/^\s*(\S+)\s*$/) {
            my $sym = $1;
        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 exists $$syms{$sym};
            $$syms{$sym} = 1;
        }
@@ -290,7 +371,7 @@ sub readvars(\%$$@) {
        if (/PERLVARA?I?S?C?\($pre(\w+)/) {
            my $sym = $1;
            $sym = $pre . $sym if $keep_pre;
        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;
        }
                if exists $$syms{$sym};
            $$syms{$sym} = $pre || 1;
        }
@@ -299,16 +380,12 @@ sub readvars(\%$$@) {
 }
 
 my %intrp;
 }
 
 my %intrp;
-my %thread;
+my %globvar;
 
 readvars %intrp,  'intrpvar.h','I';
 
 readvars %intrp,  'intrpvar.h','I';
-readvars %thread, 'thrdvar.h','T';
 readvars %globvar, 'perlvars.h','G';
 
 my $sym;
 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) = @_;
 
 sub undefine ($) {
     my ($sym) = @_;
@@ -337,11 +414,9 @@ sub multoff ($$) {
     return hide("PL_$pre$sym", "PL_$sym");
 }
 
     return hide("PL_$pre$sym", "PL_$sym");
 }
 
-safer_unlink 'embed.h';
-open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
-binmode EM;
+my $em = safer_open('embed.h-new');
 
 
-print EM do_not_edit ("embed.h"), <<'END';
+print $em do_not_edit ("embed.h"), <<'END';
 
 /* (Doing namespace management portably in C is really gross.) */
 
 
 /* (Doing namespace management portably in C is really gross.) */
 
@@ -405,18 +480,18 @@ walk_table {
     # Remember the new state.
     $ifdef_state = $new_ifdef_state;
     $ret;
     # Remember the new state.
     $ifdef_state = $new_ifdef_state;
     $ret;
-} \*EM, "";
+} $em, "";
 
 if ($ifdef_state) {
 
 if ($ifdef_state) {
-    print EM "#endif\n";
+    print $em "#endif\n";
 }
 
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
 }
 
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
-    print EM hide($sym, "Perl_$sym");
+    print $em hide($sym, "Perl_$sym");
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #else  /* PERL_IMPLICIT_CONTEXT */
 
 
 #else  /* PERL_IMPLICIT_CONTEXT */
 
@@ -483,26 +558,26 @@ walk_table {
     # Remember the new state.
     $ifdef_state = $new_ifdef_state;
     $ret;
     # Remember the new state.
     $ifdef_state = $new_ifdef_state;
     $ret;
-} \*EM, "";
+} $em, "";
 
 if ($ifdef_state) {
 
 if ($ifdef_state) {
-    print EM "#endif\n";
+    print $em "#endif\n";
 }
 
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
     if ($sym =~ /^ck_/) {
 }
 
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
     if ($sym =~ /^ck_/) {
-       print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
+       print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
     }
     elsif ($sym =~ /^pp_/) {
     }
     elsif ($sym =~ /^pp_/) {
-       print EM hide("$sym()", "Perl_$sym(aTHX)");
+       print $em hide("$sym()", "Perl_$sym(aTHX)");
     }
     else {
        warn "Illegal symbol '$sym' in pp.sym";
     }
 }
 
     }
     else {
        warn "Illegal symbol '$sym' in pp.sym";
     }
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 
 #endif /* PERL_IMPLICIT_CONTEXT */
 
@@ -510,7 +585,7 @@ print EM <<'END';
 
 END
 
 
 END
 
-print EM <<'END';
+print $em <<'END';
 
 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
    disable them.
 
 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
    disable them.
@@ -518,7 +593,7 @@ print EM <<'END';
 
 #if !defined(PERL_CORE)
 #  define sv_setptrobj(rv,ptr,name)    sv_setref_iv(rv,name,PTR2IV(ptr))
 
 #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)
 #endif
 
 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
@@ -587,16 +662,15 @@ print EM <<'END';
 #  define Perl_sv_setpvf_mg_nocontext  Perl_sv_setpvf_mg
 #endif
 
 #  define Perl_sv_setpvf_mg_nocontext  Perl_sv_setpvf_mg
 #endif
 
+/* ex: set ro: */
 END
 
 END
 
-close(EM) or die "Error closing EM: $!";
+safer_close($em);
+rename_if_different('embed.h-new', 'embed.h');
 
 
-safer_unlink 'embedvar.h';
-open(EM, '> embedvar.h')
-    or die "Can't create embedvar.h: $!\n";
-binmode EM;
+$em = safer_open('embedvar.h-new');
 
 
-print EM do_not_edit ("embedvar.h"), <<'END';
+print $em do_not_edit ("embedvar.h"), <<'END';
 
 /* (Doing namespace management portably in C is really gross.) */
 
 
 /* (Doing namespace management portably in C is really gross.) */
 
@@ -624,21 +698,11 @@ print EM do_not_edit ("embedvar.h"), <<'END';
 
 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) {
 for $sym (sort keys %intrp) {
-    print EM multon($sym,'I','vTHX->');
+    print $em multon($sym,'I','vTHX->');
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #else  /* !MULTIPLICITY */
 
 
 #else  /* !MULTIPLICITY */
 
@@ -647,18 +711,14 @@ print EM <<'END';
 END
 
 for $sym (sort keys %intrp) {
 END
 
 for $sym (sort keys %intrp) {
-    print EM multoff($sym,'I');
+    print $em multoff($sym,'I');
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 END
 
 
 END
 
-for $sym (sort keys %thread) {
-    print EM multoff($sym,'T');
-}
-
-print EM <<'END';
+print $em <<'END';
 
 #endif /* MULTIPLICITY */
 
 
 #endif /* MULTIPLICITY */
 
@@ -667,21 +727,21 @@ print EM <<'END';
 END
 
 for $sym (sort keys %globvar) {
 END
 
 for $sym (sort keys %globvar) {
-    print EM multon($sym,   'G','my_vars->');
-    print EM multon("G$sym",'', 'my_vars->');
+    print $em multon($sym,   'G','my_vars->');
+    print $em multon("G$sym",'', 'my_vars->');
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #else /* !PERL_GLOBAL_STRUCT */
 
 END
 
 for $sym (sort keys %globvar) {
 
 #else /* !PERL_GLOBAL_STRUCT */
 
 END
 
 for $sym (sort keys %globvar) {
-    print EM multoff($sym,'G');
+    print $em multoff($sym,'G');
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #endif /* PERL_GLOBAL_STRUCT */
 
 
 #endif /* PERL_GLOBAL_STRUCT */
 
@@ -690,24 +750,23 @@ print EM <<'END';
 END
 
 for $sym (sort @extvars) {
 END
 
 for $sym (sort @extvars) {
-    print EM hide($sym,"PL_$sym");
+    print $em hide($sym,"PL_$sym");
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #endif /* PERL_POLLUTE */
 
 #endif /* PERL_POLLUTE */
+
+/* ex: set ro: */
 END
 
 END
 
-close(EM) or die "Error closing EM: $!";
+safer_close($em);
+rename_if_different('embedvar.h-new', 'embedvar.h');
 
 
-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;
+my $capi = safer_open('perlapi.c-new');
+my $capih = safer_open('perlapi.h-new');
 
 
-print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
+print $capih do_not_edit ("perlapi.h"), <<'EOT';
 
 /* declare accessor functions for Perl variables */
 #ifndef __perlapi_h__
 
 /* declare accessor functions for Perl variables */
 #ifndef __perlapi_h__
@@ -730,7 +789,6 @@ START_EXTERN_C
 #define PERLVARISC(v,i)        typedef const char PL_##v##_t[sizeof(i)];       \
                        EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 
 #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"
 
 #include "intrpvar.h"
 #include "perlvars.h"
 
@@ -776,10 +834,26 @@ EXTCONST void * const PL_force_link_funcs[] = {
 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 #define PERLVARISC(v,i) PERLVAR(v,char)
 
 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 #define PERLVARISC(v,i) PERLVAR(v,char)
 
-#include "thrdvar.h"
+/* 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 "intrpvar.h"
 #include "perlvars.h"
 
 #include "intrpvar.h"
 #include "perlvars.h"
 
+#if defined(__DECC) && defined(__osf__)
+#pragma message restore
+#endif
+
 #undef PERLVAR
 #undef PERLVARA
 #undef PERLVARI
 #undef PERLVAR
 #undef PERLVARA
 #undef PERLVARI
@@ -797,28 +871,26 @@ END_EXTERN_C
 EOT
 
 foreach $sym (sort keys %intrp) {
 EOT
 
 foreach $sym (sort keys %intrp) {
-    print CAPIH bincompat_var('I',$sym);
-}
-
-foreach $sym (sort keys %thread) {
-    print CAPIH bincompat_var('T',$sym);
+    print $capih bincompat_var('I',$sym);
 }
 
 foreach $sym (sort keys %globvar) {
 }
 
 foreach $sym (sort keys %globvar) {
-    print CAPIH bincompat_var('G',$sym);
+    print $capih bincompat_var('G',$sym);
 }
 
 }
 
-print CAPIH <<'EOT';
+print $capih <<'EOT';
 
 #endif /* !PERL_CORE */
 #endif /* MULTIPLICITY */
 
 #endif /* __perlapi_h__ */
 
 
 #endif /* !PERL_CORE */
 #endif /* MULTIPLICITY */
 
 #endif /* __perlapi_h__ */
 
+/* ex: set ro: */
 EOT
 EOT
-close CAPIH or die "Error closing CAPIH: $!";
+safer_close($capih);
+rename_if_different('perlapi.h-new', 'perlapi.h');
 
 
-print CAPI do_not_edit ("perlapi.c"), <<'EOT';
+print $capi do_not_edit ("perlapi.c"), <<'EOT';
 
 #include "EXTERN.h"
 #include "perl.h"
 
 #include "EXTERN.h"
 #include "perl.h"
@@ -836,31 +908,30 @@ START_EXTERN_C
 #undef PERLVARISC
 
 #define PERLVAR(v,t)   t* Perl_##v##_ptr(pTHX)                         \
 #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)                \
 #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)                \
 
 #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)                         \
 #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)                \
 #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)           \
 #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)        \
 #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
 #include "perlvars.h"
 
 #undef PERLVAR
@@ -875,15 +946,18 @@ START_EXTERN_C
 #undef PL_check
 #undef PL_fold_locale
 Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
 #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) {
     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) {
     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
     return (unsigned char**)&fold_locale_ptr;
 }
 #endif
@@ -891,9 +965,12 @@ unsigned char** Perl_Gfold_locale_ptr(pTHX) {
 END_EXTERN_C
 
 #endif /* MULTIPLICITY */
 END_EXTERN_C
 
 #endif /* MULTIPLICITY */
+
+/* ex: set ro: */
 EOT
 
 EOT
 
-close(CAPI) or die "Error closing CAPI: $!";
+safer_close($capi);
+rename_if_different('perlapi.c-new', 'perlapi.c');
 
 # functions that take va_list* for implementing vararg functions
 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
 
 # functions that take va_list* for implementing vararg functions
 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
@@ -915,3 +992,5 @@ my %vfuncs = qw(
     Perl_dump_indent           Perl_dump_vindent
     Perl_default_protect       Perl_vdefault_protect
 );
     Perl_dump_indent           Perl_dump_vindent
     Perl_default_protect       Perl_vdefault_protect
 );
+
+# ex: set ts=8 sts=4 sw=4 noet:
Unnamed repository; edit this file 'description' to name the repository.