Add ability to define a simple implementation in embed.fnc

autodoc.pl

@@ -2570,14 +2570,23 @@ ($destpod)
     }
     elsif ($file eq "embed.h") {
 
-        # embed.h won't have any apidoc lines in it.  Instead look for lines
-        # that define the obsolete 'perl_' lines.  Then we can check later
-        # that such a definition actually exists when we encounter input that
-        # claims there is
+        # embed.h won't have any apidoc lines in it.  Instead look for:
+        #   1) lines that define Perl_foo, the long name for 'foo'; and
+        #   2) lines that define the obsolete 'perl_' lines.
+
+        # Then we can check later that such a definition actually exists when
+        # we encounter input that claims there is
         open my $fh, '<', $file or die "Cannot open $file for docs: $!\n";
         while (defined (my $input = <$fh>)) {
-            $protos{$1} = $2
-                if $input =~ / ^\# \s* define \s+ ( perl_\w+ ) ( [^)]* \) ) /x;
+            if ($input =~ s/ ^ \# \s* define \s+ ( [Pp] erl_\w+ ) \s* //x) {
+                my $full_name = $1;
+
+                # The full name might be followed by an argument list, but not
+                # necessarily
+                $input =~ s/ \( [^)]* \) \s* (\w+) //x;
+
+                $protos{$full_name} = $1;
+            }
         }
         close $fh or die "Error closing $file: $!\n";
     }

embed.fnc

@@ -35,14 +35,33 @@
 :		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 [ = implementation ]
 :
-: '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
-: comments here mostly don't include how Devel::PPPort or diag.t use them:
-: All the possible flags and their meanings are given below.
+: 'name'    is the name of the entity being declared; usually its a function
+:
+: '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 comments here mostly don't include how
+:	    Devel::PPPort or diag.t use them: All the possible flags and their
+:	    meanings are given a ways below.
+:
+: 'return_type' is the type of value that 'name' returns, or 'void' if there is
+:	    no returned value.
+:
+: 'arg1' .. argN' are the arguments to 'name'.  These are omitted for an entity
+:	    taking no parameters.
+:
+: '= implementation  is optional; if present it defines the implementation of
+:	    'name'.  Its presence indicates that 'name' is a macro, so the 'm'
+:	    flag is implied and isn't required to be present.  This is intended
+:	    for macros that are simple, typically a variation on another entity
+:	    defined in this file, like calling such an entity with an extra,
+:	    fixed, parameter.  For example the implementation
+:		= bar(a,b,c,0)
+:	    means that 'name(a,b,c)' is defined to be 'bar(a,b,c,0)'
+:	    This facility automatically will generate any required long names
+:	    with any needed thread context parameters.
 :
-: A function taking no parameters will have no 'arg' elements.
 : A line may be continued onto the next by ending it with a backslash.
 : Leading and trailing whitespace will be ignored in each component.
 :
@@ -1158,11 +1177,12 @@ AOdp	|SV *	|eval_pv	|NN const char *p			\
 				|I32 croak_on_error
 AOdp	|SSize_t|eval_sv	|NN SV *sv				\
 				|I32 flags
-ATdmp	|bool	|extended_utf8_to_uv					\
+ATdp	|bool	|extended_utf8_to_uv					\
 				|NN const U8 * const s			\
 				|NN const U8 * const e			\
 				|NN UV *cp_p				\
-				|NULLOK Size_t *advance_p
+				|NULLOK Size_t *advance_p		\
+	      = utf8_to_uv(s,e,cp_p,advance_p)
 Adfpv	|void	|fatal_warner	|U32 err				\
 				|NN const char *pat			\
 				|...
@@ -3066,11 +3086,12 @@ dopx	|PerlIO *|start_glob	|NN SV *tmpglob 			\
 				|NN IO *io
 Adp	|I32	|start_subparse |I32 is_format				\
 				|U32 flags
-ATdmp	|bool	|strict_utf8_to_uv					\
+ATdp	|bool	|strict_utf8_to_uv					\
 				|NN const U8 * const s			\
 				|NN const U8 * const e			\
 				|NN UV *cp_p				\
-				|NULLOK Size_t *advance_p
+				|NULLOK Size_t *advance_p		\
+	      = utf8_to_uv_flags(s,e,cp_p,advance_p,UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
 CRp	|NV	|str_to_version |NN SV *sv
 : Used in pp_ctl.c
 p	|void	|sub_crush_depth|NN CV *cv
@@ -3521,7 +3542,8 @@ AMbdp	|void	|sv_usepvn_mg	|NN SV *sv				\
 Adp	|bool	|sv_utf8_decode |NN SV * const sv
 AMbdp	|bool	|sv_utf8_downgrade					\
 				|NN SV * const sv			\
-				|const bool fail_ok
+				|const bool fail_ok			\
+	      = sv_utf8_downgrade_flags(sv,fail_ok,SV_GMAGIC)
 Adp	|bool	|sv_utf8_downgrade_flags				\
 				|NN SV * const sv			\
 				|const bool fail_ok			\
@@ -3835,12 +3857,14 @@ Cp	|U8 *	|uvoffuni_to_utf8_flags_msgs				\
 				|const UV flags 			\
 				|NULLOK HV **msgs
 
-Adip	|U8 *	|uv_to_utf8	|NN U8 *d				\
-				|UV uv
-Adip	|U8 *	|uv_to_utf8_flags					\
+Adp	|U8 *	|uv_to_utf8	|NN U8 *d				\
+				|UV uv					\
+	      = uv_to_utf8_flags(d,uv,0)
+Adp	|U8 *	|uv_to_utf8_flags					\
 				|NN U8 *d				\
 				|UV uv					\
-				|UV flags
+				|UV flags				\
+	      = uv_to_utf8_msgs(d,uv,flags,0)
 Adip	|U8 *	|uv_to_utf8_msgs|NN U8 *d				\
 				|UV uv					\
 				|UV flags				\

embed.h

@@ -225,7 +225,8 @@
 # define dump_vindent(a,b,c,d)                  Perl_dump_vindent(aTHX_ a,b,c,d)
 # define eval_pv(a,b)                           Perl_eval_pv(aTHX_ a,b)
 # define eval_sv(a,b)                           Perl_eval_sv(aTHX_ a,b)
-# define extended_utf8_to_uv                    Perl_extended_utf8_to_uv
+# define extended_utf8_to_uv(s,e,cp_p,advance_p) utf8_to_uv(s,e,cp_p,advance_p)
+# define Perl_extended_utf8_to_uv               extended_utf8_to_uv
 # define fbm_compile(a,b)                       Perl_fbm_compile(aTHX_ a,b)
 # define fbm_instr(a,b,c,d)                     Perl_fbm_instr(aTHX_ a,b,c,d)
 # define filter_add(a,b)                        Perl_filter_add(aTHX_ a,b)
@@ -651,7 +652,8 @@
 # define stack_grow(a,b,c)                      Perl_stack_grow(aTHX_ a,b,c)
 # define start_subparse(a,b)                    Perl_start_subparse(aTHX_ a,b)
 # define str_to_version(a)                      Perl_str_to_version(aTHX_ a)
-# define strict_utf8_to_uv                      Perl_strict_utf8_to_uv
+# define strict_utf8_to_uv(s,e,cp_p,advance_p)  utf8_to_uv_flags(s,e,cp_p,advance_p,UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
+# define Perl_strict_utf8_to_uv                 strict_utf8_to_uv
 # define suspend_compcv(a)                      Perl_suspend_compcv(aTHX_ a)
 # define sv_2bool_flags(a,b)                    Perl_sv_2bool_flags(aTHX_ a,b)
 # define sv_2cv(a,b,c,d)                        Perl_sv_2cv(aTHX_ a,b,c,d)
@@ -776,6 +778,7 @@
 # define sv_upgrade(a,b)                        Perl_sv_upgrade(aTHX_ a,b)
 # define sv_usepvn_flags(a,b,c,d)               Perl_sv_usepvn_flags(aTHX_ a,b,c,d)
 # define sv_utf8_decode(a)                      Perl_sv_utf8_decode(aTHX_ a)
+# define sv_utf8_downgrade(sv,fail_ok)          sv_utf8_downgrade_flags(sv,fail_ok,SV_GMAGIC)
 # define sv_utf8_downgrade_flags(a,b,c)         Perl_sv_utf8_downgrade_flags(aTHX_ a,b,c)
 # define sv_utf8_encode(a)                      Perl_sv_utf8_encode(aTHX_ a)
 # define sv_utf8_upgrade_flags_grow(a,b,c)      Perl_sv_utf8_upgrade_flags_grow(aTHX_ a,b,c)
@@ -823,8 +826,8 @@
 # define utf8n_to_uvchr                         Perl_utf8n_to_uvchr
 # define utf8n_to_uvchr_error                   Perl_utf8n_to_uvchr_error
 # define utf8n_to_uvchr_msgs                    Perl_utf8n_to_uvchr_msgs
-# define uv_to_utf8(a,b)                        Perl_uv_to_utf8(aTHX_ a,b)
-# define uv_to_utf8_flags(a,b,c)                Perl_uv_to_utf8_flags(aTHX_ a,b,c)
+# define uv_to_utf8(d,uv)                       uv_to_utf8_flags(d,uv,0)
+# define uv_to_utf8_flags(d,uv,flags)           uv_to_utf8_msgs(d,uv,flags,0)
 # define uv_to_utf8_msgs(a,b,c,d)               Perl_uv_to_utf8_msgs(aTHX_ a,b,c,d)
 # define uvoffuni_to_utf8_flags_msgs(a,b,c,d)   Perl_uvoffuni_to_utf8_flags_msgs(aTHX_ a,b,c,d)
 # define valid_identifier_pve(a,b,c)            Perl_valid_identifier_pve(aTHX_ a,b,c)
@@ -2259,8 +2262,15 @@
 #   define PerlIO_write(a,b,c)                  Perl_PerlIO_write(aTHX_ a,b,c)
 # endif /* defined(USE_PERLIO) */
 # if defined(USE_THREADS)
+#   define Perl_sv_utf8_downgrade(mTHX,sv,fail_ok) Perl_sv_utf8_downgrade_flags(mTHX,sv,fail_ok,SV_GMAGIC)
+#   define Perl_uv_to_utf8(mTHX,d,uv)           Perl_uv_to_utf8_flags(mTHX,d,uv,0)
+#   define Perl_uv_to_utf8_flags(mTHX,d,uv,flags) Perl_uv_to_utf8_msgs(mTHX,d,uv,flags,0)
 #   define thread_locale_init()                 Perl_thread_locale_init(aTHX)
 #   define thread_locale_term()                 Perl_thread_locale_term(aTHX)
+# else
+#   define Perl_sv_utf8_downgrade               sv_utf8_downgrade
+#   define Perl_uv_to_utf8                      uv_to_utf8
+#   define Perl_uv_to_utf8_flags                uv_to_utf8_flags
 # endif
 # if defined(VMS) || defined(WIN32)
 #   define do_aspawn(a,b,c)                     Perl_do_aspawn(aTHX_ a,b,c)

inline.h

@@ -3272,18 +3272,6 @@ Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
     return 0;
 }
 
