This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
assertion failure in ... or ((0) x 0))
[perl5.git] / t / op / repeat.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc( '../lib' );
7 }
8
9 plan(tests => 49);
10
11 # compile time
12
13 is('-' x 5, '-----',    'compile time x');
14 is('-' x 3.1, '---',    'compile time 3.1');
15 is('-' x 3.9, '---',    'compile time 3.9');
16 is('-' x 1, '-',        '  x 1');
17 is('-' x 0, '',         '  x 0');
18 is('-' x -1, '',        '  x -1');
19 is('-' x undef, '',     '  x undef');
20 is('-' x "foo", '',     '  x "foo"');
21 is('-' x "3rd", '---',  '  x "3rd"');
22
23 is('ab' x 3, 'ababab',  '  more than one char');
24
25 # run time
26
27 $a = '-';
28 is($a x 5, '-----',     'run time x');
29 is($a x 3.1, '---',     '  x 3.1');
30 is($a x 3.9, '---',     '  x 3.9');
31 is($a x 1, '-',         '  x 1');
32 is($a x 0, '',          '  x 0');
33 is($a x -3, '',         '  x -3');
34 is($a x undef, '',      '  x undef');
35 is($a x "foo", '',      '  x "foo"');
36 is($a x "3rd", '---',   '  x "3rd"');
37
38 $a = 'ab';
39 is($a x 3, 'ababab',    '  more than one char');
40 $a = 'ab';
41 is($a x 0, '',          '  more than one char');
42 $a = 'ab';
43 is($a x -12, '',        '  more than one char');
44
45 $a = 'xyz';
46 $a x= 2;
47 is($a, 'xyzxyz',        'x=2');
48 $a x= 1;
49 is($a, 'xyzxyz',        'x=1');
50 $a x= 0;
51 is($a, '',              'x=0');
52
53 @x = (1,2,3);
54
55 is(join('', @x x 4),        '3333',                 '@x x Y');
56 is(join('', (@x) x 4),      '123123123123',         '(@x) x Y');
57 is(join('', (@x,()) x 4),   '123123123123',         '(@x,()) x Y');
58 is(join('', (@x,1) x 4),    '1231123112311231',     '(@x,1) x Y');
59 is(join(':', () x 4),       '',                     '() x Y');
60 is(join(':', (9) x 4),      '9:9:9:9',              '(X) x Y');
61 is(join(':', (9,9) x 4),    '9:9:9:9:9:9:9:9',      '(X,X) x Y');
62 is(join('', (split(//,"123")) x 2), '123123',       'split and x');
63
64 is(join('', @x x -12),      '',                     '@x x -12');
65 is(join('', (@x) x -14),    '',                     '(@x) x -14');
66
67 ($a, (undef)x5, $b) = 1..10;
68 is ("$a $b", "1 7", '(undef)xCONST on lhs of list assignment');
69 (($a)x3,$b) = 1..10;
70 is ("$a, $b", "3, 4", '($x)xCONST on lhs of list assignment');
71 ($a, (undef)x${\6}, $b) = "a".."z";
72 is ("$a$b", "ah", '(undef)x$foo on lhs of list assignment');
73
74
75 # This test is actually testing for Digital C compiler optimizer bug,
76 # present in Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS),
77 # found in December 1998.  The bug was reported to Digital^WCompaq as
78 #     DECC 2745 (21-Dec-1998)
79 # GEM_BUGS 7619 (23-Dec-1998)
80 # As of April 1999 the bug has been fixed in Tru64 UNIX 5.0 and is planned
81 # to be fixed also in 4.0G.
82 #
83 # The bug was as follows: broken code was produced for util.c:repeatcpy()
84 # (a utility function for the 'x' operator) in the case *all* these
85 # four conditions held:
86 #
87 # (1) len == 1
88 # (2) "from" had the 8th bit on in its single character
89 # (3) count > 7 (the 'x' count > 16)
90 # (4) the highest optimization level was used in compilation
91 #     (which is the default when compiling Perl)
92 #
93 # The bug looked like this (. being the eight-bit character and ? being \xff):
94 #
95 # 16 ................
96 # 17 .........???????.
97 # 18 .........???????..
98 # 19 .........???????...
99 # 20 .........???????....
100 # 21 .........???????.....
101 # 22 .........???????......
102 # 23 .........???????.......
103 # 24 .........???????.???????
104 # 25 .........???????.???????.
105 #
106 # The bug was triggered in the "if (len == 1)" branch.  The fix
107 # was to introduce a new temporary variable.  In diff -u format:
108 #
109 #     register char *frombase = from;
110
111 #     if (len == 1) {
112 #-       todo = *from;
113 #+       register char c = *from;
114 #        while (count-- > 0)
115 #-           *to++ = todo;
116 #+           *to++ = c;
117 #        return;
118 #     }
119 #
120 # The bug could also be (obscurely) avoided by changing "from" to
121 # be an unsigned char pointer.
122 #
123 # This obscure bug was not found by the then test suite but instead
124 # by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00.
125 #
126 # jhi@iki.fi
127 #
128 is("\xdd" x 24, "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd", 'Dec C bug');
129
130
131 # When we use a list repeat in a scalar context, it behaves like
132 # a scalar repeat. Make sure that works properly, and doesn't leave
133 # extraneous values on the stack.
134 #  -- robin@kitsite.com
135
136 my ($x, $y) = scalar ((1,2)x2);
137 is($x, "22",    'list repeat in scalar context');
138 is($y, undef,   '  no extra values on stack');
139
140 # Make sure the stack doesn't get truncated too much - the first
141 # argument to is() needs to remain!
142 is(77, scalar ((1,7)x2),    'stack truncation');
143
144 # ( )x in void context should not read preceding stack items
145 package Tiecount {
146     sub TIESCALAR { bless[]} sub FETCH { our $Tiecount++; study; 3 }
147 }
148 sub nil {}
149 tie my $t, "Tiecount";
150 { push my @temp, $t, scalar((nil) x 3, 1) }
151 is($Tiecount::Tiecount, 1,
152    '(...)x... in void context in list (via scalar comma)');
153
154
155 # perlbug 20011113.110 (#7902) works in 5.6.1, broken in 5.7.2
156 {
157     my $x= [("foo") x 2];
158     is( join('', @$x), 'foofoo', 'list repeat in anon array ref broken [ID 20011113.110 (#7902)]' );
159 }
160
161 # [perl #35885]
162 is( (join ',', (qw(a b c) x 3)), 'a,b,c,a,b,c,a,b,c', 'x on qw produces list' );
163
164 # [perl #78194] x aliasing op return values
165 sub {
166     is(\$_[0], \$_[1],
167       '[perl #78194] \$_[0] == \$_[1] when @_ aliases elems repeated by x')
168 }
169  ->(("${\''}")x2);
170
171 $#that_array = 7;
172 for(($#that_array)x2) {
173     $_ *= 2;
174 }
175 is($#that_array, 28, 'list repetition propagates lvalue cx to its lhs');
176
177 # [perl #126309] huge list counts should give an error
178
179
180 fresh_perl_like(
181  '@a = (1) x ~1',
182   qr/Out of memory/,
183   {  },
184  '(1) x ~1',
185 );
186
187 # [perl #130247] Perl_rpeep(OP *): Assertion `oldop' failed
188
189 # the 'x 0' optimising code in rpeep didn't expect the repeat expression
190 # to occur on the op_other side of an op_next chain.
191 # This used to give an assertion failure
192
193 eval q{() = (() or ((0) x 0)); 1};
194 is($@, "", "RT #130247");