← Back to branch summary

~ubuntu-branches/ubuntu/precise/rakudo/precise

« back to all changes in this revision

Viewing changes to src/Perl6/Compiler/Package.pm

  • Committer: Bazaar Package Importer
  • Author(s): Alessandro Ghedini
  • Date: 2011-05-17 11:31:09 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20110517113109-rmfir654u1axbpt4
Tags: 0.1~2011.04-1
http://bugs.debian.org/601862
http://bugs.debian.org/585762
http://bugs.debian.org/577502
http://bugs.debian.org/584498
* New upstream release (Closes: #601862, #585762, #577502)
* New maintainer
* Switch to 3.0 (quilt) format
* Update dependencies (Closes: #584498)
* Update debian/copyright to lastest DEP5 revision
* Do not generate/install perl6 manpage (now done by the build system)
* Enable tests
* Bump Standards-Version to 3.9.2 (no changes needed)
* Do not install extra LICENSE files and duplicated docs
* Remove debian/clean (no more needed)
* Add Vcs-* fields in debian/control
* Rewrite (short) description
* Update upstream copyright years
* Upload to unstable

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/Perl6/Compiler/Package.pm
 
1
class Perl6::Compiler::Package;
 
2
 
 
3
# The block associated with this package.
 
4
has $!block;
 
5
 
 
6
# This is the name of the HOW this package is based on.
 
7
has $!how;
 
8
 
 
9
# The name of the package.
 
10
has $!name;
 
11
 
 
12
# The scope of the package.
 
13
has $!scope;
 
14
 
 
15
# Table of methods we're adding (name => PAST::Block).
 
16
has $!methods;
 
17
 
 
18
# Table of methods we're adding to the meta model
 
19
has $!meta_methods;
 
20
 
 
21
# List attributes meta-data hashes. Should be Attribute class instances one day.
 
22
has $!attributes;
 
23
 
 
24
# List of traits.
 
25
has $!traits;
 
26
 
 
27
# List of colonpair adverbs.
 
28
has $!name_adverbs;
 
29
 
 
30
# Accessor for block.
 
31
method block($block?) {
 
32
    if $block { $!block := $block }
 
33
    $!block
 
34
}
 
35
 
 
36
# Accessor for how.
 
37
method how($how?) {
 
38
    if $how { $!how := $how }
 
39
    $!how
 
40
}
 
41
 
 
42
# Accessor for name.
 
43
method name($name?) {
 
44
    if $name { $!name := $name }
 
45
    $!name
 
46
}
 
47
 
 
48
# Accessor for scope.
 
49
method scope($scope?) {
 
50
    if $scope { $!scope := $scope }
 
51
    $!scope
 
52
}
 
53
 
 
54
# Accessor for methods hash.
 
55
method methods() {
 
56
    unless $!methods { $!methods := Q:PIR { %r = root_new ['parrot';'Hash'] } }
 
57
    $!methods
 
58
}
 
59
 
 
60
# Accessor for meta_methods hash.
 
61
method meta_methods() {
 
62
    unless $!meta_methods { $!meta_methods := Q:PIR { %r = root_new ['parrot';'Hash'] } }
 
63
    $!meta_methods
 
64
}
 
65
 
 
66
# Accessor for attributes list.
 
67
method attributes() {
 
68
    unless $!attributes { $!attributes := PAST::Node.new() }
 
69
    $!attributes
 
70
}
 
71
 
 
72
# Checks if there is already an attribute with the given name.
 
73
method has_attribute($name) {
 
74
    if $!attributes {
 
75
        for @($!attributes) {
 
76
            if $_<name> eq $name {
 
77
                return 1;
 
78
            }
 
79
        }
 
80
    }
 
81
    0
 
82
}
 
83
 
 
84
# Accessor for traits list.
 
85
method traits() {
 
86
    unless $!traits { $!traits := PAST::Node.new() }
 
87
    $!traits
 
88
}
 
89
 
 
90
# Accessor for traits list.
 
91
method name_adverbs() {
 
92
    unless $!name_adverbs { $!name_adverbs := PAST::Node.new() }
 
93
    $!name_adverbs
 
94
}
 
95
 
 
96
# This method drives the code generation and fixes up the block.
 
97
method finish($block) {
 
98
    my $decl := PAST::Stmts.new();
 
99
 
 
100
    # Emit code to install the current scope as $*SCOPE.
 
101
    $decl.push(PAST::Op.new( :pasttype('bind'),
 
102
        PAST::Var.new( :scope('lexical'), :name('$*SCOPE'), :isdecl(1) ),
 
103
        ~$!scope || 'our'
 
104
    ));
 
105
 
 
106
    # Create or look up meta-class.
 
107
    my $how := $!how;
 
108
    my @how := Perl6::Grammar::parse_name(~$how);
 
109
    my $metaclass := PAST::Var.new( :name(@how.pop), :namespace(@how), :scope('package') );
 
110
    my $obj_reg := PAST::Var.new( :name('obj'), :scope('register') );
 
111
    my $meta_reg := PAST::Var.new( :name('meta'), :scope('register') );
 
112
    my $name := $!name ?? ~$!name !! '';
 
113
    if $!scope ne 'augment' {
 
114
        my $new_call :=  PAST::Op.new(
 
115
            :pasttype('callmethod'), :name('new'),
 
116
            $metaclass, $name
 
117
        );
 
118
        for @(self.name_adverbs) {
 
119
            my $param := $_[2];
 
120
            $param.named(~$_[1].value());
 
121
            $new_call.push($param);
 
122
        }
 
123
        $decl.push(PAST::Op.new(
 
124
            :pasttype('bind'),
 
125
            PAST::Var.new( :name('obj'), :scope('register'), :isdecl(1) ),
 
126
            $new_call
 
127
        ));
 
128
    }
 
129
    else {
 
130
        # Augment, so look up existing class.
 
131
        unless $name { pir::die('Cannot augment an anonymous package') }
 
132
        my @name := Perl6::Grammar::parse_name($name);
 
133
        $decl.push(PAST::Op.new(
 
134
            :pasttype('bind'),
 
135
            PAST::Var.new( :name('obj'), :scope('register'), :isdecl(1) ),
 
136
            PAST::Var.new( :name(@name.pop), :namespace(@name), :scope('package') )
 
137
        ));
 
138
    }
 
139
    $decl.push(PAST::Op.new(
 
140
        :pasttype('bind'),
 
141
        PAST::Var.new( :name('meta'), :scope('register'), :isdecl(1) ),
 
142
        PAST::Op.new( :pasttype('callmethod'), :name('HOW'), $obj_reg )
 
143
    ));
 
144
 
 
145
    # Traits.
 
146
    if $!traits {
 
147
        for @($!traits) {
 
148
            $_.unshift($obj_reg);
 
149
            $decl.push($_);
 
150
        }
 
151
    }
 
152
 
 
153
    # Meta Methods.
 
154
    my %meta_methods := $!meta_methods;
 
155
    for %meta_methods {
 
156
        $decl.push(PAST::Op.new(
 
157
            :pasttype('callmethod'),
 
158
            :name('add_meta_method'),
 
159
            $meta_reg, $obj_reg, ~$_, %meta_methods{~$_}<code_ref>
 
160
        ));
 
161
    }
 
162
 
 
163
    # Methods.
 
164
    my %methods := $!methods;
 
165
    for %methods {
 
166
        $decl.push(PAST::Op.new(
 
167
            :pasttype('callmethod'),
 
168
            :name('add_method'),
 
169
            $meta_reg, $obj_reg, ~$_, %methods{~$_}<code_ref>
 
170
        ));
 
171
    }
 
172
 
 
173
    # Attributes.
 
174
    my $attr_list := self.attributes();
 
175
    for @($attr_list) {
 
176
        my $attr := PAST::Op.new(
 
177
            :pasttype('callmethod'),
 
178
            :name('new'),
 
179
            PAST::Var.new( :name('Attribute'),   :namespace(''), :scope('package') ),
 
180
            PAST::Val.new( :value($_<name>),     :named('name') ),
 
181
            PAST::Val.new( :value($_<accessor>), :named('has_accessor') )
 
182
        );
 
183
        if pir::defined($_<rw>) {
 
184
            $attr.push(PAST::Val.new( :value($_<rw>), :named('rw') ));
 
185
        }
 
186
        if $_<build> {
 
187
            $_<build>.named('build');
 
188
            $attr.push($_<build>);
 
189
        }
 
190
        if $_<handles> {
 
191
            $_<handles>.named('handles');
 
192
            $attr.push($_<handles>);
 
193
        }
 
194
        if $_<type> ~~ PAST::Node {
 
195
            $_<type>.named('type');
 
196
            $attr.push($_<type>);
 
197
        }
 
198
        else {
 
199
            $attr.push(PAST::Var.new(
 
200
                :name('Mu'), :namespace([]), :scope('package'), :named('type')
 
201
            ));
 
202
        }
 
203
        $decl.push(PAST::Op.new(
 
204
            :pasttype('callmethod'),
 
205
            :name('add_attribute'),
 
206
            $meta_reg, $obj_reg, $attr
 
207
        ));
 
208
    }
 
209
 
 
210
    # Finally, compose call, and we're done with the decls.
 
211
    $decl.push(PAST::Op.new( :pasttype('callmethod'), :name('compose'), $meta_reg, $obj_reg ));
 
212
 
 
213
    # Check scope and put decls in the right place.
 
214
    if $!scope eq 'anon' || $!name eq '' {
 
215
        $block.blocktype('immediate');
 
216
        $block.push($decl);
 
217
    }
 
218
    elsif $!scope eq 'our' || $!scope eq 'augment' {
 
219
        my $init_decl_name := $block.unique('!class_init_');
 
220
        my @ns := Perl6::Grammar::parse_name($name);
 
221
        $block.push(PAST::Block.new( :name($init_decl_name), :blocktype('declaration'), $decl ));
 
222
        my @PACKAGE := Q:PIR { %r = get_hll_global ['Perl6'; 'Actions'], '@PACKAGE' };
 
223
        @PACKAGE[0].block.loadinit().push(PAST::Op.new(
 
224
            :pasttype('call'),
 
225
            PAST::Var.new( :name($init_decl_name), :namespace(@ns), :scope('package') )
 
226
        ));
 
227
        $block.blocktype('immediate');
 
228
        $block.namespace(@ns);
 
229
    }
 
230
    elsif $!scope eq 'my' {
 
231
        # Install a binding of the declaration to a name in the lexpad.
 
232
        $decl := PAST::Block.new( :blocktype('immediate'), $decl );
 
233
        @Perl6::Actions::BLOCK[0][0].push(PAST::Var.new(
 
234
            :name($!name), :isdecl(1),  :viviself($decl), :scope('lexical')
 
235
        ));
 
236
        @Perl6::Actions::BLOCK[0].symbol($!name, :scope('lexical'), :does_abstraction(1));
 
237
        $block.blocktype('immediate');
 
238
        $block.push(PAST::Var.new( :name($!name), :scope('lexical') ));
 
239
    }
 
240
    else {
 
241
        pir::die("Scope declarator " ~ $!scope ~ " is not supported on packages");
 
242
    }
 
243
 
 
244
    return $block;
 
245
}