# Copyright (C) 2004-2012, Parrot Foundation.

package Parrot::Pmc2c::PCCMETHOD;
use strict;
use warnings;
use Carp qw(longmess croak);
use Parrot::Pmc2c::PCCMETHOD_BITS;
use Parrot::Pmc2c::UtilFunctions qw( trim );

=head1 NAME

Parrot::Pmc2c::PCCMETHOD - Parses and preps PMC PCCMETHOD called from F<Parrot:Pmc2c::Pmc2cMain>

=head1 SYNOPSIS

    use Parrot::Pmc2c::PCCMETHOD;

=head1 DESCRIPTION

Parrot::Pmc2c::PCCMETHOD - Parses and preps PMC PCCMETHOD called from F<Parrot:Pmc2c::Pmc2cMain>

=cut

=head1 FUNCTIONS

=head2 Publicly Available Methods

=head3 C<rewrite_pccmethod($method, $pmc)>

B<Purpose:>  Parse and Build PMC PCCMETHODS.

B<Arguments:>

=over 4

=item * C<self>

=item * C<method>

Current Method Object

=item * C<body>

Current Method Body

=back

=head3 C<rewrite_pccinvoke($method, $pmc)>

B<Purpose:>  Parse and Build a PCCINVOKE Call.

B<Arguments:>

=over 4

=item * C<self>

=item * C<method>

Current Method Object

=item * C<body>

Current Method Body

=back

=cut

use constant REGNO_INT => 0;
use constant REGNO_NUM => 1;
use constant REGNO_STR => 2;
use constant REGNO_PMC => 3;

=head3
    regtype to argtype conversion hash
=cut

our $reg_type_info = {

    # s is string, ss is short string, at is arg type
    +(REGNO_INT) => { s   => "INTVAL",
                      ss  => "INT",
                      pcc => 'I',
                      at  => PARROT_ARG_INTVAL},
    +(REGNO_NUM) => { s   => "FLOATVAL",
                      ss  => "NUM",
                      pcc => "N",
                      at  => PARROT_ARG_FLOATVAL, },
    +(REGNO_STR) => { s => "STRING*",
                      ss => "STR",
                      pcc => "S",
                      at => PARROT_ARG_STRING, },
    +(REGNO_PMC) => { s => "PMC*",
                      ss => "PMC",
                      pcc => "P",
                      at => PARROT_ARG_PMC, },
};

=head3 C<parse_adverb_attributes>

  builds and returs an adverb hash from an adverb string such as
  ":optional :opt_flag :slurpy"
  {
    optional  =>1,
    opt_flag  =>1,
    slurpy    =>1,
  }

=cut

sub parse_adverb_attributes {
    my $adverb_string = shift;
    my %result;
    if ( defined $adverb_string ) {
        ++$result{$1} while $adverb_string =~ /:(\S+)/g;
    }
    return \%result;
}

sub convert_type_string_to_reg_type {
    local ($_) = @_;
    return REGNO_INT if /INTVAL|int/i;
    return REGNO_NUM if /FLOATVAL|double/i;
    return REGNO_STR if /STRING/i;
    return REGNO_PMC if /PMC/i;
    croak "$_ not recognized as INTVAL, FLOATVAL, STRING, or PMC";
}

sub gen_arg_pcc_sig {
    my ($param) = @_;

    return 'Ip'
        if exists $param->{attrs}{opt_flag};

    my $sig = $reg_type_info->{ $param->{type} }->{pcc};
    $sig   .= 'c' if  exists $param->{attrs}{constant};
    $sig   .= 'f' if  exists $param->{attrs}{flatten};
    $sig   .= 'i' if  exists $param->{attrs}{invocant};
    $sig   .= 'l' if  exists $param->{attrs}{lookahead};
    $sig   .= 'n' if (exists $param->{attrs}{name} ||
                      exists $param->{attrs}{named});
    $sig   .= 'o' if  exists $param->{attrs}{optional};
    $sig   .= 'p' if  exists $param->{attrs}{opt_flag};
    $sig   .= 's' if  exists $param->{attrs}{slurpy};

    return $sig;
}

=head3 C<rewrite_RETURNs($method, $pmc)>

Rewrites the method body performing the various macro substitutions for RETURNs.

=cut

