move version details to version::Internals and other clean up

[perl5.git] / embed.pl

diff --git a/embed.pl b/embed.pl
index 90b5f79..9c55cb4 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1,4 +1,26 @@
 #!/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
@@ -23,7 +45,7 @@ sub do_not_edit ($)
 {
     my $file = shift;
 
-    my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006';
+    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;
 
@@ -39,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,
-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.
@@ -50,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
-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
@@ -79,15 +103,12 @@ sub walk_table (&@) {
     defined $leader or $leader = do_not_edit ($filename);
     my $trailer = shift;
     my $F;
-    local *F;
     if (ref $filename) {       # filehandle
        $F = $filename;
     }
     else {
-       safer_unlink $filename if $filename ne '/dev/null';
-       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
@@ -111,7 +132,8 @@ sub walk_table (&@) {
     }
     print $F $trailer if $trailer;
     unless (ref $filename) {
-       close $F or die "Error closing $filename: $!";
+       safer_close($F);
+       rename_if_different("$filename-new", $filename);
     }
 }
 
@@ -156,13 +178,16 @@ sub write_protos {
        $ret .= "$arg\n";
     }
     else {
-       my ($flags,$retval,$func,@args) = @_;
+       my ($flags,$retval,$plain_func,@args) = @_;
        my @nonnull;
        my $has_context = ( $flags !~ /n/ );
        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 ) {
@@ -174,12 +199,14 @@ sub write_protos {
 
        if ($flags =~ /s/) {
            $retval = "STATIC $splint_flags$retval";
-           $func = "S_$func";
+           $func = "S_$plain_func";
        }
        else {
            $retval = "PERL_CALLCONV $splint_flags$retval";
-           if ($flags =~ /p/) {
-               $func = "Perl_$func";
+           if ($flags =~ /[bp]/) {
+               $func = "Perl_$plain_func";
+           } else {
+               $func = $plain_func;
            }
        }
        $ret .= "$retval\t$func(";
@@ -205,12 +232,16 @@ sub write_protos {
                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+/) ) {
-                   warn "$func: $arg doesn't have a name\n";
+               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;
        }
@@ -222,6 +253,9 @@ sub write_protos {
        if ( $flags =~ /r/ ) {
            push @attrs, "__attribute__noreturn__";
        }
+       if ( $flags =~ /D/ ) {
+           push @attrs, "__attribute__deprecated__";
+       }
        if ( $is_malloc ) {
            push @attrs, "__attribute__malloc__";
        }
@@ -251,6 +285,10 @@ sub write_protos {
        }
        $ret .= ";";
        $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;
@@ -312,7 +350,7 @@ sub readsyms (\%$) {
        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;
        }
@@ -333,7 +371,7 @@ sub readvars(\%$$@) {
        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;
        }
@@ -342,17 +380,12 @@ sub readvars(\%$$@) {
 }
 
 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) = @_;
@@ -381,11 +414,9 @@ sub multoff ($$) {
     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.) */
 
@@ -449,18 +480,18 @@ walk_table {
     # Remember the new state.
     $ifdef_state = $new_ifdef_state;
     $ret;
-} \*EM, "";
+} $em, "";
 
 if ($ifdef_state) {
-    print EM "#endif\n";
+    print $em "#endif\n";
 }
 
 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 */
 
@@ -527,26 +558,26 @@ walk_table {
     # Remember the new state.
     $ifdef_state = $new_ifdef_state;
     $ret;
-} \*EM, "";
+} $em, "";
 
 if ($ifdef_state) {
-    print EM "#endif\n";
+    print $em "#endif\n";
 }
 
 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_/) {
-       print EM hide("$sym()", "Perl_$sym(aTHX)");
+       print $em hide("$sym()", "Perl_$sym(aTHX)");
     }
     else {
        warn "Illegal symbol '$sym' in pp.sym";
     }
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #endif /* PERL_IMPLICIT_CONTEXT */
 
@@ -554,7 +585,7 @@ print EM <<'END';
 
 END
 
-print EM <<'END';
+print $em <<'END';
 
 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
    disable them.
@@ -634,14 +665,12 @@ print EM <<'END';
 /* ex: set ro: */
 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.) */
 
@@ -669,21 +698,11 @@ 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->');
+    print $em multon($sym,'I','vTHX->');
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #else  /* !MULTIPLICITY */
 
@@ -692,18 +711,14 @@ print EM <<'END';
 END
 
 for $sym (sort keys %intrp) {
-    print EM multoff($sym,'I');
+    print $em multoff($sym,'I');
 }
 
-print EM <<'END';
+print $em <<'END';
 
 END
 
-for $sym (sort keys %thread) {
-    print EM multoff($sym,'T');
-}
-
-print EM <<'END';
+print $em <<'END';
 
 #endif /* MULTIPLICITY */
 
@@ -712,21 +727,21 @@ print EM <<'END';
 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) {
-    print EM multoff($sym,'G');
+    print $em multoff($sym,'G');
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #endif /* PERL_GLOBAL_STRUCT */
 
@@ -735,26 +750,23 @@ print EM <<'END';
 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 */
 
 /* ex: set ro: */
 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__
@@ -777,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);
 
-#include "thrdvar.h"
 #include "intrpvar.h"
 #include "perlvars.h"
 
@@ -836,7 +847,6 @@ EXTCONST void * const PL_force_link_funcs[] = {
 #pragma message disable (nonstandcast)
 #endif
 
-#include "thrdvar.h"
 #include "intrpvar.h"
 #include "perlvars.h"
 
@@ -861,18 +871,14 @@ END_EXTERN_C
 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) {
-    print CAPIH bincompat_var('G',$sym);
+    print $capih bincompat_var('G',$sym);
 }
 
-print CAPIH <<'EOT';
+print $capih <<'EOT';
 
 #endif /* !PERL_CORE */
 #endif /* MULTIPLICITY */
@@ -881,9 +887,10 @@ print CAPIH <<'EOT';
 
 /* ex: set ro: */
 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"
@@ -910,7 +917,6 @@ START_EXTERN_C
 #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
@@ -963,7 +969,8 @@ END_EXTERN_C
 /* ex: set ro: */
 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