MAD changes to dump.c

[perl5.git] / embed.pl

diff --git a/embed.pl b/embed.pl
index 778090f..5aee84f 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -19,7 +19,7 @@ sub do_not_edit ($)
 {
     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';
 
     $years =~ s/1999,/1999,\n  / if length $years > 40;
 
@@ -124,26 +124,6 @@ sub munge_c_files () {
     } '/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;
@@ -194,8 +174,22 @@ sub write_protos {
            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
+
+               # 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+/) ) {
+                   warn "$func: $arg doesn't have a name\n";
+               }
            }
            $ret .= join ", ", @args;
        }
@@ -238,21 +232,30 @@ sub write_protos {
     $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;
 walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
 
 # XXX others that may need adding
@@ -534,7 +537,7 @@ print EM <<'END';
 
 #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)
@@ -873,14 +876,14 @@ START_EXTERN_C
 #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"
@@ -888,16 +891,16 @@ START_EXTERN_C
 #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
@@ -912,15 +915,18 @@ START_EXTERN_C
 #undef PL_check
 #undef PL_fold_locale
 Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
-    static const Perl_ppaddr_t* ppaddr_ptr = PL_ppaddr;
+    static const 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 const 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 const unsigned char* const fold_locale_ptr = PL_fold_locale;
+    PERL_UNUSED_CONTEXT;
     return (unsigned char**)&fold_locale_ptr;
 }
 #endif