languages/jako/lib/Jako/Construct/Statement/Call.pm

   1 #
   2 # Call.pm
   3 #
   4 # Copyright (C) 2002-2005, The Perl Foundation.
   5 # This program is free software. It is subject to the same license
   6 # as the Parrot interpreter.
   7 #
   8 # $Id$
   9 #
  10
  11 use strict;
  12 use warnings;
  13
  14 package Jako::Construct::Statement::Call;
  15
  16 use Carp;
  17
  18 use base qw(Jako::Construct::Statement);
  19
  20 sub new {
  21     my $class = shift;
  22     my ( $block, $ident, @args ) = @_;
  23
  24     confess( "Block (" . ref($block) . ") is not!" )
  25         unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
  26     confess( "Ident (" . ref($ident) . ") is not!" )
  27         unless UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
  28
  29     my $name = $ident->value;
  30
  31     my $self = bless {
  32         BLOCK => $block,
  33
  34         NAME => $name,
  35         ARGS => [@args],
  36
  37         DEBUG => 1,
  38         LINE  => $ident->line,
  39         FILE  => $ident->file
  40     }, $class;
  41
  42     $block->push_content($self);
  43
  44     return $self;
  45 }
  46
  47 sub name { return shift->{NAME}; }
  48 sub args { return @{ shift->{ARGS} }; }
  49
  50 #
  51 # compile()
  52 #
  53
  54 sub compile {
  55     my $self = shift;
  56     my ($compiler) = @_;
  57
  58     my $name = $self->name;
  59
  60     #  $self->DEBUG(0, "Searching for symbol '$name'...");
  61
  62     my $sym = $self->block->find_symbol($name);
  63
  64     $self->SYNTAX_ERROR( "Call to unknown sub '%s'.", $name ) unless $sym;
  65
  66     my %props = $sym->props;
  67
  68     my @args = $self->args;
  69
  70     my @formal_args = $sym->args;
  71
  72     $self->SYNTAX_ERROR( "Wrong number of arguments (expected %d, got %d) in call to '%s'.",
  73         scalar(@formal_args), scalar(@args), $name )
  74         unless @formal_args == @args;
  75
  76     for ( my $i = 0 ; $i < @args ; $i++ ) {
  77         my ( $formal_arg_type, $formal_arg_name ) = @{ $formal_args[$i] };
  78         my $actual_arg_type;
  79
  80         if ( UNIVERSAL::isa( $args[$i], 'Jako::Construct::Expression::Value::Identifier' ) ) {
  81             my $arg_sym = $self->block->find_symbol( $args[$i]->value );
  82             $self->SYNTAX_ERROR( "Undefined identifier '%s'.", $args[$i]->value ) unless $arg_sym;
  83             $actual_arg_type = $arg_sym->type;
  84         }
  85         else {
  86             $actual_arg_type = $args[$i]->type;
  87         }
  88
  89         $self->INTERNAL_ERROR( "Can't determine type of formal argument (%s)!", $formal_arg_name )
  90             unless defined $formal_arg_type;
  91
  92         $self->INTERNAL_ERROR( "Can't determine type of actual argument (%s)!", ref $args[$i] )
  93             unless defined $actual_arg_type;
  94
  95         if ( $formal_arg_type->name ne $actual_arg_type->name ) {
  96             my $temp  = $compiler->temp_reg($formal_arg_type);
  97             my $value = $args[$i]->compile($compiler);
  98             $compiler->emit("  $temp = $value");
  99             $args[$i] = $temp;
 100         }
 101         else {
 102             $args[$i] = $args[$i]->compile($compiler);
 103         }
 104     }
 105
 106     if ( exists $props{op} ) {
 107         my $op = $props{op};
 108
 109         #    $self->DEBUG(0, "Calling %s%s...", $name, ($op ? ' (op $op)' : ' as op'));
 110
 111         if ( defined $op ) {
 112             $name = $op->value;
 113             $name =~ s/(^"|"$)//g;
 114         }
 115
 116         $name =~ s/^.*:://;    # Strip namespaces off ops.
 117
 118         $compiler->emit( "  $name ", join( ", ", @args ) );
 119     }
 120     else {
 121
 122 #    $self->DEBUG(0, "Calling '%s' as regular or NCI sub (props = %s)...", $name, join(", ", %props));
 123
 124         $name =~ s/::/__/g;
 125
 126         if ( exists $props{fn} or exists $props{fnlib} ) {
 127             $name .= "_THUNK";
 128         }
 129
 130         $compiler->emit( "  _${name}(" . join( ", ", @args ) . ")" );
 131     }
 132
 133     return 1;
 134 }
 135
 136 #
 137 # sax()
 138 #
 139
 140 sub sax {
 141     my $self = shift;
 142     my ($handler) = @_;
 143
 144     $handler->start_element( { Name => 'call', Attributes => { name => $self->name } } );
 145     $_->sax($handler) foreach $self->args;
 146     $handler->end_element( { Name => 'call' } );
 147 }
 148
 149 1;
 150
 151 # Local Variables:
 152 #   mode: cperl
 153 #   cperl-indent-level: 4
 154 #   fill-column: 100
 155 # End:
 156 # vim: expandtab shiftwidth=4: