← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/setting/Operators.pm

  • 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:
src/setting/Operators.pm
 
1
# operators defined in the setting
 
2
 
 
3
multi sub infix:<...> (@lhs, Code $generator) {
 
4
    my $c = $generator.count;
 
5
    if $c > @lhs {
 
6
        fail 'the closure wants more parameters than given on the LHS';
 
7
    }
 
8
    my @result = @lhs;
 
9
    my @r;
 
10
    if ?any( $generator.signature.params>>.<slurpy> ) {
 
11
        while @r = $generator(|@result) {
 
12
            @result.push: @r;
 
13
        }
 
14
    } else {
 
15
        # XXX work around http://rt.perl.org/rt3/Ticket/Display.html?id=66824
 
16
        # this is a bit ugly.. since @a[1..1] returns a single item and not
 
17
        # an array, |@result[$one-item-range] throws the error
 
18
        # "argument doesn't array"
 
19
        while @r = $generator(|@(@result[*-$c..*-1])) {
 
20
            @result.push: @r;
 
21
        }
 
22
    }
 
23
    return @result;
 
24
}
 
25
 
 
26
multi sub infix:<eqv> (Num $a, Num $b) { $a === $b }
 
27
multi sub infix:<eqv> (Str $a, Str $b) { $a === $b }
 
28
multi sub infix:<eqv> (Code $a, Code $b) { $a === $b }
 
29
multi sub infix:<eqv> (Positional $a, Positional $b) {
 
30
    return Bool::False unless $a.WHAT === $b.WHAT;
 
31
    return Bool::False unless $a.elems == $b.elems;
 
32
    for @($a) Z @($b) -> $x, $y {
 
33
        return Bool::False unless $x eqv $y;
 
34
    }
 
35
    Bool::True
 
36
}
 
37
 
 
38
multi sub infix:<eqv>(Pair $a, Pair $b) {
 
39
    $a.key eqv $b.key && $a.value eqv $b.value;
 
40
}
 
41
 
 
42
multi sub infix:<eqv>(Mapping $a, Mapping $b) {
 
43
    return Bool::False if +$a != +$b;
 
44
    for $a.kv -> $k, $v {
 
45
        return Bool::False unless $b.exists($k);
 
46
        return Bool::False unless $b.{$k} eqv $v;
 
47
    }
 
48
    return Bool::True;
 
49
}
 
50
 
 
51
multi sub infix:<eqv>(Failure $a, Failure $b) {
 
52
    # do we have different values of undef yet?
 
53
    # if so, how do I detect them?
 
54
    Bool::True;
 
55
}
 
56
 
 
57
multi sub infix:<eqv> ($a, $b) {
 
58
    return Bool::False unless $a.WHAT === $b.WHAT;
 
59
    return Bool::True  if     $a      === $b;
 
60
    die "infix:<eqv> is only implemented for certain special cases yet";
 
61
}
 
62
 
 
63
multi sub infix:<minmax>(@a, @b) {
 
64
    (@a[0] min @b[0], @a[1] max @b[1]);
 
65
}
 
66
 
 
67
multi sub infix:<leg>($a, $b) {
 
68
    ~$a cmp ~$b;
 
69
}
 
70
 
 
71
sub prefix:<[//]>(*@a) {
 
72
    for @a -> $item {
 
73
        $item // next;
 
74
        return $item;
 
75
    }
 
76
    return ();
 
77
}
 
78
 
 
79
sub prefix:<[||]>(*@a) {
 
80
    for @a -> $item {
 
81
        $item || next;
 
82
        return $item;
 
83
    }
 
84
    return ();
 
85
}
 
86
 
 
87
sub infix:<!%>($a, $b) { ! ($a % $b) }
 
88
 
 
89
 
 
90
multi sub infix:<+>($a, $b) {
 
91
    Q:PIR {
 
92
        $P0 = find_lex '$a'
 
93
        $N0 = $P0
 
94
        $P1 = find_lex '$b'
 
95
        $N1 = $P1
 
96
        $N2 = $N0 + $N1
 
97
        %r = box $N2
 
98
    }
 
99
}
 
100
 
 
101
multi sub infix:<->($a, $b) {
 
102
    Q:PIR {
 
103
        $P0 = find_lex '$a'
 
104
        $N0 = $P0
 
105
        $P1 = find_lex '$b'
 
106
        $N1 = $P1
 
107
        $N2 = $N0 - $N1
 
108
        %r = box $N2
 
109
    }
 
110
}
 
111
 
 
112
multi sub infix:<*>($a, $b) {
 
113
    Q:PIR {
 
114
        $P0 = find_lex '$a'
 
115
        $N0 = $P0
 
116
        $P1 = find_lex '$b'
 
117
        $N1 = $P1
 
118
        $N2 = $N0 * $N1
 
119
        %r = box $N2
 
120
    }
 
121
}
 
122
 
 
123
multi sub infix:</>($a, $b) {
 
124
    Q:PIR {
 
125
        $P0 = find_lex '$a'
 
126
        $N0 = $P0
 
127
        $P1 = find_lex '$b'
 
128
        $N1 = $P1
 
129
        $N2 = $N0 / $N1
 
130
        %r = box $N2
 
131
    }
 
132
}
 
133
 
 
134
multi sub infix:<%>($a, $b) {
 
135
    Q:PIR {
 
136
        $P0 = find_lex '$a'
 
137
        $N0 = $P0
 
138
        $P1 = find_lex '$b'
 
139
        $N1 = $P1
 
140
        $N2 = mod $N0, $N1
 
141
        %r = box $N2
 
142
    }
 
143
}
 
144
 
 
145
multi sub infix:<**>($a, $b) {
 
146
    Q:PIR {
 
147
        $P0 = find_lex '$a'
 
148
        $N0 = $P0
 
149
        $P1 = find_lex '$b'
 
150
        $N1 = $P1
 
151
        $N2 = pow $N0, $N1
 
152
        %r = box $N2
 
153
    }
 
154
}
 
155
 
 
156
multi sub prefix:<->($a) {
 
157
    Q:PIR {
 
158
        $P0 = find_lex '$a'
 
159
        $N0 = $P0
 
160
        $N0 = neg $N0
 
161
        %r = box $N0
 
162
    }
 
163
}
 
164
 
 
165
 
 
166
multi sub prefix:<~>(Object $a) {
 
167
    Q:PIR {
 
168
        $P0 = find_lex '$a'
 
169
        $S0 = $P0
 
170
        %r = new ['Str']
 
171
        assign %r, $S0
 
172
    }
 
173
}
 
174
 
 
175
 
 
176
multi sub prefix:<~>(Multi $a) { $a.name }
 
177
 
 
178
multi sub infix:<!=>($a, $b)  { !($a == $b) }
 
179
multi sub infix:<!==>($a, $b) { !($a == $b) }
 
180
multi sub infix:<ne>($a, $b)  { !($a eq $b) }
 
181
multi sub infix:<!eq>($a, $b) { !($a eq $b) }
 
182
 
 
183
# vim: ft=perl6