← Back to branch summary

~ubuntu-branches/ubuntu/raring/rakudo/raring

« back to all changes in this revision

Viewing changes to src/core/traits.pm

  • Committer: Package Import Robot
  • Author(s): Adam Conrad
  • Date: 2012-11-29 01:00:04 UTC
  • mfrom: (7.1.5 raring-proposed)
  • Revision ID: package-import@ubuntu.com-20121129010004-3vmbbb2e53up4u14
Tags: 2012.10-1build1
Rebuild with the current version of the Not Quite Perl compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/core/traits.pm
1
1
use Perl6::BOOTSTRAP;
2
2
 
 
3
# Stub a few things the compiler wants to have really early on.
 
4
my class Pair { ... }
 
5
my class Whatever { ... }
 
6
my class WhateverCode { ... }
 
7
 
3
8
# Stub these or we can't use any sigil other than $.
4
9
my role Positional { ... }
5
10
my role Associative { ... }
6
11
my role Callable { ... }
7
12
 
8
 
proto trait_mod:<is>(|$) { * }
 
13
# for errors
 
14
my class X::Inheritance::Unsupported { ... }
 
15
my class X::Export::NameClash        { ... }
 
16
my class X::Composition::NotComposable { ... }
 
17
my class X::Import::MissingSymbols   { ... }
 
18
my class X::Redeclaration { ... }
 
19
 
 
20
proto trait_mod:<is>(|) { * }
9
21
multi trait_mod:<is>(Mu:U $child, Mu:U $parent) {
10
22
    if $parent.HOW.archetypes.inheritable() {
11
23
        $child.HOW.add_parent($child, $parent);
14
26
        $child.HOW.add_parent($child, $parent.HOW.inheritalize($parent))
15
27
    }
16
28
    else {
17
 
        die $child.HOW.name($child) ~ " cannot inherit from " ~
18
 
            $parent.HOW.name($parent) ~ " because it is not inheritable"
 
29
        X::Inheritance::Unsupported.new(
 
30
            :child-typename($child.HOW.name($child)),
 
31
            :$parent,
 
32
        ).throw;
19
33
    }
20
34
}
21
35
multi trait_mod:<is>(Mu:U $type, :$rw!) {
22
36
    $type.HOW.set_rw($type);
23
37
}
24
 
