package Parrot::Pmc2c;
use vars qw(@EXPORT_OK @writes %writes );

use base qw( Exporter );
@EXPORT_OK = qw(gen_c gen_h gen_ret dynext_load_code);

BEGIN {
    @writes = qw(STORE PUSH POP SHIFT UNSHIFT DELETE);
    @writes{@writes} = (1) x @writes;
};

sub does_write($$) {
    my ($meth, $section) = @_;
    exists $writes{$section} || $meth eq 'morph';
}

sub get_vtable_section() {
    my $self = shift;
    #  make a hash of all method names containing vtable section
    my $vt = $self->{vtable};
    foreach my $entry (@{ $vt->{methods} } ) {
	$self->{all}{$entry->{meth}} = $entry->{section};
    }
}

sub make_const() {
    my ($self, $class) = @_;
    my $const = bless {}, $class . '::Const';
    $self->{const} = $const;
    my @methods = @{ $self->{methods} };
    # copy super
    $const->{super} = { %{ $self->{super} } };
    my $i;
    foreach my $entry (@methods) {
	my $meth = $entry->{meth};
	if (does_write($meth, $self->{all}{$meth})) {
            # create methods if they write
            $const->{has_method}{$meth} = $i++;
	    push @{ $const->{methods} }, {
		meth => "$meth",
		type => $entry->{type},
		parameters => $entry->{parameters}
	    };
	}
        else {
            # if not - they are inherited from $self
            $const->{super}{$meth} = $self->{class};
        }
    }
    # copy parent(s), prepend self as parrent
    $const->{parents} = [ $self->{class}, @{ $self->{parents} } ];
    # copy flags, set is_const
    $const->{flags} = {is_const => 1, %{ $self->{flags} } };
    delete $const->{flags}{const_too};
    # set const in does
    $const->{flags}{does}{const} = 1;
    # set classname
    $const->{class} = "Const" . $self->{class};
    # and alias vtable
    $const->{vtable} = $self->{vtable};
    # set parentname
    $const->{parentname} = $self->{class};

}

sub init() {
    my ($self, $class) = @_;
    $self->get_vtable_section();
    $self->make_const($class) if $self->{flags}{const_too};

}

sub class_name {
    my ($self, $class) = @_;
    my %special = ( 'Ref' => 1, 'default' => 1 );
    my $classname = $self->{class};
    my $nclass = $class;
    # bless object into different classes inheriting from
    # Parrot::Pmc2c
    if ($special{$classname}) {
        $nclass .= "::" . $classname;
    }
    else {
        $nclass .= "::Standard";
    }
    $nclass;
}

sub new {
    my $this = shift;
    my $class = ref($this) || $this;
    my $self = shift;
    $self->{opt} = shift;
    $class = class_name($self, $class);
    bless $self, $class;
    $self->init($class);
    $self;
}

sub count_newlines {
    return scalar(() = $_[0] =~ /\n/g);
}

sub dont_edit() {
    my ($self, $pmcfile) = @_;
    return <<"EOC";
/*
 * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 *
 * This file is generated automatically from '$pmcfile'
 * by $0.
 *
 * Any changes made here will be lost!
 *
 */

EOC
}

sub decl() {
    my ($self, $classname, $method, $for_header) = @_;
    my $ret = $method->{type};
    my $meth= $method->{meth};
    my $args= $method->{parameters};
    $args = ", $args" if $args =~ /\S/;
    my ($extern, $newl, $semi, $interp, $pmc);
    if ($for_header) {
	$extern = "extern ";
	$newl = " ";
	$semi = ";";
        $interp = $pmc = "";
    }
    else {
	$extern = "";
	$newl = "\n";
	$semi = "";
        $interp = ' interpreter';
        $pmc = ' pmc';
    }
    return <<"EOC";
$extern$ret${newl}Parrot_${classname}_$meth(Parrot_Interp$interp, PMC*$pmc$args)$semi
EOC
}

sub includes() {
    my $self = shift;
    my $cout = "";
    foreach my $parents ($self->{class}, @{ $self->{parents} } ) {
	my $name = lc $parents;
	$cout .= <<"EOC";
#include "pmc_$name.h"
EOC
    }
    "$cout\n";
}


sub full_arguments {
    my $args = shift;
    if ($args =~ /\S/) {
        return "INTERP, SELF, $args";
    } else {
        return "INTERP, SELF";
    }
}

sub rewrite_method ($$$$$) {
    my ($class, $method, $super, $super_table) = @_;
    local $_ = $_[4];

    # Rewrite method body
    my $supertype = "enum_class_$super";
    die "$class defines unknown vtable method '$method'\n"
      if ! defined $super_table->{$method};
    my $supermethod = "Parrot_" . $super_table->{$method} . "_$method";

    # Rewrite DYNSUPER(args...)
    s/DYNSUPER\(\s*(.*?)\)/"Parrot_base_vtables[$supertype].$method(".full_arguments($1).")"/eg;

    # Rewrite OtherClass.SUPER(args...)
    s/(\w+)\.SUPER\(\s*(.*?)\)/"Parrot_${1}_$method(".full_arguments($2).")"/eg;

    # Rewrite SUPER(args...)
    s/SUPER\(\s*(.*?)\)/"$supermethod(".full_arguments($1).")"/eg;

    # Rewrite DYNSELF.other_method(args...)
    s/DYNSELF\.(\w+)\(\s*(.*?)\)/"pmc->vtable->$1(".full_arguments($2).")"/eg;

    # Rewrite DYNSELF(args...). See comments above.
    s/DYNSELF\(\s*(.*?)\)/"pmc->vtable->$method(".full_arguments($1).")"/eg;

    # Rewrite OtherClass.SELF.other_method(args...)
    s/(\w+)\.SELF\.(\w+)\(\s*(.*?)\)/"Parrot_${1}_$2(".full_arguments($3).")"/eg;

    # Rewrite SELF.other_method(args...)
    s/SELF\.(\w+)\(\s*(.*?)\)/"Parrot_${class}_$1(".full_arguments($2).")"/eg;

    # Rewrite SELF -> pmc, INTERP -> interpreter
    s/SELF/pmc/g;
    s/INTERP/interpreter/g;

    # now use macros for all rewritten stuff
    s/\b(?:\w+)->vtable->(\w+)\(/ VTABLE_$1(/g;

    return $_;
}

sub body
{
    my ($self, $method) = @_;
    my $cout = "";
    my $classname = $self->{class};
    my $pmc = lc($classname) .'.pmc';
    my $meth = $method->{meth};
    unless ($self->{opt}{nolines}) {
        $cout .= <<"EOC";
#line $method->{line} "$pmc"
EOC
    }
    $cout .= $self->decl($classname, $method, 0);
    my $body = $method->{body};
    $body =~ s/^\t/        /mg;
    $body =~ s/^[ ]{4}//mg;
    my $super = $self->{super}{$meth};
    $cout .= rewrite_method($classname, $meth, $super, $self->{super},
    $body);
    $cout .= "\n\n";
}


sub methods() {
    my ($self, $line) = @_;
    my $cout = "";

    foreach my $method (@{ $self->{vtable}{methods}} ) {
        my $meth = $method->{meth};
        next if $meth eq 'class_init';
        if ($self->implements($meth)) {
            my $ret = $self->body($method, $line);
            $line += count_newlines($ret);
            $cout .= $ret;
        }
    }
    $cout;
}

# util
sub dynext_load_code {
    my ($classname, $call_class_init ) = @_;
    my $lc_classname = lc $classname;
    return <<"EOC";
/*
 * This load function will be called to do global (once) setup
 * whatever is needed to get this extension running
 */
#include "parrot/dynext.h"

PMC* Parrot_lib_${lc_classname}_load(Interp *interpreter)
{
    STRING *whoami;
    PMC *pmc;
    INTVAL type;

    /*
     * create a library PMC
     */
    pmc = pmc_new(interpreter, enum_class_ConstParrotLibrary);
    /*
     * TODO stuff some info into this PMCs props
     */

    /*
     * for all PMCs we want to register:
     */
    whoami = string_from_cstring(interpreter, "$classname", 0);
    type = pmc_register(interpreter, whoami);
    /* do class_init code */
    $call_class_init

    return pmc;
}

EOC
}

sub lib_load_code() {
    my $self = shift;
    my $classname = $self->{class};
    # TODO multiple (e.g. Const subclasses)
    my $call_class_init =
        "Parrot_${classname}_class_init(interpreter, type);\n";
    return dynext_load_code($classname, $call_class_init);
}

sub init_func() {
    my $self = shift;
    my $cout = "";
    return "" if exists $self->{flags}{noinit};

    # TODO gen C line comment
    my $classname = $self->{class};
    my $vtbl_flag =  $self->{flags}{const_too} ?
        'VTABLE_HAS_CONST_TOO' : $self->{flags}{is_const} ?
	  'VTABLE_IS_CONST_FLAG' : 0;
    if (exists $self->{flags}{need_ext}) {
        $vtbl_flag .= '|VTABLE_PMC_NEEDS_EXT';
    }
    my @meths;
    foreach my $method (@{ $self->{vtable}{methods}} ) {
        my $meth = $method->{meth};
        if ($self->implements($meth)) {
            push @meths, "Parrot_${classname}_$meth";
        }
        elsif (exists $self->{super}{$meth}) {
            my $class = $self->{super}{$meth};
            push @meths, "Parrot_${class}_$meth";
        }
        else {
            push @meths, "Parrot_default_$meth";
        }
    }
    my $methlist = join(",\n        ", @meths);
    my $isa = join(" ", $classname, @{ $self->{parents} });
    $isa =~ s/\s?default$//;
    my $does = join(" ", keys(%{ $self->{flags}{does} }));
    my $n = exists $self->{has_method}{class_init} ?
                   $self->{has_method}{class_init} : -1;
    my $class_init_code = $n >= 0 ? $self->{methods}[$n]{body} : "";
    $class_init_code =~ s/INTERP/interp/g;
    $cout .= <<"EOC";
void
Parrot_${classname}_class_init(Parrot_Interp interp, int entry)
{
    struct _vtable temp_base_vtable = {
        NULL,	/* package */
        enum_class_$classname,	/* base_type */
        NULL,	/* whoami */
        NULL,	/* method_table */
        $vtbl_flag, /* flags */
        NULL,   /* does_str */
        NULL,   /* isa_str */
        NULL, /* extra data */
        $methlist
EOC
    $cout .= <<"EOC";
    };

    /*
     * parrotio calls some class_init functions during its class_init
     * code, so some of the slots might already be allocated
     */
    if (!Parrot_base_vtables[entry]) {
	temp_base_vtable.whoami = string_make(interp,
	    "$classname", @{[length($classname)]}, 0,
            PObj_constant_FLAG|PObj_external_FLAG , 0);
	temp_base_vtable.isa_str = string_make(interp,
	    "$isa", @{[length($isa)]}, 0,
            PObj_constant_FLAG|PObj_external_FLAG , 0);
	temp_base_vtable.does_str = string_make(interp,
	    "$does", @{[length($does)]}, 0,
            PObj_constant_FLAG|PObj_external_FLAG , 0);

	Parrot_base_vtables[entry] =
	    Parrot_clone_vtable(interp, &temp_base_vtable);
    }
    $class_init_code
} /* Parrot_${classname}_class_init */
EOC
    if ($self->{flags}{dynpmc}) {
        $cout .= $self->lib_load_code();
    }
    $cout;
}

sub gen_c() {
    my ($self, $file) = @_;
    my $cout = $self->dont_edit($file);
    $cout .= $self->{pre};
    $cout .= $self->includes;
    my $l = count_newlines($cout);
    $cout .= $self->methods($l);
    $cout .= $self->init_func;
    if ($self->{const}) {
        $cout .= $self->{const}->methods($l);
        $cout .= $self->{const}->init_func;
    }
    $cout .= $self->{post};
    $cout;
}

sub hdecls() {
    my $self = shift;
    my $hout;
    my $classname = $self->{class};
    # generat decls for all methods in this file
    foreach my $meth (@{ $self->{vtable}{methods} } ) {
        if ($self->implements($meth->{meth})) {
            $hout .= $self->decl($classname, $meth, 1);
        }
    }
    # class init decl
    $hout .= <<"EOC";
void Parrot_${classname}_class_init(Parrot_Interp, int);
EOC
    $hout;
}

sub gen_h() {
    my ($self, $file) = @_;
    my $hout = $self->dont_edit($file);
    my $name = uc $self->{class};
    $hout .= <<"EOH";

#ifndef PARROT_PMC_${name}_H_GUARD
#define PARROT_PMC_${name}_H_GUARD

EOH

    $hout .= $self->hdecls();
    if ($self->{const}) {
        $self = $self->{const};
        $hout .= "\n/* Const */\n";
        $hout .= $self->hdecls();
    }
    $hout .= <<"EOH";

#endif

EOH
    $hout;
}

# true if this class generates code for $meth
sub implements
{
    my ($self, $meth) = @_;
    return exists $self->{has_method}{$meth};
}

# generate a return statement, if body is empty make a cast if needed
sub gen_ret {
    my ($method, $body) = @_;
    my $ret;
    if ($body) {
        $ret = $method->{type} eq 'void' ? "$body;" : "return $body;" ;
    }
    else {
        $ret = $method->{type} eq 'void' ? "" : "return ($method->{type})0;";
    }
    $ret;
}

# standard behavior
package Parrot::Pmc2c::Standard;
use base 'Parrot::Pmc2c';
sub body
{
    my ($self, $method) = @_;
    my $meth = $method->{meth};
    my $n = $self->{has_method}{$meth};
    return $self->SUPER::body($self->{methods}[$n]);
}

# through exception if meth writes
package Parrot::Pmc2c::Standard::Const;
use base 'Parrot::Pmc2c::Standard';
import Parrot::Pmc2c qw( gen_ret );

sub body {
    my ($self, $method) = @_;
    my $meth = $method->{meth};

    my $decl = $self->decl($self->{class}, $method, 0);
    my $classname = $self->{class};
    my $parentname = $self->{parentname};
    my $ret = gen_ret($method);
    my $cout = <<"EOC";
$decl {
EOC
    if ($meth eq 'morph') {
        $cout .= <<EOC;
    if (Parrot_is_const_pmc(interpreter, pmc))
	internal_exception(WRITE_TO_CONSTCLASS,
		"$meth() in $classname");
    else
        Parrot_${parentname}_$meth(interpreter, pmc, type);
EOC
    }
    else {
        $cout .= <<EOC;
	internal_exception(WRITE_TO_CONSTCLASS,
		"$meth() in $classname");
        $ret
EOC
    }
    $cout .= <<"EOC";
}

EOC
    $cout;
}


# Ref directs all unknow methods to the referee
package Parrot::Pmc2c::Ref;
use base 'Parrot::Pmc2c';
import Parrot::Pmc2c qw( gen_ret );

sub implements
{
    1;
}

sub body
{
    my ($self, $method, $line) = @_;
    my $meth = $method->{meth};
    # existing methods get emitted
    if ($self->SUPER::implements($meth)) {
        my $n = $self->{has_method}{$meth};
        return $self->SUPER::body($self->{methods}[$n]);
    }
    my $parameters = $method->{parameters};
    my $n=0;
    my @args = grep {$n++ & 1 ? $_ : 0} split / /, $parameters;
    my $arg = '';
    $arg = ", ". join(' ', @args) if @args;
    $parameters = ", $parameters" if $parameters;
    my $body = "VTABLE_$meth(interpreter, PMC_ptr2p(pmc)$arg)";
    my $ret = gen_ret($method, $body);
    my $decl = $self->decl($self->{class}, $method, 0);
    my $l = "";
    unless ($self->{opt}{nolines}) {
        $l = <<"EOC";
#line $line "ref.c"
EOC
    }
    return <<EOC;
$l
$decl {
    $ret
}

EOC
}

# default throws an execption for unknown meths
package Parrot::Pmc2c::default;
use base 'Parrot::Pmc2c';
import Parrot::Pmc2c qw( gen_ret );

sub implements
{
    1;
}

sub body
{
    my ($self, $method, $line) = @_;
    my $meth = $method->{meth};
    # existing methods get emitted
    if ($self->SUPER::implements($meth)) {
        my $n = $self->{has_method}{$meth};
        return $self->SUPER::body($self->{methods}[$n]);
    }
    my $decl = $self->decl($self->{class}, $method, 0);
    my $l = "";
    my $ret = gen_ret($method);
    unless ($self->{opt}{nolines}) {
        $l = <<"EOC";
#line $line "default.c"
EOC
    }
    return <<EOC;
$l
${decl} {
	internal_exception(ILL_INHERIT,
		"$meth() not implemented in class '%s'",
		caller(interpreter, pmc));
        $ret
}

EOC
}

# vim: expandtab shiftwidth=4:
1;
