lib/Parrot/Pmc2c/Method.pm

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