lib/Parrot/Pmc2c/Method.pm

   1 # Copyright (C) 2004-2008, The Perl Foundation.
   2 # $Id$
   3 package Parrot::Pmc2c::Method;
   4 use strict;
   5 use warnings;
   6 use constant VTABLE_ENTRY => 'VTABLE_ENTRY';
   7 use constant VTABLE       => 'VTABLE';
   8 use constant NON_VTABLE   => 'NON_VTABLE';
   9 use Parrot::Pmc2c::UtilFunctions qw(count_newlines args_from_parameter_list passable_args_from_parameter_list);
  10
  11 sub new {
  12     my ( $class, $self_hash ) = @_;
  13     my $self = {
  14         (
  15             attrs       => {},
  16             mmds        => [],
  17             body        => "",
  18             parameters  => "",
  19             mmd_rights  => [],
  20             parent_name => "",
  21             decorators  => [],
  22             %{ $self_hash || {} }
  23         )
  24     };
  25
  26     # this is usually wrong, but *something* calls new on an object somewhere
  27     bless $self, ref $class || $class;
  28 }
  29
  30 sub clone {
  31     my ( $self, $self_hash ) = @_;
  32     return $self->new( { ( %{$self}, %{ $self_hash || {} } ) } );
  33 }
  34
  35 sub add_mmd_rights {
  36     my ( $self, $value ) = @_;
  37     push @{ $self->{mmd_rights} }, $value;
  38 }
  39
  40 sub mmd_rights {
  41     my ($self) = @_;
  42     return $self->{mmd_rights};
  43 }
  44
  45 #getters/setters
  46 for my $x qw( name parent_name type return_type body mmds symbol mmd_prefix mmd_table mmd_name
  47     right attrs decorators parameters ) {
  48     my $code = <<'EOC';
  49 sub REPLACE {
  50     my ( $self, $value ) = @_;
  51     $self->{REPLACE} = $value if defined $value;
  52     return $self->{REPLACE}
  53 }
  54 EOC
  55         $code =~ s/REPLACE/$x/g;
  56         eval $code;
  57     }
  58
  59 sub is_vtable {
  60     my ($self) = @_;
  61     my $type = $self->type;
  62     return $type eq VTABLE || $type eq VTABLE_ENTRY;
  63 }
  64
  65 sub is_mmd {
  66     my ($self) = @_;
  67
  68     return 1 if $self->{mmd_name};
  69     return 1 if $self->mmds and scalar @{ $self->mmds };
  70     return 0;
  71 }
  72
  73 =head1 C<trans($type)>
  74
  75 Used in C<signature()> to normalize argument types.
  76
  77 =cut
  78
  79 sub trans {
  80     my ( $self, $type ) = @_;
  81
  82     return 'v' unless $type;
  83
  84     my $char = substr $type, 0, 1;
  85
  86     return $1  if $char =~ /([ISP])/;
  87     return 'N' if $char eq 'F';
  88     return 'v' if $type eq 'void';
  89     return 'V' if $type =~ /void\s*\*\s*/;
  90     return 'P' if $type =~ /opcode_t\*/;
  91     return 'I' if $type =~ /int(val)?/i;
  92     return '?';
  93 }
  94
  95 =head1 C<signature()>
  96
  97 Returns the method signature for the methods $parameters
  98
  99 =cut
 100
 101 sub signature {
 102     my ($self) = @_;
 103
 104     my $args             = passable_args_from_parameter_list( $self->parameters );
 105     my ($types, $vars)   = args_from_parameter_list( $self->parameters );
 106     my $return_type      = $self->return_type;
 107     my $return_type_char = $self->trans($return_type);
 108     my $sig              = $self->trans($return_type) .
 109                            join '', map { $self->trans($_) } @{$types};
 110     my $return_prefix    = '';
 111     my $method_suffix    = '';
 112
 113     if ( $return_type ne 'void' ) {
 114         $return_prefix = "return ($return_type)";
 115
 116         # PMC* and STRING* don't need a special suffix
 117         if ( $return_type !~ /\*/ ) {
 118             $method_suffix = "_ret" . lc substr $return_type, 0, 1;
 119
 120             # change UINTVAl type to reti
 121             $method_suffix =~ s/_retu/_reti/;
 122         }
 123     }
 124
 125     my $null_return = '';
 126     $null_return = "return ($return_type) NULL;" if $return_type_char =~ /P|I|S|V/;
 127     $null_return = 'return (FLOATVAL) 0;'        if $return_type_char =~ /N/;
 128     $null_return = 'return;'                     if $return_type_char =~ /v/;
 129
 130     return ( $return_prefix, $method_suffix, $args, $sig, $return_type_char, $null_return );
 131 }
 132
 133 1;
 134
 135 # Local Variables:
 136 #   mode: cperl
 137 #   cperl-indent-level: 4
 138 #   fill-column: 100
 139 # End:
 140 # vim: expandtab shiftwidth=4:
 141