sub rewrite_RETURNs {
    my ( $method, $pmc ) = @_;
    my $method_name    = $method->name;
    my $body           = $method->body;
    my $wb             = $method->attrs->{manual_wb}
                         ? ''
                         : 'PARROT_GC_WRITE_BARRIER(interp, _self);';

    my $signature_re   = qr/
      (RETURN       #method name
      \s*              #optional whitespace
      \( ([^\(]*) \)   #returns ( stuff ... )
      ;?)              #optional semicolon
    /sx;

    croak "return not allowed in pccmethods, use RETURN instead $body"
        if $body and $body =~ m/\breturn\b.*?;\z/s;

    while ($body) {
        my $matched;

        if ($body) {
            $matched = $body->find($signature_re);
            last unless $matched;
        }

        $matched =~ /$signature_re/;
        my ( $match, $returns ) = ( $1, $2 );

        my $e = Parrot::Pmc2c::Emitter->new( $pmc->filename );

        if ($returns eq 'void') {
            $e->emit( <<"END", __FILE__, __LINE__ + 1 );
    {
    /*BEGIN RETURN $returns */
    $wb
    return;
    /*END RETURN $returns */
    }
END
            $matched->replace( $match, $e );
            next;
        }

        my $goto_string = "goto ${method_name}_returns;";
        my ( $returns_signature, $returns_varargs ) =
            process_pccmethod_args( parse_p_args_string($returns), 'return' );

        if ($returns_signature) {
        $e->emit( <<"END", __FILE__, __LINE__ + 1 );
    {
    /*BEGIN RETURN $returns */
END
        $e->emit( <<"END", __FILE__, __LINE__ + 1 );
    Parrot_pcc_set_call_from_c_args(interp, _call_object,
        "$returns_signature", $returns_varargs);
    $wb
    return;
    /*END RETURN $returns */
    }
END
        }
        else { # if ($returns_signature)
            $e->emit( <<"END", __FILE__, __LINE__ + 1 );
    {
    /*BEGIN RETURN $returns */
    $wb
    return;
    }
    /*END RETURN $returns */
END
        }

        $matched->replace( $match, $e );
    }

}

sub parse_p_args_string {
    my ($parameters) = @_;
    my $linear_args  = [];

    for my $x ( split /,/, $parameters ) {

        #change 'PMC * foo' to 'PMC *foo'
        $x =~ s/\*\s+/\*/ if ($x =~ /\s\*+\s/);

        #change 'PMC* foo' to 'PMC *foo'
        $x =~ s/(\*+)\s+/ $1/ if ($x =~ /^\w+\*/);

        my ( $type, $name, $rest ) = split /\s+/, trim($x), 3;

        die "invalid PCC arg '$x': did you forget to specify a type?\n"
            unless defined $name;

        if ($name =~ /\**([a-zA-Z_]\w*)/) {
            $name = $1;
        }

        my $arg = {
            type  => convert_type_string_to_reg_type($type),
            name  => $name,
            attrs => parse_adverb_attributes($rest)
        };

        push @$linear_args, $arg;
    }

    $linear_args;
}

sub is_named {
    my ($arg) = @_;

    while ( my ( $k, $v ) = each( %{ $arg->{attrs} } ) ) {
        return ( 1, $1 ) if $k =~ /named\((.*)\)/;
    }

    return ( 0, '' );
}

sub process_pccmethod_args {
    my ( $linear_args, $arg_type ) = @_;

    my $args           = [ [], [], [], [] ]; # actual INT, FLOAT, STRING, PMC
    my $signature    = "";
    my @vararg_list = ();
    my $varargs    = "";
    my $declarations    = "";

    for my $arg (@$linear_args) {
        my ( $named, $named_name ) = is_named($arg);
        my $type = $arg->{type};
        my $name = $arg->{name};
        if ($named) {
            my $tis  = $reg_type_info->{+(REGNO_STR)}{s};     #reg_type_info string
            my $dummy_name = "_param_name_str_". $named_name;
            $dummy_name =~ s/"//g;
            my $argn = {
                type => +(REGNO_STR),
                name => $named_name,
            };
            $arg->{named_arg}  = $argn;
            $arg->{named_name} = $named_name;

            push @{ $args->[ +(REGNO_STR) ] }, $argn;
            $signature .= 'Sn';
            $declarations .= "$tis $dummy_name = CONST_STRING_GEN(interp, $named_name);\n";
            push @vararg_list, "&$dummy_name";
        }

        push @{ $args->[ $type ] }, $arg;
        $signature .= gen_arg_pcc_sig($arg);
        if ( $arg_type eq 'arg' ) {
            my $tis  = $reg_type_info->{$type}{"s"};     #reg_type_info string
            $declarations .= "$tis $name;\n" unless $arg->{already_declared};
            push @vararg_list, "&$name"
        }
        elsif ( $arg_type eq 'return' ) {
            my $typenamestr = $reg_type_info->{$type}{s};
            push @vararg_list, "($typenamestr)$name";
        }
    }

    $varargs = join ", ", @vararg_list;
    return ( $signature, $varargs, $declarations );
}

=head3 C<rewrite_pccmethod()>

    rewrite_pccmethod($method, $pmc);

=cut

sub rewrite_pccmethod {
    my ( $method, $pmc ) = @_;

    my $e      = Parrot::Pmc2c::Emitter->new( $pmc->filename );
    my $e_post = Parrot::Pmc2c::Emitter->new( $pmc->filename );

    # parse pccmethod parameters, then unshift the PMC arg for the invocant
    my $linear_args = parse_p_args_string( $method->parameters );
    unshift @$linear_args,
        {
            type             => convert_type_string_to_reg_type('PMC'),
            name             => '_self',
            attrs            => parse_adverb_attributes(':invocant'),
            already_declared => 1,
        };

 # The invocant is already passed in the C signature, why pass it again?

    my ( $params_signature, $params_varargs, $params_declarations ) =
        process_pccmethod_args( $linear_args, 'arg' );

    my $wb             = $method->attrs->{manual_wb}
                         ? ''
                         : 'PARROT_GC_WRITE_BARRIER(interp, _self);';

    rewrite_RETURNs( $method, $pmc );
    rewrite_pccinvoke( $method, $pmc );

    $e->emit( <<"END", __FILE__, __LINE__ + 1 );
    PMC * const _ctx         = CURRENT_CONTEXT(interp);
    PMC * const _call_object = Parrot_pcc_get_signature(interp, _ctx);

    { /* BEGIN PARMS SCOPE */
END
    $e->emit(<<"END");
$params_declarations
END
    if ($params_signature) {
        $e->emit( <<"END", __FILE__, __LINE__ + 1 );
        Parrot_pcc_fill_params_from_c_args(interp, _call_object, "$params_signature",
            $params_varargs);
END
    }
    $e->emit( <<'END', __FILE__, __LINE__ + 1 );
    { /* BEGIN PMETHOD BODY */
END

    $e_post->emit( <<"END", __FILE__, __LINE__ + 1 );

    } /* END PMETHOD BODY */

    $wb

    } /* END PARAMS SCOPE */
    return;
END
    $method->return_type('void');
    $method->parameters('');
    my $e_body = Parrot::Pmc2c::Emitter->new( $pmc->filename );
    $e_body->emit($e);
    $e_body->emit( $method->body );
    $e_body->emit($e_post);
    $method->body($e_body);
    $method->{PCCMETHOD} = 1;

    return 1;
}

sub rewrite_pccinvoke {
    my ( $method, $pmc ) = @_;
    my $body             = $method->body;

    my $signature_re     = qr{
      (
      (
      \( ([^\(]*) \)   # results
      \s*              # optional whitespace
      =                # results equals PCCINVOKE invocation
      \s*              # optional whitespace
      )?               # results are optional
      \b               # exclude Parrot_pcc_invoke_method_from_c_args when lacking optional capture
      PCCINVOKE        # method name
      \s*              # optional whitespace
      \( ([^\(]*) \)   # parameters
      ;?               # optional semicolon
      )
    }sx;

    while ($body) {
        my $matched;

        if ($body) {
            $matched = $body->find($signature_re);
            last unless $matched;
        }

        $matched =~ /$signature_re/;
        my ( $match, $result_clause, $results, $parameters ) = ( $1, $2, $3, $4 );

        my ($out_vars, $out_types)
            = process_pccmethod_results( $results );

        my ($fixed_params, $in_types, $in_vars)
            = process_pccmethod_parameters( $parameters );

        my $signature = $in_types . '->' . $out_types;

        # I know this is ugly....
        my $vars      = '';
        if ($in_vars) {
            $vars .= $in_vars;
            $vars .= ', ' if $out_vars;
        }
        $vars .= $out_vars;

        my $e = Parrot::Pmc2c::Emitter->new( $pmc->filename );
        $e->emit(qq|Parrot_pcc_invoke_method_from_c_args($fixed_params, "$signature", $vars);\n|);

        $matched->replace( $match, $e );
    }

    return 1;
}

sub process_pccmethod_results {
    my $results = shift;

    return ('', '') unless $results;

    my @params  = split /,\s*/, $results;

    my (@out_vars, @out_types);

    for my $param (@params) {
        my ($type, @names) = process_parameter($param);
        push @out_types, $type;
        push @out_vars, map { "&$_" } @names;
    }

    my $out_types = join '',   @out_types;
    my $out_vars  = join ', ', @out_vars;

    return ($out_vars, $out_types);
}

sub process_pccmethod_parameters {
    my $parameters                       = shift;
    my ($interp, $pmc, $method, @params) = split /,\s*/, $parameters;

    $method = 'CONST_STRING_GEN(interp, ' . $method . ')';

    my $fixed_params = join ', ', $interp, $pmc, $method;

    my (@in_types, @in_vars);

    for my $param (@params) {
        # @var is an array because named parameters are two variables
        my ($type, @var) = process_parameter($param);
        push @in_types, $type;
        push @in_vars, @var;
    }

    my $in_types = join '',   @in_types;
    my $in_vars  = join ', ', @in_vars;

    return ($fixed_params, $in_types, $in_vars);
}

sub process_parameter {
    my $param    = shift;

    my $param_re = qr{
        (STRING\s\*|INTVAL|FLOATVAL|PMC\s\*) # type
        \s*                                  # optional whitespace
        (\w+)                                # name
        \s*                                  # optional whitespace
        (.*)?                                # adverbs
    }sx;

    my ($type, $name, $adverbs) = $param =~ /$param_re/;

    # the first letter of the type is the type in the signature
    $type = substr $type, 0, 1;

    my $adverb_re = qr{
        :        # leading colon
        (\w+)    # name
        (?:      # optional argument
            \("
            (\w+)
            "\)
        )
        \s*
    }sx;

    my %allowed_adverbs = (
        named      => 'n',
        flatten    => 'f',
        slurpy     => 's',
        optional   => 'o',
        opt_flag   => 'p',
    );

    my @arg_names = ($name);

    while (my ($name, $argument) = $adverbs =~ /$adverb_re/g) {
        next unless my $type_mod = $allowed_adverbs{$name};

        $type .= $type_mod;

        next unless $type eq 'named';
        push @arg_names, qq|CONST_STRING_GEN(interp, "$argument")|;
    }

    return ($type, @arg_names);
}

=head3 C<rewrite_multi_sub($method, $pmc)>

B<Purpose:>  Parse and Build PMC multiple dispatch subs.

B<Arguments:>

=over 4

=item * C<self>

=item * C<method>

Current Method Object

=item * C<body>

Current Method Body

=back

=cut

sub rewrite_multi_sub {
    my ( $method, $pmc ) = @_;
    my @param_types = ();
    my @new_params = ();

    # Fixup the parameters, standardizing PMC types and extracting type names
    # for the multi name.
    for my $param ( split /,/, $method->parameters ) {
        my ( $type, $name, $rest ) = split /\s+/, &Parrot::Pmc2c::PCCMETHOD::trim($param), 3;

        die "Invalid MULTI parameter '$param': missing type or name\n"
             unless defined $name;
        die "Invalid MULTI parameter '$param': attributes not allowed on multis\n"
             if defined $rest;

        # Clean any '*' out of the name or type.
        if ($name =~ /[\**]?(\"?\w+\"?)/) {
            $name = $1;
        }
        $type =~ s/\*+//;

        # Capture the actual type for the sub name
        push @param_types, $type;

        # Pass standard parameter types unmodified.
        # All other param types are rewritten as PMCs.
        if ($type eq 'STRING' or $type eq 'PMC' or $type eq 'INTVAL') {
            push @new_params, $param;
        }
        elsif ($type eq 'FLOATVAL') {
            push @new_params, $param;
        }
        else {
            push @new_params, "PMC *$name";
        }
    }

    $method->parameters(join (",", @new_params));

    $method->{MULTI_sig}      = [@param_types];
    $method->{MULTI_full_sig} = join(',', @param_types);
    $method->{MULTI}          = 1;

    return 1;
}

sub mangle_name {
    my ( $method ) = @_;
    $method->symbol( $method->name );
    $method->name( $method->type eq Parrot::Pmc2c::Method::MULTI()
        ?  (join '_', 'multi', $method->name, @{ $method->{MULTI_sig} })
        : "nci_@{[$method->name]}" );
}

1;

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
