view release on metacpan or  search on metacpan

xs/gp_generate.pl  view on Meta::CPAN

my $out;
if ( @ARGV == 1 ) {
  # For safety sake, only allow output files
  # which end in '.xsh'.  This can be overriden
  # by redirecting STDOUT, for example from
  # the shell.
    my $xsh_file_name = $ARGV[0];
    if ( $xsh_file_name !~ /[.]xsh$/ ) {
        usage();
    }
    open $out, q{>}, $xsh_file_name;
} else {
   $out = *STDOUT;
}

my %format_by_type = (
   int => '%d',
   Marpa_Assertion_ID => '%d',
   Marpa_IRL_ID => '%d',
   Marpa_NSY_ID => '%d',
   Marpa_Or_Node_ID => '%d',
   Marpa_And_Node_ID => '%d',
   Marpa_Rank => '%d',
   Marpa_Rule_ID => '%d',
   Marpa_Symbol_ID => '%d',
   Marpa_Earley_Set_ID => '%d',
);

sub gp_generate {
    my ( $function, @arg_type_pairs ) = @_;
    my $output = q{};

    # For example, 'g_wrapper'
    my $wrapper_variable = $main::CLASS_LETTER . '_wrapper';

    # For example, 'G_Wrapper'
    my $wrapper_type = ( uc $main::CLASS_LETTER ) . '_Wrapper';

    # For example, 'g_wrapper'
    my $libmarpa_method =
          $function =~ m/^_marpa_/xms
        ? $function
        : 'marpa_' . $main::CLASS_LETTER . '_' . $function;

    # Just g_wrapper for the grammar, self->base otherwise
    my $base = $main::CLASS_LETTER eq 'g' ? 'g_wrapper' : "$wrapper_variable->base";

    $output .= "void\n";
    my @args = ();
    ARG: for ( my $i = 0; $i < $#arg_type_pairs; $i += 2 ) {
        push @args, $arg_type_pairs[ $i + 1 ];
    }
    $output
        .= "$function( " . ( join q{, }, $wrapper_variable, @args ) . " )\n";
    $output .= "    $wrapper_type *$wrapper_variable;\n";
    ARG: for ( my $i = 0; $i < $#arg_type_pairs; $i += 2 ) {
        $output .= q{    };
        $output .= join q{ }, @arg_type_pairs[ $i .. $i + 1 ];
        $output .= ";\n";
    }
    $output .= "PPCODE:\n";
    $output .= "{\n";
    $output
        .= "  $main::LIBMARPA_CLASS self = $wrapper_variable->$main::CLASS_LETTER;\n";
    $output .= "  int gp_result = $libmarpa_method("
        . ( join q{, }, 'self', @args ) . ");\n";
    $output .= "  if ( gp_result == -1 ) { XSRETURN_UNDEF; }\n";
    $output .= "  if ( gp_result < 0 && $base->throw ) {\n";
    my @format    = ();
    my @variables = ();
    ARG: for ( my $i = 0; $i < $#arg_type_pairs; $i += 2 ) {
        my $arg_type = $arg_type_pairs[$i];
        my $variable = $arg_type_pairs[ $i + 1 ];
        if ( my $format = $format_by_type{$arg_type} ) {
            push @format,    $format;
            push @variables, $variable;
            next ARG;
        }
        die "Unknown arg_type $arg_type";
    } ## end for ( my $i = 0; $i < $#arg_type_pairs; $i += 2 )
    my $format_string =
          q{"Problem in }
        . $main::CLASS_LETTER . q{->}
        . $function . '('
        . ( join q{, }, @format )
        . q{): %s"};
    my @format_args = @variables;
    push @format_args, qq{xs_g_error( $base )};
    $output .= "    croak( $format_string,\n";
    $output .= q{     } . (join q{, }, @format_args) . ");\n";
    $output .= "  }\n";
    $output .= q{  XPUSHs (sv_2mortal (newSViv (gp_result)));} . "\n";
    $output .= "}\n";
    return $output;
} ## end sub gp_generate

print ${out} <<'END_OF_PREAMBLE';
 # Copyright 2022 Jeffrey Kegler
 # This file is part of Marpa::R2.  Marpa::R2 is free software: you can
 # redistribute it and/or modify it under the terms of the GNU Lesser
 # General Public License as published by the Free Software Foundation,
 # either version 3 of the License, or (at your option) any later version.
 #
 # Marpa::R2 is distributed in the hope that it will be useful,
 # but WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 # Lesser General Public License for more details.
 #
 # You should have received a copy of the GNU Lesser
 # General Public License along with Marpa::R2.  If not, see
 # http://www.gnu.org/licenses/.

END_OF_PREAMBLE

print ${out} <<END_OF_PREAMBLE;
 # Generated automatically by $PROGRAM_NAME
 # NOTE: Changes made to this file will be lost: look at $PROGRAM_NAME.

END_OF_PREAMBLE

$main::CLASS_LETTER   = 'g';