← Back to branch summary

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

« back to all changes in this revision

Viewing changes to t/pmc/perl6multisub-type.t

  • Committer: Bazaar Package Importer
  • Author(s): Ryan Niebur
  • Date: 2009-10-04 14:31:57 UTC
  • Revision ID: james.westby@ubuntu.com-20091004143157-ubq3wu0grk0f1e6a
Tags: upstream-0.1~2009.09
Import upstream version 0.1~2009.09

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/pmc/perl6multisub-type.t
 
1
#! ../../parrot
 
2
# Copyright (C) 2007-2008, The Perl Foundation.
 
3
# $Id$
 
4
 
 
5
=head1 NAME
 
6
 
 
7
t/pmc/perl6multisub-type.t - Type based dispatch tests
 
8
 
 
9
=head1 SYNOPSIS
 
10
 
 
11
    % prove t/pmc/perl6multisub-type.t
 
12
 
 
13
=head1 DESCRIPTION
 
14
 
 
15
Tests for type based dispatch using the Perl 6 MultiSub PMC.
 
16
 
 
17
=cut
 
18
 
 
19
.loadlib 'perl6_group'
 
20
 
 
21
.sub main :main
 
22
    .include 'include/test_more.pir'
 
23
    load_bytecode "perl6.pbc"
 
24
 
 
25
    plan(13)
 
26
 
 
27
    'basic_class'()
 
28
    'role'()
 
29
    'ordered_class'()
 
30
.end
 
31
 
 
32
 
 
33
.sub 'basic_class'
 
34
    $P0 = new "Perl6MultiSub"
 
35
    $P1 = get_global 'basic_class_1'
 
36
    'attach_sig'($P1, 'Int')
 
37
    push $P0, $P1
 
38
    $P1 = get_global 'basic_class_2'
 
39
    'attach_sig'($P1, 'Junction')
 
40
    push $P0, $P1
 
41
 
 
42
    $P1 = new 'Int'
 
43
    $P1 = 42
 
44
    $I0 = $P0($P1)
 
45
    is($I0, 1, 'dispatch on class')
 
46
    $P1 = new 'Junction'
 
47
    $I0 = $P0($P1)
 
48
    is($I0, 2, 'dispatch on class')
 
49
.end
 
50
.sub 'basic_class_1'
 
51
    .param pmc a
 
52
    .return (1)
 
53
.end
 
54
.sub 'basic_class_2'
 
55
    .param pmc a
 
56
    .return (2)
 
57
.end
 
58
 
 
59
 
 
60
.sub 'role'
 
61
    # Create a couple of roles.
 
62
    .local pmc R1, R2
 
63
    R1 = '!keyword_role'('R1')
 
64
    R1 = R1.'!select'()
 
65
    R2 = '!keyword_role'('R2')
 
66
    R2 = R2.'!select'()
 
67
 
 
68
    # Set up multis.
 
69
    $P0 = new "Perl6MultiSub"
 
70
    $P1 = get_global 'role_1'
 
71
    'attach_sig'($P1, 'R1')
 
72
    push $P0, $P1
 
73
    $P1 = get_global 'role_2'
 
74
    'attach_sig'($P1, 'R2')
 
75
    push $P0, $P1
 
76
 
 
77
    # Couple of classes that do the roles.
 
78
    .local pmc C1, C2, p6meta
 
79
    p6meta = get_hll_global ['Perl6Object'], '$!P6META'
 
80
    C1 = p6meta.'new_class'('C1', 'parent'=>'Any')
 
81
    p6meta.'add_role'(R1, 'to'=>C1)
 
82
    C2 = p6meta.'new_class'('C2', 'parent'=>'Any')
 
83
    p6meta.'add_role'(R2, 'to'=>C2)
 
84
 
 
85
    # Tests
 
86
    $P1 = C1.'new'()
 
87
    $I0 = $P0($P1)
 
88
    is($I0, 1, 'dispatch on a role')
 
89
    $P1 = C2.'new'()
 
90
    $I0 = $P0($P1)
 
91
    is($I0, 2, 'dispatch on a role')
 
92
.end
 
93
.sub 'role_1'
 
94
    .param pmc a
 
95
    .return (1)
 
96
.end
 
97
.sub 'role_2'
 
98
    .param pmc a
 
99
    .return (2)
 
100
.end
 
101
 
 
102
 
 
103
.sub 'ordered_class'
 
104
    # Create 3 classes.
 
105
    .local pmc p6meta
 
106
    p6meta = get_hll_global ['Perl6Object'], '$!P6META'
 
107
    p6meta.'new_class'('Paper', 'parent'=>'Any')
 
108
    p6meta.'new_class'('Scissors', 'parent'=>'Any')
 
109
    p6meta.'new_class'('Stone', 'parent'=>'Any')
 
110
 
 
111
    $P0 = new "Perl6MultiSub"
 
112
    $P1 = get_global 'ordered_class_1'
 
113
    'attach_sig'($P1, 'Any', 'Any')
 
114
    push $P0, $P1
 
115
    $P1 = get_global 'ordered_class_2'
 
116
    'attach_sig'($P1, 'Paper', 'Stone')
 
117
    push $P0, $P1
 
118
    $P1 = get_global 'ordered_class_3'
 
119
    'attach_sig'($P1, 'Stone', 'Scissors')
 
120
    push $P0, $P1
 
121
    $P1 = get_global 'ordered_class_4'
 
122
    'attach_sig'($P1, 'Scissors', 'Paper')
 
123
    push $P0, $P1
 
124
 
 
125
    .local pmc paper, scissors, stone
 
126
    paper = get_hll_global 'Paper'
 
127
    paper = paper.'new'()
 
128
    scissors = get_hll_global 'Scissors'
 
129
    scissors = scissors.'new'()
 
130
    stone = get_hll_global 'Stone'
 
131
    stone = stone.'new'()
 
132
 
 
133
    $I0 = $P0(paper, paper)
 
134
    is($I0, 0, 'topological sorting')
 
135
    $I0 = $P0(paper, scissors)
 
136
    is($I0, 0, 'topological sorting')
 
137
    $I0 = $P0(paper, stone)
 
138
    is($I0, 1, 'topological sorting')
 
139
    $I0 = $P0(scissors, paper)
 
140
    is($I0, 1, 'topological sorting')
 
141
    $I0 = $P0(scissors, scissors)
 
142
    is($I0, 0, 'topological sorting')
 
143
    $I0 = $P0(scissors, stone)
 
144
    is($I0, 0, 'topological sorting')
 
145
    $I0 = $P0(stone, paper)
 
146
    is($I0, 0, 'topological sorting')
 
147
    $I0 = $P0(stone, scissors)
 
148
    is($I0, 1, 'topological sorting')
 
149
    $I0 = $P0(stone, stone)
 
150
    is($I0, 0, 'topological sorting')
 
151
.end
 
152
.sub 'ordered_class_1'
 
153
    .param pmc a
 
154
    .param pmc b
 
155
    .return (0)
 
156
.end
 
157
.sub 'ordered_class_2'
 
158
    .param pmc a
 
159
    .param pmc b
 
160
    .return (1)
 
161
.end
 
162
.sub 'ordered_class_3'
 
163
    .param pmc a
 
164
    .param pmc b
 
165
    .return (1)
 
166
.end
 
167
.sub 'ordered_class_4'
 
168
    .param pmc a
 
169
    .param pmc b
 
170
    .return (1)
 
171
.end
 
172
 
 
173
.sub 'attach_sig'
 
174
    .param pmc sub
 
175
    .param pmc types :slurpy
 
176
    
 
177
    # Make signature.
 
178
    .local pmc true
 
179
    true = new 'Integer'
 
180
    true = 1
 
181
    $P0 = new 'Signature'
 
182
    $P1 = new 'Perl6Array'
 
183
    setattribute $P0, "@!params", $P1
 
184
    .local pmc it, type
 
185
    it = iter types
 
186
  param_loop:
 
187
    unless it goto param_loop_end
 
188
    $P3 = shift it
 
189
    $S0 = $P3
 
190
    type = get_hll_global $S0
 
191
    $P2 = new 'Perl6Hash'
 
192
    $P2["nom_type"] = type
 
193
    $P2["multi_invocant"] = true
 
194
    push $P1, $P2
 
195
    goto param_loop
 
196
  param_loop_end:
 
197
 
 
198
    setprop sub, '$!signature', $P0
 
199
.end
 
200
 
 
201
# Local Variables:
 
202
#   mode: pir
 
203
#   fill-column: 100
 
204
# End:
 
205
# vim: expandtab shiftwidth=4 ft=pir: