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
Abolish wraplen from struct regexp. We're already storing it in SvCUR.
[perl5.git] / embed.pl
diff --git a/embed.pl b/embed.pl
index 2ef42aa..964406f 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -3,11 +3,15 @@
 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,7 +23,7 @@ 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';
 
     $years =~ s/1999,/1999,\n  / if length $years > 40;
 
 
     $years =~ s/1999,/1999,\n  / if length $years > 40;
 
@@ -35,7 +39,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.
@@ -124,26 +128,6 @@ sub munge_c_files () {
     } '/dev/null', '', '';
     local $^I = '.bak';
     while (<>) {
     } '/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;
        s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
         {
            my $repl = $1;
@@ -175,14 +159,26 @@ sub write_protos {
        my ($flags,$retval,$func,@args) = @_;
        my @nonnull;
        my $has_context = ( $flags !~ /n/ );
        my ($flags,$retval,$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 $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";
+           $retval = "STATIC $splint_flags$retval";
            $func = "S_$func";
        }
        else {
            $func = "S_$func";
        }
        else {
-           $retval = "PERL_CALLCONV $retval";
-           if ($flags =~ /p/) {
+           $retval = "PERL_CALLCONV $splint_flags$retval";
+           if ($flags =~ /[bp]/) {
                $func = "Perl_$func";
            }
        }
                $func = "Perl_$func";
            }
        }
@@ -199,8 +195,22 @@ sub write_protos {
                    our $unflagged_pointers;
                    ++$unflagged_pointers;
                }
                    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+/) ) {
+                   warn "$func: $arg doesn't have a name\n";
+               }
+               if ( $SPLINT && $nullok && !$commented_out ) {
+                   $arg = '/*@null@*/ ' . $arg;
+               }
            }
            $ret .= join ", ", @args;
        }
            }
            $ret .= join ", ", @args;
        }
@@ -212,21 +222,24 @@ sub write_protos {
        if ( $flags =~ /r/ ) {
            push @attrs, "__attribute__noreturn__";
        }
        if ( $flags =~ /r/ ) {
            push @attrs, "__attribute__noreturn__";
        }
-       if ( $flags =~ /a/ ) {
+       if ( $is_malloc ) {
            push @attrs, "__attribute__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/ ) {
            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;
        }
        if ( @nonnull ) {
            my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
@@ -237,7 +250,7 @@ sub write_protos {
            $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
        }
        $ret .= ";";
            $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
        }
        $ret .= ";";
-       $ret .= ' */' if $flags =~ /m/;
+       $ret = "/* $ret */" if $commented_out;
        $ret .= @attrs ? "\n\n" : "\n";
     }
     $ret;
        $ret .= @attrs ? "\n\n" : "\n";
     }
     $ret;
@@ -299,7 +312,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;
        }
@@ -320,7 +333,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;
        }
@@ -329,16 +342,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) = @_;
@@ -548,7 +557,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)
@@ -655,16 +664,6 @@ 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) {
     print EM multon($sym,'I','vTHX->');
 }
 for $sym (sort keys %intrp) {
     print EM multon($sym,'I','vTHX->');
 }
@@ -685,10 +684,6 @@ print EM <<'END';
 
 END
 
 
 END
 
-for $sym (sort keys %thread) {
-    print EM multoff($sym,'T');
-}
-
 print EM <<'END';
 
 #endif /* MULTIPLICITY */
 print EM <<'END';
 
 #endif /* MULTIPLICITY */
@@ -763,7 +758,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"
 
@@ -822,7 +816,6 @@ EXTCONST void * const PL_force_link_funcs[] = {
 #pragma message disable (nonstandcast)
 #endif
 
 #pragma message disable (nonstandcast)
 #endif
 
-#include "thrdvar.h"
 #include "intrpvar.h"
 #include "perlvars.h"
 
 #include "intrpvar.h"
 #include "perlvars.h"
 
@@ -850,10 +843,6 @@ foreach $sym (sort keys %intrp) {
     print CAPIH bincompat_var('I',$sym);
 }
 
     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);
 }
 foreach $sym (sort keys %globvar) {
     print CAPIH bincompat_var('G',$sym);
 }
@@ -887,31 +876,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
@@ -926,15 +914,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
Unnamed repository; edit this file 'description' to name the repository.