regen/mk_invlists.pl: Fix-ups for early Unicode versions

[perl5.git] / regen / embed.pl

diff --git a/regen/embed.pl b/regen/embed.pl
index f1b7449..ed49f5f 100755 (executable)
--- a/regen/embed.pl
+++ b/regen/embed.pl
@@ -30,7 +30,6 @@ BEGIN {
     require './regen/embed_lib.pl';
 }
 
-my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org
 my $unflagged_pointers;
 
 #
@@ -40,6 +39,13 @@ my $unflagged_pointers;
 # implicit interpreter context argument.
 #
 
+my $error_count = 0;
+sub die_at_end ($) { # Keeps going for now, but makes sure the regen doesn't
+                     # succeed.
+    warn shift;
+    $error_count++;
+}
+
 sub full_name ($$) { # Returns the function name with potentially the
                     # prefixes 'S_' or 'Perl_'
     my ($func, $flags) = @_;
@@ -76,7 +82,7 @@ my ($embed, $core, $ext, $api) = setup_embed();
 
        my ($flags,$retval,$plain_func,@args) = @$_;
         if ($flags =~ / ( [^AabDdEfiMmnOoPpRrsUWXx] ) /x) {
-           warn "flag $1 is not legal (for function $plain_func)";
+           die_at_end "flag $1 is not legal (for function $plain_func)";
        }
        my @nonnull;
         my $has_depth = ( $flags =~ /W/ );
@@ -93,16 +99,10 @@ my ($embed, $core, $ext, $api) = setup_embed();
            warn "It is nonsensical to require the return value of a void function ($plain_func) to be checked";
        }
 
-       warn "$plain_func: s flag is mutually exclusive from the i and p plags"
+       die_at_end "$plain_func: s flag is mutually exclusive from the i and p plags"
                                            if $flags =~ /s/ && $flags =~ /[ip]/;
-       my $splint_flags = "";
-       if ( $SPLINT && !$commented_out ) {
-           $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
-           if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
-               $retval .= " /*\@alt void\@*/";
-           }
-       }
 
+       my $static_inline = 0;
        if ($flags =~ /([si])/) {
            my $type;
            if ($never_returns) {
@@ -111,19 +111,22 @@ my ($embed, $core, $ext, $api) = setup_embed();
            else {
                $type = $1 eq 's' ? "STATIC" : "PERL_STATIC_INLINE";
            }
-           $retval = "$type $splint_flags$retval";
+           $retval = "$type $retval";
+           die_at_end "Don't declare static function '$plain_func' pure" if $flags =~ /P/;
+           $static_inline = $type eq 'PERL_STATIC_INLINE';
        }
        else {
            if ($never_returns) {
-               $retval = "PERL_CALLCONV_NO_RET $splint_flags$retval";
+               $retval = "PERL_CALLCONV_NO_RET $retval";
            }
            else {
-               $retval = "PERL_CALLCONV $splint_flags$retval";
+               $retval = "PERL_CALLCONV $retval";
            }
        }
        $func = full_name($plain_func, $flags);
        $ret = "";
        $ret .= "#ifndef NO_MATHOMS\n" if $binarycompat;
+       $ret .= "#ifndef PERL_NO_INLINE_FUNCTIONS\n" if $static_inline;
        $ret .= "$retval\t$func(";
        if ( $has_context ) {
            $ret .= @args ? "pTHX_ " : "pTHX";
@@ -148,10 +151,7 @@ my ($embed, $core, $ext, $api) = setup_embed();
                $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;
+                   die_at_end "$func: $arg ($n) doesn't have a name\n";
                }
                if (defined $1 && $nn && !($commented_out && !$binarycompat)) {
                    push @names_of_nn, $1;
@@ -219,6 +219,7 @@ my ($embed, $core, $ext, $api) = setup_embed();
            $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
                . join '; ', map "assert($_)", @names_of_nn;
        }
+       $ret .= "\n#endif" if $static_inline;
        $ret .= "\n#endif" if $binarycompat;
        $ret .= @attrs ? "\n\n" : "\n";
 
@@ -232,21 +233,21 @@ my ($embed, $core, $ext, $api) = setup_embed();
 END_EXTERN_C
 EOF
 
-    read_only_bottom_close_and_rename($pr);
+    read_only_bottom_close_and_rename($pr) if ! $error_count;
 }
 
-warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
+die_at_end "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
 
 sub readvars {
     my ($file, $pre) = @_;
     local (*FILE, $_);
     my %seen;
-    open(FILE, "< $file")
+    open(FILE, '<', $file)
        or die "embed.pl: Can't open $file: $!\n";
     while (<FILE>) {
        s/[ \t]*#.*//;          # Delete comments.
        if (/PERLVARA?I?C?\($pre,\s*(\w+)/) {
-           warn "duplicate symbol $1 while processing $file line $.\n"
+           die_at_end "duplicate symbol $1 while processing $file line $.\n"
                if $seen{$1}++;
        }
     }
@@ -438,7 +439,7 @@ print $em <<'END';
 #endif
 END
 
-read_only_bottom_close_and_rename($em);
+read_only_bottom_close_and_rename($em) if ! $error_count;
 
 $em = open_print_header('embedvar.h');
 
@@ -503,7 +504,7 @@ print $em <<'END';
 #endif /* PERL_GLOBAL_STRUCT */
 END
 
-read_only_bottom_close_and_rename($em);
+read_only_bottom_close_and_rename($em) if ! $error_count;
 
 my $capih = open_print_header('perlapi.h');
 
@@ -606,7 +607,7 @@ print $capih <<'EOT';
 #endif /* __perlapi_h__ */
 EOT
 
-read_only_bottom_close_and_rename($capih);
+read_only_bottom_close_and_rename($capih) if ! $error_count;
 
 my $capi = open_print_header('perlapi.c', <<'EOQ');
  *
@@ -655,6 +656,8 @@ END_EXTERN_C
 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
 EOT
 
-read_only_bottom_close_and_rename($capi);
+read_only_bottom_close_and_rename($capi) if ! $error_count;
+
+die "$error_count errors found" if $error_count;
 
 # ex: set ts=8 sts=4 sw=4 noet: