X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/3f1866a8f6c7a9d70d0c8bb1b4f20d2db63756f1..7dc0f1bb7f6dd199fb0aae6f5edfa264e67a051a:/regen/embed.pl

diff --git a/regen/embed.pl b/regen/embed.pl
index 6007d92..5c33127 100755
--- a/regen/embed.pl
+++ b/regen/embed.pl
@@ -1,5 +1,5 @@
 #!/usr/bin/perl -w
-# 
+#
 # Regenerate (overwriting only if changed):
 #
 #    embed.h
@@ -26,11 +26,10 @@ use strict;
 
 BEGIN {
     # Get function prototypes
-    require 'regen/regen_lib.pl';
-    require 'regen/embed_lib.pl';
+    require './regen/regen_lib.pl';
+    require './regen/embed_lib.pl';
 }
 
-my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org
 my $unflagged_pointers;
 
 #
@@ -40,12 +39,19 @@ 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) = @_;
 
-    return "S_$func" if $flags =~ /[si]/;
     return "Perl_$func" if $flags =~ /p/;
+    return "S_$func" if $flags =~ /[SIi]/;
     return $func;
 }
 
@@ -75,16 +81,18 @@ my ($embed, $core, $ext, $api) = setup_embed();
 	}
 
 	my ($flags,$retval,$plain_func,@args) = @$_;
-	if ($flags =~ / ( [^AabDdEfiMmnOoPpRrsUXx] ) /x) {
-	    warn "flag $1 is not legal (for function $plain_func)";
+        if ($flags =~ / ( [^AabCDdEefFGhIiMmNnOoPpRrSsTUuWXx] ) /x) {
+	    die_at_end "flag $1 is not legal (for function $plain_func)";
 	}
 	my @nonnull;
-	my $has_context = ( $flags !~ /n/ );
+	my $args_assert_line = ( $flags !~ /G/ );
+        my $has_depth = ( $flags =~ /W/ );
+	my $has_context = ( $flags !~ /T/ );
 	my $never_returns = ( $flags =~ /r/ );
 	my $binarycompat = ( $flags =~ /b/ );
-	my $commented_out = ( ! $binarycompat && $flags =~ /m/ );
+	my $commented_out = ( $flags =~ /m/ );
 	my $is_malloc = ( $flags =~ /a/ );
-	my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
+	my $can_ignore = ( $flags !~ /R/ ) && ( $flags !~ /P/ ) && !$is_malloc;
 	my @names_of_nn;
 	my $func;
 
@@ -92,46 +100,70 @@ 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";
 	}
 
-	my $scope_type_flag_count = 0;
-	$scope_type_flag_count++ if $flags =~ /s/;
-	$scope_type_flag_count++ if $flags =~ /i/;
-	$scope_type_flag_count++ if $flags =~ /p/;
-	warn "$plain_func: i, p, and s flags are all mutually exclusive"
-						   if $scope_type_flag_count > 1;
-	my $splint_flags = "";
-	if ( $SPLINT && !$commented_out ) {
-	    $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
-	    if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
-		$retval .= " /*\@alt void\@*/";
-	    }
-	}
+	die_at_end "$plain_func: S and p flags are mutually exclusive"
+					    if $flags =~ /S/ && $flags =~ /p/;
+	die_at_end "$plain_func: m and $1 flags are mutually exclusive"
+					if $flags =~ /m/ && $flags =~ /([pS])/;
+
+	die_at_end "$plain_func: u flag only usable with m" if $flags =~ /u/
+							    && $flags !~ /m/;
 
-	if ($flags =~ /([si])/) {
+	my $static_inline = 0;
+	if ($flags =~ /([SIi])/) {
 	    my $type;
 	    if ($never_returns) {
-		$type = $1 eq 's' ? "PERL_STATIC_NO_RET" : "PERL_STATIC_INLINE_NO_RET";
+		$type = {
+		    'S' => 'PERL_STATIC_NO_RET',
+		    'i' => 'PERL_STATIC_INLINE_NO_RET',
+		    'I' => 'PERL_STATIC_FORCE_INLINE_NO_RET'
+		}->{$1};
 	    }
 	    else {
-		$type = $1 eq 's' ? "STATIC" : "PERL_STATIC_INLINE";
+		$type = {
+		    'S' => 'STATIC',
+		    'i' => 'PERL_STATIC_INLINE',
+		    'I' => 'PERL_STATIC_FORCE_INLINE'
+		}->{$1};
 	    }
-	    $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 =~ /^PERL_STATIC(?:_FORCE)?_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";
 	    }
 	}
+
+	die_at_end "For '$plain_func', M flag requires p flag"
+					    if $flags =~ /M/ && $flags !~ /p/;
+	die_at_end "For '$plain_func', C flag requires one of [pIimb] flags"
+					    if $flags =~ /C/ && $flags !~ /[Iibmp]/;
+	die_at_end "For '$plain_func', X flag requires one of [Iip] flags"
+					    if $flags =~ /X/ && $flags !~ /[Iip]/;
+	die_at_end "For '$plain_func', X and m flags are mutually exclusive"
+					    if $flags =~ /X/ && $flags =~ /m/;
+	die_at_end "For '$plain_func', [Ii] with [ACX] requires p flag"
+			if $flags =~ /[Ii]/ && $flags =~ /[ACX]/ && $flags !~ /p/;
+	die_at_end "For '$plain_func', b and m flags are mutually exclusive"
+	         . " (try M flag)" if $flags =~ /b/ && $flags =~ /m/;
+	die_at_end "For '$plain_func', b flag without M flag requires D flag"
+			    if $flags =~ /b/ && $flags !~ /M/ && $flags !~ /D/;
+	die_at_end "For '$plain_func', I and i flags are mutually exclusive"
+					    if $flags =~ /I/ && $flags =~ /i/;
+
 	$func = full_name($plain_func, $flags);
 	$ret = "";
-	$ret .= "#ifndef NO_MATHOMS\n" if $binarycompat;
 	$ret .= "$retval\t$func(";
 	if ( $has_context ) {
 	    $ret .= @args ? "pTHX_ " : "pTHX";
 	}
 	if (@args) {
+	    die_at_end "n flag is contradicted by having arguments"
+								if $flags =~ /n/;
 	    my $n;
 	    for my $arg ( @args ) {
 		++$n;
@@ -151,10 +183,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;
@@ -165,6 +194,7 @@ my ($embed, $core, $ext, $api) = setup_embed();
 	else {
 	    $ret .= "void" if !$has_context;
 	}
+        $ret .= " _pDEPTH" if $has_depth;
 	$ret .= ")";
 	my @attrs;
 	if ( $flags =~ /r/ ) {
@@ -182,6 +212,9 @@ my ($embed, $core, $ext, $api) = setup_embed();
 	if ( $flags =~ /P/ ) {
 	    push @attrs, "__attribute__pure__";
 	}
+	if ( $flags =~ /I/ ) {
+	    push @attrs, "__attribute__always_inline__";
+	}
 	if( $flags =~ /f/ ) {
 	    my $prefix	= $has_context ? 'pTHX_' : '';
 	    my ($args, $pat);
@@ -211,17 +244,24 @@ my ($embed, $core, $ext, $api) = setup_embed();
 				    $prefix, $pat, $args;
 	    }
 	}
+	elsif ((grep { $_ eq '...' } @args) && $flags !~ /F/) {
+	    die_at_end "$plain_func: Function with '...' arguments must have"
+	             . " f or F flag";
+	}
 	if ( @attrs ) {
 	    $ret .= "\n";
 	    $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
 	}
 	$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 .= "\n#endif" if $binarycompat;
+
+	$ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E"
+					    if $args_assert_line || @names_of_nn;
+	$ret .= "\t\\\n\t" . join '; ', map "assert($_)", @names_of_nn
+								if @names_of_nn;
+
+	$ret = "#ifndef PERL_NO_INLINE_FUNCTIONS\n$ret\n#endif" if $static_inline;
+	$ret = "#ifndef NO_MATHOMS\n$ret\n#endif" if $binarycompat;
 	$ret .= @attrs ? "\n\n" : "\n";
 
 	print $pr $ret;
@@ -234,21 +274,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}++;
 	}
     }
@@ -303,9 +343,9 @@ sub embed_h {
 	}
 	my $ret = "";
 	my ($flags,$retval,$func,@args) = @$_;
-	unless ($flags =~ /[om]/) {
+	unless ($flags =~ /[omM]/) {
 	    my $args = scalar @args;
-	    if ($flags =~ /n/) {
+	    if ($flags =~ /T/) {
 		my $full_name = full_name($func, $flags);
 		next if $full_name eq $func;	# Don't output a no-op.
 		$ret = hide($func, $full_name);
@@ -325,7 +365,15 @@ sub embed_h {
 		$ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
 		$ret .= full_name($func, $flags) . "(aTHX";
 		$ret .= "_ " if $alist;
-		$ret .= $alist . ")\n";
+                $ret .= $alist;
+                if ($flags =~ /W/) {
+                    if ($alist) {
+                        $ret .= " _aDEPTH";
+                    } else {
+                        die "Can't use W without other args (currently)";
+                    }
+                }
+                $ret .= ")\n";
 	    }
 	    $ret = "#ifndef NO_MATHOMS\n$ret#endif\n" if $flags =~ /b/;
 	}
@@ -432,7 +480,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');
 
@@ -485,9 +533,11 @@ END
 
 for $sym (@globvar) {
     print $em "#ifdef OS2\n" if $sym eq 'sh_path';
+    print $em "#ifdef __VMS\n" if $sym eq 'perllib_sep';
     print $em multon($sym,   'G','my_vars->');
     print $em multon("G$sym",'', 'my_vars->');
     print $em "#endif\n" if $sym eq 'sh_path';
+    print $em "#endif\n" if $sym eq 'perllib_sep';
 }
 
 print $em <<'END';
@@ -495,7 +545,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');
 
@@ -598,7 +648,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');
  *
@@ -647,6 +697,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: