-
Notifications
You must be signed in to change notification settings - Fork 135
/
sub.t
539 lines (437 loc) · 17.4 KB
/
sub.t
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
use v6;
use Test;
plan 96;
=begin pod
Testing operator overloading subroutines
=end pod
# L<S06/"Operator overloading">
# This set of tests is very basic for now.
# TODO: all variants of overloading syntax (see spec "So any of these")
{
sub prefix:<X> ($thing) { return "ROUGHLY$thing"; };
is(X "fish", "ROUGHLYfish",
'prefix operator overloading for new operator');
}
{
sub prefix:<±> ($thing) { return "AROUND$thing"; };
is ± "fish", "AROUNDfish", 'prefix operator overloading for new operator (unicode, latin-1 range)';
sub prefix:<(+-)> ($thing) { return "ABOUT$thing"; };
is EVAL(q[ (+-) "fish" ]), "ABOUTfish", 'prefix operator overloading for new operator (nasty)';
}
{
sub prefix:<∔> ($thing) { return "AROUND$thing"; };
is ∔ "fish", "AROUNDfish", 'prefix operator overloading for new operator (unicode, U+2214 DOT PLUS)';
}
#?rakudo skip 'prefix:[] form NYI RT #124974'
{
sub prefix:['Z'] ($thing) { return "ROUGHLY$thing"; };
is(Z "fish", "ROUGHLYfish",
'prefix operator overloading for new operator Z');
}
#?rakudo skip 'prefix:[] form NYI RT #124975'
{
sub prefix:["∓"] ($thing) { return "AROUND$thing"; };
is ∓ "fish", "AROUNDfish", 'prefix operator overloading for new operator (unicode, U+2213 MINUS-OR-PLUS SIGN)';
}
#?rakudo skip 'prefix:[] form NYI RT #124976'
{
sub prefix:["\x[2213]"] ($thing) { return "AROUND$thing"; };
is ∓ "fish", "AROUNDfish", 'prefix operator overloading for new operator (unicode, \x[2213] MINUS-OR-PLUS SIGN)';
}
#?rakudo skip 'prefix:[] form NYI RT #124977'
{
sub prefix:["\c[MINUS-OR-PLUS SIGN]"] ($thing) { return "AROUND$thing"; };
is ∓ "fish", "AROUNDfish", 'prefix operator overloading for new operator (unicode, \c[MINUS-OR-PLUS SIGN])';
}
{
my sub prefix:<->($thing) { return "CROSS$thing"; };
is(-"fish", "CROSSfish",
'prefix operator overloading for existing operator (but only lexically so we don\'t mess up runtime internals (needed at least for PIL2JS, probably for PIL-Run, too)');
}
{
sub infix:<×> ($a, $b) { $a * $b }
is(5 × 3, 15, "infix Unicode operator");
}
{
sub infix:<C> ($text, $owner) { return "$text copyright $owner"; };
is "romeo & juliet" C "Shakespeare", "romeo & juliet copyright Shakespeare",
'infix operator overloading for new operator';
}
{
sub infix:<©> ($text, $owner) { return "$text Copyright $owner"; };
is "romeo & juliet" © "Shakespeare", "romeo & juliet Copyright Shakespeare",
'infix operator overloading for new operator (unicode)';
}
{
sub infix:<(C)> ($text, $owner) { return "$text CopyRight $owner"; };
is EVAL(q[ "romeo & juliet" (C) "Shakespeare" ]), "romeo & juliet CopyRight Shakespeare",
'infix operator overloading for new operator (nasty)';
}
{
sub infix:«_<_ »($one, $two) { return 42 } #OK not used
is 3 _<_ 5, 42, "frenchquoted infix sub";
}
# unfreak perl6.vim: >>
{
sub postfix:<W> ($wobble) { return "ANDANDAND$wobble"; };
is("boop"W, "ANDANDANDboop",
'postfix operator overloading for new operator');
}
{
sub postfix:<&&&&&> ($wobble) { return "ANDANDANDANDAND$wobble"; };
is("boop"&&&&&, "ANDANDANDANDANDboop",
"postfix operator overloading for new operator (weird)");
}
#?rakudo skip 'macros RT #124978'
#?niecza skip 'Unhandled exception: Malformed block at (eval) line 1'
{
use experimental :macros;
my $var = 0;
ok(EVAL('macro circumfix:["<!--","-->"] ($text) is parsed / .*? / { "" }; <!-- $var = 1; -->; $var == 0;'), 'circumfix macro {"",""}');
ok(EVAL('macro circumfix:«<!-- -->» ($text) is parsed / .*? / { "" }; <!-- $var = 1; -->; $var == 0;'), 'circumfix macro «»');
}
# demonstrate sum prefix
{
my sub prefix:<Σ> (@x) { [+] @x }
is(Σ [1..10], 55, "sum prefix operator");
}
# check that the correct overloaded method is called
{
multi postfix:<!> ($x) { [*] 1..$x }
multi postfix:<!> (Str $x) { return($x.uc ~ "!!!") }
is(10!, 3628800, "factorial postfix operator");
is("bumbershoot"!, "BUMBERSHOOT!!!", "correct overloaded method called");
}
# Overloading by setting the appropriate code variable
#?rakudo skip "cannot bind with this LHS RT #124979"
{
my &infix:<plus>;
BEGIN {
&infix:<plus> := { $^a + $^b };
}
is 3 plus 5, 8, 'overloading an operator using "my &infix:<...>" worked';
}
# Overloading by setting the appropriate code variable using symbolic
# dereferentiation
#?niecza skip 'Cannot use hash access on an object of type Array'
{
my &infix:<times>;
BEGIN {
&::("infix:<times>") = { $^a * $^b };
}
is 3 times 5, 15, 'operator overloading using symbolic dereferentiation';
}
# Accessing an operator using its subroutine name
{
is &infix:<+>(2, 3), 5, "accessing a builtin operator using its subroutine name";
my &infix:<z> := { $^a + $^b };
is &infix:<z>(2, 3), 5, "accessing a userdefined operator using its subroutine name";
#?rakudo skip 'undeclared name'
#?niecza skip 'Undeclared routine'
is ~(&infix:<»+«>([1,2,3],[4,5,6])), "5 7 9", "accessing a hyperoperator using its subroutine name";
}
# Overriding infix:<;>
#?rakudo todo 'infix:<;> RT #124981'
#?niecza todo
{
my proto infix:<;> ($a, $b) { $a + $b }
is $(3 ; 2), 5 # XXX correct?
}
# [NOTE]
# pmichaud ruled that prefix:<;> and postfix:<;> shouldn't be defined by
# the synopses:
# http://colabti.de/irclogger/irclogger_log/perl6?date=2006-07-29,Sat&sel=189#l299
# so we won't test them here.
# Overriding prefix:<if>
# L<S04/"Statement parsing" /"since prefix:<if> would hide statement_modifier:<if>">
#?rakudo skip 'missing block, apparently "if" not an op RT #124982'
{
my proto prefix:<if> ($a) { $a*2 }
is (if+5), 10;
}
# [NOTE]
# pmichaud ruled that infix<if> is incorrect:
# http://colabti.de/irclogger/irclogger_log/perl6?date=2006-07-29,Sat&sel=183#l292
# so we won't test it here either.
# great. Now, what about those silent auto-conversion operators a la:
# multi sub prefix:<+> (Str $x) returns Num { ... }
# ?
# I mean, + is all well and good for number classes. But what about
# defining other conversions that may happen?
# here is one that co-erces a MyClass into a Str and a Num.
#?niecza skip 'import NYI'
{
class OtherClass {
has $.x is rw;
}
class MyClass {
method prefix:<~> is export { "hi" }
method prefix:<+> is export { 42 }
method infix:<as>($self: OtherClass $to) is export { #OK not used
my $obj = $to.new;
$obj.x = 23;
return $obj;
}
}
import MyClass; # should import that sub forms of the exports
my $obj;
lives-ok { $obj = MyClass.new }, "instantiation of a prefix:<...> and infix:<as> overloading class worked";
lives-ok { ~$obj }, "our object can be stringified";
is ~$obj, "hi", "our object was stringified correctly";
is EVAL('($obj as OtherClass).x'), 23, "our object was coerced correctly";
}
#?rakudo skip 'infix Z will never work; no lexical Z RT #124983'
{
my sub infix:<Z> ($a, $b) {
$a ** $b;
}
is (2 Z 1 Z 2), 4, "default Left-associative works.";
}
#?rakudo skip 'no lexical Z RT #124983'
{
my sub infix:<Z> ($a, $b) is assoc('left') {
$a ** $b;
}
is (2 Z 1 Z 2), 4, "Left-associative works.";
}
#?rakudo skip 'no lexical Z RT #124983'
{
my sub infix:<Z> ($a, $b) is assoc('right') {
$a ** $b;
}
is (2 Z 1 Z 2), 2, "Right-associative works.";
}
#?rakudo skip 'no lexical Z RT #124983'
{
my sub infix:<Z> ($a, $b) is assoc('chain') {
$a eq $b;
}
is (1 Z 1 Z 1), Bool::True, "Chain-associative works.";
is (1 Z 1 Z 2), Bool::False, "Chain-associative works.";
}
{
sub infix:<our_non_assoc_infix> ($a, $b) is assoc('non') {
$a ** $b;
}
is (2 our_non_assoc_infix 3), (2 ** 3), "Non-associative works for just tow operands.";
is ((2 our_non_assoc_infix 2) our_non_assoc_infix 3), (2 ** 2) ** 3, "Non-associative works when used with parens.";
throws-like '2 our_non_assoc_infix 3 our_non_assoc_infix 4',
X::Syntax::NonAssociative,
"Non-associative should not parsed when used chainly.";
}
#?niecza skip "roles NYI"
{
role A { has $.v }
multi sub infix:<==>(A $a, A $b) { $a.v == $b.v }
lives-ok { 3 == 3 or die() }, 'old == still works on integers (+)';
lives-ok { 3 == 4 and die() }, 'old == still works on integers (-)';
ok (A.new(v => 3) == A.new(v => 3)), 'infix:<==> on A objects works (+)';
ok !(A.new(v => 2) == A.new(v => 3)), 'infix:<==> on A objects works (-)';
}
{
sub circumfix:<<` `>>(*@args) { @args.join('-') }
is `3, 4, "f"`, '3-4-f', 'slurpy circumfix:<<...>> works';
is ` 3, 4, "f" `, '3-4-f', 'slurpy circumfix:<<...>> works, allows spaces';
is EVAL('` 3, 4, "f" `'),'3-4-f','lexically defined circumfix works inside EVAL';
}
{
sub circumfix:<⌊ ⌋>($e) { $e.floor }
is ⌊pi⌋, 3, 'circumfix with non-Latin1 bracketing characters';
is ⌊ pi ⌋, 3, 'circumfix with non-Latin1 bracketing characters, allows spaces';
}
{
sub postcircumfix:<⌊ ⌋>($int,$arg) { $int + 1 }
is 1⌊1⌋,2, "sub postcircumfix:<...> works";
is EVAL(q|1⌊1⌋|),2,"lexically defined postcircumfix works inside EVAL";
}
# RT #86906
{
throws-like { EVAL q[ multi sub circumfix:<⌊⌋>($a) { return $a.floor; } ] },
X::Syntax::AddCategorical::TooFewParts,
message => "Not enough symbols provided for categorical of type circumfix; needs 2",
'circumfix definition without whitespace between starter and stopper fails with X::Syntax::AddCategorical::TooFewParts';
throws-like { EVAL q[ multi sub circumfix:< ⌊ | ⌋ >($a) { return $a.floor; } ] },
X::Syntax::AddCategorical::TooManyParts,
message => "Too many symbols provided for categorical of type circumfix; needs only 2",
'circumfix definition with three parts fails with X::Syntax::AddCategorical::TooManyParts';
throws-like { EVAL q[ multi sub infix:< ⌊ ⌋ >($a) { return $a.floor; } ] },
X::Syntax::AddCategorical::TooManyParts,
message => "Too many symbols provided for categorical of type infix; needs only 1",
'infix definition with two parts fails with X::Syntax::AddCategorical::TooManyParts';
throws-like { EVAL q[ multi sub term:< foo bar >() { return pi; } ] },
X::Syntax::AddCategorical::TooManyParts,
message => "Too many symbols provided for categorical of type term; needs only 1",
'term definition with two parts fails with X::Syntax::AddCategorical::TooManyParts';
}
{
multi sub infix:<+=> (Int $a is rw, Int $b) { $a -= $b }
my $frew = 10;
$frew += 5;
is $frew, 5, 'infix redefinition of += works';
}
{
class MMDTestType {
has $.a is rw;
method add(MMDTestType $b) { $.a ~ $b.a }
}
multi sub infix:<+>(MMDTestType $a, MMDTestType $b) { $a.add($b) };
my MMDTestType $a .= new(a=>'foo');
my MMDTestType $b .= new(a=>'bar');
is $a + $b, 'foobar', 'can overload exiting operators (here: infix:<+>)';
}
# test that multis with other arity don't interfere with existing ones
# used to be RT #65640
#?niecza skip 'No matching candidates to dispatch for &infix:<+>'
{
multi sub infix:<+>() { 42 };
ok 5 + 5 == 10, "New multis don't disturb old ones";
}
# taken from S06-operator-overloading/method.t
{
class Bar {
has $.bar is rw;
method Stringy() { ~self }; # the tests assume prefix:<~> gets called by qq[], but .Stringy gets actually called
}
multi sub prefix:<~> (Bar $self) { return $self.bar }
multi sub infix:<+> (Bar $a, Bar $b) { return "$a $b" }
{
my $val;
my $foo = Bar.new();
$foo.bar = 'software';
$val = "$foo";
is($val, 'software', '... basic prefix operator overloading worked');
lives-ok {
my $foo = Bar.new();
$foo.bar = 'software';
$val = $foo + $foo;
}, '... class methods work for class';
#?niecza todo '... basic infix operator overloading worked'
is($val, 'software software', '... basic infix operator overloading worked');
}
# Test that the object is correctly stringified when it is in an array.
# And test that »...« automagically work, too.
{
my $obj;
$obj = Bar.new;
$obj.bar = "pugs";
my @foo = ($obj, $obj, $obj);
my $res;
#?niecza todo "stringification didn't die"
lives-ok { $res = ~<<@foo }, "stringification didn't die";
#?niecza todo "... worked in array stringification"
is $res, "pugs pugs pugs", "stringification overloading worked in array stringification";
}
}
# RT #65638
{
is EVAL('sub infix:<,>($a, $b) { 42 }; 5, 5'), 42, 'infix:<,>($a, $b)';
is EVAL('sub infix:<,>(Int $x where 1, Int $y where 1) { 42 }; 1, 1'), 42,
'very specific infix:<,>';
#?rakudo todo 'RT #65638'
#?niecza todo
is EVAL('sub infix:<#>($a, $b) { 42 }; 5 # 5'), 42, 'infix:<comment char>($a, $b)';
is EVAL('multi sub infix:<+>() { 42 }; 5 + 5'), 10, 'infix:<+>()';
is EVAL('sub infix:<+>($a, $b) { 42 }; 5 + 5'), 42, 'infix:<+>($a, $b)';
}
{
multi sub infix:<foo>($a, $b) {$a + $b};
# autoviv tries to call &[foo]() with no arguments, so we define first
# alternative is below, with a candidate with an empty parameter list
my $x = 0;
$x foo=6;
is $x, 6, 'foo= works for custom operators';
}
{
multi sub infix:<foo>($a, $b) {$a + $b};
multi sub infix:<foo>() { 0 };
# alternative with a candidate with an empty parameter list
my $x foo=6;
is $x, 6, 'foo= works for custom operators';
}
{
our sub infix:<bar>($a, $b) {$a + $b};
# similar to above, but without the empty param candidate
my $x = 0;
$x bar=6;
is $x, 6, 'bar= works for custom operators';
}
# RT #74104
#?niecza skip 'No matching candidates to dispatch for &infix:<+>'
{
class RT74104 {}
multi sub infix:<+>(RT74104 $, RT74104 $) { -1 }
is 2+2, 4, 'overloading an operator does not hide other candidates';
}
# RT #111418
# RT #112870
{
sub infix:<*+>($a, $b) { $a * $b + $b }
is 2 *+ 5, 15, 'longest operator wins (RT #111418)';
sub infix:<~eq>(Str $a, Str $b) { uc($a) eq uc($b) }
ok 'a' ~eq 'A', 'longest operator wins (RT #112870)';
}
# RT #109800
{
my &infix:<c> = { $^a + $^b };
is 1 c 2, 3, 'assignment to code variable works.';
}
# RT #116643
{
lives-ok { sub prefix:<\o/>($) {} }, 'can declare operator with a backslash (1)';
lives-ok { sub postfix:<\\>($) {} }, 'can declare operator with a backslash (2)';
my $RT116643 = EVAL 'sub infix:<\\o/>($a, $b) { $a * $b }; 21 \\o/ 2';
is $RT116643, 42, 'can declare and use operator with a backslash';
}
# RT #115724
{
lives-ok { sub circumfix:<w "> ($a) { }; },
'can define circumfix operator with a double quote (")';
my $RT115724 = EVAL 'sub circumfix:<w "> ($a) { $a }; w 111 "';
is $RT115724 , 111, 'can define and use circumfix operator with a double quote (")';
}
# RT #117737
{
throws-like { EVAL q< sub infix:[/./] { 42 } > },
X::Syntax::Extension::TooComplex,
message => "Colon pair value '/./' too complex to use in name",
'infix definition for /./ fails with X::Syntax::Extension::TooComplex';
}
# RT #119919
{
lives-ok { sub infix:["@"] ($a, $b) { 42 } },
'can define infix with brackets as delimiter';
my $RT119919 = EVAL 'sub infix:["@"] ($a, $b) { 42 }; 5@5';
is $RT119919, 42, 'can define and use infix with brackets as delimiter';
lives-ok { sub circumfix:["@", "@"] ($a) { $a } },
'can define circumfix with brackets as delimiter';
#?rakudo.jvm emit # TTIAR
$RT119919 = EVAL 'sub circumfix:["@", "@"] ($a) { $a }; @ 5 @';
#?rakudo.jvm skip 'failing due to above failure'
is $RT119919, 5, 'can define and use circumfix with brackets as delimiter';
constant sym = "µ";
sub infix:[sym] { "$^a$^b" };
is 5 µ 5, "55", 'can define and use operator with a sigilless constant as symbol';
constant $sym = "°";
sub infix:[$sym] { "$^a$^b" };
is 5 ° 5, "55", 'can define and use operator with a sigiled constant as symbol';
}
{
lives-ok { constant $x = "µ @"; sub circumfix:<<$x>>($) { 42 } },
'can define circumfix using << >> and both delimiters from the same constant';
my $test = EVAL 'constant $x = "µ @"; sub circumfix:<<$x>>($) { 42 }; µ 5 @';
is $test, 42, 'can define and use circumfix using << >> and both delimiters from the same constant (1)';
lives-ok { constant $x = "µµ @@"; sub circumfix:<<$x>>($) { 42 } },
'can define circumfix using << >> and both delimiters from the same constant';
$test = EVAL 'constant $x = "µµ @@"; sub circumfix:<<$x>>($) { 42 }; µµ 5 @@';
is $test, 42, 'can define and use circumfix using << >> and both delimiters from the same constant (2)';
lives-ok { constant sym = "µ @"; sub circumfix:<< {sym} >>($) { 42 } },
'can define circumfix using << {sym} >> and both delimiters from the same constant';
$test = EVAL 'constant sym = "µ @"; sub circumfix:<< {sym} >>($) { 42 }; µ 5 @';
is $test, 42, 'can define and use circumfix using << >> and both delimiters from the same constant';
throws-like { EVAL q[ constant $x = "@ µ ."; sub circumfix:<<$x>>($) { 42 } ] },
X::Syntax::AddCategorical::TooManyParts,
'constants containing too many parts throw correctly';
}
is infix:['+'](2,3), 5, 'can call existing infix via compile-time string lookup';
is infix:['Z~'](<a b>, <c d>), 'ac bd', 'can call autogen infix via compile-time string lookup';
# vim: ft=perl6