#!/usr/bin/perl -w
#
# Regenerate (overwriting only if changed):
#
#    embed.h
#    embedvar.h
#    proto.h
#
# from information stored in
#
#    embed.fnc
#    intrpvar.h
#    perlvars.h
#    regen/opcodes
#
# Accepts the standard regen_lib -q and -v args.
#
# This script is normally invoked from regen.pl.

require 5.004;  # 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/regen_lib.pl';
    require './regen/embed_lib.pl';
}

# This program has historically generated compatibility macros for a few
# functions of the form Perl_FOO(pTHX_ ...).  Those macros would be named
# FOO(...), and would expand outside the core to Perl_FOO_nocontext(...)
# instead of the expected value.  This was done so XS code that didn't do a
# PERL_GET_CONTEXT would continue to work unchanged after threading was
# introduced.  Any new API functions that came along would require an aTHX_
# parameter; this was just to avoid breaking existing source.  Hence no new
# functions need be added to the list of such macros.  This is the list.
# All have varargs.
#
# N.B. If you change this list, update the copy in autodoc.pl.  This is likely
# to never happen, so not worth coding automatic synchronization.
my @have_compatibility_macros = qw(
                                    deb
                                    form
                                    load_module
                                    mess
                                    newSVpvf
                                    sv_catpvf
                                    sv_catpvf_mg
                                    sv_setpvf
                                    sv_setpvf_mg
                                    warn
                                    warner
                                  );
my %has_compat_macro;
$has_compat_macro{$_} = 1 for @have_compatibility_macros;
my %perl_compats;   # Have 'perl_' prefix

my $unflagged_pointers;
my @az = ('a'..'z');

#
# See database of global and static function prototypes in embed.fnc
# This is used to generate prototype headers under various configurations,
# export symbols lists for different platforms, and macros to provide an
# 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) = @_;

    if ($flags =~ /[ps]/) {

        # An all uppercase macro name gets an uppercase prefix.
        return (($flags =~ tr/mp// > 1) && $func !~ /[[:lower:]]/)
               ? "PERL_$func"
               : "Perl_$func";
    }

    return "S_$func" if $flags =~ /[SIi]/;
    return $func;
}

sub open_print_header {
    my ($file, $quote) = @_;

    return open_new($file, '>',
                    { file => $file, style => '*', by => 'regen/embed.pl',
                      from => [
                               'embed.fnc',
                               'intrpvar.h',
                               'perlvars.h',
                               'regen/opcodes',
                               'regen/embed.pl',
                               'regen/embed_lib.pl',
                               'regen/HeaderParser.pm',
                           ],
                      final => "\nEdit those files and run 'make regen_headers' to effect changes.\n",
                      copyright => [1993 .. 2022],
                      quote => $quote });
}


sub open_buf_out {
    $_[0] //= "";
    open my $fh,">", \$_[0]
        or die "Failed to open buffer: $!";
    return $fh;
}

my %type_asserts = (
    # Templates for argument type checking for different argument types.
    # __arg__ will be replaced by the parameter variable name

    'AV*' => "SvTYPE(__arg__) == SVt_PVAV",
    'HV*' => "SvTYPE(__arg__) == SVt_PVHV",

    # Any CV* might point at a PVCV or PVFM
    'CV*' => "SvTYPE(__arg__) == SVt_PVCV || SvTYPE(__arg__) == SVt_PVFM",

    # We don't check GV*s for now because too many functions
    # take non-initialised GV pointers
);

# generate proto.h
sub generate_proto_h {
    my ($all)= @_;
    my $pr = open_buf_out(my $proto_buffer);
    my $ret;

    foreach (@$all) {
        if ($_->{type} ne "content") {
            print $pr "$_->{line}";
            next;
        }
        my $embed= $_->{embed}
            or next;

        my $level= $_->{level};
        my $ind= $level ? " " : "";
        $ind .= "  " x ($level-1) if $level>1;
        my $inner_ind= $ind ? "  " : " ";

        my ($flags, $retval, $plain_func, $args, $assertions ) =
                        @{$embed}{qw(flags return_type name args assertions)};
        if ($flags =~ / ( [^ AabCDdEefFhIiMmNnOoPpRrSsTUuWXx;] ) /xx) {
            die_at_end "flag $1 is not legal (for function $plain_func)";
        }

        if ($flags =~ /O/) {
            die_at_end "$plain_func: O flag requires p flag" if $flags !~ /p/;
            die_at_end "$plain_func: O flag forbids T flag" if $flags =~ /T/;
        }

        my @nonnull;
        my $args_assert_line = ( $flags !~ /m/ );
        my $has_depth = ( $flags =~ /W/ );
        my $has_context = ( $flags !~ /T/ );
        my $never_returns = ( $flags =~ /r/ );
        my $binarycompat = ( $flags =~ /b/ );
        my $has_mflag = ( $flags =~ /m/ );
        my $is_malloc = ( $flags =~ /a/ );
        my $can_ignore = $flags !~ /[RP]/ && !$is_malloc;
        my $extensions_only = ( $flags =~ /E/ );
        my @asserts;
        my $func;

        if (! $can_ignore && $retval eq 'void') {
            warn "It is nonsensical to require the return value of a void function ($plain_func) to be checked";
        }

        my $has_E_or_X = $flags =~ /[EX]/;
        if ($has_E_or_X + ($flags =~ tr/AC//) > 1) {
            die_at_end "$plain_func: A, C, and either E or X flags are"
                     . " mutually exclusive";
        }

        die_at_end "$plain_func: S and p flags are mutually exclusive"
                                                    if $flags =~ tr/Sp// > 1;
        if ($has_mflag) {
            if ($flags =~ /S/) {
                die_at_end
                          "$plain_func: m and S flags are mutually exclusive";
            }
        }
        else {
            die_at_end "$plain_func: u flag only usable with m"
                                                            if $flags =~ /u/;
        }

        my ($static_flag, @extra_static_flags)= $flags =~/([SsIi])/g;

        if (@extra_static_flags) {
            my $flags_str = join ", ", $static_flag, @extra_static_flags;
            $flags_str =~ s/, (\w)\z/ and $1/;
            die_at_end
                     "$plain_func: flags $flags_str are mutually exclusive\n";
        }

        my $static_inline = 0;
        if ($static_flag) {
            my $type;
            if ($never_returns) {
                $type = {
                    'S' => 'PERL_STATIC_NO_RET',
                    's' => 'PERL_STATIC_NO_RET',
                    'i' => 'PERL_STATIC_INLINE_NO_RET',
                    'I' => 'PERL_STATIC_FORCE_INLINE_NO_RET'
                }->{$static_flag};
            }
            else {
                $type = {
                    'S' => 'STATIC',
                    's' => 'STATIC',
                    'i' => 'PERL_STATIC_INLINE',
                    'I' => 'PERL_STATIC_FORCE_INLINE'
                }->{$static_flag};
            }
            $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 {

            # A publicly accessible non-static element needs to have a Perl_
            # prefix available to call it with (in case of name conflicts).
            die_at_end "'$plain_func' requires p flag because has A or C flag"
                                    if $flags !~ /p/
                                    && $flags =~ /[AC]/
                                    && $plain_func !~ /[Pp]erl/;

            if ($never_returns) {
                $retval = "PERL_CALLCONV_NO_RET $retval";
            }
            else {
                $retval = "PERL_CALLCONV $retval";
            }
        }

        $func = full_name($plain_func, $flags);

        die_at_end "For '$plain_func', M flag requires p flag"
                                            if $flags =~ /M/ && $flags !~ /p/;
        my $C_required_flags = '[pIimbs]';
        die_at_end
          "For '$plain_func', C flag requires one of $C_required_flags] flags"
                                             if $flags =~ /C/
                                             && ($flags !~ /$C_required_flags/

                                                # Notwithstanding the
                                                # above, if the name won't
                                                # clash with a user name,
                                                # it's ok.
                                             && $plain_func !~ /^[Pp]erl/);

        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/ && $has_mflag;
        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/ && $has_mflag;
        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 =~ tr/Ii// > 1;

        $ret = "";
        $ret .= "$retval\n";
        $ret .= "$func(";
        if ( $has_context ) {
            $ret .= @$args ? "pTHX_ " : "pTHX";
        }
        if (@$args) {
            die_at_end
                    "$plain_func: n flag is contradicted by having arguments"
                                                            if $flags =~ /n/;
            my $n;
            my @bounded_strings;

            for my $arg ( @$args ) {
                ++$n;

                if ($arg =~ / ^ " (.+) " $ /x) {    # Handle literal string
                    my $name = $1;

                    # Make the string a legal C identifier; 'p' is arbitrary,
                    # and is because C reserves leading underscores
                    $name =~ s/^\W/p/a;
                    $name =~ s/\W/_/ag;

                    $arg = "const char * const $name";
                    die_at_end "$plain_func: func: m flag required for"
                             . '"literal" argument' unless $has_mflag;
                }
                else {  # Look for constraints about this argument

                    my $ptr_type;   # E, M, and S are the three types
                                    # corresponding respectively to EPTR(Q)?,
                                    # MPTR, and SPTR
                    my $equal = ""; # EPTRQ is just an EPTR with this set to
                                    # "="
                    if ($arg =~ s/ \b ( [EMS] ) PTR (Q)? \b //x) {;
                        $ptr_type = $1;
                        if (defined $2) {
                            die_at_end ": $func: Q only valid with EPTR"
                                                          if $ptr_type ne 'E';
                            $equal = "=";
                        }
                        elsif ($ptr_type eq 'M') {
                            # A middle position always is <=
                            $equal = "=";
                        }
                    }

                    # A $ptr_type is a specialized 'nn'
                    my $nn =  (defined $ptr_type) + ( $arg =~ s/\bNN\b// );

                    my $nz =      ( $arg =~ s/\bNZ\b// );
                    my $nullok =  ( $arg =~ s/\bNULLOK\b// );
                    my $nocheck = ( $arg =~ s/\bNOCHECK\b// );

                    # Trim $arg and remove multiple blanks
                    $arg =~ s/^\s+//;
                    $arg =~ s/\s+$//;
                    $arg =~ s/\s{2,}/ /g;

                    # Note that we don't care if you say e.g., 'NN' multiple
                    # times
                    die_at_end
                           ":$func: $arg Use only one of NN (including"
                         . " EPTR, EPTRQ, MPTR, SPTR), NULLOK, or NZ"
                                               if 0 + $nn + $nz + $nullok > 1;

                    push( @nonnull, $n ) if $nn;

                    # A non-pointer shouldn't have a pointer-related modifier.
                    # But typedefs may be pointers without our knowing it, so
                    # we can't check for non-pointer issues.  We can only
                    # check for the case where the argument is definitely a
                    # pointer.
                    if ($args_assert_line && $arg =~ /\*/) {
                        if ($nn + $nullok == 0) {
                            warn "$func: $arg needs one of: NN, EPTR, EPTRQ,"
                               . " MPTR, SPTR, or NULLOK\n";
                            ++$unflagged_pointers;
                        }

                        warn "$func: $arg should not have NZ\n" if $nz;
                    }

                    # 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 $argtype = ( $arg =~ m/^(\w+(?:\s*\*+)?)/ )[0];
                    defined $argtype and $argtype =~ s/\s+//g;

                    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+)(?:\[\d+\])?\s*$/) ) {
                        die_at_end "$func: $arg ($n) doesn't have a name\n";
                    }
                    my $argname = $1;

                    if (defined $argname && (! $has_mflag || $binarycompat)) {
                        if ($nn||$nz) {
                            push @asserts, "assert($argname)";
                        }

                        if (   ! $nocheck
                            && defined $argtype
                            && exists $type_asserts{$argtype})
                        {
                            my $type_assert =
                             $type_asserts{$argtype} =~ s/__arg__/$argname/gr;
                            $type_assert = "!$argname || $type_assert"
                                                                   if $nullok;
                            push @asserts, "assert($type_assert)";
                        }

                        # If this is a pointer to a character string argument,
                        # we need extra work.
                        if ($ptr_type) {

                            # For these, not only does the parameter have to
                            # be non-NULL, but every dereference of it has to
                            # too.
                            #
                            # First, get all the '*" derefs, except one.
                            my $derefs = "*" x (($arg =~ tr/*//) - 1);

                            # Then add the asserts that each dereferenced
                            # layer is non-NULL.
                            for (my $i = 1; $i <= length $derefs; $i++) {
                                push @asserts, "assert("
                                             . substr($derefs, 0, $i)
                                             . "$argname)";
                            }

                            # Save the data we need later
                            my %entry = (
                                          argname => $argname,
                                          equal   => $equal,
                                          deref   => $derefs,
                                        );

                            # The motivation for all this is that some string
                            # pointer parameters have constraints, such as
                            # that the starting position can't be beyond the
                            # ending one.  Unfortunately, the function's
                            # parameters can be positioned in its prototype so
                            # that the pointer to the ending position comes
                            # before the pointer to the starting one, and this
                            # can't be changed because they are API.  To cope
                            # with this, we use the array below to save just
                            # the crucial information about each while parsing
                            # the parameters.  After all information is
                            # gathered, we go through and handle it.  An entry
                            # looks like this after all the parameters are
                            # parsed:
                            #   {
                            #       'M' => {
                            #               'equal' => '=',
                            #               'argname' => 'curpos',
                            #               'deref' => ''
                            #               },
                            #       'E' => {
                            #               'equal' => '',
                            #               'argname' => 'strend',
                            #               'deref' => ''
                            #               },
                            #       'S' => {
                            #               'equal' => '',
                            #               'deref' => '',
                            #               'argname' => 'strbeg'
                            #               }
                            #   }
                            #
                            # Only two of the keys need be present.
                            # If the function has multiple string parameters,
                            # the [0] entry in @bounded_strings will be for
                            # the first string, [1] for the second, and so on.
                            #
                            # Here, we are in the middle of parsing the
                            # parameters.  We add this parameter to the
                            # current string's boundary constraints hash,
                            # or create a new string if necessary.  The new
                            # string's data is pushed as a new element onto
                            # the array.
                            #
                            # A new element is created if the array is empty,
                            # or if there is already an existing hash element
                            # for the new key.  For example, you can't have
                            # two EPTRs for the same string, so the second
                            # must be for a new string.
                            #
                            # Otherwise we presume this hash value is for the
                            # most recent string in the array.  If we have an
                            # EPTR, and an MPTR comes along, assume that it is
                            # for the same string as the EPTR.
                            #
                            # This hack works as long as all parameters for the
                            # current string come before any of the next
                            # string, which is the case for all existing
                            # function calls, and any new ones can be
                            # fashioned to conform.
                            if (   @bounded_strings
                                && ! defined $bounded_strings[-1]{$ptr_type})
                            {
                                $bounded_strings[-1]{$ptr_type} = \%entry;
                            }
                            else {
                                push @bounded_strings,
                                     { $ptr_type => \%entry };
                            }
                        }   # End of special handling of string bounds
                    }
                }   # End of this argument
            }   # End of loop through all arguments

            # We have looped through all arguments, and for any bounded string
            # ones, we have saved the information needed to generate things
            # like
            #   assert(s < e)
            foreach my $string (@bounded_strings) {

                # We need at least two bounds
                if (1 == (  (defined $string->{S})
                          + (defined $string->{M})
                          + (defined $string->{E})))
                {
                    my ($type, $object) = each %$string;
                    die_at_end
                           "$func: Missing PTR constraint for string given by "
                         . $object->{argname};
                    next;
                }

                # But three or any two bounds work.  We may need to generate
                # two asserts, so loop to do so, skipping any missing one.
                for my $i (["S", "E"], ["S", "M"], ["M", "E"]) {

                    # We don't need an assert for the whole span if we have an
                    # intermediate one.
                    next if defined $string->{M} &&    $i->[0] eq 'S'
                                                    && $i->[1] eq 'E';

                    my $lower = $string->{$i->[0]} or next;
                    my $upper = $string->{$i->[1]} or next;

                    # This reduces to either;
                    #   assert(lower < upper);
                    # or
                    #   assert(lower <= upper);
                    #
                    # There might also be some derefences, like **lower
                    push @asserts, "assert("
                                        . "$lower->{deref}$lower->{argname}"
                                        . " <$upper->{equal} "
                                        . "$upper->{deref}$upper->{argname}"
                                        . ")";
                }
            }

            $ret .= join ", ", @$args;
        }
        else {
            $ret .= "void" if !$has_context;
        }
        $ret .= " comma_pDEPTH" if $has_depth;
        $ret .= ")";

        push @asserts, @$assertions if $assertions;

        my @attrs;
        if ( $flags =~ /r/ ) {
            push @attrs, "__attribute__noreturn__";
        }
        if ( $flags =~ /D/ ) {
            push @attrs, "__attribute__deprecated__";
        }
        if ( $is_malloc ) {
            push @attrs, "__attribute__malloc__";
        }
        if ( !$can_ignore ) {
            push @attrs, "__attribute__warn_unused_result__";
        }
        if ( $flags =~ /P/ ) {
            push @attrs, "__attribute__pure__";
        }
        if ( $flags =~ /I/ ) {
            push @attrs, "__attribute__always_inline__";
        }
        # roughly the inverse of the rules used in makedef.pl
        if ( $flags !~ /[AbCeIimSX]/ ) {
            push @attrs, '__attribute__visibility__("hidden")'
        }
        if( $flags =~ /f/ ) {
            my $prefix  = $has_context ? 'pTHX_' : '';
            my ($argc, $pat);
            if (!defined $args->[1]) {
                use Data::Dumper;
                die Dumper($_);
            }
            if ($args->[-1] eq '...') {
                $argc   = scalar @$args;
                $pat    = $argc - 1;
                $argc   = $prefix . $argc;
            }
            else {
                # don't check args, and guess which arg is the pattern
                # (one of 'fmt', 'pat', 'f'),
                $argc = 0;
                my @fmts = grep $args->[$_] =~ /\b(f|pat|fmt)$/, 0..$#$args;
                if (@fmts != 1) {
                    die
                    "embed.pl: '$plain_func': can't determine pattern arg\n";
                }
                $pat = $fmts[0] + 1;
            }
            my $macro   = grep($_ == $pat, @nonnull)
                                ? '__attribute__format__'
                                : '__attribute__format__null_ok__';
            if ($plain_func =~ /strftime/) {
                push @attrs, sprintf "%s(__strftime__,%s1,0)",
                                     $macro, $prefix;
            }
            else {
                push @attrs, sprintf "%s(__printf__,%s%d,%s)", $macro,
                                    $prefix, $pat, $argc;
            }
        }
        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 { (" " x 8) . $_ } @attrs );
        }
        $ret .= ";";
        $ret = "/* $ret */" if $has_mflag;

        # Hide the prototype from non-authorized code.  This acts kind of like
        # __attribute__visibility__("hidden") for cases where that can't be
        # used.
        $ret = "#${ind}if defined(PERL_CORE) || defined(PERL_EXT)\n"
             . $ret
             . " \n#${ind}endif"
          if $extensions_only;

        # We don't hide the ARGS_ASSERT macro; having that defined does no
        # harm, and otherwise some inline functions that are looking for it
        # would fail to compile.
        if ($args_assert_line || @asserts) {
            $ret .= "\n#${ind}define PERL_ARGS_ASSERT_\U$plain_func\E";
            if (@asserts) {
                $ret .= " \\\n";

                my $line = "";
                while(@asserts) {
                    my $assert = shift @asserts;

                    if(length($line) + length($assert) > 78) {
                        $ret .= $line . "; \\\n";
                        $line = "";
                    }

                    $line .= " " x 8 if !length $line;
                    $line .= "; " if $line =~ m/\S/;
                    $line .= $assert;
                }

                $ret .= $line if length $line;
                $ret .= "\n";
            }
        }
        $ret .= "\n";

        $ret = "#${ind}ifndef PERL_NO_INLINE_FUNCTIONS\n$ret\n#${ind}endif"
            if $static_inline;
        $ret = "#${ind}ifndef NO_MATHOMS\n$ret\n#${ind}endif"
            if $binarycompat;

        $ret .= @attrs ? "\n\n" : "\n";

        print $pr $ret;
    }


    close $pr;

    my $clean= normalize_group_content($proto_buffer);

    my $fh = open_print_header("proto.h");
    print $fh <<~"EOF";
    START_EXTERN_C
    $clean
    #ifdef PERL_CORE
    #  include "pp_proto.h"
    #endif
    END_EXTERN_C
    EOF

    read_only_bottom_close_and_rename($fh) if ! $error_count;
}

{
    my $hp= HeaderParser->new();
    sub normalize_group_content {
        open my $in, "<", \$_[0]
            or die "Failed to open buffer: $!";
        $hp->parse_fh($in);
        my $ppc= sub {
            my ($self, $line_data)= @_;
            # re-align defines so that the definitions line up at the 48th col
            # as much as possible.
            if ($line_data->{sub_type} eq "#define") {
                $line_data->{line} =~
                        s/^(\s*#\s*define\s+\S+?(?:\([^()]*\))?\s)(\s*)(\S+)/
                    sprintf "%-48s%s", $1, $3/e;
            }
        };
        my $clean= $hp->lines_as_str($hp->group_content(),$ppc);
        return $clean;
    }
}

sub normalize_and_print {
    my ($file, $buffer)= @_;
    my $fh = open_print_header($file);
    print $fh normalize_group_content($buffer);
    read_only_bottom_close_and_rename($fh);
}


sub readvars {
    my ($file, $pre) = @_;
    my $hp= HeaderParser->new()->read_file($file);
    my %seen;
    foreach my $line_data (@{$hp->lines}) {
        #next unless $line_data->is_content;
        my $line= $line_data->line;
        if ($line=~m/^\s*PERLVARA?I?C?\(\s*$pre\s*,\s*(\w+)/){
            $seen{$1}++
                and
                die_at_end "duplicate symbol $1 while processing $file line "
                       . ($line_data->start_line_num) . "\n"
        }
    }
    my @keys= sort { lc($a) cmp lc($b) ||
                        $a  cmp    $b }
              keys %seen;
    return @keys;
}

sub add_indent {
    #my ($ret, $add, $width)= @_;
    my $width= $_[2] || 48;
    $_[0] .= " " x ($width-length($_[0])) if length($_[0])<$width;
    $_[0] .= " " unless $_[0]=~/\s\z/;
    if (defined $_[1]) {
        $_[0] .= $_[1];
    }
    return $_[0];
}

sub indent_define {
    my ($from, $to, $indent, $width) = @_;
    $indent = '' unless defined $indent;
    my $ret= "#${indent}define $from";
    add_indent($ret,"$to\n",$width);
}

sub multon {
    my ($sym,$pre,$ptr,$ind) = @_;
    $ind//="";
    indent_define("PL_$sym", "($ptr$pre$sym)", $ind);
}

sub embed_h {
    my (
        $em,    # file handle
        $guard, # ifdef text
        $funcs  # functions to go into this text
       ) = @_;

    my $lines;
    foreach (@$funcs) {
        if ($_->{type} ne "content") {
            $lines .= $_->{line};
            next;
        }
        my $level= $_->{level};
        my $embed= $_->{embed} or next;
        my ($flags,$retval,$func,$args) =
                                   @{$embed}{qw(flags return_type name args)};
        my $full_name = full_name($func, $flags);
        next if $full_name eq $func;    # Don't output a no-op.

        my $ret = "";
        my $ind= $level ? " " : "";
        $ind .= "  " x ($level-1) if $level>1;
        my $inner_ind= $ind ? "  " : " ";

        if ($flags =~ tr/mp// > 1) {    # Has both m and p

            # Yields
            #   #define Perl_func  func
            # which works when there is no thread context.
            $ret = indent_define($full_name, $func, $ind);

            if ($flags !~ /[T]/) {

                # But when there is the possibility of a thread context
                # parameter, $ret works only on non-threaded builds
                my $no_thread_full_define = $ret;

                # And we have to do more when there are threads.  First,
                # convert the input argument list to 'a', 'b' ....  This keeps
                # us from having to worry about all the extra stuff in the
                # input list; stuff like the type declarations, things like
                # NULLOK, and pointers '*'.
                my $argname = 'a';
                my @stripped_args;
                push @stripped_args, $argname++ for $args->@*;
                my $arglist = join ",", @stripped_args;

                # In the threaded case, the Perl_ form is expecting an aTHX
                # first argument.  Use mTHX to match that, which isn't passed
                # on to the short form name, as that is expecting an implicit
                # aTHX.  The non-threaded case just uses what we generated
                # above for the /T/ flag case.
                my $mTHX_ = "mTHX";
                $mTHX_ .= ',' if $arglist ne "";
                $ret = "#${ind}ifdef USE_THREADS\n"
                     . "#${ind}  define $full_name($mTHX_$arglist)"
                     .           "  $func($arglist)\n"
                     . "#${ind}else\n"
                     . "$ind  $no_thread_full_define" # No \n because no chomp
                     . "#${ind}endif\n";
            }
        }
        elsif ($flags !~ /[omM]/) {
            my $argc = scalar @$args;
            if ($flags =~ /[T]/) {
                $ret = indent_define($func, $full_name, $ind);
            }
            else {
                my $use_va_list = $argc && $args->[-1] =~ /\.\.\./;

                if($use_va_list) {
                    # CPP has trouble with empty __VA_ARGS__ and comma
                    # joining, so we'll have to eat an extra params here.
                    if($argc < 2) {
                        die "Cannot use ... as the only parameter to a macro"
                          . " ($func)\n";
                    }
                    $argc -= 2;
                }

                my $paramlist   = join(",", @az[0..$argc-1],
                    $use_va_list ? ("...") : ());
                my $replacelist = join(",", @az[0..$argc-1],
                    $use_va_list ? ("__VA_ARGS__") : ());
                $ret = "#${ind}define $func($paramlist) ";
                add_indent($ret,full_name($func, $flags) . "(aTHX");
                if ($replacelist) {
                    $ret .= ($flags =~ /m/) ? "," : "_ ";
                    $ret .= $replacelist;
                }

                if ($flags =~ /W/) {
                    if ($replacelist) {
                        $ret .= " comma_aDEPTH";
                    } else {
                        die "Can't use W without other args (currently)";
                    }
                }
                $ret .= ")";

                # For functions that have an old 'perl_' name, create an entry
                # here while we have all the information, for output later
                # (when not under NO_SHORT_NAMES)
                if ($flags =~ /O/) {
                    my $extra_entry = $ret;
                    $extra_entry =~ s/define /define perl_/;
                    $perl_compats{$extra_entry} = 1;
                }

                $ret .= "\n";

                if($has_compat_macro{$func}) {
                    # Make older ones available only when !MULTIPLICITY or
                    # PERL_CORE or PERL_WANT_VARARGS.  These should not be
                    # done unconditionally because existing code might call
                    # e.g.  warn() without aTHX in scope.
                    $ret = "#${ind}if !defined(MULTIPLICITY)"
                         . " || defined(PERL_CORE)"
                         . " || defined(PERL_WANT_VARARGS)\n"
                         . $ret
                         . "#${ind}endif\n";
                }

            }
            $ret = "#${ind}ifndef NO_MATHOMS\n$ret#${ind}endif\n"
                                                             if $flags =~ /b/;
        }
        $lines .= $ret;
    }
    # remove empty blocks
    1 while $lines =~ s/^#\s*if.*\n#\s*endif.*\n//mg
         or $lines =~ s/^(#\s*if)\s+(.*)\n#else.*\n/$1 !($2)\n/mg;
    if ($guard) {
        print $em "$guard /* guard */\n";
        $lines=~s/^#(\s*)/"#".(length($1)?"  ":" ").$1/mge;
    }
    print $em $lines;
    print $em "#endif\n" if $guard;
}

sub generate_embed_h {
    my ($all, $api, $ext, $core)= @_;

    my $em= open_buf_out(my $embed_buffer);

    print $em <<~'END';
    /* (Doing namespace management portably in C is really gross.) */

    /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
     * (like warn instead of Perl_warn) for the API are not defined.
     * Not defining the short forms is a good thing for cleaner embedding.
     * BEWARE that a bunch of macros don't have long names, so either must be
     * added or don't use them if you define this symbol */

    #ifndef PERL_NO_SHORT_NAMES

    /* Hide global symbols */

    END

    embed_h($em, '', $api);
    embed_h($em, '#if defined(PERL_CORE) || defined(PERL_EXT)', $ext);
    embed_h($em, '#if defined(PERL_CORE)', $core);

    print $em <<~'END';

    #endif      /* #ifndef PERL_NO_SHORT_NAMES */

    #if !defined(PERL_CORE)
    /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
     * disable them.
     */
    #  define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
    #  define sv_setptrref(rv,ptr)      sv_setref_iv(rv,NULL,PTR2IV(ptr))
    #endif

    #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)

    /* Compatibility for this renamed function. */
    #  define perl_atexit(a,b)          Perl_call_atexit(aTHX_ a,b)

    /* Compatibility for these functions that had a 'perl_' prefix before
     * 'Perl_' became the standard */
    END

    # These have been saved up for now
    print $em map { "$_\n" } sort keys %perl_compats;

    print $em <<~'END';

    /* Before C99, macros could not wrap varargs functions. This
       provides a set of compatibility functions that don't take an
       extra argument but grab the context pointer using the macro dTHX.
     */
    #if defined(MULTIPLICITY)           \
     && !defined(PERL_NO_SHORT_NAMES)   \
     && !defined(PERL_WANT_VARARGS)
    END

    foreach (@have_compatibility_macros) {
        print $em indent_define($_, "Perl_${_}_nocontext", "  ");
    }

    print $em <<~'END';
    #endif

    #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */

    #if !defined(MULTIPLICITY)
    /* undefined symbols, point them back at the usual ones */
    END

    foreach (@have_compatibility_macros) {
        print $em indent_define("Perl_${_}_nocontext", "Perl_$_", "  ");
    }

    print $em "#endif\n";
    close $em;

    normalize_and_print('embed.h',$embed_buffer)
        unless $error_count;
}

sub generate_embedvar_h {
    my $em = open_buf_out(my $embedvar_buffer);

    print $em "#if defined(MULTIPLICITY)\n",
              indent_define("vTHX","aTHX"," ");


    my @intrp = readvars 'intrpvar.h','I';
    #my @globvar = readvars 'perlvars.h','G';


    for my $sym (@intrp) {
        my $ind = " ";
        if ($sym eq 'sawampersand') {
            print $em "# if !defined(PL_sawampersand)\n";
            $ind = "   ";
        }
        my $line = multon($sym, 'I', 'vTHX->', $ind);
        print $em $line;
        if ($sym eq 'sawampersand') {
            print $em "# endif /* !defined(PL_sawampersand) */\n";
        }
    }

    print $em "#endif       /* MULTIPLICITY */\n";
    close $em;

    normalize_and_print('embedvar.h',$embedvar_buffer)
        unless $error_count;
}

sub update_headers {
    my ($all, $api, $ext, $core) = setup_embed(); # see regen/embed_lib.pl
    generate_proto_h($all);
    die_at_end "$unflagged_pointers pointer arguments to clean up\n"
                                                       if $unflagged_pointers;
    generate_embed_h($all, $api, $ext, $core);
    generate_embedvar_h();
    die "$error_count errors found" if $error_count;
}

update_headers() unless caller;

# ex: set ts=8 sts=4 sw=4 et:
