Perl_op_sibling_splice(0 remove dead code
[perl.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 => 50);
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");
195
196 # yes, the newlines matter
197 fresh_perl_is(<<'PERL', "", { stderr => 1 }, "(perl #133778) MARK mishandling");
198 map{s[][];eval;0}<DATA>__END__
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 ()x0
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 0
276 PERL