Add ability to specify assert() calls in embed.fnc

embed.fnc

@@ -35,7 +35,7 @@
 :		Supported at least since perl-5.23.8, with or without ppport.h.
 :
 : Lines in this file are of the form:
-:    flags|return_type|name|arg1|arg2|...|argN
+:    flags|return_type|name|arg1|arg2|...|argN ( assert(...) )*
 :
 : 'flags' is a string of single letters.  Most of the flags are meaningful only
 : to embed.pl; some only to autodoc.pl, and others only to makedef.pl.  The
@@ -46,6 +46,9 @@
 : A line may be continued onto the next by ending it with a backslash.
 : Leading and trailing whitespace will be ignored in each component.
 :
+: The optional list of asserts is used to customize the generated
+: PERL_ARGS_ASSERT macro.  See AUTOMATIC PARAMETER SANITY CHECKING below
+:
 : Most entries here have a macro created with the entry name.  This presents
 : name space collision potentials which haven't been well thought out, but are
 : now documented here.  In practice this has rarely been an issue.  At least,
@@ -172,6 +175,14 @@
 :	may not be of the correct type. As already mentioned, NOCHECK
 :	suppresses this check.
 :
+:   You can specify your own checking beyond these by adding any number of
+:   assert() calls to any given entry after its final argument.  Whatever you
+:   specify will be added to the ARGS_ASSERT macro for the entry in the order
+:   you've specified, and after all the assertions that already have been
+:   described in this section.  When adding yours, weigh that doing it here
+:   will make it less visible to a maintainer than keeping it in the function
+:   it applies to
+:
 :   Currently, it is optional to include an empty ARGS_ASSERT macro in your
 :   functions.  But a porting test enforces that a non-empty one is included.
 :   The call should be at the top of your function so that the sanity checks
@@ -442,13 +453,6 @@
 :        flag even on a format function is if the format would generate error:
 :        format string argument is not a string type
 :
-:   'G'  Suppress empty PERL_ARGS_ASSERT_foo macro.  Normally such a macro is
-:        generated for all entries for functions 'foo' in this file.  The macro
-:        is empty unless regen/embed.pl deems that there should be assert()
-:        calls to verify the sanity of some or all of foo's arguments.
-:
-:          proto.h: An empty PERL_ARGS_ASSERT macro is not defined
-:
 :   'h'  Hide any documentation that would normally go into perlapi or
 :        perlintern. This is typically used when the documentation is actually
 :        in another pod. If you don't use the 'h', that documentation is
@@ -750,7 +754,8 @@ ARdp	|SSize_t|av_len 	|NN AV *av
 ARdp	|AV *	|av_make	|SSize_t size				\
 				|NN SV **strp
 CRdip	|AV *	|av_new_alloc	|SSize_t size				\
-				|bool zeroflag
+				|bool zeroflag				\
+				assert(size > 0)
 p	|SV *	|av_nonelem	|NN AV *av				\
 				|SSize_t ix
 Adp	|SV *	|av_pop 	|NN AV *av
@@ -2410,7 +2415,7 @@ p	|void	|no_bareword_filehandle 				\
 				|NN const char *fhname
 Tefprv	|void	|noperl_die	|NN const char *pat			\
 				|...
-CGTdp	|void	|noshutdownhook
+CTdp	|void	|noshutdownhook
 Adp	|int	|nothreadhook
 p	|void	|notify_parser_that_encoding_changed
 : Used in perly.y
@@ -4524,11 +4529,12 @@ op	|void	|sv_add_backref |NN SV * const tsv			\
 				|NN SV * const sv
 #endif
 #if defined(PERL_IN_GV_C) || defined(PERL_IN_UNIVERSAL_C)
-EGdp	|HV *	|gv_stashsvpvn_cached					\
-				|SV *namesv				\
-				|const char *name			\
+Edp	|HV *	|gv_stashsvpvn_cached					\
+				|NULLOK SV *namesv			\
+				|NULLOK const char *name		\
 				|U32 namelen				\
-				|I32 flags
+				|I32 flags				\
+				assert(namesv || name)
 #endif
 #if defined(PERL_IN_HV_C)
 Sx	|void	|clear_placeholders					\
@@ -6107,17 +6113,19 @@ S	|I32	|utf16_textfilter					\
 # endif
 #endif /* defined(PERL_IN_TOKE_C) */
 #if defined(PERL_IN_UNIVERSAL_C)
-GS	|bool	|isa_lookup	|NULLOK NOCHECK HV *stash		\
+S	|bool	|isa_lookup	|NN HV *stash				\
 				|NULLOK SV *namesv			\
 				|NULLOK const char *name		\
 				|STRLEN len				\
-				|U32 flags
-GS	|bool	|sv_derived_from_svpvn					\
-				|NULLOK SV *sv				\
+				|U32 flags				\
+				assert(namesv || name)
+S	|bool	|sv_derived_from_svpvn					\
+				|NN SV *sv				\
 				|NULLOK SV *namesv			\
 				|NULLOK const char *name		\
 				|const STRLEN len			\
-				|U32 flags
+				|U32 flags				\
+				assert(namesv || name)
 #endif
 #if defined(PERL_IN_UTF8_C)
 RS	|UV	|check_locale_boundary_crossing 			\

gv.c

@@ -1691,17 +1691,14 @@ reasons.
 =cut
 */
 
-#define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
-    assert(namesv || name)
-
 HV*
 Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
 {
+    PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
+
     HV* stash;
     HE* he;
 
-    PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
-
     he = (HE *)hv_common(
         PL_stashcache, namesv, name, namelen,
         (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0

inline.h

@@ -191,10 +191,10 @@ initialized.
 PERL_STATIC_INLINE AV *
 Perl_av_new_alloc(pTHX_ SSize_t size, bool zeroflag)
 {
+    PERL_ARGS_ASSERT_AV_NEW_ALLOC;
+
     AV * const av = newAV();
     SV** ary;
-    PERL_ARGS_ASSERT_AV_NEW_ALLOC;
-    assert(size > 0);
 
     Newx(ary, size, SV*); /* Newx performs the memwrap check */
     AvALLOC(av) = ary;

pod/perldelta.pod

@@ -423,6 +423,19 @@ memory saving is unrealistic.
 C<sv_vcatpvfn_flags()> now substitutes the Unicode REPLACEMENT CHARACTER
 for malformed input.  Previously it used the NUL character.
 
+=item *
+
+For core Perl maintainers, the syntax of F<embed.fnc> has been extended.
+Every function, C<foo()>, named in this file has generated for it a
+macro named C<PERL_ARGS_ASSERT_FOO>.  The macro expands to C<assert()>
+calls that do basic sanity checking for each argument to C<foo()> that
+we currently deem as being appropriate to have such checking.  (That
+means that many arguments are not checked, and that the generated macro
+may currently expand to nothing.)  With this release, you can add
+C<assert()> statements yourself to F<embed.fnc> that will be
+incorporated into the generated macro, beyond the system-generated ones.
+Comments and examples in F<embed.fnc> give details.
+
 =back
 
 =head1 Selected Bug Fixes

regen/HeaderParser.pm

@@ -737,46 +737,94 @@ sub lines { $_[0]->{lines} }
 sub tidy_embed_fnc_entry {
     my ($self, $line_data)= @_;
     my $line= $line_data->{line};
-    return $line if $line =~ /^\s*:/;
-    return $line unless $line_data->{type} eq "content";
-    return $line unless $line =~ /\|/;
 
-    $line =~ s/\s*\\\n/ /g;
-    $line =~ s/\s+\z//;
-    ($line)= expand($line);
+    return $line if $line =~ /^\s*:/;                    # Don't tidy comments
+    return $line unless $line_data->{type} eq "content"; # Nor #if-like
+    return $line unless $line =~ /\|/;                   # Nor non-entries
+
+    $line =~ s/\s*\\\n/ /g;     # Embedded \n to blank
+    $line =~ s/\s+\z//;         # No trailing white space
+    ($line)= expand($line);     # No tabs
+
+    # Remove any assertions, and save them.  This must be done before the
+    # split because the assertions can contain '|'
+    $line =~ s/ \b ( assert \s* \( .* ) \z //x;
+    my $assertions = $1;
+
+    # Split into fields
     my ($flags, $ret, $name, @args)= split /\s*\|\s*/, $line;
+
+    # Sort and remove duplicate flags.  Alpha flags are sorted first
     my %flag_seen;
-    $flags= join "", grep !$flag_seen{$_}++, sort split //, $flags;
-    if ($flags =~ s/^#//) {
-        $flags .= "#";
-    }
-    if ($flags eq "#") {
+    $flags = join "", grep !$flag_seen{$_}++,
+                      sort {
+                             my $a_is_word = $a =~ /\w/;
+                             my $b_is_word = $b =~ /\w/;
+                             return $a cmp $b if $a_is_word == $b_is_word;
+                             return -1 if $a_is_word;
+                             return  1;
+                           } split //, $flags;
+
+    if ($flags eq "#") {    # Could be an attempt at a conditional
         die "Not allowed to use only '#' for flags"
             . "in 'embed.fnc' at line $line_data->{start_line_num}";
     }
+
     if (!$flags) {
         die "Missing flags in function definition"
             . " in 'embed.fnc' at line $line_data->{start_line_num}\n"
             . "Did you a forget a line continuation on the previous line?\n";
     }
+
+    # Normalize the return type and arguments
     for ($ret, @args) {
         s/(\w)\*/$1 */g;
         s/\*\s+(\w)/*$1/g;
         s/\*const/* const/g;
     }
+
+    # Start the output; right justify
     my $head= sprintf "%-8s|%-7s", $flags, $ret;
     $head .= sprintf "|%*s", -(31 - length($head)), $name;
+
+    # Start first argument on next line if $head already extends too far to
+    # the right
     if (@args and length($head) > 32) {
         $head .= "\\\n";
         $head .= " " x 32;
     }
+
+    # Add each argument on a separate line
     foreach my $ix (0 .. $#args) {
         my $arg= $args[$ix];
         $head .= "|$arg";
         $head .= "\\\n" . (" " x 32) if $ix < $#args;
     }
+
+    my @assertions;
+    if ($assertions) {
+        # Put each assertion into a separate array element
+        @assertions = split / \s* assert \s* \( /x, $assertions;
+        shift @assertions;  # The split leaves an empty first element
+
+        # Trim each assertion, including any trailing semicolon
+        foreach my $this_assertion (@assertions) {
+            $this_assertion =~ s/ ^ \s+  //x;
+            $this_assertion =~ s/ \s+ \z //x;
+            $this_assertion =~ s/ ; \z   //x;
+
+            # Restore split delimitter
+            $this_assertion = "assert($this_assertion";
+
+            # Each assertion is on a separate line (for now, anyway)
+            $head .= "\\\n" . (" " x 32);
+            $head .= $this_assertion;
+        }
+    }
+
     $line= $head . "\n";
 
+    # Make all lines in this entry the same length; minimum 72
     if ($line =~ /\\\n/) {
         my @lines= split /\s*\\\n/, $line;
         my $len= length($lines[0]);
@@ -787,15 +835,18 @@ sub tidy_embed_fnc_entry {
             (map { sprintf "%*s", -$len, $_ } @lines[ 0 .. $#lines - 1 ]),
             $lines[-1]);
     }
-    ($line)= unexpand($line);
+
+    ($line)= unexpand($line);   # Back to using tabs
 
     $line_data->{embed}= EmbedLine->new(
         flags          => $flags,
         return_type    => $ret,
         name           => $name,
         args           => \@args,
+        assertions     => \@assertions,
         start_line_num => $line_data->{start_line_num},
     );
+
     $line =~ s/\s+\z/\n/;
     $line_data->{line}= $line;
     return $line;