#
# Sub.pm
#
# Copyright (C) 2002-2005, The Perl Foundation.
# This program is free software. It is subject to the same license
# as the Parrot interpreter.
#
# $Id: Sub.pm 16255 2006-12-25 22:20:28Z paultcochrane $
#

use strict;
use warnings;

package Jako::Construct::Block::Sub;

use Carp;

use base qw(Jako::Construct::Block);

sub kind { return 'sub'; }

sub new {
    my $class = shift;

    confess "Expected 5 args!" unless @_ == 5;
    my ( $block, $type, $ident, $props, $args ) = @_;

    confess "Block is not!" unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
    confess "Type is not!"
        if defined $type and not UNIVERSAL::isa( $type, 'Jako::Construct::Type' );
    confess "Ident is not!"
        unless UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
    confess "Props are not hash!" if defined $props and ref($props) ne "HASH";
    confess "Args are not hash!"  if defined $args  and ref($args)  ne "ARRAY";

    my $self = bless {
        BLOCK => $block,

        TYPE  => $type,
        NAME  => $ident->value,
        PROPS => $props,
        ARGS  => $args,

        DEBUG => 1,
        FILE  => $ident->file,
        LINE  => $ident->line
    }, $class;

    $block->push_content($self);

    foreach my $arg (@$args) {
        my ( $arg_type, $arg_name, $arg_token ) = @$arg;
        my $sym =
            Jako::Symbol->new( $self, 'local', 'arg', $arg_type, $arg_name, undef, undef, undef,
            $arg_token->file, $arg_token->line );
        $self->set_symbol( $arg_name, $sym );
    }

    return $self;
}

#
# ACCESSORS:
#

sub type  { return shift->{TYPE}; }
sub name  { return shift->{NAME}; }
sub props { return %{ shift->{PROPS} }; }
sub args  { return @{ shift->{ARGS} }; }

#
# compile()
#

sub compile {
    my $self = shift;
    my ($compiler) = @_;

    my $type  = $self->type;
    my $name  = $self->name;
    my %props = $self->props;
    my @args  = $self->args;

    my $subname = $name;

    $subname =~ s/::/__/g;

    $compiler->emit(".sub _${subname}");

    foreach my $arg (@args) {
        my ( $arg_type, $arg_name ) = @$arg;
        my $imcc_type = $arg_type->imcc;

        $compiler->emit("  .param $imcc_type $arg_name");
    }

    $compiler->indent;
    $self->SUPER::compile($compiler);
    $compiler->outdent;

    $compiler->emit("_${name}_LEAVE:");
    $compiler->emit("  .return()")
        ;    # Fallthrough return() in case the code in the sub doesn't return anything
    $compiler->emit(".end");

    return 1;
}

#
# sax()
#

sub sax {
    my $self = shift;
    my ($handler) = @_;

    my $type = $self->type;
    my $name = $self->name;
    my @args = $self->args;

    if ($type) {
        $handler->start_element(
            { Name => 'sub', Attributes => { name => $name, type => $type } } );
    }
    else {
        $handler->start_element( { Name => 'sub', Attributes => { name => $name } } );
    }

    foreach my $arg (@args) {
        my ( $arg_type, $arg_name ) = @$arg;

        $handler->start_element(
            { Name => 'arg', Attributes => { name => $arg_name, type => $arg_type } } );
        $handler->end_element( { Name => 'arg' } );
    }

    foreach my $content ( $self->content ) {
        $content->sax($handler);
    }

    $handler->end_element( { Name => 'sub' } );
}

1;


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