languages/jako/lib/Jako/Construct/Expression/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::Expression::Call;
  15
  16 use Carp;
  17
  18 use base qw(Jako::Construct::Expression);
  19
  20 sub new {
  21     my $class = shift;
  22     my ( $block, $dest, $ident, @args ) = @_;
  23
  24     confess( "Dest (" . ref($block) . ") not Identifer!" )
  25         unless UNIVERSAL::isa( $dest, 'Jako::Construct::Expression::Value::Identifier' );
  26     confess( "Ident (" . ref($block) . ") not Identifer!" )
  27         unless UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
  28     confess( "Block (" . ref($block) . ") not!" )
  29         unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
  30
  31     my $self = bless {
  32         BLOCK => $block,
  33
  34         DEST => $dest,
  35         NAME => $ident,
  36         ARGS => [@args],
  37
  38         DEBUG => 1,
  39         FILE  => $ident->file,
  40         LINE  => $ident->line
  41     }, $class;
  42
  43     $block->push_content($self);
  44
  45     return $self;
  46 }
  47
  48 sub dest { return shift->{DEST}; }
  49 sub name { return shift->{NAME}; }
  50 sub args { return @{ shift->{ARGS} }; }
  51
  52 #
  53 # compile()
  54 #
  55
  56 sub compile {
  57     my $self = shift;
  58     my ($compiler) = @_;
  59
  60     my $dest_ident = $self->dest;
  61
  62     my $dest = $self->dest->value;
  63     my $name = $self->name->value;
  64
  65     #  $self->DEBUG(0, "Searching for symbol '$name'...");
  66
  67     my $sym = $self->block->find_symbol($name);
  68
  69     unless ($sym) {
  70
  71         #    $self->block->dump_symbols;
  72         $self->SYNTAX_ERROR( "Call to unknown sub '%s'.", $name );
  73     }
  74
  75     my %props = $sym->props;
  76
  77     my @args = $self->args;
  78
  79     my @formal_args = $sym->args;
  80
  81     $self->SYNTAX_ERROR( "Wrong number of arguments (expected %d, got %d) in call to '%s'.",
  82         scalar(@formal_args), scalar(@args), $name )
  83         unless @formal_args == @args;
  84
  85     for ( my $i = 0 ; $i < @args ; $i++ ) {
  86         my ( $formal_arg_type, $formal_arg_name ) = @{ $formal_args[$i] };
  87         my $actual_arg_type;
  88
  89         if ( UNIVERSAL::isa( $args[$i], 'Jako::Construct::Expression::Value::Identifier' ) ) {
  90             my $arg_sym = $self->block->find_symbol( $args[$i]->value );
  91             $self->SYNTAX_ERROR( "Undefined identifier '%s'.", $args[$i]->value ) unless $arg_sym;
  92             $actual_arg_type = $arg_sym->type;
  93         }
  94         else {
  95             $actual_arg_type = $args[$i]->type;
  96         }
  97
  98         $self->INTERNAL_ERROR( "Can't determine type of formal argument (%s)!", $formal_arg_name )
  99             unless defined $formal_arg_type;
 100
 101         $self->INTERNAL_ERROR( "Can't determine type of actual argument (%s)!", ref $args[$i] )
 102             unless defined $actual_arg_type;
 103
 104         if ( $formal_arg_type->name ne $actual_arg_type->name ) {
 105             my $temp  = $compiler->temp_reg($formal_arg_type);
 106             my $value = $args[$i]->compile($compiler);
 107             $compiler->emit("  $temp = $value");
 108             $args[$i] = $temp;
 109         }
 110         else {
 111             $args[$i] = $args[$i]->compile($compiler);
 112         }
 113     }
 114
 115     if ( ( $dest_ident->kind eq 'var' ) and ( $dest_ident->scope eq 'global' ) ) {
 116         $dest = $dest_ident->compile($compiler);
 117     }
 118
 119     #
 120     # For built-in subs (ops):
 121     #
 122
 123     if ( exists $props{op} ) {
 124         my $op = $props{op};
 125
 126         #    $self->DEBUG(0, "Calling %s%s...", $name, ($op ? ' (op $op)' : ' as op'));
 127
 128         $name = $op->value if defined $op;
 129         $name =~ s/(^")|("$)//g;    # Delete leading and trailing quotes;
 130
 131         $name =~ s/^.*:://;         # Delete namespaces from ops
 132
 133         $compiler->emit( "  $name ", join( ", ", $dest, @args ) );
 134     }
 135
 136     #
 137     # For regular (user-defined) and NCI (Native Call Interface) subs:
 138     #
 139
 140     else {
 141
 142      #    $self->DEBUG(0, "Calling '%s' as regular sub (props = %s)...", $name, join(", ", %props));
 143
 144         $name =~ s/::/__/g;
 145
 146         if ( exists $props{fn} or exists $props{fnlib} ) {
 147             $name .= "_THUNK";
 148         }
 149
 150         $compiler->emit( "  $dest = _${name}(" . join( ", ", @args ) . ")" );
 151     }
 152
 153     if ( ( $dest_ident->kind eq 'var' ) and ( $dest_ident->scope eq 'global' ) ) {
 154         my $pmc_type = $dest_ident->type->imcc_pmc();
 155         my $temp_pmc = $compiler->temp_pmc();
 156
 157         $compiler->emit("  $temp_pmc = new '$pmc_type'");
 158         $compiler->emit("  $temp_pmc = $dest");
 159
 160         my $dest_name = $dest_ident->value;
 161         $compiler->emit("  global \"$dest_name\" = $temp_pmc");
 162     }
 163
 164     return 1;
 165 }
 166
 167 #
 168 # sax()
 169 #
 170
 171 sub sax {
 172     my $self = shift;
 173     my ($handler) = @_;
 174
 175     $handler->start_element( { Name => 'assign' } );
 176     $self->dest->sax($handler);
 177
 178     $handler->start_element( { Name => 'call', Attributes => { name => $self->name->value } } );
 179     $_->sax($handler) foreach $self->args;
 180     $handler->end_element( { Name => 'call' } );
 181
 182     $handler->end_element( { Name => 'assign' } );
 183 }
 184
 185 1;
 186
 187 # Local Variables:
 188 #   mode: cperl
 189 #   cperl-indent-level: 4
 190 #   fill-column: 100
 191 # End:
 192 # vim: expandtab shiftwidth=4: