← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/cheats/parrot/P6role.pir

  • 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/cheats/parrot/P6role.pir
 
1
## $Id$
 
2
 
 
3
=head1 NAME
 
4
 
 
5
src/parrot/P6role.pir - methods for the our P6role class
 
6
 
 
7
=head2 Methods on P6role
 
8
 
 
9
We also add some methods to P6role.
 
10
 
 
11
=item !pun
 
12
 
 
13
Puns the role to a class and returns that class.
 
14
 
 
15
=cut
 
16
 
 
17
.namespace ["P6role"]
 
18
.sub '!pun' :method
 
19
    self = descalarref self
 
20
 
 
21
    # See if we have already created a punned class; use it if so.
 
22
    .local pmc pun
 
23
    pun = getprop '$!pun', self
 
24
    if null pun goto make_pun
 
25
    .return (pun)
 
26
  make_pun:
 
27
 
 
28
    # Otherwise, need to create a punned class; set a $*SCOPE that is not
 
29
    # 'our' just to ensure that we don't try and associate with a Parrot
 
30
    # namespace.
 
31
    $P0 = box 'anon'
 
32
    .lex '$*SCOPE', $P0
 
33
    .local pmc ClassHOW, temp, meta, proto
 
34
    ClassHOW = get_root_global ['perl6'], 'ClassHOW'
 
35
    $P1 = getprop '$!owner', self
 
36
    $P1 = getattribute $P1, '$!shortname'
 
37
    temp = ClassHOW.'new'($P1)
 
38
    meta = temp.'HOW'()
 
39
    meta.'add_composable'(temp, self)
 
40
    proto = meta.'compose'(temp)
 
41
    
 
42
    # Stash it away, and return it.
 
43
    setprop self, '$!pun', proto
 
44
    .return (proto)
 
45
.end
 
46
 
 
47
 
 
48
=item ACCEPTS
 
49
 
 
50
=cut
 
51
 
 
52
.sub 'ACCEPTS' :method
 
53
    .param pmc topic
 
54
 
 
55
    # First, check if this role is directly done by the topic.
 
56
    $I0 = does topic, self
 
57
    if $I0 goto done
 
58
 
 
59
    # Otherwise, need to consider subtypes in the parameters.
 
60
    .local pmc all_variants, it, want_rf, our_types, cur_variant
 
61
    self = descalarref self
 
62
    $P0 = getprop '$!owner', self
 
63
    all_variants = getattribute $P0, '$!created'
 
64
    want_rf = getprop '$!orig_role', self
 
65
    our_types = getprop '@!type_args', self
 
66
    it = iter all_variants
 
67
  it_loop:
 
68
    unless it goto it_loop_end
 
69
    cur_variant = shift it
 
70
 
 
71
    # We can exclude a variant if it wasn't from the same role factory.
 
72
    $P0 = cur_variant['role']
 
73
    $P1 = getprop '$!orig_role', $P0
 
74
    eq_addr $P1, want_rf, same_variant
 
75
    goto it_loop
 
76
  same_variant:
 
77
 
 
78
    # Also we can exclude it if our topic doens't do it.
 
79
    $I0 = does topic, $P0
 
80
    unless $I0 goto it_loop
 
81
 
 
82
    # If it's from the same variant, check all types of the role we're
 
83
    # considering here are broader-or-equal types.
 
84
    .local pmc check_types
 
85
    check_types = cur_variant['pos_args']
 
86
    $I0 = elements check_types
 
87
    $I1 = elements our_types
 
88
    if $I0 != $I1 goto it_loop
 
89
    $I0 = 0
 
90
  type_loop:
 
91
    if $I0 >= $I1 goto type_loop_end
 
92
    $P0 = our_types[$I0]
 
93
    $P1 = check_types[$I0]
 
94
    $I2 = $P0.'ACCEPTS'($P1)
 
95
    unless $I2 goto it_loop
 
96
    inc $I0
 
97
    goto type_loop
 
98
  type_loop_end:
 
99
 
 
100
    # If we get here, we found a role that through the subtypes of its
 
101
    # parameters is applicable.
 
102
    $I0 = 1
 
103
    goto done
 
104
  it_loop_end:
 
105
 
 
106
    # If we get here, no applicable roles.
 
107
    $I0 = 0
 
108
  done:
 
109
    .return ($I0)
 
110
.end
 
111
 
 
112
 
 
113
=item defined
 
114
 
 
115
Role objects serve as type objects and thus should be undefined.
 
116
 
 
117
=cut
 
118
 
 
119
.sub 'defined' :method
 
120
    $P0 = get_root_global ['perl6';'Bool'], 'False'
 
121
    .return ($P0)
 
122
.end
 
123
 
 
124
 
 
125
=item perl
 
126
 
 
127
=cut
 
128
 
 
129
.sub 'perl' :method
 
130
    .local pmc args, it
 
131
    self = descalarref self
 
132
    $P0 = getprop '$!owner', self
 
133
    $P0 = getattribute $P0, '$!shortname'
 
134
    $S0 = $P0
 
135
    $S0 = concat $S0, '['
 
136
    args = getprop '@!type_args', self
 
137
    it = iter args
 
138
  it_loop:
 
139
    unless it goto it_loop_end
 
140
    $P0 = shift it
 
141
    $S1 = $P0.'perl'()
 
142
    $S0 = concat $S0, $S1
 
143
    goto it_loop
 
144
  it_loop_end:
 
145
    $S0 = concat $S0, ']'
 
146
    .return ($S0)
 
147
.end
 
148
 
 
149
 
 
150
=item HOW
 
151
 
 
152
=cut
 
153
 
 
154
.sub 'HOW' :method :nsentry
 
155
    self = descalarref self
 
156
    $P0 = getprop 'metaclass', self
 
157
    .return ($P0)
 
158
.end
 
159
 
 
160
 
 
161
=item WHICH
 
162
 
 
163
=cut
 
164
 
 
165
.sub 'WHICH' :method
 
166
    $I0 = get_addr self
 
167
    .return ($I0)
 
168
.end
 
169
 
 
170
 
 
171
=item WHAT
 
172
 
 
173
=cut
 
174
 
 
175
.sub 'WHAT' :method
 
176
    self = descalarref self
 
177
    .return (self)
 
178
.end
 
179
 
 
180
 
 
181
=item Str (vtable get_string)
 
182
 
 
183
=cut
 
184
 
 
185
.sub 'Str' :method :vtable('get_string')
 
186
    self = descalarref self
 
187
    $P0 = getprop '$!owner', self
 
188
    $S0 = $P0
 
189
    .return ($S0)
 
190
.end
 
191
 
 
192
 
 
193
=item postcircumfix:<[ ]>
 
194
 
 
195
=cut
 
196
 
 
197
.sub 'postcircumfix:<[ ]>' :method
 
198
    .return (self)
 
199
.end
 
200
 
 
201
=back
 
202
 
 
203
=cut
 
204
 
 
205
# Local Variables:
 
206
#   mode: pir
 
207
#   fill-column: 100
 
208
# End:
 
209
# vim: expandtab shiftwidth=4 ft=pir: