1# Copyright (C) 2004-2012, Parrot Foundation.
2package Parrot::Pmc2c::Dumper;
3
4use strict;
5use warnings;
6
7use Parrot::Pmc2c::UtilFunctions qw(slurp spew filename);
8use Parrot::Pmc2c::Parser qw(parse_pmc);
9use Carp;
10
11use base 'Exporter';
12@Parrot::Pmc2c::Dumper::EXPORT_OK = 'dump_pmc';
13
14=head1 NAME
15
16Parrot::Pmc2c::Dumper
17
18=head1 DESCRIPTION
19
20Create dump file for PMCs.
21
22=head1 FUNCTIONS
23
24=head2 Public Functions
25
26=head3 C<dump_pmc()>
27
28    $return_value = dump_pmc($pmc2cMain);
29
30B<Purpose:>  Creates a F<.dump> file for each file listed in pmc2cMain's C<arg>
31key (which can be found in the directories listed in pmc2cMain's C<include>
32key).
33
34B<Arguments:>
35
36B<Return Values:>  Returns 1 upon success.
37
38B<Comments:>  Called when C<--dump> is specified as the command-line option to
39F<pmc2c.pl>.
40
41=cut
42
43sub dump_pmc {
44    my ($self)    = @_;
45    my $pmc2cMain = $self;
46    my @files     = @{ $pmc2cMain->{args} };
47    my $pmcs;
48
49    # help those dumb 'shells' that are not shells
50    @files = glob $files[0] if $files[0] eq 'src/pmc/*.pmc';
51
52    # make sure that a default.dump will always be created if it doesn't
53    $pmc2cMain->find_file('default.dump') or unshift @files, 'default.pmc';
54
55    # load and parse all pmc files in @files
56    for my $filename (@files) {
57        my $parsed_pmc = parse_pmc( $pmc2cMain, $filename );
58        $pmcs->{ $parsed_pmc->name } = $parsed_pmc;
59    }
60
61    $pmcs->{default} = $pmc2cMain->read_dump("default.pmc")
62        unless $pmcs->{default};
63
64    # ensure that the default pmc's super entries point back to itself.
65    my $vtable_dump = $pmc2cMain->read_dump("vtable.pmc");
66    my $default_pmc = $pmcs->{default};
67
68    for my $vt_method_name ( @{ $vtable_dump->names } ) {
69        $default_pmc->super_method( $vt_method_name, 'default' );
70    }
71
72    for my $pmc ( values %$pmcs ) {
73        next if $pmc->name =~ /default$/ && $pmc->dump_is_current($pmc2cMain->find_file('default.dump'));
74
75        gen_parent_lookup_info( $pmc, $pmc2cMain, $pmcs );
76        gen_parent_reverse_lookup_info( $pmc, $pmcs, $vtable_dump );
77
78        $pmc->dump;
79    }
80
81    return 1;
82}
83
84=head2 Non-Public Methods
85
86These functions are expressed as methods called on the Parrot::Pmc2c::Pmc2cMain
87object, but only because they make use of data stored in that object.  They
88are called within the publicly available methods described above and are not
89intended to be publicly callable.
90
91=head3 C<gen_parent_lookup_info()>
92
93    $pmc2cMain->gen_parent_lookup_info($name, \%all);
94
95B<Purpose:>  Generate an ordered list of parent classes to put in the
96C<$classes->{name}->{parents}> array, using the given directories to find parents.
97
98B<Arguments:>  List of two arguments:
99
100=over 4
101
102=item *
103
104String holding class name.
105
106=item *
107
108Hash reference holding data structure being built up within C<dump_pmc()>.
109
110=back
111
112B<Return Value:>  Returns 1 upon success.
113
114B<Comments:>  Called within C<dump_pmc()>.
115
116=cut
117
118sub gen_parent_lookup_info {
119    my ( $pmc, $pmc2cMain, $pmcs ) = @_;
120
121    my @c3_work_queue = ( $pmc->name );
122    while (@c3_work_queue) {
123        my $current_pmc_name = shift @c3_work_queue;
124        next if $current_pmc_name eq 'default';
125
126        for my $parent_name ( @{ [ @{ $pmcs->{$current_pmc_name}->parents } ] } ) {
127            next if $parent_name eq 'default';
128
129            # load $parent_name pmc into $pmcs if needed
130            $pmcs->{$parent_name} = $pmc2cMain->read_dump( lc("$parent_name.pmc") )
131                unless $pmcs->{$parent_name};
132
133            $pmc->add_parent( $pmcs->{$parent_name} );
134
135            # add parent_name on to work queue list.
136            push @c3_work_queue, $parent_name;
137        }
138    }
139
140    # default should appear very last in the @c3 order
141    $pmc->add_parent( $pmcs->{"default"} );
142    return 1;
143}
144
145=head2 Subroutines
146
147=head3 C<gen_parent_reverse_lookup_info()>
148
149    $class = gen_parent_reverse_lookup_info($name, $all, $vt);
150
151B<Purpose:>  Generate a list of inherited methods for C<$name> by searching the
152inheritance tree. The method list is found in C<$vt>.
153
154B<Arguments:>  List of three elements:
155
156=over 4
157
158=item *
159
160String holding name of class being dumped.
161
162=item *
163
164Reference to the hash holding the data structure being built up within
165C<dump_pmc()>.
166
167=item *
168
169The result of a call of C<read_dump()> on F<vtable.pmc>.
170
171=back
172
173B<Return Value:>  Returns 1 upon success.
174
175B<Comments:>  Called within C<dump_pmc()>.
176
177=cut
178
179sub gen_parent_reverse_lookup_info {
180    my ( $pmc, $pmcs, $vt ) = @_;
181
182    # for each vt_meth in pmc, locate the implementing
183    foreach my $vt_method_name ( @{ $vt->names } ) {
184        # skip if super mapping is already set
185        next if $pmc->super_method($vt_method_name);
186
187        foreach my $parent_name ( @{ $pmc->parents } ) {
188            my $parent = $pmcs->{$parent_name};
189            if ( $pmc->parent_has_method( $parent_name, $vt_method_name ) ) {
190                $pmc->super_method( $vt_method_name, $parent );
191                last;
192            }
193        }
194    }
195    return 1;
196}
1971;
198
199# Local Variables:
200#   mode: cperl
201#   cperl-indent-level: 4
202#   fill-column: 100
203# End:
204# vim: expandtab shiftwidth=4:
205