-PERL_STATIC_INLINE U8 *
-Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
-{
-    return uv_to_utf8_msgs(d, uv, 0, 0);
-}
-
-PERL_STATIC_INLINE U8 *
-Perl_uv_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
-{
-    return uv_to_utf8_msgs(d, uv, flags, 0);
-}
-
 PERL_STATIC_INLINE U8 *
 Perl_uv_to_utf8_msgs(pTHX_ U8 *d, UV uv, UV flags , HV **msgs)
 {

makedef.pl

@@ -796,8 +796,10 @@ sub readvar {
     foreach (@$embed_array) {
         my $embed= $_->{embed}
             or next;
-	my ($flags, $retval, $func, $args) = @{$embed}{qw(flags return_type name args)};
+	my ($flags, $retval, $func, $args, $implementation) =
+                    @{$embed}{qw(flags return_type name args implementation)};
 	next unless $func;
+	next if $implementation;    # Having this implies it is a macro
 	if (($flags =~ /[AXC]/ && $flags !~ $excludedre)
             || (!$define{'NO_MATHOMS'} && $flags =~ /b/))
         {

mathoms.c

@@ -808,14 +808,6 @@ Perl_newSVsv(pTHX_ SV *const old)
     return newSVsv(old);
 }
 
-bool
-Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
-{
-    PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
-
-    return sv_utf8_downgrade(sv, fail_ok);
-}
-
 char *
 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
 {

regen/HeaderParser.pm

@@ -744,6 +744,8 @@ sub tidy_embed_fnc_entry {
     $line =~ s/\s*\\\n/ /g;
     $line =~ s/\s+\z//;
     ($line)= expand($line);
+    $line =~ s/ \s* = \s* (.*?) \s* \z //x;
+    my $implementation = $1;
     my ($flags, $ret, $name, @args)= split /\s*\|\s*/, $line;
     my %flag_seen;
     $flags= join "", grep !$flag_seen{$_}++, sort split //, $flags;
@@ -759,28 +761,55 @@ sub tidy_embed_fnc_entry {
             . " in 'embed.fnc' at line $line_data->{start_line_num}\n"
             . "Did you a forget a line continuation on the previous line?\n";
     }
-    for ($ret, @args) {
+    for ($ret, @args, $implementation) {
+        next unless defined $_;
         s/(\w)\*/$1 */g;
         s/\*\s+(\w)/*$1/g;
         s/\*const/* const/g;
     }
     my $head= sprintf "%-8s|%-7s", $flags, $ret;
     $head .= sprintf "|%*s", -(31 - length($head)), $name;
-    if (@args and length($head) > 32) {
+    if ((@args || $implementation) and length($head) > 32) {
         $head .= "\\\n";
         $head .= " " x 32;
     }
     foreach my $ix (0 .. $#args) {
         my $arg= $args[$ix];
         $head .= "|$arg";
-        $head .= "\\\n" . (" " x 32) if $ix < $#args;
+
+        # Append continuation marker for all but final line
+        $head .= "\\\n" if $ix < $#args || $implementation;
+
+        # indent next argument line; $implementation line indented
+        # separately below
+        $head .= (" " x 32) if $ix < $#args;
+    }
+
+    if ($implementation) {
+
+        # Get rid of spaces around punctuation
+        $implementation =~ s/ \s* ( [[:punct:]] ) \s* /$1/xg;
+
+        # Use 14 spaces so as to generally line up with $name
+        $head .= (" " x 14) . "= $implementation";
     }
+
     $line= $head . "\n";
 
     if ($line =~ /\\\n/) {
+
+        # Create continuation line markers so as to all be in the same column,
+        # and at least in column 72
         my @lines= split /\s*\\\n/, $line;
         my $len= length($lines[0]);
-        $len < length($_) and $len= length($_) for @lines;
+
+        # Any implementation line doesn't cause the marker to be output
+        # further right than the argument lines.  Otherwise, could move them
+        # far to the right, giving more of a bad display.  XXX We could fold
+        # the implementation line.
+        my $upper_bound = ($implementation) ? $#lines - 1 : $#lines;
+
+        $len < length($_) and $len= length($_) for @lines[ 0 .. $upper_bound ];
         $len= int(($len + 7) / 8) * 8;
         $len= 72 if $len < 72;
         $line= join("\\\n",
@@ -794,6 +823,7 @@ sub tidy_embed_fnc_entry {
         return_type => $ret,
         name        => $name,
         args        => \@args,
+        implementation => $implementation,
     );
     $line =~ s/\s+\z/\n/;
     $line_data->{line}= $line;