multi trait_mod:<is>(Mu:U $type, $size, :$nativesize!) {
25
 
    $type.HOW.set_nativesize($type, $size);
 
38
multi trait_mod:<is>(Mu:U $type, :$nativesize!) {
 
39
    $type.HOW.set_nativesize($type, $nativesize);
 
40
}
 
41
multi trait_mod:<is>(Mu:U $type, :$hidden!) {
 
42
    $type.HOW.set_hidden($type);
26
43
}
27
44
 
28
45
multi trait_mod:<is>(Attribute:D $attr, :$rw!) {
41
58
multi trait_mod:<is>(Routine:D $r, :$default!) {
42
59
    $r does role { method default() { True } }
43
60
}
44
 
multi trait_mod:<is>(Routine:D $r, $info, :$inlinable!) {
45
 
    $r.set_inline_info($info);
46
 
}
 
61
multi trait_mod:<is>(Routine:D $r, :$DEPRECATED!) {
 
62
    # we'll add logic here later
 
63
}
 
64
multi trait_mod:<is>(Routine:D $r, Mu :$inlinable!) {
 
65
    $r.set_inline_info(nqp::p6decont($inlinable));
 
66
}
 
67
multi trait_mod:<is>(Routine:D $r, :$onlystar!) {
 
68
    $r.set_onlystar();
 
69
}
 
70
 
 
71
# Since trait_mod:<is> to set onlystar isn't there at the
 
72
# point we wrote its proto, we do it manually here.
 
73
BEGIN &trait_mod:<is>.set_onlystar();
47
74
 
48
75
multi trait_mod:<is>(Parameter:D $param, :$readonly!) {
49
76
    # This is the default.
63
90
 
64
91
# TODO: Make this much less cheaty. That'll probably need the
65
92
# full-blown serialization, though.
66
 
sub EXPORT_SYMBOL(\$exp_name, @tags, Mu \$sym) {
67
 
    for @tags -> $tag {
68
 
        my $install_in;
69
 
        if $*EXPORT.WHO.exists($tag) {
70
 
            $install_in := $*EXPORT.WHO.{$tag};
71
 
        }
72
 
        else {
73
 
            $install_in := $*W.pkg_create_mo($/, (package { }).HOW, :name($tag));
74
 
            $*W.pkg_compose($install_in);
75
 
            $*W.install_package_symbol($*EXPORT, $tag, $install_in);
76
 
        }
77
 
        if $install_in.WHO.exists($exp_name) {
78
 
            unless ($install_in.WHO){$exp_name} =:= $sym {
79
 
                die "A symbol $exp_name has already been exported";
80
 
            }
81
 
        }
82
 
        $*W.install_package_symbol($install_in, $exp_name, $sym);
 
93
sub EXPORT_SYMBOL(\exp_name, @tags, Mu \sym) {
 
94
    my @export_packages = $*EXPORT;
 
95
    for nqp::p6type(@*PACKAGES) {
 
96
        unless .WHO.exists('EXPORT') {
 
97
            .WHO<EXPORT> := Metamodel::PackageHOW.new_type(:name('EXPORT'));
 
98
            .WHO<EXPORT>.^compose;
 
99
        }
 
100
        @export_packages.push: .WHO<EXPORT>;
 
101
    }
 
102
    for @export_packages -> $p {
 
103
        for @tags -> $tag {
 
104
            my $install_in;
 
105
            if $p.WHO.exists($tag) {
 
106
                $install_in := $p.WHO.{$tag};
 
107
            }
 
108
            else {
 
109
                $install_in := $*W.pkg_create_mo($/, (package { }).HOW, :name($tag));
 
110
                $*W.pkg_compose($install_in);
 
111
                $*W.install_package_symbol($p, $tag, $install_in);
 
112
            }
 
113
            if $install_in.WHO.exists(exp_name) {
 
114
                unless ($install_in.WHO){exp_name} =:= sym {
 
115
                    X::Export::NameClash.new(symbol => exp_name).throw;
 
116
                }
 
117
            }
 
118
            $*W.install_package_symbol($install_in, exp_name, sym);
 
119
        }
83
120
    }
84
121
}
85
 
multi trait_mod:<is>(Routine:D \$r, :$export!) {
86
 
    my $to_export := $r.multi ?? $r.dispatcher !! $r;
87
 
    my $exp_name  := '&' ~ $r.name;
88
 
    my @tags = 'ALL', 'DEFAULT';
 
122
multi trait_mod:<is>(Routine:D \r, :$export!) {
 
123
    my $to_export := r.multi ?? r.dispatcher !! r;
 
124
    my $exp_name  := '&' ~ r.name;
 
125
    my @tags = 'ALL', ($export ~~ Pair ?? $export.key() !!
 
126
                       $export ~~ Positional ?? @($export)>>.key !!
 
127
                       'DEFAULT');
89
128
    EXPORT_SYMBOL($exp_name, @tags, $to_export);
90
129
}
91
 
multi trait_mod:<is>(Mu:U \$type, :$export!) {
92
 
    my $exp_name := $type.HOW.name($type);
93
 
    my @tags = 'ALL', 'DEFAULT';
94
 
    EXPORT_SYMBOL($exp_name, @tags, $type);
 
130
multi trait_mod:<is>(Mu:U \type, :$export!) {
 
131
    my $exp_name := type.HOW.name(type);
 
132
    my @tags = 'ALL', ($export ~~ Pair ?? $export.key !!
 
133
                       $export ~~ Positional ?? @($export)>>.key !!
 
134
                       'DEFAULT');
 
135
    EXPORT_SYMBOL($exp_name, @tags, type);
 
136
}
 
137
# for constants
 
138
multi trait_mod:<is>(Mu \sym, :$export!, :$SYMBOL!) {
 
139
    my @tags = 'ALL', ($export ~~ Pair ?? $export.key !!
 
140
                    $export ~~ Positional ?? @($export)>>.key !!
 
141
                    'DEFAULT');
 
142
    EXPORT_SYMBOL($SYMBOL, @tags, sym);
95
143
}
96
144
 
97
 
multi trait_mod:<is>(Mu:D $docee, $doc, :$docs!) {
 
145
multi trait_mod:<is>(Mu:D $docee, :$docs!) {
98
146
    $docee does role {
99
147
        has $!WHY;
100
148
        method WHY          { $!WHY      }
101
149
        method set_docs($d) { $!WHY = $d }
102
150
    }
103
 
    $docee.set_docs($doc);
104
 
    $doc.set_docee($docee);
105
 
}
106
 
 
107
 
multi trait_mod:<is>(Mu:U $docee, $doc, :$docs!) {
108
 
    $docee.HOW.set_docs($doc);
109
 
    $doc.set_docee($docee);
110
 
}
111
 
 
112
 
 
113
 
proto trait_mod:<does>(|$) { * }
 
151
    $docee.set_docs($docs);
 
152
    $docs.set_docee($docee);
 
153
}
 
154
 
 
155
multi trait_mod:<is>(Mu:U $docee, :$docs!) {
 
156
    $docee.HOW.set_docs($docs);
 
157
    $docs.set_docee($docee);
 
158
}
 
159
 
 
160
 
 
161
proto trait_mod:<does>(|) { * }
114
162
multi trait_mod:<does>(Mu:U $doee, Mu:U $role) {
115
163
    if $role.HOW.archetypes.composable() {
116
164
        $doee.HOW.add_role($doee, $role)
119
167
        $doee.HOW.add_role($doee, $role.HOW.composalize($role))
120
168
    }
121
169
    else {
122
 
        die $doee.HOW.name($doee) ~ " cannot compose " ~
123
 
            $role.HOW.name($role) ~ " because it is not composable"
 
170
        X::Composition::NotComposable.new(
 
171
            target-name => $doee.HOW.name($doee),
 
172
            composer    => $role,
 
173
        ).throw;
124
174
    }
125
175
}
126
176
 
127
 
proto trait_mod:<of>(|$) { * }
 
177
proto trait_mod:<of>(|) { * }
128
178
multi trait_mod:<of>(Mu:U $target, Mu:U $type) {
129
179
    # XXX Ensure we can do this, die if not.
130
180
    $target.HOW.set_of($target, $type);
131
181
}
132
182
multi trait_mod:<of>(Routine:D $target, Mu:U $type) {
133
 
    $target.signature.set_returns($type)
 
183
    my $sig := $target.signature;
 
184
    X::Redeclaration.new(what => 'return type for', symbol => $target,
 
185
        postfix => " (previous return type was {$sig.returns.^name})").throw
 
186
        if $sig.has_returns;
 
187
    $sig.set_returns($type)
134
188
}
135
189
 
136
190
multi trait_mod:<is>(Routine:D $r, :$hidden_from_backtrace!) {
140
194
}
141
195
 
142
196
 
143
 
proto trait_mod:<returns>(|$) { * }
 
197
proto trait_mod:<returns>(|) { * }
144
198
multi trait_mod:<returns>(Routine:D $target, Mu:U $type) {
145
 
    $target.signature.set_returns($type)
 
199
    my $sig := $target.signature;
 
200
    X::Redeclaration.new(what => 'return type for', symbol => $target,
 
201
        postfix => " (previous return type was {$sig.returns.^name})").throw
 
202
        if $sig.has_returns;
 
203
    $sig.set_returns($type)
146
204
}
147
205
 
148
 
proto trait_mod:<as>(|$) { * }
 
206
proto trait_mod:<as>(|) { * }
149
207
multi trait_mod:<as>(Parameter:D $param, $type) {
150
208
    $param.set_coercion($type);
151
209
}
152
210
 
153
211
my class Pair { ... }
154
 
proto trait_mod:<handles>(|$) { * }
 
212
proto trait_mod:<handles>(|) { * }
155
213
multi trait_mod:<handles>(Attribute:D $target, $thunk) {
156
214
    $target does role {
157
215
        has $.handles;
161
219
        }
162
220
        
163
221
        method add_delegator_method($attr: $pkg, $meth_name, $call_name) {
164
 
            my $meth := method (|$c) is rw {
165
 
                $attr.get_value(self)."$call_name"(|$c)
 
222
            my $meth := method (|c) is rw {
 
223
                $attr.get_value(self)."$call_name"(|c)
166
224
            };
167
225
            $meth.set_name($meth_name);
168
226
            $pkg.HOW.add_method($pkg, $meth_name, $meth);
188
246
                                ?($name ~~ $expr)
189
247
                            },
190
248
                            -> $obj, $name {
191
 
                                -> $self, |$c {
192
 
                                    $attr.get_value($self)."$name"(|$c)
 
249
                                -> $self, |c {
 
250
                                    $attr.get_value($self)."$name"(|c)
193
251
                                }
194
252
                            });
195
253
                    }
200
258
                            ?$expr.can($name)
201
259
                        },
202
260
                        -> $obj, $name {
203
 
                            -> $self, |$c {
204
 
                                $attr.get_value($self)."$name"(|$c)
 
261
                            -> $self, |c {
 
262
                                $attr.get_value($self)."$name"(|c)
205
263
                            }
206
264
                        });
207
265
                }
212
270
    $target.set_handles($thunk());
213
271
}
214
272
 
215
 
proto trait_mod:<will>(|$) { * }
216
 
multi trait_mod:<will>(Attribute $attr, Block $closure, :$build!) {
217
 
    $attr.set_build($closure)
218
 
}
219
 
 
220
 
proto trait_mod:<trusts>(|$) { * }
 
273
multi sub trait_mod:<handles>(Method:D $m, &thunk) {
 
274
    my $pkg := $m.signature.params[0].type;
 
275
    my $call_name := $m.name;
 
276
    for thunk() -> $meth_name {
 
277
        my $meth := method (|c) is rw {
 
278
            self."$call_name"()."$meth_name"(|c);
 
279
        }
 
280
        $meth.set_name($meth_name);
 
281
        $pkg.HOW.add_method($pkg, $meth_name, $meth);
 
282
    }
 
283
}
 
284
 
 
285
proto trait_mod:<will>(|) { * }
 
286
multi trait_mod:<will>(Attribute $attr, Block :$build!) {
 
287
    $attr.set_build($build)
 
288
}
 
289
 
 
290
proto trait_mod:<trusts>(|) { * }
221
291
multi trait_mod:<trusts>(Mu:U $truster, Mu:U $trustee) {
222
292
    $truster.HOW.add_trustee($truster, $trustee);
223
293
}
 
294
 
 
295
proto trait_mod:<hides>(|) { * }
 
296
multi trait_mod:<hides>(Mu:U $child, Mu:U $parent) {
 
297
    if $parent.HOW.archetypes.inheritable() {
 
298
        $child.HOW.add_parent($child, $parent, :hides);
 
299
    }
 
300
    elsif $parent.HOW.archetypes.inheritalizable() {
 
301
        $child.HOW.add_parent($child, $parent.HOW.inheritalize($parent), :hides)
 
302
    }
 
303
    else {
 
304
        X::Inheritance::Unsupported.new(
 
305
            :child-typename($child.HOW.name($child)),
 
306
            :$parent,
 
307
        ).throw;
 
308
    }
 
309
}