lib/Parrot/Pmc2c/Object.pm

   1 package Parrot::Pmc2c::Object;
   2
   3 # Copyright (C) 2007-2008, The Perl Foundation.
   4 # $Id$
   5
   6 use base 'Parrot::Pmc2c';
   7 use strict;
   8 use warnings;
   9
  10 =over 4
  11
  12 =item C<implements($method)>
  13
  14 Always true for vtables.
  15
  16 =cut
  17
  18 sub implements {
  19     my ( $self, $meth ) = @_;
  20     $self->implements_vtable($meth);
  21 }
  22
  23 =item C<body($method, $line, $out_name)>
  24
  25 Returns the C code for the method body. C<$line> is used to accumulate
  26 the number of lines, C<$out_name> is the name of the output file we are
  27 generating.
  28
  29 Overrides the default implementation to direct all unknown methods to
  30 first check if there is an implementation of the vtable method in the
  31 vtable methods hash of this class of any others, and delegates up to
  32 any PMCs in the MRO.
  33
  34 =back
  35
  36 =cut
  37
  38 sub body {
  39     my ( $self, $method, $line, $out_name ) = @_;
  40
  41     my $meth = $method->{meth};
  42
  43     # existing methods get emitted
  44     if ( $self->SUPER::implements($meth) ) {
  45         my $n = $self->{has_method}{$meth};
  46         return $self->SUPER::body( $self->{methods}[$n], $line, $out_name );
  47     }
  48
  49     my $parameters = $method->{parameters};
  50     my $n          = 0;
  51     my @args       = grep { $n++ & 1 ? $_ : 0 } split / /, $parameters;
  52     my $arg        = '';
  53     $arg = ", " . join( ' ', @args ) if @args;
  54     $parameters = ", $parameters" if $parameters;
  55     my $decl = $self->decl( $self->{class}, $method, 0 );
  56
  57     # Need to build signature and work out what return type we expect.
  58     my $ret_sig  = ctype_to_sigchar( $method->{type} );
  59
  60     my $ret_type = $ret_sig eq 'I' ? '_reti' : '_retf';
  61
  62     my $sig      = $ret_sig;
  63     my @types    = grep { $_ } map { my @x = split /\s+/; $x[0] }
  64                         split /\s*,\s*/, $parameters;
  65
  66     foreach (@types) {
  67         $sig .= ctype_to_sigchar($_);
  68     }
  69
  70     # Do we have a return value?
  71     my $return      = $method->{type} =~ /void/ ? ''        : 'return ';
  72     my $void_return = $method->{type} =~ /void/ ? 'return;' : '';
  73
  74     # work out what the null return should be so that we can quieten the "no
  75     # return from non-void function" warnings.
  76     # unfortunately, the general case:
  77     #my $null_return = "($method->{type})NULL";
  78     # doesn't work with gcc (it builds and tests without even a warning with
  79     # icc), so we add a workaround for the null return from a FLOATVAL
  80     # function
  81     my $null_return;
  82     if ( $method->{type} eq 'void' ) {
  83         $null_return = '';
  84     }
  85     elsif ( $method->{type} eq 'void*' ) {
  86         $null_return = 'return NULL;';
  87     }
  88     elsif ( $method->{type} =~ /PMC|INTVAL|STRING|opcode_t/ ) {
  89         $null_return = "return ($method->{type})NULL;";
  90     }
  91
  92     # workaround for gcc because the general case doesn't work there
  93     elsif ( $method->{type} =~ /FLOATVAL/ ) {
  94         $null_return = 'return (FLOATVAL) 0;';
  95     }
  96     else {
  97         $null_return = '';
  98     }
  99
 100     my $l         = $self->line_directive( $line + 1, "\L$self->{class}.c" );
 101     my $generated = <<EOC;
 102 $l
 103 $decl {
 104     Parrot_Object * const obj    = PARROT_OBJECT(pmc);
 105     Parrot_Class  * const _class = PARROT_CLASS(obj->_class);
 106
 107     /* Walk and search for the vtable method. */
 108     const int num_classes       = VTABLE_elements(interp, _class->all_parents);
 109     const int all_in_universe   = !PObj_HasAlienParents_TEST(obj->_class);
 110     const int alien_parents_pos = VTABLE_elements(interp, _class->attrib_metadata);
 111     int i;
 112     for (i = 0; i < num_classes; i++) {
 113         /* Get the class. */
 114         PMC * const cur_class =
 115             VTABLE_get_pmc_keyed_int(interp, _class->all_parents, i);
 116
 117         /* If it's from this universe or the class doesn't inherit from
 118          * anything outside of it... */
 119         if (all_in_universe
 120         ||  VTABLE_isa(interp, cur_class, CONST_STRING_GEN(interp, "Class"))) {
 121 EOC
 122
 123     # We shouldn't allow overrides of get_pointer and friends,
 124     # since it's unsafe.
 125     if ( $meth !~ /get_pointer/ ) {
 126         $generated .= <<EOC;
 127             const Parrot_Class * const class_info = PARROT_CLASS(cur_class);
 128             if (VTABLE_exists_keyed_str(interp, class_info->vtable_overrides, CONST_STRING_GEN(interp, "$meth"))) {
 129                 /* Found it; call. */
 130                 PMC * const meth = VTABLE_get_pmc_keyed_str(interp,
 131                     class_info->vtable_overrides, CONST_STRING_GEN(interp, "$meth"));
 132                 ${return}Parrot_run_meth_fromc_args$ret_type(interp, meth, pmc, CONST_STRING_GEN(interp, "$meth"), "$sig"$arg);
 133                 $void_return
 134             }
 135 EOC
 136     }
 137
 138     $generated .= <<EOC;
 139         }
 140         else {
 141             /* Get the PMC instance and call the vtable method on that. */
 142             PMC * const del_class = VTABLE_get_pmc_keyed_int(interp,
 143                                         obj->attrib_store, alien_parents_pos);
 144
 145             ${return}VTABLE_$meth(interp, del_class$arg);
 146         }
 147     }
 148     $null_return
 149 }
 150 EOC
 151
 152     return $generated;
 153 }
 154
 155 sub ctype_to_sigchar {
 156     my $ctype = shift;
 157     $ctype    =~ s/\s//g;
 158
 159     if ( !$ctype || $ctype =~ /void/ ) {
 160         return "v";
 161     }
 162     elsif ( $ctype =~ /opcode_t\*/ ) {
 163
 164         # Only invoke's return needs this; we'll get away with this.
 165         return "P";
 166     }
 167     elsif ( $ctype =~ /PMC/ ) {
 168         return "P";
 169     }
 170     elsif ( $ctype =~ /STRING/ ) {
 171         return "S";
 172     }
 173     elsif ( $ctype =~ /int(val)?/i ) {
 174         return "I";
 175     }
 176     else {
 177         return "N";
 178     }
 179 }
 180
 181 1;
 182
 183 # Local Variables:
 184 #   mode: cperl
 185 #   cperl-indent-level: 4
 186 #   fill-column: 100
 187 # End:
 188 # vim: expandtab shiftwidth=4: